Code Library
Home Submit Free Hosting Link To Us Contacts

Pascal Ncolor

 Pascal Ncolor Pascal Pascal Ncolor Download (.zip)



Unit NColor;

{$Define Windowed}

{****************************************************************************}
{*******************************} Interface {********************************}
{****************************************************************************}

Const AlphaChannel:Byte=0;
{$IfDef Windowed}
      MinX:Word=0;
      MaxX:Word=319;
      MinY:Word=0;
      MaxY:Word=199;
{$EndIf}

Const Ascii_Data:Array [32..93] Of Word=(0,                                  { }
                                         08338,00045,24445,32223,21157,      {!,",#,$,%}
                                         15018,00018,                        {&,'}
                                         08778,10530,                        {(,)}
                                         02728,01488,05120,00448,08192,      {*,+,,,-,.}
                                         05268,                              {/}
                                         11114,18740,29351,31143,18926,      {0,1,2,3,4}
                                         31183,31695,04775,10922,31215,      {5,6,7,8,9}
                                         01040,05136,                        {:,;}
                                         17492,03640,05393,08615,29695,      {<,=,>,?,@}
                                         23535,15083,29263,15211,29391,      {A,B,C,D,E}
                                         04815,31311,23533,09362,11044,      {F,G,H,I,J}
                                         23277,29257,23421,24573,11114,      {K,L,M,N,O}
                                         05103,15215,22511,31183,09367,      {P,Q,R,S,T}
                                         31597,11117,24429,23213,09389,      {U,V,W,X,Y}
                                         29351,                              {Z}
                                         29263,17553,31015);                 {[,\,]}

{Type PScreen=^TScreen;
     TScreen=Array [0..63999] Of Byte;

Var VScreen:PScreen;}
Var VScreen:Pointer;

Procedure InitGraphMode;                                    {Standard Procs}
Procedure InitTextMode;
Procedure PutPixel(X,Y:Word; Col:Byte);
Function GetPixel(X,Y:Word):Byte;
Procedure HLine(X,Y,L:Word; Col:Byte);
Procedure VLine(X,Y,L:Word; Col:Byte);
Procedure Line(X1,Y1,X2,Y2:Integer; Col:Byte);
Procedure Box(X,Y,L,H:Word; Col:Byte);
Procedure FBox(X,Y,L,H:Word; Col:Byte);
Procedure FillTriAngle(X1,Y1,X2,Y2,X3,Y3:Integer; Col:Byte);
Procedure FillPoly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Integer; Col:Byte);
Procedure TexturePoly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Integer; Texture:Pointer);
Procedure DumpScreen;
Procedure UnDumpScreen;
Procedure WaitRetrace;
Procedure WaitShortRetrace;
Procedure FillScreen(Col:Byte);

Procedure GetSprite(Var P:Pointer; X,Y,Breite,Hohe:Word);   {Sprite Procs}
Procedure PutSprite(P:Pointer; X,Y:Word);
Procedure PutSpriteTrans(P:Pointer; X,Y:Word);
{$IfDef Windowed}
Procedure PutWinSprite(P:Pointer; X,Y:Integer);
Procedure PutWinSpriteTrans(P:Pointer; X,Y:Integer);
{$EndIf}
Procedure PutScaleSprite(P:Pointer;X,Y:Integer;XL,YL:Word);
Procedure PutScaleSpriteTrans(P:Pointer;X,Y:Integer;XL,YL:Word);
Procedure PutSpritePixel(Var P:Pointer; X,Y:Word; Col:Byte);
Function GetSpritePixel(P:Pointer; X,Y:Word):Byte;
Procedure FreeSprite(Var P:Pointer);
Procedure OpenSprite(Var P:Pointer;Hohe,Breite:Word);
Procedure SaveSprite(P:Pointer; FileName:String);
Procedure LoadSprite(Var P:Pointer; FileName:String);
Function SpriteOverLap(P1,P2:Pointer;X1,Y1,X2,Y2:Word):Boolean;
Function GetSpriteXL(P:Pointer):Word;
Function GetSpriteYL(P:Pointer):Word;

Procedure SetPal(PalNum,R,G,B:Byte);                        {Palette Procs}
Function GetPalR(PalNum:Byte):Byte;
Function GetPalG(PalNum:Byte):Byte;
Function GetPalB(PalNum:Byte):Byte;
Procedure SetBorder(Col:Byte);

Function StrLen(Text:String):Word;                          {Font Procs}
Function Int2Str(I:LongInt):String;
Function Str2Int(S:String):LongInt;
Procedure OutText(X,Y:Integer; Text:String; Col:Byte);

Procedure Wait(Time:Word);                                  {Misc Procs}
Function Key:Boolean;
Procedure NoKey;
Function ReadPort:Byte;
Function ReadKey:Char;

{****************************************************************************}
{*****************************} Implementation {*****************************}
{****************************************************************************}

Const GraphModeOpen:Boolean=False;

Var SaveProc:Pointer;

{****************************************************************************}
{*********************************************************** Standard Procs *}
{****************************************************************************}

Procedure InitGraphMode;Assembler;

Asm
   mov GraphModeOpen,True
   mov ax,$0013
   int 10h
End;

Procedure InitTextMode;Assembler;

Asm
   mov GraphModeOpen,False
   mov ax,$0003
   int 10h
End;

Procedure PutPixel;Assembler;

Asm
{$IfDef Windowed}
   mov ax,X
   cmp ax,MinX
   jb @skip
   cmp ax,MaxX
   ja @skip
   mov ax,Y
   cmp ax,MinY
   jb @skip
   cmp ax,MaxY
   ja @skip
{$EndIf}
   les di,VScreen
   mov di,X
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add di,ax
   add di,bx
   mov al,Col
   stosb
@skip:
End;

Function GetPixel;Assembler;

