Pascal ASM graph Code Library

{$A+,B+,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
Unit AsmGraph;

Interface

Type PalType = Array[0..767] of Byte;
     Virtual = Array[1..64003] of Byte;
     VirtPtr = ^Virtual;

Const VGA = $A000;

Var LineOffsets: Array[0..199] of Word;
    FontX,FontY:Byte;
    PlusCol:Integer;

{$L Scale.obj}
{$F+}
Procedure Scale(X,Y:Integer;Sx,Sy:Word;SpriteName:Pointer;Mode:Byte;Where:Word);
Procedure Flip(Source,Dest:Word);
{$F-}
Procedure WaitRetrace;
Procedure SetMode(Mode: Integer);
Procedure Cls(ClsCol:Byte;SegMent:Word);
Procedure PutPixel(PX,PY:Integer;PCol:Byte;SegMent:Word);
Function  GetPixel(GX,GY:Integer;SegMent:Word):Byte;
Procedure PutSprite(X1,Y1:Integer;Sprt:Array of byte;Mode:Byte;Segment:Word);
Procedure GetSprite(X1,Y1,X2,Y2:Integer;Var Sprt:Array of Byte;Segment:Word);
Procedure BlockCopy(X1,Y1,X2,Y2:Integer;Source,Dest:Word);
Procedure Line (X1,Y1,X2,Y2: Integer; LineCol : Byte; Adresse: Word);
Procedure Rectangle(X1,Y1,X2,Y2:Integer;LineCol:Byte;Where:Word);
Procedure FilledRect(X1,Y1,X2,Y2:Integer;Col:Byte;Where:Word);
Procedure Circle (X1,Y1,Rad:Integer;CircleCol:Byte;Adresse:Word);
Procedure SetPalette(PalNum,Red,Green,Blue:Byte);
Procedure GetPalette(Var PalArray: PalType);
Procedure Get1Pal(PalNum:Byte;Var RR,GG,BB:Byte);
Procedure Fadein(PalArray: PalType);
Procedure Fadeout(PalArray: PalType);
Procedure LoadPalette(Fich: String; Var PalArray: PalType);
Procedure SetAllPal(PalArray:PalType);
Procedure AllColor(Colnum:Byte);
Procedure LoadFont(FileName:String;SegMent:Word);
Procedure Font(Fx,Fy:Integer;FontStr:String;FontSeg,Where:Word);

Implementation

Procedure WaitRetrace; Assembler;
Label L1, L2;
asm
Mov Dx,3DAh
L1:
In al,dx
And al,08h
Jnz l1
L2:
In al,dx
And al,08h
Jz  l2
End;

Procedure SetMode(Mode: Integer); Assembler;
Asm
Mov Ax, Mode
Int 10h
End;

Procedure Cls(ClsCol:Byte;SegMent:Word); Assembler;
Asm
Xor Di, Di
Mov Ax, Segment
Mov Es, Ax
Mov Al, ClsCol
Mov Ah, Al
Mov Cx, 32000
Rep Stosw
End;

Procedure PutPixel(PX,PY:Integer;PCol:Byte;SegMent:Word); Assembler;
Label Nopaint;
Asm
Mov Ax, Segment
Mov Es, Ax
Cmp Px, 0
Jl Nopaint
Cmp Px, 319
Jg Nopaint
Cmp Py, 0
Jl Nopaint
Cmp Py, 199
Jg Nopaint
Mov Bx, Py
Shl Bx, 1
Mov Di, Word Ptr [LineOffsets + Bx]
Add Di, Px
Mov Al, Pcol
Stosb
Nopaint:
End;

Function GetPixel(GX,GY:Integer;SegMent:Word):Byte; Assembler;
Label Noget;
Asm
Mov Ax, Segment
Mov Es, Ax
Cmp Gx, 0
Jb NoGet
Cmp Gx, 319
Ja NoGet
Cmp Gy, 0
Jb NoGet
Cmp Gy, 199
Ja NoGet
Mov Bx, GY
Shl Bx, 1
Mov Di, Word Ptr [LineOffsets + Bx]
Add Di, Gx
Mov Al, [Es:Di]
Noget:
End;

Procedure PutSprite(X1,Y1:Integer;Sprt:Array of byte;Mode:Byte;Segment:Word); Assembler;
Label Alldone,PutLine,NextLine,Nopixel,Pixel;
Asm
Push Ds
Lds Si, Sprt
Mov Ax, Segment
Mov Es, Ax
Mov Di, X1
Mov Bx, Y1
Mov Dx, Y1
Shl Bx, 8
Shl Dx, 6
Add Dx, Bx
Add Di, Dx
Mov Ax, [Ds:Si]
Add Si, 2
Mov Bl, [Ds:Si]
Inc Si
Xor Cx, Cx
Xor Bh, Bh
PutLine:
Cmp X1, 0
Jb NoPixel
Cmp X1, 319
Ja NoPixel
Cmp Y1, 0
Jl NoPixel
Cmp Y1, 199
Ja Alldone
Cmp Mode, 0
Je Pixel
Mov Dl, [Ds:Si]
Cmp Dl, 0
Je Nopixel
Pixel:
Movsb
Inc X1
Inc Cx
Cmp Cx, Ax
Je NextLine
Jmp Putline
Nopixel:
Inc Si
Inc Di
Inc X1
Inc Cx
Cmp Cx, Ax
Je Nextline
Jmp Putline
NextLine:
Add Di, 320
Sub Di, Ax
Xor Cx, Cx
Sub X1, Ax
Inc Bh
Inc Y1
Cmp Bh, Bl
Je Alldone
Jmp PutLine
Alldone:
Pop Ds
End;

Procedure GetSprite(X1,Y1,X2,Y2:Integer;Var Sprt:Array of Byte;Segment:Word); Assembler;
Label Alldone,GetLine,NextLine,Noget;
Asm
Push Ds
Les Di, Sprt
Mov Ax, Segment
Mov Ds, Ax
Mov Cx, X1
Mov Ax, X2
Inc Ax
Sub Ax, Cx
Mov Cx, Y1
Mov Bx, Y2
Inc Bx
Sub Bx, Cx
Xor Cx, Cx
Xor Bh, Bh
Stosw
Mov [Es:Di], Bl
Inc Di
Push Bx
Mov Si, X1
Mov Bx, Y1
Mov Dx, Y1
Shl Bx, 8
Shl Dx, 6
Add Dx, Bx
Add Si, Dx
Pop Bx
Mov Dl, 0
GetLine:
Cmp X1, 0
Jb Noget
Cmp X1, 319
Ja Noget
Cmp Y1, 0
Jb Noget
Cmp Y1, 199
Ja Noget
Movsb
Inc X1
Inc Cx
Cmp Cx, Ax
Je NextLine
Jmp GetLine
Noget:
Mov [Es:Di], Dl
Inc Di
Inc Si
Inc X1
Inc Cx
Cmp Cx, Ax
Je NextLine
Jmp GetLine
NextLine:
Add Si, 320
Sub Si, Ax
Xor Cx, Cx
Sub X1, Ax
Inc Bh
Inc Y1
Cmp Bh, Bl
Je Alldone
Jmp GetLine
Alldone:
Pop Ds
End;

Procedure BlockCopy(X1,Y1,X2,Y2:Integer;Source,Dest:Word); Assembler;
Label Alldone,NextLine,CopyLine,Nocopy;
Asm
Push Ds
Mov Ax, Source
Mov Ds, Ax
Mov Ax, Dest
Mov Es, Ax
Mov Cx, X1
Mov Ax, X2
Inc Ax
Sub Ax, Cx
Mov Cx, Y1
Mov Bx, Y2
Inc Bx
Sub Bx, Cx
Xor Cx, Cx
Xor Bh, Bh
Push Bx
Mov Si, X1
Mov Di, X1
Mov Bx, Y1
Mov Dx, Y1
Shl Bx, 8
Shl Dx, 6
Add Dx, Bx
Add Si, Dx
Add Di, Dx
Pop Bx
CopyLine:
Cmp Di, 63999
Ja Nocopy
Movsb
Inc Cx
Cmp Cx, Ax
Je NextLine
Jmp CopyLine
Nocopy:
Inc Si
Inc Di
Inc Cx
Cmp Cx, Ax
Je NextLine
Jmp CopyLine
NextLine:
Xor Cx, Cx
Mov Dx, 320
Sub Dx, Ax
Add Di, Dx
Add Si, Dx
Inc Bh
Cmp Bh, Bl
Je Alldone
Jmp CopyLine
AllDone:
Pop Ds
End;

Procedure Line (X1,Y1,X2,Y2:Integer;LineCol:Byte;Adresse:Word);
Var A1,B1,L1,L2,N,N2,M,M2,Xlength,Ylength,W : Integer;
     Slope,OriginSlope : Real;
Begin
  M2 := 1; M := 1; B1 := Y1; W := 1; N := X1; N2 := X2; B1 := Y1; Slope := 1000;
  XLength := ABS(X2-X1); Ylength := ABS(Y2-Y1); L1 := Xlength; L2 := Ylength;
  If X2 < X1 then
   Begin
    N := X2;
    N2 := X1;
    B1 := Y2;
    M2 := -1;
   End;
  If Y2 < Y1 then
   Begin
   B1 := Y1;
   M2 := -1;
   End;
  If (X2 < X1) AND (Y2 <Y1) then
   Begin
    B1 := Y2;
    M2 := +1;
   End;
  If Ylength > Xlength then
   Begin
    B1 := X1;
    N := Y1;
    N2 := Y2;
    L1 := Ylength;
    L2 := Xlength;
    W := -1;
    If Y2 < Y1 then
     Begin
      N := Y2;
      N2 := Y1;
      B1 := X2;
      M2 := -1;
     End;
   End;
  If L2 <> 0 then Slope := L1 / L2;
  OriginSLope := Slope;
  For A1 := N to N2 do
   Begin
    If W = +1 then PutPixel (A1, B1, LineCol, Adresse);
    If W = -1 then PutPixel (B1, A1, LineCol, Adresse);
    If A1 >= Slope + N - 1 then
     Begin
      M := M + 1;
      B1 := B1 + (1*M2);
      Slope := OriginSlope * (M);
     End;
   End;
End;

Procedure Rectangle(X1,Y1,X2,Y2:Integer;LineCol:Byte;Where:Word);
Begin
Line(X1,Y1,X2,Y1,LineCol,Where);
Line(X1,Y2,X2,Y2,LineCol,Where);
Line(X1,Y1,X1,Y2,LineCol,Where);
Line(X2,Y1,X2,Y2,LineCol,Where);
End;

Procedure FilledRect(X1,Y1,X2,Y2:Integer;Col:Byte;Where:Word); Assembler;
Var Xlength, Ylength, X3: Integer;
    Ditemp:Word;
Asm
Mov Ax, X1
Mov X3, Ax
Mov Ax, Where
Mov Es, Ax
Mov Di, X1
Mov Bx, Y1
Mov Dx, Y1
Shl Bx, 8
Shl Dx, 6
Add Dx, Bx
Add Di, Dx
Mov Ax, X1
Mov Bx, X2
Sub Bx, Ax
Mov Xlength, Bx
Mov Cx, Y1
Mov Dx, Y2
Sub Dx, Cx
Mov YLength, Dx
Mov Dl, Col
Xor Ax, Ax
Xor Cx, Cx
Mov DiTemp, Di
Inc Xlength
Inc Ylength
@Horizontal:
Cmp Y1, 0
Jl @Nopixel
Cmp X1, 0
Jl @Nopixel
Cmp X1, 319
Jg @Nopixel
Mov [Es:Di], Dl
@Nopixel:
Inc Di
Inc Ax
Inc X1
Cmp Ax, Xlength
Je @Vertical
Jmp @Horizontal
@Vertical:
Add Ditemp, 320
Mov DI, Ditemp
Mov Ax, X3
Mov X1, Ax
Inc Y1
Inc Cx
Cmp Cx, Ylength
Je @Fini
Cmp Y1, 199
Jg @Fini
Xor Ax, Ax
Jmp @Horizontal
@Fini:
End;

Procedure Circle (X1,Y1,Rad:Integer;CircleCol:Byte;Adresse:Word);
Var Deg : Real;
     X2,Y2: Integer;
Begin
  Deg:=0;
  Repeat
    X2 := Round(Rad * Cos(Deg));
    Y2 := Round(Rad * Sin(Deg));
    PutPixel (X2 + X1,Y2 + Y1,CircleCol,Adresse);
    Deg := Deg  +0.005;
  Until (Deg > 6.4);
End;

Procedure SetPalette(PalNum,Red,Green,Blue:Byte); Assembler;
Asm
Mov Dx, 3C8h
Mov Al, Palnum
Out Dx, Al
Inc Dx
Mov Al, Red
Out Dx, Al
Mov Al, Green
Out Dx, Al
Mov Al, Blue
Out Dx, Al
End;

Procedure GetPalette(Var PalArray: PalType); Assembler;
Label GetLoop;
Asm
Push Ds
Lds Si, PalArray
Xor Al, Al
Xor Bl, Bl
Mov Cx, 256
GetLoop:
Mov Dx, 3C7h
Mov Al, Bl
Out Dx, Al
Add Dx, 2
In Al, Dx
Mov [Ds:Si], Al
Inc Si
In Al, Dx
Mov [Ds:Si], Al
Inc Si
In Al, Dx
Mov [Ds:Si], Al
Inc Bl
Inc Si
Loop GetLoop
Pop Ds
End;

Procedure Get1Pal(PalNum:Byte;Var RR,GG,BB:Byte);
Var RRR,GGG,BBB:Byte;
Begin
Asm
Mov Dx, 3C7h
Mov Al, PalNum
Out Dx, Al
Add Dx, 2
In Al, Dx
Mov RRR, Al
In Al, Dx
Mov GGG, Al
In Al, Dx
Mov BBB, Al
End;
RR := RRR;
GG := GGG;
BB := BBB;
End;

Procedure Fadein(PalArray: PalType);
Var Pal2: PalType;
    X1,Y1,X3: Byte;
    X2: Integer;
Begin
For X2 := 0 to 767 do
Pal2[X2] := 0;
For Y1 := 0 to 63 do
Begin
  For X1 := 0 to 255 do
   Begin
   SetPalette(X1,Pal2[X1*3],Pal2[X1*3+1],Pal2[X1*3+2]);
   For X3 := 0 to 2 do
    If Pal2[X1+X3*256] < PalArray[X1+X3*256] then
     Pal2[X1+X3*256] := Pal2[X1+X3*256] + 1;
   End;
WaitRetrace;
End;
End;

Procedure Fadeout(PalArray: PalType);
Var Pal2: PalType;
    X1,Y1,X3: Byte;
    X2: Integer;
Begin
For X2 := 0 to 767 do
Pal2[X2] := PalArray[X2];
For Y1 := 0 to 63 do
Begin
  For X1 := 0 to 255 do
   Begin
   SetPalette(X1,Pal2[X1*3],Pal2[X1*3+1],Pal2[X1*3+2]);
   For X3 := 0 to 2 do
    If Pal2[X1+X3*256] >0 then Pal2[X1+X3*256] := Pal2[X1+X3*256] - 1;
   End;
WaitRetrace;
End;
End;

Procedure LoadPalette(Fich: String; Var PalArray: PalType);
Var PalFile: File;
Begin
Assign(PalFile, Fich);
BlockRead(PalFile,PalArray,768);
Close(PalFile);
End;

Procedure SetAllPal(PalArray:PalType);
Var Num : Byte;
Begin
For Num := 0 to 255 do
SetPalette(Num,PalArray[Num*3],PalArray[Num*3+1],PalArray[Num*3+2]);
End;

Procedure AllColor(Colnum:Byte); Assembler;
Label PalLoop;
Asm
Mov Bl, ColNum
Mov Cx, 256
Xor Al, Al
PalLoop:
Mov Dx, 3C8h
Out Dx, Al
Inc Al
Push AX
Inc Dx
Mov Al, Bl
Out Dx, Al
Out Dx, Al
Out Dx, Al
Pop AX
Loop PalLoop
End;

Procedure Scale(X,Y:Integer;Sx,Sy:Word;SpriteName:Pointer;Mode:Byte;Where:Word);External;

Procedure Flip(Source,Dest:Word); External;

Procedure MakeOffsets;
Var XX : Byte;
Begin
For XX := 0 to 199 do
LineOffsets[XX] := XX * 320;
End;

Procedure LoadFont(FileName:String;SegMent:Word);
Var FontFile:File;
    FontX,FontY:Byte;
Begin
Assign(FontFile,FileName);
Reset(FontFile,1);
BlockRead(FontFile,FontX,1);
BlockRead(FontFile,FontY,1);
BlockRead(FontFile,Mem[SegMent:2],FontX*FontY*90);
Close(FontFile);
Mem[SegMent:0] := FontX;
Mem[SegMent:1] := FontY;
End;

Procedure Font(Fx,Fy:Integer;FontStr:String;FontSeg,Where:Word);
Var FontX,FontY,X,Y,L,OrdNum,C:Byte;
Begin
FontX := Mem[FontSeg:0];
FontY := Mem[FontSeg:1];
For L := 1 to Length(FontStr) do
Begin
OrdNum := Ord(FontStr[L]);
For Y := 0 to FontY-1 do
  For X := 0 to FontX-1 do
   Begin
   If (OrdNum >32) And (OrdNum <123) then
    Begin
     C := Mem[FontSeg:2+X+Y*FontX+(OrdNum-33)*FontX*FontY];
     If C > 0 then
      PutPixel(X+Fx,Y+Fy,C+PlusCol,Where);
    End;
   End;
Inc(Fx, FontX+1);
End;
End;

Begin
MakeOffsets;
PlusCol := 0;
End.