Asm
   push ds
{$IfDef Windowed}
   mov ax,X
   cmp ax,MinX
   jb @skip
   cmp ax,MaxX
   ja @skip
   mov ax,Y
   cmp ax,MinY
   jb @skip
   cmp ax,MaxY
   ja @skip
{$EndIf}
   lds si,VScreen
   mov si,X
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add si,ax
   add si,bx
   lodsb
@skip:
   pop ds
End;

Procedure HLine;Assembler;

Asm
   les di,VScreen
   mov bx,Y
   mov cx,bx
   shl bx,$08
   shl cx,$06
   add bx,cx
   add bx,X
   add di,bx
   mov al,Col
   mov ah,al
   mov cx,L
   shr cx,$01
   jnc @nobyte
   stosb
@nobyte:
   rep stosw
End;

Procedure VLine;Assembler;

Asm
   les di,VScreen
   mov bx,Y
   mov cx,bx
   shl bx,$08
   shl cx,$06
   add bx,cx
   add bx,X
   add di,bx
   mov cx,L
   mov al,Col
@looper1:
   stosb
   add di,319
   loop @looper1
End;

Procedure Line;

Function Sign(a:integer):Integer;

Begin
     If a>0 Then Sign:=+1;
     If a<0 Then Sign:=-1;
     If a=0 Then Sign:=0;
End;

Var i,s,d1x,d1y,d2x,d2y,u,v,m,n:Integer;

Begin
     u:=x2-x1;
     v:=y2-y1;
     d1x:=Sign(u);
     d1y:=Sign(v);
     d2x:=Sign(u);
     d2y:=0;
     m:=Abs(u);
     n:=Abs(v);
     If Not(M>N) Then
        Begin
             d2x:=0;
             d2y:=Sign(v);
             m:=Abs(v);
             n:=Abs(u);
        End;
     s:=m ShR 1;
     For i:=0 To M Do
         Begin
              PutPixel(x1,y1,Col);
              Asm
                 mov ax,n
                 add s,ax         {s := s + n;}
                 mov ax,s
                 cmp ax,m
                 jb @elseif       {IF not (s<m) THEN BEGIN}
                 mov ax,m
                 sub s,ax         {s := s - m;}
                 mov ax,d1x
                 add x1,ax         {x1:= x1 + d1x;}
                 mov ax,d1y
                 add y1,ax         {y1 := y1 + d1y;}
                 jmp @endif       {end}
              @elseif:            {ELSE BEGIN}
                 mov ax,d2x
                 add x1,ax         {x1 := x1 + d2x;}
                 mov ax,d2y
                 add y1,ax         {y1 := y1 + d2y;}
              @endif:             {END;}
              End;
         End;
End;

Procedure FBox;Assembler;

Asm
{$IfDef Windowed}
   mov ax,X             {ganz draussen rechts}
   cmp ax,MaxX
   ja @ende
   add ax,L            {ganz draussen links}
   cmp ax,MinX
   jbe @ende
   cmp ax,MaxX          {halb draussen rechts}
   jbe @weiterx1
   mov bx,ax
   sub bx,MaxX
   sub L,bx
   inc L
@weiterx1:
   mov ax,x             {halb draussen links}
   cmp ax,MinX
   ja @weiterx2
   mov bx,MinX
   sub bx,ax
   add X,bx
   sub L,bx
@weiterx2:
   mov ax,Y             {ganz draussen unten}
   cmp ax,MaxY
   ja @ende
   add ax,H            {ganz draussen oben}
   cmp ax,MinY
   jbe @ende
   cmp ax,MaxY          {halb draussen unten}
   jbe @weitery1
   mov bx,ax
   sub bx,MaxY
   sub H,bx
   inc H
@weitery1:
   mov ax,Y             {halb draussen oben}
   cmp ax,MinY
   ja @weitery2
   mov bx,MinY
   sub bx,ax
   add Y,bx
   sub H,bx
@weitery2:
{$EndIf}
   les di,VScreen
   mov bx,Y
   mov cx,bx
   shl bx,$08
   shl cx,$06
   add bx,cx
   add di,bx
   add di,X
   mov bx,H
   mov al,Col
   mov ah,al
   mov si,320
   sub si,L
   mov cx,L
   push cx
@looper1:
   shr cx,$01
   jnc @nobyte
   stosb
@nobyte:
   rep stosw
   add di,si
   pop cx
   push cx
   dec bx
   jnz @looper1
   pop cx
@ende:
End;

Procedure Box;Assembler;

Asm
   les di,VScreen       {Anfangs Adresse berechnen}
   mov bx,y
   mov cx,bx
   shl bx,$08
   shl cx,$06
   add bx,cx
   add di,bx
   add di,X             {AA Ende}
   mov dx,L
   and dx,$01
   mov si,320
   sub si,L
                        {Erste Linie berechnen}
   mov cx,L
   push cx
   mov al,Col
   mov ah,al
                        {Erste Linie Zeichnen}
   shr cx,$01
   jnc @nobyte1
   stosb
@nobyte1:
   rep stosw
                        {vertikalen Linien}
   mov bx,H
   sub bx,$02
@looper1:
   add di,si
   stosb
   add di,L
   sub di,$02
   stosb
   dec bx
   jnz @looper1
                        {Letzte Linie}
   add di,si
   pop cx
   shr cx,$01
   jnc @nobyte2
   stosb
@nobyte2:
   rep stosw
End;

Procedure FillTriAngle;

Const FracBits=16;

Var YMin,YMax,YCurr:Integer;
    XMin,XMax:Integer;
    DX1,DX2,DX3:LongInt;
    XP1,XP2,XP3:LongInt;
    Temp,Dont:Integer;

Begin
     YMin:=Y1;
     YMax:=Y1;
     If (Y2<YMin) Then
        Begin
             YMin:=X2; X2:=X1; X1:=YMin;
             YMin:=Y2; Y2:=Y1; Y1:=YMin;
        End;
     If (Y2>YMax) Then YMax:=Y2;
     If (Y3<YMin) Then
        Begin
             YMin:=X3; X3:=X1; X1:=YMin;
             YMin:=Y3; Y3:=Y1; Y1:=YMin;
        End;
     If (Y3>YMax) Then YMax:=Y3;
     If (Y3<Y2) Then
        Begin
             Temp:=Y3; Y3:=Y2; Y2:=Temp;
             Temp:=X3; X3:=X2; X2:=Temp;
        End;

     XP1:=LongInt(X1) Shl FracBits;                    {Xpos in 9.7 fixed point math }
     XP2:=LongInt(X1) Shl FracBits;
     XP3:=LongInt(X2) Shl FracBits;
     Dont:=0;
     If Y2=Y1 Then Dont:=1
              Else DX1:=(LongInt(X2-X1) Shl FracBits) Div (Y2-Y1);
     If Y3=Y1 Then Dont:=2
              Else DX2:=(LongInt(X3-X1) Shl FracBits) Div (Y3-Y1);
     If Y3=Y2 Then Dont:=3
              Else DX3:=(LongInt(X3-X2) Shl FracBits) Div (Y3-Y2);
     For YCurr:=YMin To YMax Do
         Begin
              XMin:=32000;
              XMax:=-32000;
              If (YCurr<=Y2) And (Dont<>1) Then
                 Begin
                      XMin:=XP1 Shr FracBits;
                      XMax:=XMin;
                      Inc(XP1,DX1);
                 End;
              If (YCurr<=Y3) And (Dont<>2) Then
                 Begin
                      Temp:=XP2 Shr FracBits;
                      If Temp<XMin Then XMin:=Temp;
                      If Temp>XMax Then XMax:=Temp;
                      Inc(XP2,DX2);
                 End;
              If (YCurr>=Y2) And (Dont<>3) Then
                 Begin
                      Temp:=XP3 Shr FracBits;
                      If Temp<XMin Then XMin:=Temp;
                      If Temp>XMax Then XMax:=Temp;
                      Inc(XP3,DX3);
                 End;
              If XMin<MinX Then XMin:=MinX;
              If XMax>MaxX Then XMax:=MaxX;
              If (XMin<=MaxX) And (XMax>=XMin) And
                 (YCurr>=MinY) And (YCurr<=MaxY) Then
                 HLine(XMin,YCurr,XMax-XMin+1,Col);
         End;
End;

Procedure FillPoly;

Const FracBits=16;

Var YMin,YMax,YCurr:Integer;
    XMin,XMax:Integer;
    DX1,DX2,DX3,DX4:LongInt;
    XP1,XP2,XP3,XP4:LongInt;
    Temp:Integer;

Begin
     YMin:=Y1;
     YMax:=Y1;
     If (Y2<YMin) Then YMin:=Y2;
     If (Y2>YMax) Then YMax:=Y2;
     If (Y3<YMin) Then YMin:=Y3;
     If (Y3>YMax) Then YMax:=Y3;
     If (Y4<YMin) Then YMin:=Y4;
     If (Y4>YMax) Then YMax:=Y4;

     {Xpos in 16.16 fixed point math }
     If Y1<Y2 Then XP1:=LongInt(X1) Shl FracBits
              Else XP1:=LongInt(X2) Shl FracBits;
     If Y2<Y3 Then XP2:=LongInt(X2) Shl FracBits
              Else XP2:=LongInt(X3) Shl FracBits;
     If Y3<Y4 Then XP3:=LongInt(X3) Shl FracBits
              Else XP3:=LongInt(X4) Shl FracBits;
     If Y4<Y1 Then XP4:=LongInt(X4) Shl FracBits
              Else XP4:=LongInt(X1) Shl FracBits;

     If Y1=Y2 Then DX1:=0
              Else DX1:=(LongInt(X1-X2) Shl FracBits) Div (Y1-Y2);
     If Y2=Y3 Then DX2:=0
              Else DX2:=(LongInt(X2-X3) Shl FracBits) Div (Y2-Y3);
     If Y3=Y4 Then DX3:=0
              Else DX3:=(LongInt(X3-X4) Shl FracBits) Div (Y3-Y4);
     If Y4=Y1 Then DX4:=0
              Else DX4:=(LongInt(X4-X1) Shl FracBits) Div (Y4-Y1);

     For YCurr:=YMin To YMax Do
         Begin
              XMin:=32000;
              XMax:=-32000;
              If ((YCurr<=Y1) And (YCurr>=Y2)) Or
                 ((YCurr<=Y2) And (YCurr>=Y1)) Then
                 Begin
                      XMin:=XP1 Shr FracBits;
                      XMax:=XMin;
                      Inc(XP1,DX1);
                 End;
              If ((YCurr<=Y2) And (YCurr>=Y3)) Or
                 ((YCurr<=Y3) And (YCurr>=Y2)) Then
                 Begin
                      Temp:=XP2 Shr FracBits;
                      If Temp<XMin Then XMin:=Temp;
                      If Temp>XMax Then XMax:=Temp;
                      Inc(XP2,DX2);
                 End;
              If ((YCurr<=Y3) And (YCurr>=Y4)) Or
                 ((YCurr<=Y4) And (YCurr>=Y3)) Then
                 Begin
                      Temp:=XP3 Shr FracBits;
                      If Temp<XMin Then XMin:=Temp;
                      If Temp>XMax Then XMax:=Temp;
                      Inc(XP3,DX3);
                 End;
              If ((YCurr<=Y4) And (YCurr>=Y1)) Or
                 ((YCurr<=Y1) And (YCurr>=Y4)) Then
                 Begin
                      Temp:=XP4 Shr FracBits;
                      If Temp<XMin Then XMin:=Temp;
                      If Temp>XMax Then XMax:=Temp;
                      Inc(XP4,DX4);
                 End;
              HLine(XMin,YCurr,XMax-XMin+1,Col);
         End;
End;

Procedure TexturePoly;

Const FracBits=16;
{      TextureSizeX:Word=64;
      TextureSizeY:Word=64;{}

Procedure TexLine(XMin,Y,XMax,Tex1X,Tex1Y,Tex2X,Tex2Y:Integer; Texture:Pointer);

Var TexDX,TexDY:LongInt;
    CTX,CTY:LongInt;
    XCurr:Integer;

Begin
     If XMax=XMin Then
        Begin
             TexDX:=0;
             TexDY:=0;
        End
     Else Begin
               TexDX:=(LongInt(Tex2X-Tex1X) Shl FracBits) Div (XMax-XMin);
               TexDY:=(LongInt(Tex2Y-Tex1Y) Shl FracBits) Div (XMax-XMin);
          End;
     CTX:=LongInt(Tex1X) Shl FracBits;
     CTY:=LongInt(Tex1Y) Shl FracBits;
     For XCurr:=XMin To XMax Do
         Begin
              PutPixel(XCurr,Y,
                      Mem[Seg(Texture^):Ofs(Texture^)+4+
                      (CTX Shr FracBits)+(CTY Shr FracBits)*64]);
              Inc(CTX,TexDX);
              Inc(CTY,TexDY);
         End;
End;{}

Var YMin,YMax,YCurr:Integer;
    XMin,XMax:Integer;
    DX1,DX2,DX3,DX4:LongInt;
    XP1,XP2,XP3,XP4:LongInt;
    Tex1X,Tex1Y,Tex2X,Tex2Y:Integer;
    Tex1DX,Tex2DX,Tex3DX,Tex4DX:LongInt;
    Tex1P,Tex2P,Tex3P,Tex4P:LongInt;
    Temp:Integer;

Begin
     YMin:=Y1;
     YMax:=Y1;
{     TextureSizeX:=GetSpriteXL(Texture);
     TextureSizeX:=GetSpriteXL(Texture);{}
     If (Y2<YMin) Then YMin:=Y2;
     If (Y2>YMax) Then YMax:=Y2;
     If (Y3<YMin) Then YMin:=Y3;
     If (Y3>YMax) Then YMax:=Y3;
     If (Y4<YMin) Then YMin:=Y4;
     If (Y4>YMax) Then YMax:=Y4;
     {Xpos in 16.16 fixed point math }
     If Y1<Y2 Then
        Begin
             XP1:=LongInt(X1) Shl FracBits;
             Tex1P:=1;
        End
     Else Begin
               XP1:=LongInt(X2) Shl FracBits;
               Tex1P:=64 Shl FracBits;
          End;
     If Y2<Y3 Then
        Begin
             XP2:=LongInt(X2) Shl FracBits;
             Tex2P:=1;
        End
     Else Begin
               XP2:=LongInt(X3) Shl FracBits;
               Tex2P:=64 Shl FracBits;
          End;
     If Y3<Y4 Then
        Begin
             XP3:=LongInt(X3) Shl FracBits;
             Tex3P:=64 Shl FracBits;
        End
     Else Begin
               XP3:=LongInt(X4) Shl FracBits;
               Tex3P:=1;
          End;
     If Y4<Y1 Then
        Begin
             XP4:=LongInt(X4) Shl FracBits;
             Tex4P:=64 Shl FracBits;
        End
     Else Begin
               XP4:=LongInt(X1) Shl FracBits;
               Tex4P:=1;
          End;

     If Y1=Y2 Then
        Begin
             DX1:=0;
             Tex1DX:=0;
        End
     Else Begin
               DX1:=(LongInt(X1-X2) Shl FracBits) Div (Y1-Y2);
               Tex1DX:=(LongInt(64) Shl FracBits) Div (Y2-Y1);
          End;
     If Y2=Y3 Then
        Begin
             DX2:=0;
             Tex2DX:=0;
        End
     Else Begin
               DX2:=(LongInt(X2-X3) Shl FracBits) Div (Y2-Y3);
               Tex2DX:=(LongInt(64) Shl FracBits) Div (Y3-Y2);
          End;
     If Y3=Y4 Then
        Begin
             DX3:=0;
             Tex3DX:=0;
        End
     Else Begin
               DX3:=(LongInt(X3-X4) Shl FracBits) Div (Y3-Y4);
               Tex3DX:=(LongInt(64) Shl FracBits) Div (Y3-Y4);
          End;
     If Y4=Y1 Then
        Begin
             DX4:=0;
             Tex4DX:=0;
        End
     Else Begin
               DX4:=(LongInt(X4-X1) Shl FracBits) Div (Y4-Y1);
               Tex4DX:=(LongInt(64) Shl FracBits) Div (Y4-Y1);
          End;

     For YCurr:=YMin To YMax Do
         Begin
              XMin:=32000;
              XMax:=-32000;
              If ((YCurr<=Y1) And (YCurr>=Y2)) Or
                 ((YCurr<=Y2) And (YCurr>=Y1)) Then
                 Begin
                      XMin:=XP1 Shr FracBits;
                      XMax:=XMin;
                      Tex1X:=Tex1P Shr FracBits;Tex1Y:=0;
                      Tex2X:=Tex1P Shr FracBits;Tex2Y:=0;
                      Inc(XP1,DX1);
                      Inc(Tex1P,Tex1DX);
                 End;
              If ((YCurr<=Y2) And (YCurr>=Y3)) Or
                 ((YCurr<=Y3) And (YCurr>=Y2)) Then
                 Begin
                      Temp:=XP2 Shr FracBits;
                      If Temp<XMin Then
                         Begin
                              XMin:=Temp;
                              Tex1X:=63;Tex1Y:=Tex2P Shr FracBits;
                         End;
                      If Temp>XMax Then
                         Begin
                              XMax:=Temp;
                              Tex2X:=63;Tex2Y:=Tex2P Shr FracBits;
                         End;
                      Inc(XP2,DX2);
                      Inc(Tex2P,Tex2DX);
                 End;
              If ((YCurr<=Y3) And (YCurr>=Y4)) Or
                 ((YCurr<=Y4) And (YCurr>=Y3)) Then
                 Begin
                      Temp:=XP3 Shr FracBits;
                      If Temp<XMin Then
                         Begin
                              XMin:=Temp;
                              Tex1X:=Tex3P Shr FracBits;Tex1Y:=63;
                         End;
                      If Temp>XMax Then
                         Begin
                              XMax:=Temp;
                              Tex2X:=Tex3P Shr FracBits;Tex2Y:=63;
                         End;
                      Inc(XP3,DX3);
                      Inc(Tex3P,Tex3DX);
                 End;
              If ((YCurr<=Y4) And (YCurr>=Y1)) Or
                 ((YCurr<=Y1) And (YCurr>=Y4)) Then
                 Begin
                      Temp:=XP4 Shr FracBits;
                      If Temp<XMin Then
                         Begin
                              XMin:=Temp;
                              Tex1X:=0;Tex1Y:=Tex4P Shr FracBits;
                         End;
                      If Temp>XMax Then
                         Begin
                              XMax:=Temp;
                              Tex2X:=0;Tex2Y:=Tex4P Shr FracBits;
                         End;
                      Inc(XP4,DX4);
                      Inc(Tex4P,Tex4DX);
                 End;
              TexLine(XMin,YCurr,XMax,Tex1X,Tex1Y,Tex2X,Tex2Y,Texture);
        End;
End;

Procedure DumpScreen;Assembler;

Asm
   push ds
   lds si,VScreen
   xor di,di
   mov ax,$a000
   mov es,ax
   mov cx,$7d00
   rep movsw
   pop ds
End;

Procedure UnDumpScreen;Assembler;

Asm
   push ds
   les di,VScreen
   xor si,si
   mov ax,$a000
   mov ds,ax
   mov cx,$7d00
   rep movsw
   pop ds
End;

Procedure FillScreen;Assembler;

Asm
   les di,VScreen
   mov al,Col
   mov ah,al
   mov cx,$7d00
   rep stosw
End;

Procedure WaitRetrace;Assembler;

Asm
   mov dx,$03da
@l1:
   in al,dx
   and al,$08
   jnz @l1
@l2:
   in al,dx
   and al,$08
   jz @l2
End;

Procedure WaitShortRetrace;Assembler;

Asm
   mov dx,$03da
@l1:
   in al,dx
   and al,$01
   jnz @l1
@l2:
   in al,dx
   and al,$01
   jz @l2
End;

{****************************************************************************}
{************************************************************* Sprite Procs *}
{****************************************************************************}

Procedure GetSprite;

Begin
     GetMem(P,Breite*Hohe+4);
     Asm
        push ds
        lds si,P
        lodsw
        mov di,ax
        lodsw
        mov es,ax
        pop ds
        mov ax,Breite
        stosw
        mov ax,Hohe
        stosw
        mov cx,Breite
        mov dx,Hohe
        mov ax,Y
        mov bx,ax
        shl ax,$08
        shl bx,$06
        add ax,bx
        add ax,X
        mov bx,320
        sub bx,Breite
        push ds
        lds si,[VScreen]
        add si,ax
     @looper1:
        push cx
        shr cx,$01
        jnc @nobyte
        movsb
     @nobyte:
        rep movsw
        pop cx
        add si,bx
        dec dx
        jnz @looper1
        pop ds
     End;
End;

Procedure PutSprite;Assembler;

Asm
   push ds
   les di,[VScreen]
   lds si,P
   lodsw
   mov cx,ax
   lodsw
   mov dx,ax
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add ax,bx
   add ax,X
   mov bx,320
   sub bx,cx
   add di,ax
@looper1:
   push cx
   shr cx,$01
   jnc @nobyte
   movsb
@nobyte:
   rep movsw
   pop cx
   add di,bx
   dec dx
   jnz @looper1
   pop ds
End;

Procedure PutSpriteTrans;Assembler;

Var A:Byte;

Asm
   mov ah,AlphaChannel
   mov A,ah
   push ds
   les di,[VScreen]
   lds si,P
   lodsw
   mov cx,ax
   lodsw
   mov dx,ax
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add ax,bx
   add ax,X
   mov bx,320
   sub bx,cx
   add di,ax
@looper1:
   push cx
@looper2:
   lodsb
   inc di
   cmp al,A
   je @trans
   dec di
   stosb
@trans:
   loop @looper2
   pop cx
   add di,bx
   dec dx
   jnz @looper1
   pop ds
End;

{$IfDef Windowed}
Procedure PutWinSprite;Assembler;

Var X1,X2,Y1:Word;

Asm
   xor ax,ax
   mov X1,ax
   mov X2,ax
   mov Y1,ax
   push ds
   les di,[VScreen]
   lds si,P
   lodsw
   mov cx,ax
   lodsw
   mov dx,ax
   pop ds
   mov ax,X             {ganz draussen rechts}
   cmp ax,MaxX
   jg @ende
   add ax,cx            {ganz draussen links}
   cmp ax,MinX
   jle @ende
   cmp ax,MaxX          {halb draussen rechts}
   jle @weiterx1
   mov bx,ax
   sub bx,MaxX
   mov X2,bx                    {X2}
   dec X2
   sub cx,bx
   inc cx
@weiterx1:
   mov ax,x             {halb draussen links}
   cmp ax,MinX
   jg @weiterx2
   mov bx,MinX
   sub bx,ax
   add X,bx
   mov X1,bx                    {X1}
   sub cx,bx
@weiterx2:
   mov ax,Y             {ganz draussen unten}
   cmp ax,MaxY
   jg @ende
   add ax,dx            {ganz draussen oben}
   cmp ax,MinY
   jle @ende
   cmp ax,MaxY          {halb draussen unten}
   jle @weitery1
   mov bx,ax
   sub bx,MaxY
   sub dx,bx
   inc dx
@weitery1:
   mov ax,Y             {halb draussen oben}
   cmp ax,MinY
   jg @weitery2
   mov bx,MinY
   sub bx,ax
   add Y,bx
   mov Y1,bx                    {Y1}
   sub dx,bx
@weitery2:
   push ds
   push dx
   lds si,P
   lodsw
   add si,2
   mul Y1
   add si,ax
   pop dx
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add ax,bx
   add ax,X
   mov bx,320
   sub bx,cx
   add di,ax
@looper1:
   add si,X1
   push cx
   shr cx,$01
   jnc @nobyte
   movsb
@nobyte:
   rep movsw
   pop cx
   add di,bx
   add si,X2
   dec dx
   jnz @looper1
   pop ds
@ende:
End;

Procedure PutWinSpriteTrans;Assembler;

Var X1,X2,Y1:Word;
    A:Byte;

Asm
   mov ah,AlphaChannel
   mov A,ah
   xor ax,ax
   mov X1,ax
   mov X2,ax
   mov Y1,ax
   push ds
   les di,[VScreen]
   lds si,P
   lodsw
   mov cx,ax
   lodsw
   mov dx,ax
   pop ds
   mov ax,X             {ganz draussen rechts}
   cmp ax,MaxX
   jg @ende
   add ax,cx            {ganz draussen links}
   cmp ax,MinX
   jle @ende
   cmp ax,MaxX          {halb draussen rechts}
   jle @weiterx1
   mov bx,ax
   sub bx,MaxX
   mov X2,bx                    {X2}
   dec X2
   sub cx,bx
   inc cx
@weiterx1:
   mov ax,x             {halb draussen links}
   cmp ax,MinX
   jg @weiterx2
   mov bx,MinX
   sub bx,ax
   add X,bx
   mov X1,bx                    {X1}
   sub cx,bx
@weiterx2:
   mov ax,Y             {ganz draussen unten}
   cmp ax,MaxY
   jg @ende
   add ax,dx            {ganz draussen oben}
   cmp ax,MinY
   jle @ende
   cmp ax,MaxY          {halb draussen unten}
   jle @weitery1
   mov bx,ax
   sub bx,MaxY
   sub dx,bx
   inc dx
@weitery1:
   mov ax,Y             {halb draussen oben}
   cmp ax,MinY
   jg @weitery2
   mov bx,MinY
   sub bx,ax
   add Y,bx
   mov Y1,bx                    {Y1}
   sub dx,bx
@weitery2:
   push ds
   push dx
   lds si,P
   lodsw
   add si,2
   mul Y1
   add si,ax
   pop dx
   mov ax,Y
   mov bx,ax
   shl ax,$08
   shl bx,$06
   add ax,bx
   add ax,X
   mov bx,320
   sub bx,cx
   add di,ax
@looper1:
   add si,X1
   push cx
@looper2:
   lodsb
   inc di
   cmp al,A
   je @trans
   dec di
   stosb
@trans:
   loop @looper2
   pop cx
   add di,bx
   add si,X2
   dec dx
   jnz @looper1
   pop ds
@ende:
End;
{$EndIf}

Procedure PutScaleSprite;Assembler;

Var I,II:Integer;

Asm
   les di,VScreen          {Berechne Ort in VScreen}
   push ds
   add di,X
   mov ax,Y
   mov bx,ax
   shl ax,8
   shl bx,6
   add di,ax
   add di,bx

   mov ax,320d             {berechne offset zwischen zwei hlines=320-XL}
   sub ax,XL
   push ax                 {speichern an oberster stelle in stack}

   xor ax,ax               {initialisiere schlaufe II=Y z„hler}
   mov II,ax
@for1:
   xor ax,ax               {initialisiere schlaufe I=X z„hler}
   mov I,ax

   lds si,P                {berechne Y position in sprite bezglich YL}
   lodsw
   mov bx,ax               {XL in bx speichern...}
   lodsw
   mul II
   div YL
   mul bx                  {...um damit ypos zu berechnen}
   add ax,2                {wegen lodsw bei xpos von unten}
   mov cx,ax               {ypos in cx speichern}
   mov bx,XL               {bx mit XL Laden 2x fr unten}

@for2:
   lds si,P                {Berechne x position in Sprite bezglich XL}
   lodsw
   mul I
   div bx                  {bx=XL noch von oben initialisiert}

   add si,ax               {xposition addieren}
   add si,cx               {yposition addieren}
   movsb                   {kopieren}

   inc I                   {Schlaufe I=X z„hler}
   cmp I,bx                {bx=XL noch von oben initialisiert}
   jnz @for2

   add di,[bp-8]           {offset zwischen zeilen=pop ax;add di,ax;push ax}

   inc II                  {Schlaufe II=Y z„hler}
   mov ax,YL
   cmp II,ax
   jnz @for1
   pop ax
   pop ds
End;

Procedure PutScaleSpriteTrans;Assembler;

Var I,II:Integer;
    A:Byte;  {eine var mehr als oben-> [bp-10]}

Asm
   mov al,AlphaChannel
   mov A,al
   les di,VScreen          {Berechne Ort in VScreen}
   push ds
   add di,X
   mov ax,Y
   mov bx,ax
   shl ax,8
   shl bx,6
   add di,ax
   add di,bx

   mov ax,320d             {berechne offset zwischen zwei hlines=320-XL}
   sub ax,XL
   push ax                 {speichern an oberster stelle in stack}

   xor ax,ax               {initialisiere schlaufe II=Y z„hler}
   mov II,ax
@for1:
   xor ax,ax               {initialisiere schlaufe I=X z„hler}
   mov I,ax

   lds si,P                {berechne Y position in sprite bezglich YL}
   lodsw
   mov bx,ax               {XL in bx speichern...}
   lodsw
   mul II
   div YL
   mul bx                  {...um damit ypos zu berechnen}
   add ax,2                {wegen lodsw bei xpos von unten}
   mov cx,ax               {ypos in cx speichern}
   mov bx,XL               {bx mit XL Laden 2x fr unten}

@for2:
   lds si,P                {Berechne x position in Sprite bezglich XL}
   lodsw
   mul I
   div bx                  {bx=XL noch von oben initialisiert}

   add si,ax               {xposition addieren}
   add si,cx               {yposition addieren}

   lodsb                   {kopieren}
   inc di
   cmp al,A
   je @nocopy
   dec di
   stosb
@nocopy:

   inc I                   {Schlaufe I=X z„hler}
   cmp I,bx                {bx=XL noch von oben initialisiert}
   jnz @for2

   add di,[bp-10]          {offset zwischen zeilen=pop ax;add di,ax;push ax}
                           {da eine "var a:byte" mehr->10 statt 8}

   inc II                  {Schlaufe II=Y z„hler}
   mov ax,YL
   cmp II,ax
   jnz @for1
   pop ax
   pop ds
End;


Procedure PutSpritePixel;Assembler;

Asm
   push ds
   lds si,P
   lodsw
   mov di,ax
   lodsw
   mov es,ax
   mov ds,ax
   mov si,di
   lodsw
   pop ds

   mov bx,Y        {Berechne pos}
   dec bx
   mul bx
   add di,ax
   add di,X
   add di,$03      {2+2 (Hohe+Breite)=4  -1 (X)}
   mov al,Col
   stosb
End;

Function GetSpritePixel;Assembler;

Asm
   push ds         {Setze lods register}
   lds si,P
   lodsw

   mov bx,Y        {Berechne pos}
   dec bx
   mul bx
   add si,ax
   add si,X
   inc si          {2+2 (Hohe+Breite)=4  -1 (X)=3  -2 (lodsw Breite)=1 -> inc}
   lodsb
   pop ds
End;

Procedure FreeSprite;

Var Size:Word;

Begin
     Asm
        push ds
        lds si,P
        lodsw
        mov bx,ax
        lodsw
        mov ds,ax
        mov si,bx
        lodsw
        mov bx,ax
        lodsw
        mul bx
        add ax,$04
        pop ds
        mov Size,ax
     End;
     FreeMem(P,Size);
End;

Procedure OpenSprite;


Begin
     GetMem(P,Breite*Hohe+4);
     Asm
        push ds
        lds si,P
        lodsw
        mov di,ax
        lodsw
        mov es,ax
        pop ds
        mov ax,Hohe
        stosw
        mov ax,Breite
        stosw
        mov cx,Breite
        mov ax,Hohe
        mul cx
        mov cx,ax
        xor ax,ax
        rep stosb
     End;
End;

Procedure SaveSprite;

Var F:File;
    Breite,Hohe:Word;

Begin
     Asm
        push ds
        lds si,P
        lodsw
        mov bx,ax
        lodsw
        pop ds
        mov Breite,bx
        mov Hohe,ax
     End;
     Assign(F,FileName);
     ReWrite(F,1);
     BlockWrite(F,P^,Breite*Hohe+4);
     Close(F);
End;

Procedure LoadSprite;

Var F:File;
    Breite,Hohe:Word;

Begin
     Assign(F,FileName);
     ReSet(F,1);
     BlockRead(F,Breite,2);
     BlockRead(F,Hohe,2);
     GetMem(P,Breite*Hohe+4);
     Seek(F,0);
     BlockRead(F,P^,Breite*Hohe+4);
     Close(F);
End;

Function SpriteOverLap;

Var O1,S1,O2,S2:Word;

Begin
     O1:=Ofs(P1^);
     S1:=Seg(P1^);
     O2:=Ofs(P2^);
     S2:=Seg(P2^);
     Asm
        mov @result,False
        push ds
        mov ds,S1
        mov si,O1
        lodsw           {Breite}
        mov O1,ax
        lodsw           {Hohe}
        mov S1,ax
        mov ds,S2
        mov si,O2
        lodsw           {Breite}
        mov O2,ax
        lodsw           {Hohe}
        mov S2,ax
        pop ds
        mov ax,X1
        add ax,O1
        cmp ax,X2
        jb @ende
        mov ax,Y1
        add ax,S1
        cmp ax,Y2
        jb @ende
        mov ax,X2
        add ax,O2
        cmp ax,X1
        jb @ende
        mov ax,Y2
        add ax,S2
        cmp ax,Y1
        jb @ende
        mov @result,True
     @ende:
     End;
End;

Function GetSpriteXL;

Var Breite,Hohe:Word;

Begin
     Breite:=Ofs(P^);
     Hohe:=Seg(P^);
     Asm
        push ds
        mov si,Breite
        mov ds,Hohe
        lodsw
        mov Breite,ax
        pop ds
     End;
     GetSpriteXL:=Breite;
End;

Function GetSpriteYL;

Var Breite,Hohe:Word;

Begin
     Breite:=Ofs(P^);
     Hohe:=Seg(P^);
     Asm
        push ds
        mov si,Breite
        mov ds,Hohe
        add si,$02              {alternativ: lodsw -> speedtest!}
        lodsw
        mov Hohe,ax
        pop ds
     End;
     GetSpriteYL:=Hohe;
End;

{****************************************************************************}
{************************************************************ Palette Procs *}
{****************************************************************************}

Procedure SetPal;Assembler;

Asm
   mov dx,$03c8
   mov al,Palnum
   out dx,al
   inc dx
   mov al, R
   out dx,al
   mov al,G
   out dx,al
   mov al,B
   out dx,al
End;

Function GetPalR;Assembler;

Asm
   mov dx,$03c7
   mov al,PalNum
   out dx,al
   add dx,2
   in al,dx
End;

Function GetPalG;Assembler;

Asm
   mov dx,$03c7
   mov al,PalNum
   out dx,al
   add dx,2
   in al,dx
   in al,dx
End;

Function GetPalB;Assembler;

Asm
   mov dx,$03c7
   mov al,PalNum
   out dx,al
   add dx,2
   in al,dx
   in al,dx
   in al,dx
End;

Procedure SetBorder;Assembler;

Asm
   mov dx,$3da
   in al,dx
   mov dx,$3c0
   mov al,$11
   or al,$20
   out dx,al
   mov al,Col
   out dx,al
End;

{****************************************************************************}
{*************************************************************** Font Procs *}
{****************************************************************************}

Function StrLen;Assembler;

Asm
   push ds
   lds si,Text
   lodsb
   xor ah,ah
   shl ax,$02
   dec ax
   pop ds
End;

Function ConvertChar(Letter:Byte):Byte;

Begin
     Case Letter Of
          32..93:ConvertChar:=Letter-32;

     Else ConvertChar:=0;
     End;
End;

Procedure OutWinChar(X,Y:Word; Letter,Col:Byte);Assembler;

Asm
   push ds
   mov cx,15
   lea si,Ascii_Data
   mov al,Letter
   xor ah,ah
   shl ax,1
   add si,ax
   lodsw
   mov dx,ax
   shl dx,1
@looper:                {PutPixel(X+((I-1) Mod 3),Y+((I-1) Div 3),Col);}
   shl dx,1
   jnc @nopixel
   mov ax,cx
   dec ax
   mov bx,3
   div bl
   mov bl,ah
   add bx,x
   mov di,bx
{$IfDef Windowed}
   cmp bx,MinX
   jl @nopixel
   cmp bx,MaxX
   jg @nopixel
{$EndIf}
   xor bh,bh
   mov bl,al
   add bx,y
{$IfDef Windowed}
   cmp bx,MinY
   jl @nopixel
   cmp bx,MaxY
   jg @nopixel
{$EndIf}
   push di
   les di,VScreen
   pop di
   mov ax,bx
   shl ax,8
   shl bx,6
   add di,ax
   add di,bx
   mov al,Col
   stosb
@nopixel:
   loop @looper
   pop ds
End;

Procedure OutChar(X,Y:Word; Letter,Col:Byte);Assembler;

Asm
   push ds
   mov cx,15
   lea si,Ascii_Data
   mov al,Letter
   xor ah,ah
   shl ax,1
   add si,ax
   lodsw
   mov dx,ax
   shl dx,1
@looper:                {PutPixel(X+((I-1) Mod 3),Y+((I-1) Div 3),Col);}
   shl dx,1
   jnc @nopixel
   mov ax,cx
   dec ax
   mov bx,3
   div bl
   mov bl,ah
   add bx,x
   mov di,bx
   xor bh,bh
   mov bl,al
   add bx,y
   push di
   les di,VScreen
   pop di
   mov ax,bx
   shl ax,8
   shl bx,6
   add di,ax
   add di,bx
   mov al,Col
   stosb
@nopixel:
   loop @looper
   pop ds
End;

Function Int2Str;

Var S:String;

Begin
     Str(I,S);
     Int2Str:=S;
End;

Function Str2Int;

Var I,Code:Integer;

Begin
     Val(S,I,Code);
     Str2Int:=I;
End;

Procedure OutText;

Var I:Integer;

Begin
     If Length(Text)>0 Then
        For I:=1 To Length(Text) Do
            If (X+(I-1)*4<=MaxX) And
               (X+(I-1)*4+3>=MinX) And
               (Y<=MaxY) And
               (Y+5>=MinY) Then
               Begin
                    If (X+(I-1)*4<MinX) Or
                       (X+(I-1)*4+3>MaxX) Or
                       (Y>MinY) Or
                       (Y+5<MaxY) Then
                       OutWinChar(X+(I-1)*4,Y,ConvertChar(Ord(UpCase(Text[I]))),Col)
                       Else OutChar(X+(I-1)*4,Y,ConvertChar(Ord(UpCase(Text[I]))),Col)
               End;
End;

{****************************************************************************}
{*************************************************************** Misc Procs *}
{****************************************************************************}

Procedure Wait;Assembler;

Asm
   mov ax,$03e8
   mul Time
   mov cx,dx
   mov dx,ax
   mov ah,$86
   int 15h
End;

Function Key;Assembler;

Asm
   mov ah,$01
   int 16h
   mov ax,$01
   jnz @weiter
   xor ax,ax
@weiter:
End;

Procedure NoKey;Assembler;

Asm
@looper:
   mov ah,$01
   int 16h
   jz @nokey
   xor ah,ah
   int 16h
   jmp @looper
@nokey:
End;

Function ReadPort;Assembler;

Asm
   mov dx,$60
   in al,dx
End;

Function ReadKey;Assembler;

Asm
   xor ah,ah
   int 16h
End;

Const Text='Visit http://www.datacomm.ch/asuter';

{$F+}
Procedure NewExitProc;

Begin
     ExitProc:=SaveProc;
{     Dispose(VScreen);}
     FreeMem(VScreen,64000);
     If GraphModeOpen Then InitTextMode;
     WriteLn('NColor by Peter Suter & Clau Curtins');
     WriteLn(Text);
End;
{$F-}

Begin
     WriteLn('NColor by Peter Suter & Clau Curtins');
     WriteLn(Text);
     SaveProc:=ExitProc;
     ExitProc:=@NewExitProc;
{     New(VScreen);}
     GetMem(VScreen,64000);
End.




  • PascalNcolor


Tatet

Home | Bookmark Us | Terms of Use | Link to us | Contact Us

Copyright 2012 Code Library, All rights reserved.