Skip to content

Instantly share code, notes, and snippets.

@Fortyseven

Fortyseven/GFX13.PAS

Last active August 29, 2015 14:06
Show Gist options
  • Save Fortyseven/52afef0aee5119319165 to your computer and use it in GitHub Desktop.
Save Fortyseven/52afef0aee5119319165 to your computer and use it in GitHub Desktop.
Download ZIP
Very old graphics lib from when I was first starting out
Raw
GFX13.PAS
{$G+,A+,S-,R-,I-,D+,V-,L+,X+,Q-,Y-}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍGFX v1.3}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ(c)1995 Hacsoft Developments}
Unit GFX;
Interface
Uses UTILS;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Const
VGA =$A000;
Page :Word=VGA;
Type
Virtual =Array [1..64000] Of Byte; { The size of our Virtual Screen }
VirtPtr =^Virtual; { Pointer to the virtual screen }
{ tPal =Array [0..768] Of Byte;}
tPal =Array[0..255, 1..3] of byte;
Var
Virscr :VirtPtr; { Our first Virtual screen }
Vaddr :Word; { The segment of our virtual screen}
ytab :Array [0..199] Of Word;
PCXPal :Array[0..768] of byte; {PCX palette after loading if TRUE}
Var{FONT-RELATED VARIABLES}
gPage :Word;
gFontSeg,
gFontOfs :Word;
gFontLength,
gFontWidth :Word;
{FONT REALTED ROUTINES -- FORMERLY FONTPAK.PASÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
{Sets up the current font at '@font' with a height of 'height'}
Procedure wCenter(y,c:word; s:string);
{Writes text to the screen centered}
Procedure w3DCenter(y,c,c2:word; s:string);
{Writes text to the screen centered with a 2-color simple 3D look}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
{Writes text to the screen normally at (Xp,Yp)}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
{Writes text to the screen normally with a 2-color simple 3D look}
{MISCELANIOUS SUPPORTÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function Exist(fs :string):boolean;
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Procedure mAlloc(p:pointer; s:word);
{ Secure memory alloc}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Procedure Set50;
{ Set 50 line mode...text...}
Procedure LoadVGAFont(var Block);
{ Loads a VGA text-mode bitmap into current use.}
{GRAPHICS ROUTINESÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPCX (buff: pointer; Size: Word; DoPal: Boolean);
{ Decodes a PCX from mem to Page }
{Procedure FadeTo(pall: tPal);}
Procedure LoadPCX(s:string; dopal:boolean); {Draws PCX of <64k from disk}
{Loads in a PCX from a file...needs at least as much memory as the filesize
is to operate...takes up no memory after though...}
Procedure FadeTo (pall2: tPal);
{ This procedure fades the screen to name ... if you use this for yourself,
you will need to cut out the extra stuff I do in here specific to this
program }
Procedure Cls (Col : Byte);
{ This clears the screen to the specified color }
Procedure flip (source, dest: Word);
{ This copies the entire screen at "source" to destination }
Procedure Pal (Col, R, G, B : Byte);
{ This sets the Red, Green and Blue values of a certain color }
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Procedure VSinc;
{ This waits for a vertical retrace to reduce snow on the screen }
Procedure Hline (X1, X2, Y: Word; col: Byte);
{ This draws a horizontal line from x1 to x2 on line y in color col }
Procedure Box(x,y,xx,yy,col:word);
{ DA B0X!}
Procedure Line (a, b, c, D: Integer; col: Byte);
{ This draws a solid line from a,b to c,d in colour col }
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Function ImageSize(X1,Y1,X2,Y2:Word):Word;
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
Procedure Put(X1,Y1:Word; Var IMG);
Procedure tPut(X1,Y1:Word; Var IMG);
Procedure PutPixel (X, Y : Integer; Col : Byte);
{ This puts a pixel on the screen by writing directly to memory. }
Function GetPixel (X, Y : Integer) : Byte;
{ This gets the pixel on the screen by reading directly to memory. }
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Procedure SetPal(p:tPal);
{ This sets a mass palette like LOADPAL, but from a pointer of palette...}
Procedure ZDC;
{ This sets the current palette BLACK...}
Procedure LoadPal (FileName : String);
{ This loads in an Autodesk Animator V1 pallette file }
Procedure GetTPal(var p:tPal);
Procedure GetRawPal(p:pointer);
{ get pal}
Procedure Fade2White;
{ This fades up the pallette to white }
Procedure Fade2Black;
{ This fades down the pallette to black }
Procedure FadeColors(FromColors, ToColors : Pointer;
StartCol, NoColors, NoSteps : byte);
Procedure Pixelize(from, too:word; level:word);
{ Implements a slow, but true digitiazation effect  la SNES...}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
Implementation
Const
Bits : array[1..8] of byte = ($80,$40,$20,$10,$08,$04,$02,$01);
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure mAlloc(p:pointer; s:word);
Begin
if maxavail<s then begin
asm mov ax, 3; int $10; end;
writeln('Wants ',s,', have ',maxavail,'...');
halt(40);
end
else getmem(p,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
Begin
gFontSeg :=seg(font^);
gFontOfs :=ofs(font^);
gFontLength :=height;
gFontWidth :=width;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
Var
Loop :Word;
X :Word;
Y :Word;
Loop2 :Word;
o,p,q :Word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to gFontWidth do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9; asm
mov ax, gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov ax, Color
mov [es:di], al
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wCenter(y,c:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3DCenter(y,c,c2:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
wString(xofs+1,y+1,c2,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
Var
Loop : Byte;
X : Word;
Y : Word;
Loop2 : Word;
Var
o,p,q :word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to 8 do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9;
asm
mov ax,gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov al, color
mov ah, color2
mov [es:di], ax
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadVGAFont(var Block); Assembler;
Asm
push es
mov ax,1100h
mov bx,1000h
mov cx,100h
xor dx,dx
push bp
les bp, Block
int 10h
pop bp
pop es
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
function Exist(fs :string):boolean;
var
f: file;
begin
{$I-}
Assign(f,fs);
Reset(f);
Close(f);
{$I+}
Exist:=(IOResult=0) and (fs<>'');
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pixelize(from, too:word; level:word);
Const
Bit :Array[0..8] of word =(0,1,3,7,15,31,63,127,255);
Var
x,y : word;
Begin
For x := 0 to 319 do
For y := 0 to 199 do
mem[too:320*y+x]:=
mem[from:320 * (y or bit[level])+(x or bit[level])];
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure ZDC;
Var
foo:word;
begin
port[$3c8]:=0;
for foo:=0 to 768 do port[$3c9]:=0;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2White;
{ This fades up the pallette to white }
Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] < 63 Then Inc (Tmp [1] );
If Tmp [2] < 63 Then Inc (Tmp [2] );
If Tmp [3] < 63 Then Inc (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2Black;
{ This fades up the pallette to white }
Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] > 0 Then Dec (Tmp [1] );
If Tmp [2] > 0 Then Dec (Tmp [2] );
If Tmp [3] > 0 Then Dec (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeTo (pall2: tPal);
Var loop1, loop2 :Integer;
tmp :tPal;
Begin
For loop1 := 0 To 255 Do
getpal (loop1, tmp [loop1, 1], tmp [loop1, 2], tmp [loop1, 3] );
For loop1 := 1 To 64 Do Begin
For loop2 := 0 To 255 Do Begin
If Tmp [loop2, 1] < Pall2 [loop2, 1] Then Inc (Tmp [loop2, 1] );
If Tmp [loop2, 2] < Pall2 [loop2, 2] Then Inc (Tmp [loop2, 2] );
If Tmp [loop2, 3] < Pall2 [loop2, 3] Then Inc (Tmp [loop2, 3] );
If Tmp [loop2, 1] > Pall2 [loop2, 1] Then Dec (Tmp [loop2, 1] );
If Tmp [loop2, 2] > Pall2 [loop2, 2] Then Dec (Tmp [loop2, 2] );
If Tmp [loop2, 3] > Pall2 [loop2, 3] Then Dec (Tmp [loop2, 3] );
End;
VSinc;
{ For loop2 := 0 To 255 Do
pal (loop2, tmp [loop2, 1], tmp [loop2, 2], tmp [loop2, 3] );}
setpal(tmp);
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPCX(buff: pointer; Size: Word; DoPal: Boolean);
Type
TPalette = Array [0..767] Of Byte;
PalettePtr = ^TPalette;
{ PCX stuff }
PCXHeaderPtr = ^PCXHeader;
PCXHeader = Record
Signature : Char;
Version : Char;
Encoding : Char;
BitsPerPixel : Char;
XMin, YMin,
XMax, YMax : Integer;
HRes, VRes : Integer;
Palette : Array [0..47] Of Byte;
Reserved : Char;
Planes : Char;
BytesPerLine : Integer;
PaletteType : Integer;
Filler : Array [0..57] Of Byte;
End;
Procedure ExtractLineASM (BytesWide: Integer; Var Source, Dest: Pointer);
Var
DestSeg,
DestOfs,
SourceSeg,
SourceOfs : Word;
Begin
SourceSeg := Seg (Source^);
SourceOfs := Ofs (Source^);
DestSeg := Seg (Dest^);
DestOfs := Ofs (Dest^);
Asm
push DS
push SI
cld
mov AX, DestSeg
mov ES, AX
mov DI, DestOfs { es:di -> destination pointer }
mov AX, SourceSeg
mov DS, AX
mov SI, SourceOfs { ds:si -> source buffer }
mov BX, DI
add BX, BytesWide { bx holds position to stop for this row }
XOr CX, CX
@@GetNextByte:
cmp BX, DI { are we done with the line }
jbe @@ExitHere
lodsb { al contains next byte }
mov AH, AL
And AH, 0C0h
cmp AH, 0C0h
jne @@SingleByte
{ must be a run of bytes }
mov CL, AL
And CL, 3Fh
lodsb
rep stosb
jmp @@GetNextByte
@@SingleByte:
stosb
jmp @@GetNextByte
@@ExitHere:
mov SourceSeg, DS
mov SourceOfs, SI
mov DestSeg, ES
mov DestOfs, DI
pop SI
pop DS
End;
Source := Ptr (SourceSeg, SourceOfs);
Dest := Ptr (DestSeg, DestOfs);
End;
Procedure DisplayPCX (X, Y: Integer; Buf: Pointer);
Var
I, NumRows,
BytesWide : Integer;
Header : PCXHeaderPtr;
DestPtr : Pointer;
Offset : Word;
Begin
Header := Ptr (Seg (Buf^), Ofs (Buf^) );
Buf := Ptr (Seg (Buf^), Ofs (Buf^) + 128);
Offset := Y * 320 + X;
NumRows := Header^. YMax - Header^. YMin + 1;
BytesWide := Header^. XMax - Header^. XMin + 1;
If Odd (BytesWide) Then Inc (BytesWide);
For I := 1 To NumRows Do Begin
DestPtr := Ptr (page, Offset);
ExtractLineASM (BytesWide, Buf, DestPtr);
Inc (Offset, 320);
End;
End;
Var
Pal : PalettePtr; { PCX palette }
Shade : Word; { RGB shade, file size }
Hdr : PCXHeaderPtr;
temp : Word;
Begin
Pal := Ptr (Seg (buff^), Ofs (buff^) + Size - 768); { get palette location }
If DoPal = True Then
Begin
Port [968] := 0; { set palette }
For Shade := 0 To 767 Do Port [969] := Pal^ [Shade] ShR 2;
End;
For temp := 0 To 768 Do PcxPal [temp] := Pal^ [temp] ShR 2;
DisplayPCX (0, 0, Buff);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Cls (Col : Byte); Assembler;
{ This clears the screen to the specified color }
Asm
push ES
mov CX, 32000;
mov ES, [page]
XOr DI, DI
mov AL, [col]
mov AH, AL
rep stosw
pop ES
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Label poo;
Begin
initv:=true;
if maxavail<64000 then begin initv:=false; goto poo; end;
getmem(VirScr, 64000);
vaddr:=Seg(virscr^);
poo:
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Begin
FreeMem(VirScr, 64000);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure flip (source, dest: Word); Assembler;
{ This copies the entire screen at "source" to destination }
Asm
push DS
mov AX, [Dest]
mov ES, AX
mov AX, [Source]
mov DS, AX
XOr SI, SI
XOr DI, DI
mov CX, 32000
rep movsw
pop DS
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pal (Col, R, G, B : Byte); Assembler;
{ This sets the Red, Green and Blue values of a certain color }
Asm
mov DX, 3c8h
mov AL, [col]
out DX, AL
Inc DX
mov AL, [r]
out DX, AL
mov AL, [g]
out DX, AL
mov AL, [b]
out DX, AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Var
rr, gg, bb : Byte;
Begin
Asm
mov DX, 3c7h
mov AL, col
out DX, AL
add DX, 2
In AL, DX
mov [rr], AL
In AL, DX
mov [gg], AL
In AL, DX
mov [bb], AL
End;
r := rr;
g := gg;
b := bb;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure VSinc; Assembler;
{ This waits for a vertical retrace to reduce snow on the screen }
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 Hline (X1, X2, Y: Word; col: Byte); Assembler;
{ This draws a horizontal line from x1 to x2 on line y in color col }
Asm
mov AX, page
mov ES, AX
mov AX, Y
mov DI, AX
ShL AX, 8
ShL DI, 6
add DI, AX
add DI, X1
mov AL, col
mov AH, AL
mov CX, X2
sub CX, X1
ShR CX, 1
jnc @start
stosb
@Start :
rep stosw
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Line (a, b, c, D: Integer; col: Byte);
{ This draws a solid line from a,b to c,d in colour col }
Function sgn (a: Real): Integer;
Begin
If a > 0 Then sgn := + 1;
If a < 0 Then sgn := - 1;
If a = 0 Then sgn := 0;
End;
Var i, s, D1X, D1Y, D2X, D2Y, u, v, m, n: Integer;
Begin
u := c - a;
v := D - b;
D1X := SGN (u);
D1Y := SGN (v);
D2X := SGN (u);
D2Y := 0;
m := Abs (u);
n := Abs (v);
If Not (M > N) Then
Begin
D2X := 0 ;
D2Y := SGN (v);
m := Abs (v);
n := Abs (u);
End;
s := m ShR 1;
For i := 0 To m Do
Begin
PutPixel (a, b, col);
s := s + n;
If Not (s < m) Then
Begin
s := s - m;
a := a + D1X;
b := b + D1Y;
End
Else
Begin
a := a + D2X;
b := b + D2Y;
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Var
X: Integer;
mny, mxy: Integer;
mnx, mxx, yc: Integer;
mul1, Div1,
mul2, Div2,
mul3, Div3,
mul4, Div4: Integer;
Begin
mny := Y1; mxy := Y1;
If Y2 < mny Then mny := Y2;
If Y2 > mxy Then mxy := Y2;
If Y3 < mny Then mny := Y3;
If Y3 > mxy Then mxy := Y3; { Choose the min y mny and max y mxy }
If Y4 < mny Then mny := Y4;
If Y4 > mxy Then mxy := Y4;
If mny < 0 Then mny := 0;
If mxy > 199 Then mxy := 199;
If mny > 199 Then Exit;
If mxy < 0 Then Exit; { Verticle range checking }
mul1 := X1 - X4; Div1 := Y1 - Y4;
mul2 := X2 - X1; Div2 := Y2 - Y1;
mul3 := X3 - X2; Div3 := Y3 - Y2;
mul4 := X4 - X3; Div4 := Y4 - Y3; { Constansts needed for intersection calc }
For yc := mny To mxy Do
Begin
mnx := 320;
mxx := - 1;
If (Y4 >= yc) Or (Y1 >= yc) Then
If (Y4 <= yc) Or (Y1 <= yc) Then { Check that yc is between y1 and y4 }
If Not (Y4 = Y1) Then
Begin
X := (yc - Y4) * mul1 Div Div1 + X4; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y1 >= yc) Or (Y2 >= yc) Then
If (Y1 <= yc) Or (Y2 <= yc) Then { Check that yc is between y1 and y2 }
If Not (Y1 = Y2) Then
Begin
X := (yc - Y1) * mul2 Div Div2 + X1; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y2 >= yc) Or (Y3 >= yc) Then
If (Y2 <= yc) Or (Y3 <= yc) Then { Check that yc is between y2 and y3 }
If Not (Y2 = Y3) Then
Begin
X := (yc - Y2) * mul3 Div Div3 + X2; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y3 >= yc) Or (Y4 >= yc) Then
If (Y3 <= yc) Or (Y4 <= yc) Then { Check that yc is between y3 and y4 }
If Not (Y3 = Y4) Then
Begin
X := (yc - Y3) * mul4 Div Div4 + X3; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If mnx < 0 Then
mnx := 0;
If mxx > 319 Then
mxx := 319; { Range checking on horizontal line }
If mnx <= mxx Then
hline (mnx, mxx, yc, Color); { Draw the horizontal line }
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Begin
rad := theta * Pi / 180
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure PutPixel (X, Y : Integer; Col : Byte); Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, [col]
mov ES: [DI], AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function GetPixel (X, Y : Integer): Byte; Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, ES: [DI]
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Var
Fil : File;
Buf : Array [1..1024] Of Byte;
BlocksRead, Count : Word;
Begin
Assign (Fil, FileName);
Reset (Fil, 1);
BlockRead (Fil, Buf, 800); { Read and ignore the 800 byte header }
Count := 0;
BlocksRead := $FFFF;
While (Not EoF (Fil) ) And (BlocksRead <> 0) Do Begin
BlockRead (Fil, mem [Seg (ScrPtr^): Ofs (ScrPtr^) + Count], 1024, BlocksRead);
Count := Count + 1024;
End;
Close (Fil);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadPal (FileName : String);
Var
F: File;
loop1: Integer;
pall: Array [0..255, 1..3] Of Byte;
Begin
Assign (F, FileName);
Reset (F, 1);
BlockRead (F, pall, 768);
Close (F);
For loop1 := 0 To 255 Do
Pal (loop1, pall [loop1, 1], pall [loop1, 2], pall [loop1, 3] );
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Set50; Assembler;
Asm
mov ax,1202h
mov bl,30h
int 10h
mov ax,3
int 10h
mov ax,1112h
mov bl,0
int 10h
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetPal(p:tPal);
Var
foo :word;
Begin
{ VSinc;
Port[$3c8]:=1;
for foo:=0 to 768 do port[$3c9]:=p[foo];}
for foo:=0 to 255 do pal(foo, p[foo,1], p[foo,2], p[foo,3]);
{ While foo<768 do begin
port[$3c9]:=mem[seg(pal^):foo];
port[$3c9]:=mem[seg(pal^):foo+1];
port[$3c9]:=mem[seg(pal^):foo+2];
inc(foo,3);
end;}
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Box(x,y,xx,yy,col:word);
Var z:word;
Begin
For z:=y to yy do
hLine(x,xx,z,col);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeColors(FromColors, ToColors : Pointer; StartCol, NoColors, NoSteps : byte); assembler;
Asm
jmp @@Start
@@DummyPalette:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@DummySub:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@NoColorsX3 :
dw 0
@@Start:
push ds
lds si, ToColors
les di, FromColors
xor ch, ch
mov cl, NoColors
shl cx, 1
add cl, NoColors
adc ch, 0
mov word ptr cs:[@@NoColorsX3], cx
mov bx, 0
push di
@@SubLoop:
lodsb
sub al, byte ptr es:di
mov byte ptr cs:[@@DummySub+bx], al
inc di
inc bx
loop @@SubLoop
pop di
push cs
pop ds
mov dh, 0
mov dl, NoSteps
@@StepLoop:
push di
mov cx, word ptr cs:[@@NoColorsX3]
mov bx, 0
@@ColorLoop:
xor ah, ah
mov al, byte ptr cs:[@@DummySub+bx]
or al, al
jns @@over1
neg al
@@over1:
mul dh
div dl
cmp byte ptr cs:[@@DummySub+bx], 0
jge @@over2
neg al
@@over2:
mov ah, byte ptr es:[di]
add ah, al
mov byte ptr cs:[@@DummyPalette+bx], ah
inc bx
inc di
loop @@ColorLoop
push dx
mov si, offset @@DummyPalette
mov cx, word ptr cs:[@@NoColorsX3]
mov dx, 03DAh
@@retrloop1:
in al, dx
test al, 8
jnz @@retrloop1
@@retrloop2:
in al, dx
test al, 8
jz @@retrloop2
mov dx, 03C8h
mov al, StartCol
out dx, al
inc dx
rep outsb
pop dx
pop di
inc dh
cmp dh, dl
jbe @@StepLoop
pop ds
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetRawPal(p:pointer);
Var
x,c :word;
r,g,b :byte;
Begin
c:=0;
For x:=0 to 255 do
begin
getpal(x, r,g,b);
mem[seg(p^):c]:=r;
inc(c);
mem[seg(p^):c]:=g;
inc(c);
mem[seg(p^):c]:=b;
inc(c);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetTPal(var p:tPal);
Var
x :word;
Begin
For x:=0 to 255 do getpal(x, p[x,1],
p[x,2],
p[x,3]);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-15-95 (SJM) Re-Optimized for speed } Var
{ Screen :Array[1..200,1..320] of Byte absolute page:0;}
I,Width,
Height,
IOF,
ISG :Word;
Begin
IOF := Ofs(Image^);
ISG := Seg(Image^);
Width := X2-X1;
Height := Y2-Y1;
MEMW[ISG:IOF] := Width;
MEMW[ISG:IOF+2] := Y2-Y1;
Inc(IOF,4);
For I:=0 to Height do
{ Move386(Screen[Y1+I,X1],MEM[ISG:IOF+(I*Width)],Width+1);}
Move386(mem[page:320*(y1+i)+x1],MEM[ISG:IOF+(I*Width)],Width+1);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function ImageSize(X1,Y1,X2,Y2:Word):Word; Begin
ImageSize := ((1+X2-X1)*(1+Y2-Y1))+8;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Put(X1,Y1:Word; Var IMG); Assembler;
{ X1,X2 = Position to place IMG }
{ IMG = Buffer to a standard formatted image }
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-24-95 (SJM) Converted to Assembler! } Var
CX1, CX2 : Word; { Holders for precalculations } ASM
{ Instructions: Clocks: Comments: }
PUSH DS; { 11: DS Must be preserved! }
LDS SI, IMG; { 16: DS:SI = Image Buffer }
MOV AX, page; { 04: A000:00 = Video Buffer }
MOV ES, AX; { 02: Can't "MOV ES, Immediate" }
LODSW; { 12: Get Width in AX }
MOV CX, AX; { 10: Set Counter to IMG width }
AND CX, 3; { 04: Num of BYTEs to MOVE (0-3)}
MOV CX1, CX; { 09: Store in CX1 for LOOP }
MOV CX, AX; { 10: Set Counter to IMG width }
SHR CX, 2; { 09: Number of DOUBLEs to MOVE }
MOV CX2, CX; { 09: Store in CX2 for LOOP }
MOV DX, 320; { 04: Width of full screen .. }
SUB DX, AX; { 03: .. SUB width of IMG in DX }
LODSW; { 12: Get Height in AX }
MOV BX, AX; { 10: Get Height from IMG }
MOV AX, Y1; { 04: MOV Y1 into AX for SHLing }
MOV CX, AX; { 03: Store a second copy in BX }
SHL AX, 6; { 04: ** AX := (Y1*320)+X1 ** }
SHL CX, 8; { 04: ** without using MUL ** }
ADD AX, CX; { 03: ** by using shifts ** }
ADD AX, X1; { 09: ** and adding. ** }
MOV DI, AX; { 02: DI to start position }
@LOOP: { --: Loop here after each line }
MOV CX, CX1; { 08: Number of BYTEs restored }
REP MOVSB; { --: Store leftover BYTEs. }
MOV CX, CX2; { 08: Number of DOUBLEs restored}
DB 66h; REP MOVSW; { --: Extended 32-bit REP MOVSD.}
ADD DI, DX; { 03: Set DI to next position }
DEC BX; { 03: Decrement height counter }
JNZ @LOOP;
POP DS; { 08: DS Must be preserved! }
{ Clocks Based on Intel 8086/8088 Instruction Set! }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure tPut(X1,Y1:Word; Var IMG); Assembler;
{ X1,X2 = Position to place IMG }
{ IMG = Buffer to a standard formatted image }
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-24-95 (SJM) Converted to Assembler! } Var
CX1 : Word; { Holders for precalculations } ASM
{ Instructions: Clocks: Comments: }
PUSH DS; { 11: DS Must be preserved! }
LDS SI, IMG; { 16: DS:SI = Image Buffer }
MOV AX, page; { 04: A000:00 = Video Buffer }
MOV ES, AX; { 02: Can't "MOV ES, Immediate" }
LODSW; { 12: Get Width in AX }
MOV CX1, AX; { 10: Set Counter to IMG width }
MOV DX, 320; { 04: Width of full screen .. }
SUB DX, AX; { 03: .. SUB width of IMG in DX }
LODSW; { 12: Get Height in AX }
MOV BX, AX; { 10: Get Height from IMG }
MOV AX, Y1; { 04: MOV Y1 into AX for SHLing }
MOV CX, AX; { 03: Store a second copy in BX }
SHL AX, 6; { 04: ** AX := (Y1*320)+X1 ** }
SHL CX, 8; { 04: ** without using MUL ** }
ADD AX, CX; { 03: ** by using shifts ** }
ADD AX, X1; { 09: ** and adding. ** }
MOV DI, AX; { 02: DI to start position } @LOOP1: { -
-: Loop here after each line }
MOV CX, CX1; { 08: Number of BYTEs restored } @LOOP2: { -
-: Loop here after each byte }
LODSB; { 12: Get BYTE from IMAGE }
CMP Al, 0; { 04: Is it a zero? }
JE @SKIP; { 16: If so, SKIP it! }
STOSB; { 11: else STOS it! }
LOOP @LOOP2; { 17: Next Byte? }
JMP @DONE; { 15: else done with line... } @SKIP: { -
-: Come here to skip BYTE }
INC DI; { 03: INC Destination pointer }
LOOP @LOOP2; { 17: Next Byte or DONE? } @DONE: { -
-: Done with line... }
ADD DI, DX; { 03: Update index to next line }
DEC BX; { 03: Decrement height counter }
JNZ @LOOP1; { 16: Start the line Loop }
POP DS; { 08: DS Must be preserved! }
end;
{ Clocks Based on Intel 8086/8088 Instruction Set! }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadPCX(s:string; dopal:boolean); {Draws PCX of <64k from disk}
Var f :file;
sz :word;
p :pointer;
Begin
assign(f, s);
reset(f,1);
sz:=filesize(f);
getmem(p, sz);
blockread(f, p^, sz);
close(f);
DrawPCX(@P^, sz, dopal);
freemem(p,sz);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Var Loop1:byte;
Begin
For Loop1 := 0 To 199 do ytab [Loop1] := Loop1 * 320;
gPage:=VGA;
gFontSeg:=$f000;
gFontOfs:=$fa6e;
gFontLength:=8;
gFontWidth:=8;
End.
Raw
GFX15.PAS
{$G+,A+,S-,R-,I-,D-,V-,L-,X+,Q-,Y-}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍGFX v1.5}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ(c)1995 Hacsoft Developments}
Unit GFX;
Interface
Uses DOSX, UTILS;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Const
VGA =$A000;
pRed =1;
pGreen =2;
pBlue =3;
Type
Virtual =Array [1..64000] Of Byte; { The size of our Virtual Screen }
VirtPtr =^Virtual; { Pointer to the virtual screen }
{ tPal =Array [0..768] Of Byte;}
tPal =Array[0..255, 1..3] of byte;
Var
page :word;
Virscr :VirtPtr; { Our first Virtual screen }
Vaddr :Word; { The segment of our virtual screen}
ytab :Array [0..199] Of Word;
PCXPal :Array[0..768] of byte; {PCX palette after loading if TRUE}
Var{FONT-RELATED VARIABLES}
gPage :Word;
gFontSeg,
gFontOfs :Word;
gFontLength,
gFontWidth :Word;
{FONT REALTED ROUTINES -- FORMERLY FONTPAK.PASÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
{Sets up the current font at '@font' with a height of 'height'}
Procedure wCenter(y,c:word; s:string);
{Writes text to the screen centered}
Procedure w3DCenter(y,c,c2:word; s:string);
{Writes text to the screen centered with a 2-color simple 3D look}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
{Writes text to the screen normally at (Xp,Yp)}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
{Writes text to the screen normally with a 2-color simple 3D look}
{MISCELANIOUS SUPPORTÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function Exist(fs :string):boolean;
{ Checks for a file's existance...}
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Procedure mAlloc(p:pointer; s:word);
{ Secure memory alloc}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Procedure Set50;
{ Set 50 line mode...text...}
Procedure setoffset(Saddr : Word);
{ "Pel Panning" routine...}
Procedure LoadVGAFont(var Block);
{ Loads a VGA text-mode bitmap into current use.}
{GRAPHICS ROUTINESÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPCX (Page: Word; buff: pointer; Size: Word; DoPal: Boolean);
{ Decodes a PCX from mem to Page }
{Procedure FadeTo(pall: tPal);}
Procedure LoadPCX(s:string; dopal:boolean); {Draws PCX of <64k from disk}
{Loads in a PCX from a file...needs at least as much memory as the filesize
is to operate...takes up no memory after though...}
Procedure FadeTo (pall2: tPal);
{ This procedure fades the screen to name ... if you use this for yourself,
you will need to cut out the extra stuff I do in here specific to this
program }
Procedure Cls (Col : Byte);
{ This clears the screen to the specified color }
Procedure flip (source, dest: Word);
{ This copies the entire screen at "source" to destination }
Procedure Pal (Col, R, G, B : Byte);
{ This sets the Red, Green and Blue values of a certain color }
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Procedure VSinc;
{ This waits for a vertical retrace to reduce snow on the screen }
Procedure Hline (X1, X2, Y: Word; col: Byte);
{ This draws a horizontal line from x1 to x2 on line y in color col }
Procedure Box(x,y,xx,yy,col:word);
{ DA B0X!}
Procedure Line (a, b, c, D: Integer; col: Byte);
{ This draws a solid line from a,b to c,d in colour col }
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Function ImageSize(X1,Y1,X2,Y2:Word):Word;
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
Procedure Put(X1,Y1:Word; Var IMG);
Procedure tPut(X1,Y1:Word; Var IMG);
Procedure PutPixel (X, Y : Integer; Col : Byte);
{ This puts a pixel on the screen by writing directly to memory. }
Function GetPixel (X, Y : Integer) : Byte;
{ This gets the pixel on the screen by reading directly to memory. }
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Procedure SetPal(p:tPal);
{ This sets a mass palette like LOADPAL, but from a pointer of palette...}
Procedure ZDC;
{ This sets the current palette BLACK...}
Procedure LoadPal (FileName : String);
{ This loads in an Autodesk Animator V1 pallette file }
Procedure GetTPal(var p:tPal);
Procedure GetRawPal(p:pointer);
{ get pal}
Procedure Fade2White;
{ This fades up the pallette to white }
Procedure Fade2Black(i:word);
{ This fades down the pallette to black in 'i' steps...}
Procedure rFade2Black(i:word; from, too:byte);
{ Same as Fade2Black, but only effects a range of colors (from..too)}
Procedure Intense(p:tPal; s:real);
{ This changes a palettes intensity by s percent. 100 is normal, 200 is
twice as bright, and 50 is half...etc..etc......p is original pal (not
affected...}
Procedure rIntense(p:tPal; s:real; from, too:byte);
{ Same as Intense, but only effects a range of colors (from..too)}
Procedure FadeColors(FromColors, ToColors : Pointer;
StartCol, NoColors, NoSteps : byte);
Procedure Pixelize(from, too:word; level:word);
{ Implements a slow, but true digitiazation effect  la SNES...}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
Implementation
Const
Bits : array[1..8] of byte = ($80,$40,$20,$10,$08,$04,$02,$01);
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure mAlloc(p:pointer; s:word);
Begin
if maxavail<s then begin
asm mov ax, 3; int $10; end;
writeln('Wants ',s,', have ',maxavail,'...');
halt(40);
end
else getmem(p,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
Begin
gFontSeg :=seg(font^);
gFontOfs :=ofs(font^);
gFontLength :=height;
gFontWidth :=width;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
Var
Loop :Word;
X :Word;
Y :Word;
Loop2 :Word;
o,p,q :Word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to gFontWidth do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9; asm
mov ax, gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov ax, Color
mov [es:di], al
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wCenter(y,c:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3DCenter(y,c,c2:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
wString(xofs+1,y+1,c2,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
Var
Loop : Byte;
X : Word;
Y : Word;
Loop2 : Word;
Var
o,p,q :word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to 8 do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9;
asm
mov ax,gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov al, color
mov ah, color2
mov [es:di], ax
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadVGAFont(var Block); Assembler;
Asm
push es
mov ax,1100h
mov bx,1000h
mov cx,100h
xor dx,dx
push bp
les bp, Block
int 10h
pop bp
pop es
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
function Exist(fs :string):boolean;
var
f: file;
begin
{$I-}
Assign(f,fs);
Reset(f);
Close(f);
{$I+}
Exist:=(IOResult=0) and (fs<>'');
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pixelize(from, too:word; level:word);
Const
Bit :Array[0..8] of word =(0,1,3,7,15,31,63,127,255);
Var
x,y : word;
Begin
For x := 0 to 319 do
For y := 0 to 199 do
mem[too:320*y+x]:=
mem[from:320 * (y or bit[level])+(x or bit[level])];
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure ZDC;
Var
foo:word;
begin
port[$3c8]:=0;
for foo:=0 to 768 do port[$3c9]:=0;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2White;
{ This fades up the pallette to white }
Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] < 63 Then Inc (Tmp [1] );
If Tmp [2] < 63 Then Inc (Tmp [2] );
If Tmp [3] < 63 Then Inc (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{Procedure Fade2Black;
{ This fades up the pallette to white } {THIS IS THE ORIGINAL CODE!!}
{Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] > 0 Then Dec (Tmp [1] );
If Tmp [2] > 0 Then Dec (Tmp [2] );
If Tmp [3] > 0 Then Dec (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeTo (pall2: tPal);
Var loop1, loop2 :Integer;
tmp :tPal;
Begin
For loop1 := 0 To 255 Do
getpal (loop1, tmp [loop1, 1], tmp [loop1, 2], tmp [loop1, 3] );
For loop1 := 1 To 64 Do Begin
For loop2 := 0 To 255 Do Begin
If Tmp [loop2, 1] < Pall2 [loop2, 1] Then Inc (Tmp [loop2, 1] );
If Tmp [loop2, 2] < Pall2 [loop2, 2] Then Inc (Tmp [loop2, 2] );
If Tmp [loop2, 3] < Pall2 [loop2, 3] Then Inc (Tmp [loop2, 3] );
If Tmp [loop2, 1] > Pall2 [loop2, 1] Then Dec (Tmp [loop2, 1] );
If Tmp [loop2, 2] > Pall2 [loop2, 2] Then Dec (Tmp [loop2, 2] );
If Tmp [loop2, 3] > Pall2 [loop2, 3] Then Dec (Tmp [loop2, 3] );
End;
VSinc;
{ For loop2 := 0 To 255 Do
pal (loop2, tmp [loop2, 1], tmp [loop2, 2], tmp [loop2, 3] );}
setpal(tmp);
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPCX(page: Word; buff: pointer; Size: Word; DoPal: Boolean);
Type
TPalette = Array [0..767] Of Byte;
PalettePtr = ^TPalette;
{ PCX stuff }
PCXHeaderPtr = ^PCXHeader;
PCXHeader = Record
Signature : Char;
Version : Char;
Encoding : Char;
BitsPerPixel : Char;
XMin, YMin,
XMax, YMax : Integer;
HRes, VRes : Integer;
Palette : Array [0..47] Of Byte;
Reserved : Char;
Planes : Char;
BytesPerLine : Integer;
PaletteType : Integer;
Filler : Array [0..57] Of Byte;
End;
Procedure ExtractLineASM (BytesWide: Integer; Var Source, Dest: Pointer);
Var
DestSeg,
DestOfs,
SourceSeg,
SourceOfs : Word;
Begin
SourceSeg := Seg (Source^);
SourceOfs := Ofs (Source^);
DestSeg := Seg (Dest^);
DestOfs := Ofs (Dest^);
Asm
push DS
push SI
cld
mov AX, DestSeg
mov ES, AX
mov DI, DestOfs { es:di -> destination pointer }
mov AX, SourceSeg
mov DS, AX
mov SI, SourceOfs { ds:si -> source buffer }
mov BX, DI
add BX, BytesWide { bx holds position to stop for this row }
XOr CX, CX
@@GetNextByte:
cmp BX, DI { are we done with the line }
jbe @@ExitHere
lodsb { al contains next byte }
mov AH, AL
And AH, 0C0h
cmp AH, 0C0h
jne @@SingleByte
{ must be a run of bytes }
mov CL, AL
And CL, 3Fh
lodsb
rep stosb
jmp @@GetNextByte
@@SingleByte:
stosb
jmp @@GetNextByte
@@ExitHere:
mov SourceSeg, DS
mov SourceOfs, SI
mov DestSeg, ES
mov DestOfs, DI
pop SI
pop DS
End;
Source := Ptr (SourceSeg, SourceOfs);
Dest := Ptr (DestSeg, DestOfs);
End;
Procedure DisplayPCX (X, Y: Integer; Buf: Pointer);
Var
I, NumRows,
BytesWide : Integer;
Header : PCXHeaderPtr;
DestPtr : Pointer;
Offset : Word;
Begin
Header := Ptr (Seg (Buf^), Ofs (Buf^) );
Buf := Ptr (Seg (Buf^), Ofs (Buf^) + 128);
Offset := Y * 320 + X;
NumRows := Header^. YMax - Header^. YMin + 1;
BytesWide := Header^. XMax - Header^. XMin + 1;
If Odd (BytesWide) Then Inc (BytesWide);
For I := 1 To NumRows Do Begin
DestPtr := Ptr (page, Offset);
ExtractLineASM (BytesWide, Buf, DestPtr);
Inc (Offset, 320);
End;
End;
Var
Pal : PalettePtr; { PCX palette }
Shade : Word; { RGB shade, file size }
Hdr : PCXHeaderPtr;
temp : Word;
Begin
Pal := Ptr (Seg (buff^), Ofs (buff^) + Size - 768); { get palette location }
If DoPal = True Then
Begin
Port [968] := 0; { set palette }
For Shade := 0 To 767 Do Port [969] := Pal^ [Shade] ShR 2;
End;
For temp := 0 To 768 Do PcxPal [temp] := Pal^ [temp] ShR 2;
DisplayPCX (0, 0, Buff);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Cls (Col : Byte); Assembler;
{ This clears the screen to the specified color }
Asm
push ES
mov CX, 32000;
mov ES, [page]
XOr DI, DI
mov AL, [col]
mov AH, AL
rep stosw
pop ES
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Label poo;
Begin
initv:=true;
if maxavail<64000 then begin initv:=false; goto poo; end;
getmem(VirScr, 64000);
vaddr:=Seg(virscr^);
poo:
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Begin
FreeMem(VirScr, 64000);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure flip (source, dest: Word); Assembler;
{ This copies the entire screen at "source" to destination }
Asm
push DS
mov AX, [Dest]
mov ES, AX
mov AX, [Source]
mov DS, AX
XOr SI, SI
XOr DI, DI
mov CX, 32000
rep movsw
pop DS
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pal (Col, R, G, B : Byte); Assembler;
{ This sets the Red, Green and Blue values of a certain color }
Asm
mov DX, 3c8h
mov AL, [col]
out DX, AL
Inc DX
mov AL, [r]
out DX, AL
mov AL, [g]
out DX, AL
mov AL, [b]
out DX, AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Var
rr, gg, bb : Byte;
Begin
Asm
mov DX, 3c7h
mov AL, col
out DX, AL
add DX, 2
In AL, DX
mov [rr], AL
In AL, DX
mov [gg], AL
In AL, DX
mov [bb], AL
End;
r := rr;
g := gg;
b := bb;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure VSinc; Assembler;
{ This waits for a vertical retrace to reduce snow on the screen }
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 Hline (X1, X2, Y: Word; col: Byte); Assembler;
{ This draws a horizontal line from x1 to x2 on line y in color col }
Asm
mov AX, page
mov ES, AX
mov AX, Y
mov DI, AX
ShL AX, 8
ShL DI, 6
add DI, AX
add DI, X1
mov AL, col
mov AH, AL
mov CX, X2
sub CX, X1
ShR CX, 1
jnc @start
stosb
@Start :
rep stosw
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Line (a, b, c, D: Integer; col: Byte);
{ This draws a solid line from a,b to c,d in colour col }
Function sgn (a: Real): Integer;
Begin
If a > 0 Then sgn := + 1;
If a < 0 Then sgn := - 1;
If a = 0 Then sgn := 0;
End;
Var i, s, D1X, D1Y, D2X, D2Y, u, v, m, n: Integer;
Begin
u := c - a;
v := D - b;
D1X := SGN (u);
D1Y := SGN (v);
D2X := SGN (u);
D2Y := 0;
m := Abs (u);
n := Abs (v);
If Not (M > N) Then
Begin
D2X := 0 ;
D2Y := SGN (v);
m := Abs (v);
n := Abs (u);
End;
s := m ShR 1;
For i := 0 To m Do
Begin
PutPixel (a, b, col);
s := s + n;
If Not (s < m) Then
Begin
s := s - m;
a := a + D1X;
b := b + D1Y;
End
Else
Begin
a := a + D2X;
b := b + D2Y;
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Var
X: Integer;
mny, mxy: Integer;
mnx, mxx, yc: Integer;
mul1, Div1,
mul2, Div2,
mul3, Div3,
mul4, Div4: Integer;
Begin
mny := Y1; mxy := Y1;
If Y2 < mny Then mny := Y2;
If Y2 > mxy Then mxy := Y2;
If Y3 < mny Then mny := Y3;
If Y3 > mxy Then mxy := Y3; { Choose the min y mny and max y mxy }
If Y4 < mny Then mny := Y4;
If Y4 > mxy Then mxy := Y4;
If mny < 0 Then mny := 0;
If mxy > 199 Then mxy := 199;
If mny > 199 Then Exit;
If mxy < 0 Then Exit; { Verticle range checking }
mul1 := X1 - X4; Div1 := Y1 - Y4;
mul2 := X2 - X1; Div2 := Y2 - Y1;
mul3 := X3 - X2; Div3 := Y3 - Y2;
mul4 := X4 - X3; Div4 := Y4 - Y3; { Constansts needed for intersection calc }
For yc := mny To mxy Do
Begin
mnx := 320;
mxx := - 1;
If (Y4 >= yc) Or (Y1 >= yc) Then
If (Y4 <= yc) Or (Y1 <= yc) Then { Check that yc is between y1 and y4 }
If Not (Y4 = Y1) Then
Begin
X := (yc - Y4) * mul1 Div Div1 + X4; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y1 >= yc) Or (Y2 >= yc) Then
If (Y1 <= yc) Or (Y2 <= yc) Then { Check that yc is between y1 and y2 }
If Not (Y1 = Y2) Then
Begin
X := (yc - Y1) * mul2 Div Div2 + X1; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y2 >= yc) Or (Y3 >= yc) Then
If (Y2 <= yc) Or (Y3 <= yc) Then { Check that yc is between y2 and y3 }
If Not (Y2 = Y3) Then
Begin
X := (yc - Y2) * mul3 Div Div3 + X2; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y3 >= yc) Or (Y4 >= yc) Then
If (Y3 <= yc) Or (Y4 <= yc) Then { Check that yc is between y3 and y4 }
If Not (Y3 = Y4) Then
Begin
X := (yc - Y3) * mul4 Div Div4 + X3; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If mnx < 0 Then
mnx := 0;
If mxx > 319 Then
mxx := 319; { Range checking on horizontal line }
If mnx <= mxx Then
hline (mnx, mxx, yc, Color); { Draw the horizontal line }
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Begin
rad := theta * Pi / 180
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure PutPixel (X, Y : Integer; Col : Byte); Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, [col]
mov ES: [DI], AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function GetPixel (X, Y : Integer): Byte; Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, ES: [DI]
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Var
Fil : File;
Buf : Array [1..1024] Of Byte;
BlocksRead, Count : Word;
Begin
Assign (Fil, FileName);
Reset (Fil, 1);
BlockRead (Fil, Buf, 800); { Read and ignore the 800 byte header }
Count := 0;
BlocksRead := $FFFF;
While (Not EoF (Fil) ) And (BlocksRead <> 0) Do Begin
BlockRead (Fil, mem [Seg (ScrPtr^): Ofs (ScrPtr^) + Count], 1024, BlocksRead);
Count := Count + 1024;
End;
Close (Fil);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadPal (FileName : String);
Var
F: File;
loop1: Integer;
pall: Array [0..255, 1..3] Of Byte;
Begin
Assign (F, FileName);
Reset (F, 1);
BlockRead (F, pall, 768);
Close (F);
For loop1 := 0 To 255 Do
Pal (loop1, pall [loop1, 1], pall [loop1, 2], pall [loop1, 3] );
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Set50; Assembler;
Asm
mov ax,1202h
mov bl,30h
int 10h
mov ax,3
int 10h
mov ax,1112h
mov bl,0
int 10h
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetPal(p:tPal);
Var
foo :word;
Begin
{ VSinc;
Port[$3c8]:=1;
for foo:=0 to 768 do port[$3c9]:=p[foo];}
for foo:=0 to 255 do pal(foo, p[foo,1], p[foo,2], p[foo,3]);
{ While foo<768 do begin
port[$3c9]:=mem[seg(pal^):foo];
port[$3c9]:=mem[seg(pal^):foo+1];
port[$3c9]:=mem[seg(pal^):foo+2];
inc(foo,3);
end;}
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Box(x,y,xx,yy,col:word);
Var z:word;
Begin
For z:=y to yy do
hLine(x,xx,z,col);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeColors(FromColors, ToColors : Pointer; StartCol, NoColors, NoSteps : byte); assembler;
Asm
jmp @@Start
@@DummyPalette:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@DummySub:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@NoColorsX3 :
dw 0
@@Start:
push ds
lds si, ToColors
les di, FromColors
xor ch, ch
mov cl, NoColors
shl cx, 1
add cl, NoColors
adc ch, 0
mov word ptr cs:[@@NoColorsX3], cx
mov bx, 0
push di
@@SubLoop:
lodsb
sub al, byte ptr es:di
mov byte ptr cs:[@@DummySub+bx], al
inc di
inc bx
loop @@SubLoop
pop di
push cs
pop ds
mov dh, 0
mov dl, NoSteps
@@StepLoop:
push di
mov cx, word ptr cs:[@@NoColorsX3]
mov bx, 0
@@ColorLoop:
xor ah, ah
mov al, byte ptr cs:[@@DummySub+bx]
or al, al
jns @@over1
neg al
@@over1:
mul dh
div dl
cmp byte ptr cs:[@@DummySub+bx], 0
jge @@over2
neg al
@@over2:
mov ah, byte ptr es:[di]
add ah, al
mov byte ptr cs:[@@DummyPalette+bx], ah
inc bx
inc di
loop @@ColorLoop
push dx
mov si, offset @@DummyPalette
mov cx, word ptr cs:[@@NoColorsX3]
mov dx, 03DAh
@@retrloop1:
in al, dx
test al, 8
jnz @@retrloop1
@@retrloop2:
in al, dx
test al, 8
jz @@retrloop2
mov dx, 03C8h
mov al, StartCol
out dx, al
inc dx
rep outsb
pop dx
pop di
inc dh
cmp dh, dl
jbe @@StepLoop
pop ds
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetRawPal(p:pointer);
Var
x,c :word;
r,g,b :byte;
Begin
c:=0;
For x:=0 to 255 do
begin
getpal(x, r,g,b);
mem[seg(p^):c]:=r;
inc(c);
mem[seg(p^):c]:=g;
inc(c);
mem[seg(p^):c]:=b;
inc(c);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetTPal(var p:tPal);
Var
x :word;
Begin
For x:=0 to 255 do getpal(x, p[x,1],
p[x,2],
p[x,3]);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-15-95 (SJM) Re-Optimized for speed } Var
{ Screen :Array[1..200,1..320] of Byte absolute page:0;}
I,Width,
Height,
IOF,
ISG :Word;
Begin
IOF := Ofs(Image^);
ISG := Seg(Image^);
Width := X2-X1;
Height := Y2-Y1;
MEMW[ISG:IOF] := Width;
MEMW[ISG:IOF+2] := Y2-Y1;
Inc(IOF,4);
For I:=0 to Height do
{ Move386(Screen[Y1+I,X1],MEM[ISG:IOF+(I*Width)],Width+1);}
Move386(mem[page:320*(y1+i)+x1],MEM[ISG:IOF+(I*Width)],Width+1);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function ImageSize(X1,Y1,X2,Y2:Word):Word; Begin
ImageSize := ((1+X2-X1)*(1+Y2-Y1))+8;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Put(X1,Y1:Word; Var IMG); Assembler;
{ X1,X2 = Position to place IMG }
{ IMG = Buffer to a standard formatted image }
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-24-95 (SJM) Converted to Assembler! } Var
CX1, CX2 : Word; { Holders for precalculations } ASM
{ Instructions: Clocks: Comments: }
PUSH DS; { 11: DS Must be preserved! }
LDS SI, IMG; { 16: DS:SI = Image Buffer }
MOV AX, page; { 04: A000:00 = Video Buffer }
MOV ES, AX; { 02: Can't "MOV ES, Immediate" }
LODSW; { 12: Get Width in AX }
MOV CX, AX; { 10: Set Counter to IMG width }
AND CX, 3; { 04: Num of BYTEs to MOVE (0-3)}
MOV CX1, CX; { 09: Store in CX1 for LOOP }
MOV CX, AX; { 10: Set Counter to IMG width }
SHR CX, 2; { 09: Number of DOUBLEs to MOVE }
MOV CX2, CX; { 09: Store in CX2 for LOOP }
MOV DX, 320; { 04: Width of full screen .. }
SUB DX, AX; { 03: .. SUB width of IMG in DX }
LODSW; { 12: Get Height in AX }
MOV BX, AX; { 10: Get Height from IMG }
MOV AX, Y1; { 04: MOV Y1 into AX for SHLing }
MOV CX, AX; { 03: Store a second copy in BX }
SHL AX, 6; { 04: ** AX := (Y1*320)+X1 ** }
SHL CX, 8; { 04: ** without using MUL ** }
ADD AX, CX; { 03: ** by using shifts ** }
ADD AX, X1; { 09: ** and adding. ** }
MOV DI, AX; { 02: DI to start position }
@LOOP: { --: Loop here after each line }
MOV CX, CX1; { 08: Number of BYTEs restored }
REP MOVSB; { --: Store leftover BYTEs. }
MOV CX, CX2; { 08: Number of DOUBLEs restored}
DB 66h; REP MOVSW; { --: Extended 32-bit REP MOVSD.}
ADD DI, DX; { 03: Set DI to next position }
DEC BX; { 03: Decrement height counter }
JNZ @LOOP;
POP DS; { 08: DS Must be preserved! }
{ Clocks Based on Intel 8086/8088 Instruction Set! }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure tPut(X1,Y1:Word; Var IMG); Assembler;
{ X1,X2 = Position to place IMG }
{ IMG = Buffer to a standard formatted image }
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-24-95 (SJM) Converted to Assembler! } Var
CX1 : Word; { Holders for precalculations } ASM
{ Instructions: Clocks: Comments: }
PUSH DS; { 11: DS Must be preserved! }
LDS SI, IMG; { 16: DS:SI = Image Buffer }
MOV AX, page; { 04: A000:00 = Video Buffer }
MOV ES, AX; { 02: Can't "MOV ES, Immediate" }
LODSW; { 12: Get Width in AX }
MOV CX1, AX; { 10: Set Counter to IMG width }
MOV DX, 320; { 04: Width of full screen .. }
SUB DX, AX; { 03: .. SUB width of IMG in DX }
LODSW; { 12: Get Height in AX }
MOV BX, AX; { 10: Get Height from IMG }
MOV AX, Y1; { 04: MOV Y1 into AX for SHLing }
MOV CX, AX; { 03: Store a second copy in BX }
SHL AX, 6; { 04: ** AX := (Y1*320)+X1 ** }
SHL CX, 8; { 04: ** without using MUL ** }
ADD AX, CX; { 03: ** by using shifts ** }
ADD AX, X1; { 09: ** and adding. ** }
MOV DI, AX; { 02: DI to start position } @LOOP1: { -
-: Loop here after each line }
MOV CX, CX1; { 08: Number of BYTEs restored } @LOOP2: { -
-: Loop here after each byte }
LODSB; { 12: Get BYTE from IMAGE }
CMP Al, 0; { 04: Is it a zero? }
JE @SKIP; { 16: If so, SKIP it! }
STOSB; { 11: else STOS it! }
LOOP @LOOP2; { 17: Next Byte? }
JMP @DONE; { 15: else done with line... } @SKIP: { -
-: Come here to skip BYTE }
INC DI; { 03: INC Destination pointer }
LOOP @LOOP2; { 17: Next Byte or DONE? } @DONE: { -
-: Done with line... }
ADD DI, DX; { 03: Update index to next line }
DEC BX; { 03: Decrement height counter }
JNZ @LOOP1; { 16: Start the line Loop }
POP DS; { 08: DS Must be preserved! }
end;
{ Clocks Based on Intel 8086/8088 Instruction Set! }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadPCX(s:string; dopal:boolean); {Draws PCX of <64k from disk}
Var f :file;
sz :word;
p :pointer;
Begin
assign(f, s);
reset(f,1);
sz:=filesize(f);
getmem(p, sz);
blockread(f, p^, sz);
close(f);
DrawPCX(page, @P^, sz, dopal);
freemem(p,sz);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure setoffset(Saddr : Word);
VAR
LB , HB : Byte;
Begin
LB:=HI(Saddr);
HB:=LO(Saddr);
VSinc;
ASM
MOV DX,3D4H
MOV AL,0DH
MOV AH,[HB]
OUT DX,AX
MOV AL,0CH
MOV AH,[LB]
OUT DX,AX
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Intense(p:tPal; s:real);
var z :tPal;
x :byte;
Begin
for x:=0 to 255 do begin
z[x,1]:=round((p[x,1] / 100) * s);
if z[x,1]>63 then z[x,1]:=63;
z[x,2]:=round((p[x,2] / 100) * s);
if z[x,2]>63 then z[x,2]:=63;
z[x,3]:=round((p[x,3] / 100) * s);
if z[x,3]>63 then z[x,3]:=63;
end;
setpal(z);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2Black(i:word);
var c,x :byte;
p,z :tPal;
Begin
GetTPal(p);
for c:=i downto 1 do
begin
for x:=0 to 255 do begin
z[x,1]:=round((p[x,1] / i) * c);
z[x,2]:=round((p[x,2] / i) * c);
z[x,3]:=round((p[x,3] / i) * c);
end;
vSinc;
setpal(z);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure rIntense(p:tPal; s:real; from, too:byte);
var z :tPal;
x :byte;
Begin
for x:=from to too do begin
z[x,1]:=round((p[x,1] / 100) * s);
if z[x,1]>63 then z[x,1]:=63;
z[x,2]:=round((p[x,2] / 100) * s);
if z[x,2]>63 then z[x,2]:=63;
z[x,3]:=round((p[x,3] / 100) * s);
if z[x,3]>63 then z[x,3]:=63;
end;
setpal(z);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure rFade2Black(i:word; from, too:byte);
var c,x :byte;
p,z :tPal;
Begin
GetTPal(p);
for c:=i downto 1 do
begin
for x:=from to too do begin
z[x,1]:=round((p[x,1] / i) * c);
z[x,2]:=round((p[x,2] / i) * c);
z[x,3]:=round((p[x,3] / i) * c);
end;
vSinc;
setpal(z);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Var Loop1:byte;
Begin
For Loop1 := 0 To 199 do ytab [Loop1] := Loop1 * 320;
page :=VGA;
gPage :=page;
gFontSeg :=$F000;
gFontOfs :=$FA6E;
gFontLength:=8;
gFontWidth :=8;
End.
Raw
GFX16.PAS
{$G+,A+,S-,R-,I-,D+,N-,L+,E-}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍGFX v1.6}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ(c)1996 Hacsoft Developments}
{v1.5 - Added my own PCX routine. Doesn't require filesize!! }
{v1.6 - Did a little restructring after finding RTL took over 10k overhead!
- Incorporated new fully-ASM linedrawing routine.
{}
Unit GFX;
Interface
Uses UTILS;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{$I C:\DATE.}
Const
RTMVer ='GFX16';
{ VGA :Word=$A000;}
palRed =1;
palGreen =2;
palBlue =3;
{Error CodesÄÄ}
errNoVGA =$100;
Type
tScr =Array[0..319, 0..199] of byte; {Nice little template}
Virt =Array [1..64000] Of Byte; { The size of our Virtual Screen }
VirtPtr =^Virt; { Pointer to the virtual screen }
{ tPal =Array [0..768] Of Byte;}
tPal =Array[0..255, 1..3] of byte;
Var
page :word;
Virscr :VirtPtr; { Our first Virtual screen }
Vaddr :Word; { The segment of our virtual screen}
ytab :Array [0..199] Of Word;
PCXPal :tPal; {PCX palette after loading if TRUE}
oldmode :byte;
vga :word;
{FONT-RELATED VARIABLES}
gPage :Word;
gFontSeg,
gFontOfs :Word;
gFontLength,
gFontWidth :Byte;
Procedure InitGFX; {NOW REQUIRED}
Procedure DeInitGFX;
{FONT REALTED ROUTINES -- FORMERLY FONTPAK.PASÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
{Sets up the current font at '@font' with a height of 'height'}
Procedure wCenter(y,c:word; s:string);
{Writes text to the screen centered}
Procedure w3DCenter(y,c,c2:word; s:string);
{Writes text to the screen centered with a 2-color simple 3D look}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
{Writes text to the screen normally at (Xp,Yp)}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
{Writes text to the screen normally with a 2-color simple 3D look}
{MISCELANIOUS SUPPORTÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function Exist(fs :string):boolean;
{ Checks for a file's existance...}
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Procedure mAlloc(p:pointer; s:word);
{ Secure memory alloc}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Procedure Set50;
{ Set 50 line mode...text...}
Procedure setoffset(Saddr : Word);
{ "Pel Panning" routine...}
Procedure LoadVGAFont(var Block);
{ Loads a VGA text-mode bitmap into current use.}
{GRAPHICS ROUTINESÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{Procedure DrawPCX (Page: Word; buff: pointer; Size: Word; DoPal: Boolean);}
Procedure DrawPCX(pcx:pointer; setok:boolean);
{ Decodes a PCX from mem to Page }
{Procedure FadeTo(pall: tPal);}
Function LoadPCX(s:string; dopal:boolean):Byte; {Draws PCX of <64k from disk}
{Loads in a PCX from a file...needs at least as much memory as the filesize
is to operate...takes up no memory after though...}
Procedure FadeTo (pall2: tPal);
{ This procedure fades the screen to name ... if you use this for yourself,
you will need to cut out the extra stuff I do in here specific to this
program }
Procedure Cls (Col : Byte);
{ This clears the screen to the specified color }
Procedure flip (source, dest: Word);
{ This copies the entire screen at "source" to destination }
Procedure Pal (Col, R, G, B : Byte);
{ This sets the Red, Green and Blue values of a certain color }
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Procedure VSinc;
{ This waits for a vertical retrace to reduce snow on the screen }
Procedure Hline (X1, X2, Y: Word; col: Byte);
{ This draws a horizontal line from x1 to x2 on line y in color col }
Procedure Box(x,y,xx,yy,col:word);
{ DA B0X!}
Procedure Square(x,y,xx,yy:word; c:byte);
{ DA UNPHILLED B0CKS! }
Procedure Line(X1,Y1,X2,Y2:Word; Color:Byte);
{ This draws a solid line from a,b to c,d in colour col }
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Function ImageSize(X1,Y1,X2,Y2:Word):Word;
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
Procedure Put(X1,Y1:Word; Var IMG);
Procedure tPut( XOfs,YOfs : Word; ImgPtr : pointer );
Procedure PutPixel (X, Y : Integer; Col : Byte);
{ This puts a pixel on the screen by writing directly to memory. }
Function GetPixel (X, Y : Integer) : Byte;
{ This gets the pixel on the screen by reading directly to memory. }
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Procedure SetPal(p:tPal);
{ This sets a mass palette like LOADPAL, but from a pointer of palette...}
Procedure ZDC;
{ This sets the current palette BLACK...}
Procedure LoadPal (FileName : String);
{ This loads in an Autodesk Animator V1 pallette file }
Procedure GetTPal(var p:tPal);
Procedure GetRawPal(p:pointer);
{ get pal}
Procedure Fade2White;
{ This fades up the pallette to white }
Procedure Fade2Black(i:word);
{ This fades down the pallette to black in 'i' steps...}
{Procedure rFade2Black(i:word; from, too:byte);
{ Same as Fade2Black, but only effects a range of colors (from..too)}
Procedure Intense(p:tPal; s:real);
{ This changes a palettes intensity by s percent. 100 is normal, 200 is
twice as bright, and 50 is half...etc..etc......p is original pal (not
affected...}
{Procedure rIntense(p:tPal; s:real; from, too:byte);
{ Same as Intense, but only effects a range of colors (from..too)}
Procedure FadeColors(FromColors, ToColors : Pointer;
StartCol, NoColors, NoSteps : byte);
Procedure Pixelize(from, too:word; level:word);
{ Implements a slow, but true digitiazation effect  la SNES...}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
{ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ}
Implementation
Const
Bits : array[1..8] of byte = ($80,$40,$20,$10,$08,$04,$02,$01);
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure mAlloc(p:pointer; s:word);
Begin
if maxavail<s then begin
asm mov ax, 3; int $10; end;
writeln('Wants ',s,', have ',maxavail,'...');
halt(40);
end
else getmem(p,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wSetFont(font:pointer; height, width:byte);
Begin
gFontSeg :=seg(font^);
gFontOfs :=ofs(font^);
gFontLength :=height;
gFontWidth :=width;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wString(Xp,Yp, Color : Integer; Line : String);
Var
Loop :Word;
X :Word;
Y :Word;
Loop2 :Word;
o,p,q :Word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to gFontWidth do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9; asm
mov ax, gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov ax, Color
mov [es:di], al
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure wCenter(y,c:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3DCenter(y,c,c2:word; s:string);
Var
xofs,
swidth :word;
Begin
sWidth:=length(s)*8;
xofs := ((319 div 2) - (swidth div 2)) - 30;
wString(xofs,y,c,s);
wString(xofs+1,y+1,c2,s);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure w3String(Xp,Yp:word; Color, Color2:byte; Line:String);
Var
Loop : Byte;
X : Word;
Y : Word;
Loop2 : Word;
Var
o,p,q :word;
Begin
For Loop := 1 to Length(line) do
For Y := 1 to gFontLength do
For X := 1 to 8 do
If MEM[gFontSeg:gFontOfs+(Y-1)+ord(Line[Loop])*gFontLength] and bits[X] <> 0 then
Begin
o:=x+xp;
p:=y+yp;
q:=Loop*9;
asm
mov ax,gPage;
mov es,ax
mov bx,[o]
mov dx,[p]
mov di,bx
mov bx, dx
shl dx, 8
shl bx, 6
add dx, bx
add di, dx
mov bx, [q]
add di, bx;
mov al, color
mov ah, color2
mov [es:di], ax
end;
End;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadVGAFont(var Block); Assembler;
Asm
push es
mov ax,1100h
mov bx,1000h
mov cx,100h
xor dx,dx
push bp
les bp, Block
int 10h
pop bp
pop es
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
function Exist(fs :string):boolean;
var
f: file;
begin
{$I-}
Assign(f,fs);
Reset(f);
Close(f);
{$I+}
Exist:=(IOResult=0) and (fs<>'');
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pixelize(from, too:word; level:word);
Const
Bit :Array[0..8] of word =(0,1,3,7,15,31,63,127,255);
Var
x,y : word;
Begin
For x := 0 to 319 do
For y := 0 to 199 do
mem[too:320*y+x]:=
mem[from:320 * (y or bit[level])+(x or bit[level])];
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure ZDC;
Var
foo:word;
begin
port[$3c8]:=0;
for foo:=0 to 768 do port[$3c9]:=0;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2White;
{ This fades up the pallette to white }
Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] < 63 Then Inc (Tmp [1] );
If Tmp [2] < 63 Then Inc (Tmp [2] );
If Tmp [3] < 63 Then Inc (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{Procedure Fade2Black;
{ This fades up the pallette to white } {THIS IS THE ORIGINAL CODE!!}
{Var
loop1, loop2 : Integer;
Tmp : Array [1..3] Of Byte;
Begin
For loop1 := 1 To 64 Do Begin
VSinc;
For loop2 := 0 To 255 Do Begin
Getpal (loop2, Tmp [1], Tmp [2], Tmp [3] );
If Tmp [1] > 0 Then Dec (Tmp [1] );
If Tmp [2] > 0 Then Dec (Tmp [2] );
If Tmp [3] > 0 Then Dec (Tmp [3] );
Pal (loop2, Tmp [1], Tmp [2], Tmp [3] );
End;
End;
End;}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeTo (pall2: tPal);
Var loop1, loop2 :Integer;
tmp :tPal;
Begin
For loop1 := 0 To 255 Do
getpal (loop1, tmp [loop1, 1], tmp [loop1, 2], tmp [loop1, 3] );
For loop1 := 1 To 64 Do Begin
For loop2 := 0 To 255 Do Begin
If Tmp [loop2, 1] < Pall2 [loop2, 1] Then Inc (Tmp [loop2, 1] );
If Tmp [loop2, 2] < Pall2 [loop2, 2] Then Inc (Tmp [loop2, 2] );
If Tmp [loop2, 3] < Pall2 [loop2, 3] Then Inc (Tmp [loop2, 3] );
If Tmp [loop2, 1] > Pall2 [loop2, 1] Then Dec (Tmp [loop2, 1] );
If Tmp [loop2, 2] > Pall2 [loop2, 2] Then Dec (Tmp [loop2, 2] );
If Tmp [loop2, 3] > Pall2 [loop2, 3] Then Dec (Tmp [loop2, 3] );
End;
VSinc;
{ For loop2 := 0 To 255 Do
pal (loop2, tmp [loop2, 1], tmp [loop2, 2], tmp [loop2, 3] );}
setpal(tmp);
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
(*Procedure DrawPCX(page: Word; buff: pointer; Size: Word; DoPal: Boolean);
Type
TPalette = Array [0..767] Of Byte;
PalettePtr = ^TPalette;
{ PCX stuff }
PCXHeaderPtr = ^PCXHeader;
PCXHeader = Record
Signature : Char;
Version : Char;
Encoding : Char;
BitsPerPixel : Char;
XMin, YMin,
XMax, YMax : Integer;
HRes, VRes : Integer;
Palette : Array [0..47] Of Byte;
Reserved : Char;
Planes : Char;
BytesPerLine : Integer;
PaletteType : Integer;
Filler : Array [0..57] Of Byte;
End;
Procedure ExtractLineASM (BytesWide: Integer; Var Source, Dest: Pointer);
Var
DestSeg,
DestOfs,
SourceSeg,
SourceOfs : Word;
Begin
SourceSeg := Seg (Source^);
SourceOfs := Ofs (Source^);
DestSeg := Seg (Dest^);
DestOfs := Ofs (Dest^);
Asm
push DS
push SI
cld
mov AX, DestSeg
mov ES, AX
mov DI, DestOfs { es:di -> destination pointer }
mov AX, SourceSeg
mov DS, AX
mov SI, SourceOfs { ds:si -> source buffer }
mov BX, DI
add BX, BytesWide { bx holds position to stop for this row }
XOr CX, CX
@@GetNextByte:
cmp BX, DI { are we done with the line }
jbe @@ExitHere
lodsb { al contains next byte }
mov AH, AL
And AH, 0C0h
cmp AH, 0C0h
jne @@SingleByte
{ must be a run of bytes }
mov CL, AL
And CL, 3Fh
lodsb
rep stosb
jmp @@GetNextByte
@@SingleByte:
stosb
jmp @@GetNextByte
@@ExitHere:
mov SourceSeg, DS
mov SourceOfs, SI
mov DestSeg, ES
mov DestOfs, DI
pop SI
pop DS
End;
Source := Ptr (SourceSeg, SourceOfs);
Dest := Ptr (DestSeg, DestOfs);
End;
Procedure DisplayPCX (X, Y: Integer; Buf: Pointer);
Var
I, NumRows,
BytesWide : Integer;
Header : PCXHeaderPtr;
DestPtr : Pointer;
Offset : Word;
Begin
Header := Ptr (Seg (Buf^), Ofs (Buf^) );
Buf := Ptr (Seg (Buf^), Ofs (Buf^) + 128);
Offset := Y * 320 + X;
NumRows := Header^. YMax - Header^. YMin + 1;
BytesWide := Header^. XMax - Header^. XMin + 1;
If Odd (BytesWide) Then Inc (BytesWide);
For I := 1 To NumRows Do Begin
DestPtr := Ptr (page, Offset);
ExtractLineASM (BytesWide, Buf, DestPtr);
Inc (Offset, 320);
End;
End;
Var
Pal : PalettePtr; { PCX palette }
Shade : Word; { RGB shade, file size }
Hdr : PCXHeaderPtr;
temp : Word;
Begin
Pal := Ptr (Seg (buff^), Ofs (buff^) + Size - 768); { get palette location }
If DoPal = True Then
Begin
Port [968] := 0; { set palette }
For Shade := 0 To 767 Do Port [969] := Pal^ [Shade] ShR 2;
End;
For temp := 0 To 768 Do PcxPal [temp] := Pal^ [temp] ShR 2;
DisplayPCX (0, 0, Buff);
End;*)
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPCX(pcx:pointer; setok:boolean);
const count:word=0;
var s, pn :word;
b1, b2, run :byte;
pal :array[1..768] of byte;
Begin
count:=0;
s:=seg(pcx^);
pn:=128+ofs(pcx^);
{ while c<64000 do}
repeat
b1:=mem[s:pn];
b2:=mem[s:pn+1];
if b1 in [0..191] then
begin
mem[page:count]:=b1;
inc(pn); inc(count);
end
else
begin
run:=b1-192;
fillchar(mem[page:count], run, b2);
inc(count,run); inc(pn,2);
end;
until (count >= 64000);
move(mem[s:pn+1], pal, 768);
for count:=1 to 768 do pal[count]:=pal[count] shr 2;
pcxpal:=tPal(pal);
if setok then setpal(pcxpal);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Cls (Col : Byte); Assembler;
{ This clears the screen to the specified color }
Asm
push ES
mov CX, 32000;
mov ES, [page]
XOr DI, DI
mov AL, [col]
mov AH, AL
rep stosw
pop ES
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function InitV:Boolean;
{ This sets up the memory needed for the virtual screen }
Label poo;
Begin
initv:=true;
if maxavail<64000 then begin initv:=false; goto poo; end;
getmem(VirScr, 64000);
vaddr:=Seg(virscr^);
poo:
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DeInitV;
{ This frees the memory used by the virtual screen }
Begin
FreeMem(VirScr, 64000);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure flip (source, dest: Word); (*Assembler;
{ This copies the entire screen at "source" to destination }
Asm
MOV AX, DS; { 08: Save DS in AX. }
{ LDS SI, SRC; { 16: Load Source Buffer. }
{ LES DI, DST; { 16: Load Destination Buffer. }
MOV AX, source;
MOV DS, AX;
MOV AX, Dest;
mov es, ax;
MOV CX, 16000; { 08: Store length in CX. }
MOV BX, CX; { 02: Store a copy in BX. }
{ SHR CX, 2; { 09: Number of DWORDs to MOVS. }
DB 66h; REP MOVSW; { --: Extended 32-bit REP MOVSD.}
MOV CX, BX; { 02: Get Length again. }
{ AND CX, 3; { 04: # of leftover BYTEs (0-3).}
{ REP MOVSB; { --: Store leftover BYTEs. }
MOV DS, AX; { 08: Restore DS from AX. }
End;*)
Begin
move386(mem[source:0], mem[dest:0], 64000);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pal (Col, R, G, B : Byte); Assembler;
{ This sets the Red, Green and Blue values of a certain color }
Asm
mov DX, 3c8h
mov AL, [col]
out DX, AL
Inc DX
mov AL, [r]
out DX, AL
mov AL, [g]
out DX, AL
mov AL, [b]
out DX, AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetPal (Col : Byte; Var R, G, B : Byte);
{ This gets the Red, Green and Blue values of a certain color }
Var
rr, gg, bb : Byte;
Begin
Asm
mov DX, 3c7h
mov AL, col
out DX, AL
add DX, 2
In AL, DX
mov [rr], AL
In AL, DX
mov [gg], AL
In AL, DX
mov [bb], AL
End;
r := rr;
g := gg;
b := bb;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure VSinc; Assembler;
{ This waits for a vertical retrace to reduce snow on the screen }
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 Hline (X1, X2, Y: Word; col: Byte); Assembler;
{ This draws a horizontal line from x1 to x2 on line y in color col }
Asm
mov AX, page
mov ES, AX
mov AX, Y
mov DI, AX
ShL AX, 8
ShL DI, 6
add DI, AX
add DI, X1
mov AL, col
mov AH, AL
mov CX, X2
sub CX, X1
ShR CX, 1
jnc @start
stosb
@Start :
rep stosw
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Line(X1,Y1,X2,Y2:Word; Color:Byte); Assembler;
Var DeX,DeY : Integer;
IncF : Integer;
Offset : Word;
Asm
Mov AX,[X2]
Sub AX,[X1]
JNC @@Dont1
Neg AX
@@Dont1:
Mov [DeX],AX
Mov AX,[Y2]
Sub AX,[Y1]
JNC @@Dont2
Neg AX
@@Dont2:
Mov [DeY],AX
Cmp AX,[DeX]
JBE @@OtherLine
Mov AX,[Y1]
Cmp AX,[Y2]
JBE @@DontSwap1
Mov BX,[Y2]
Mov [Y1],BX
Mov [Y2],AX
Mov AX,[X1]
Mov BX,[X2]
Mov [X1],BX
Mov [X2],AX
@@DontSwap1:
Mov [IncF],1
Mov AX,[X1]
Cmp AX,[X2]
JBE @@SkipNegate1
Neg [IncF]
@@SkipNegate1:
Mov AX,[Y1]
Mov BX,320
Mul BX
Mov DI,AX
Add DI,[X1] {Offset in DI}
Mov BX,[DeY] {RefVar in BX}
Mov CX,BX
Mov AX,page
Mov ES,AX {Video segment}
Mov DL,[Color]
Mov SI,[DeX]
@@DrawLoop1:
Mov ES:[DI],DL
Add DI,320
Sub BX,SI
JNC @@GoOn1
Add BX,[DeY]
Add DI,[IncF]
@@GoOn1:
Loop @@DrawLoop1
Jmp @@ExitLine
@@OtherLine:
Mov AX,[X1]
Cmp AX,[X2]
JBE @@DontSwap2
Mov BX,[X2]
Mov [X1],BX
Mov [X2],AX
Mov AX,[Y1]
Mov BX,[Y2]
Mov [Y1],BX
Mov [Y2],AX
@@DontSwap2:
Mov [IncF],320
Mov AX,[Y1]
Cmp AX,[Y2]
JBE @@SkipNegate2
Neg [IncF]
@@SkipNegate2:
Mov AX,[Y1]
Mov BX,320
Mul BX
Mov DI,AX
Add DI,[X1] {Offset in DI}
Mov BX,[DeX] {RefVar in BX}
Mov CX,BX
Mov AX, page
Mov ES,AX {Video segment}
Mov DL,[Color]
Mov SI,[DeY]
@@DrawLoop2:
Mov ES:[DI],DL
Inc DI
Sub BX,SI
JNC @@GoOn2
Add BX,[DeX]
Add DI,[IncF]
@@GoOn2:
Loop @@DrawLoop2
@@ExitLine:
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DrawPoly (X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Color: Byte);
{ This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
in color col }
Var
X: Integer;
mny, mxy: Integer;
mnx, mxx, yc: Integer;
mul1, Div1,
mul2, Div2,
mul3, Div3,
mul4, Div4: Integer;
Begin
mny := Y1; mxy := Y1;
If Y2 < mny Then mny := Y2;
If Y2 > mxy Then mxy := Y2;
If Y3 < mny Then mny := Y3;
If Y3 > mxy Then mxy := Y3; { Choose the min y mny and max y mxy }
If Y4 < mny Then mny := Y4;
If Y4 > mxy Then mxy := Y4;
If mny < 0 Then mny := 0;
If mxy > 199 Then mxy := 199;
If mny > 199 Then Exit;
If mxy < 0 Then Exit; { Verticle range checking }
mul1 := X1 - X4; Div1 := Y1 - Y4;
mul2 := X2 - X1; Div2 := Y2 - Y1;
mul3 := X3 - X2; Div3 := Y3 - Y2;
mul4 := X4 - X3; Div4 := Y4 - Y3; { Constansts needed for intersection calc }
For yc := mny To mxy Do
Begin
mnx := 320;
mxx := - 1;
If (Y4 >= yc) Or (Y1 >= yc) Then
If (Y4 <= yc) Or (Y1 <= yc) Then { Check that yc is between y1 and y4 }
If Not (Y4 = Y1) Then
Begin
X := (yc - Y4) * mul1 Div Div1 + X4; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y1 >= yc) Or (Y2 >= yc) Then
If (Y1 <= yc) Or (Y2 <= yc) Then { Check that yc is between y1 and y2 }
If Not (Y1 = Y2) Then
Begin
X := (yc - Y1) * mul2 Div Div2 + X1; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y2 >= yc) Or (Y3 >= yc) Then
If (Y2 <= yc) Or (Y3 <= yc) Then { Check that yc is between y2 and y3 }
If Not (Y2 = Y3) Then
Begin
X := (yc - Y2) * mul3 Div Div3 + X2; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If (Y3 >= yc) Or (Y4 >= yc) Then
If (Y3 <= yc) Or (Y4 <= yc) Then { Check that yc is between y3 and y4 }
If Not (Y3 = Y4) Then
Begin
X := (yc - Y3) * mul4 Div Div4 + X3; { Point of intersection on x axis }
If X < mnx Then
mnx := X;
If X > mxx Then
mxx := X; { Set point as start or end of horiz line }
End;
If mnx < 0 Then
mnx := 0;
If mxx > 319 Then
mxx := 319; { Range checking on horizontal line }
If mnx <= mxx Then
hline (mnx, mxx, yc, Color); { Draw the horizontal line }
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function rad (theta : Real) : Real;
{ This calculates the degrees of an angle }
Begin
rad := theta * Pi / 180
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure PutPixel (X, Y : Integer; Col : Byte); Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, [col]
mov ES: [DI], AL
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function GetPixel (X, Y : Integer): Byte; Assembler;
{ This puts a pixel on the screen by writing directly to memory. }
Asm
mov AX, page
mov ES, AX
mov BX, [Y]
ShL BX, 1
mov DI, Word Ptr [ytab + BX]
add DI, [X]
mov AL, ES: [DI]
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadCEL (FileName : String; ScrPtr : pointer);
{ This loads the cel 'filename' into the pointer scrptr }
Var
Fil : File;
Buf : Array [1..1024] Of Byte;
BlocksRead, Count : Word;
Begin
Assign (Fil, FileName);
Reset (Fil, 1);
BlockRead (Fil, Buf, 800); { Read and ignore the 800 byte header }
Count := 0;
BlocksRead := $FFFF;
While (Not EoF (Fil) ) And (BlocksRead <> 0) Do Begin
BlockRead (Fil, mem [Seg (ScrPtr^): Ofs (ScrPtr^) + Count], 1024, BlocksRead);
Count := Count + 1024;
End;
Close (Fil);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure LoadPal (FileName : String);
Var
F: File;
loop1: Integer;
pall: Array [0..255, 1..3] Of Byte;
Begin
Assign (F, FileName);
Reset (F, 1);
BlockRead (F, pall, 768);
Close (F);
For loop1 := 0 To 255 Do
Pal (loop1, pall [loop1, 1], pall [loop1, 2], pall [loop1, 3] );
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Set50; Assembler;
Asm
mov ax,1202h
mov bl,30h
int 10h
mov ax,3
int 10h
mov ax,1112h
mov bl,0
int 10h
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetPal(p:tPal);
Var foo :byte;
Begin
port[$3C8]:=0;
for foo:=0 to 255 do pal(foo, p[foo,1], p[foo,2], p[foo,3]);
{begin
port[$3C9]:=p[foo,1];
port[$3C9]:=p[foo,2];
port[$3C9]:=p[foo,3];
end;}
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{Procedure SetPal(var p);
Begin
asm
mov dx, $3C8;
mov al, 0;
out dx, al;
inc dx;
lds si, p;
mov cx, 768;
rep outsb;
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Box(x,y,xx,yy,col:word);
Var z:word;
Begin
For z:=y to yy do
hLine(x,xx,z,col);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeColors(FromColors, ToColors : Pointer; StartCol, NoColors, NoSteps : byte); assembler;
Asm
jmp @@Start
@@DummyPalette:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@DummySub:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
@@NoColorsX3 :
dw 0
@@Start:
push ds
lds si, ToColors
les di, FromColors
xor ch, ch
mov cl, NoColors
shl cx, 1
add cl, NoColors
adc ch, 0
mov word ptr cs:[@@NoColorsX3], cx
mov bx, 0
push di
@@SubLoop:
lodsb
sub al, byte ptr es:di
mov byte ptr cs:[@@DummySub+bx], al
inc di
inc bx
loop @@SubLoop
pop di
push cs
pop ds
mov dh, 0
mov dl, NoSteps
@@StepLoop:
push di
mov cx, word ptr cs:[@@NoColorsX3]
mov bx, 0
@@ColorLoop:
xor ah, ah
mov al, byte ptr cs:[@@DummySub+bx]
or al, al
jns @@over1
neg al
@@over1:
mul dh
div dl
cmp byte ptr cs:[@@DummySub+bx], 0
jge @@over2
neg al
@@over2:
mov ah, byte ptr es:[di]
add ah, al
mov byte ptr cs:[@@DummyPalette+bx], ah
inc bx
inc di
loop @@ColorLoop
push dx
mov si, offset @@DummyPalette
mov cx, word ptr cs:[@@NoColorsX3]
mov dx, 03DAh
@@retrloop1:
in al, dx
test al, 8
jnz @@retrloop1
@@retrloop2:
in al, dx
test al, 8
jz @@retrloop2
mov dx, 03C8h
mov al, StartCol
out dx, al
inc dx
rep outsb
pop dx
pop di
inc dh
cmp dh, dl
jbe @@StepLoop
pop ds
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetRawPal(p:pointer);
Var
x,c :word;
r,g,b :byte;
Begin
c:=0;
For x:=0 to 255 do
begin
getpal(x, r,g,b);
mem[seg(p^):c]:=r;
inc(c);
mem[seg(p^):c]:=g;
inc(c);
mem[seg(p^):c]:=b;
inc(c);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetTPal(var p:tPal);
Var
x :word;
Begin
For x:=0 to 255 do getpal(x, p[x,1],
p[x,2],
p[x,3]);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetImage(X1,Y1,X2,Y2:Word;Var Image:Pointer);
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-15-95 (SJM) Re-Optimized for speed } Var
{ Screen :Array[1..200,1..320] of Byte absolute page:0;}
I,Width,
Height,
IOF,
ISG :Word;
Begin
IOF := Ofs(Image^);
ISG := Seg(Image^);
Width := X2-X1;
Height := Y2-Y1;
MEMW[ISG:IOF] := Width;
MEMW[ISG:IOF+2] := Y2-Y1;
Inc(IOF,4);
For I:=0 to Height do
{ Move386(Screen[Y1+I,X1],MEM[ISG:IOF+(I*Width)],Width+1);}
Move386(mem[page:320*(y1+i)+x1],MEM[ISG:IOF+(I*Width)],Width+1);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function ImageSize(X1,Y1,X2,Y2:Word):Word; Begin
ImageSize := ((1+X2-X1)*(1+Y2-Y1))+8;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Put(X1,Y1:Word; Var IMG); Assembler;
{ X1,X2 = Position to place IMG }
{ IMG = Buffer to a standard formatted image }
{ Revision History: }
{ 05-06-95 Pascal Prototype by Steven J Morales! }
{ 09-24-95 (SJM) Converted to Assembler! } Var
CX1, CX2 : Word; { Holders for precalculations } ASM
{ Instructions: Clocks: Comments: }
PUSH DS; { 11: DS Must be preserved! }
LDS SI, IMG; { 16: DS:SI = Image Buffer }
MOV AX, page; { 04: A000:00 = Video Buffer }
MOV ES, AX; { 02: Can't "MOV ES, Immediate" }
LODSW; { 12: Get Width in AX }
MOV CX, AX; { 10: Set Counter to IMG width }
AND CX, 3; { 04: Num of BYTEs to MOVE (0-3)}
MOV CX1, CX; { 09: Store in CX1 for LOOP }
MOV CX, AX; { 10: Set Counter to IMG width }
SHR CX, 2; { 09: Number of DOUBLEs to MOVE }
MOV CX2, CX; { 09: Store in CX2 for LOOP }
MOV DX, 320; { 04: Width of full screen .. }
SUB DX, AX; { 03: .. SUB width of IMG in DX }
LODSW; { 12: Get Height in AX }
MOV BX, AX; { 10: Get Height from IMG }
MOV AX, Y1; { 04: MOV Y1 into AX for SHLing }
MOV CX, AX; { 03: Store a second copy in BX }
SHL AX, 6; { 04: ** AX := (Y1*320)+X1 ** }
SHL CX, 8; { 04: ** without using MUL ** }
ADD AX, CX; { 03: ** by using shifts ** }
ADD AX, X1; { 09: ** and adding. ** }
MOV DI, AX; { 02: DI to start position }
@LOOP: { --: Loop here after each line }
MOV CX, CX1; { 08: Number of BYTEs restored }
REP MOVSB; { --: Store leftover BYTEs. }
MOV CX, CX2; { 08: Number of DOUBLEs restored}
DB 66h; REP MOVSW; { --: Extended 32-bit REP MOVSD.}
ADD DI, DX; { 03: Set DI to next position }
DEC BX; { 03: Decrement height counter }
JNZ @LOOP;
POP DS; { 08: DS Must be preserved! }
{ Clocks Based on Intel 8086/8088 Instruction Set! }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
(*Procedure GetImage( XOfs,YOfs,XSize,YSize : Word; ImgPtr : pointer );
Assembler;
asm
PUSH DS
MOV AX,0A000h
MOV DS,AX
LES DI,Imgptr
MOV BX,YOfs
XCHG BH,BL
MOV DX,BX
SHR BX,1
SHR BX,1
ADD DX,BX
ADD DX,XOfs
MOV AX,xsize
STOSW
MOV BX,AX
MOV AX,ysize
STOSW
@JP1:
MOV SI,DX
MOV CX,BX
shr cx,1
jnc @Jp2
movsb
@Jp2:
repz movsw
ADD DX,0140h
DEC AX
JNZ @JP1
POP DS
end;
*)
Procedure tPut( XOfs,YOfs : Word; ImgPtr : pointer );
Assembler;
asm
PUSH DS
MOV AX,0A000h
MOV ES,AX
LDS SI,ImgPtr
MOV BX,YOfs
XCHG BH,BL
MOV CX,BX
SHR BX,1
SHR BX,1
ADD CX,BX
ADD CX,XOfs
lodsw
or ax,ax
jz @Exit
mov dx,ax
lodsw
or ax,ax
jz @Exit
mov bx,ax
mov ax,cx
@JP1:
MOV DI,AX
MOV CX,DX
SHR CX,1
JNC @JP2
MOVSB
@JP2:
REPZ MOVSW
ADD AX,140h
DEC BX
JNZ @JP1
@Exit:
POP DS
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function LoadPCX(s:string; dopal:boolean):Byte; {Draws PCX of <64k from disk}
Var f :file;
sz :word;
p :pointer;
Begin
assign(f, s);
reset(f,1);
sz:=filesize(f);
if maxavail<sz then begin LoadPCX:=1; exit; end;
getmem(p, sz);
blockread(f, p^, sz);
close(f);
drawpcx(p, dopal);
freemem(p,sz);
LoadPCX:=0;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure setoffset(Saddr : Word);
VAR
LB , HB : Byte;
Begin
LB:=HI(Saddr);
HB:=LO(Saddr);
VSinc;
ASM
MOV DX,3D4H
MOV AL,0DH
MOV AH,[HB]
OUT DX,AX
MOV AL,0CH
MOV AH,[LB]
OUT DX,AX
End;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Intense(p:tPal; s:real);
var z :tPal;
x :byte;
Begin
for x:=0 to 255 do begin
z[x,1]:=round((p[x,1] / 100) * s);
if z[x,1]>63 then z[x,1]:=63;
z[x,2]:=round((p[x,2] / 100) * s);
if z[x,2]>63 then z[x,2]:=63;
z[x,3]:=round((p[x,3] / 100) * s);
if z[x,3]>63 then z[x,3]:=63;
end;
setpal(z);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fade2Black(i:word);
var c,x :byte;
p,z :tPal;
Begin
GetTPal(p);
for c:=i downto 1 do
begin
for x:=0 to 255 do begin
z[x,1]:=round((p[x,1] / i) * c);
z[x,2]:=round((p[x,2] / i) * c);
z[x,3]:=round((p[x,3] / i) * c);
end;
vSinc;
setpal(z);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Procedure rIntense(p:tPal; s:real; from, too:byte);
var z :tPal;
x :byte;
Begin
for x:=from to too do begin
z[x,1]:=round((p[x,1] / 100) * s);
if z[x,1]>63 then z[x,1]:=63;
z[x,2]:=round((p[x,2] / 100) * s);
if z[x,2]>63 then z[x,2]:=63;
z[x,3]:=round((p[x,3] / 100) * s);
if z[x,3]>63 then z[x,3]:=63;
end;
setpal(z);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Procedure rFade2Black(i:word; from, too:byte);
var c,x :byte;
p,z :tPal;
Begin
GetTPal(p);
for c:=i downto 1 do
begin
for x:=from to too do begin
z[x,1]:=round((p[x,1] / i) * c);
z[x,2]:=round((p[x,2] / i) * c);
z[x,3]:=round((p[x,3] / i) * c);
end;
vSinc;
setpal(z);
end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
function VGAPresent:boolean; assembler;
asm
mov ah,$F;
int $10;
mov oldMode,al; {save old Gr mode}
mov ax,$1A00;
int $10; {check for VGA}
cmp al,$1A;
jne @ERR; {no VGA Bios}
cmp bl,7;
jb @ERR; {is VGA or better?}
cmp bl,$FF;
jnz @OK;
@ERR:
xor al,al;
jmp @EXIT;
@OK:
mov al,1;
@EXIT:
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure InitGFX;
Var loop1:byte;
Begin
if not vgapresent then begin
writeln('A VGA compatable video card is required, but was not detected.');
halt(errNoVGA);
end;
For Loop1 := 0 To 199 do ytab [Loop1] := Loop1 * 320;
asm mov ax, $13; int $10; end;
{if squarepixels then asm end;}
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure DeInitGFX;
Var loop1:byte;
Begin
asm mov ax, $3; int $10; end;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Square(x,y,xx,yy:word; c:byte);
Begin
Line(x,y,x,yy,c);
Line(x,y,xx,y,c);
Line(xx,yy,x,yy,c);
Line(xx,yy,xx,y,c);
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Begin
VGA :=segA000;
page :=VGA;
gPage :=page;
gFontSeg :=$F000;
gFontOfs :=$FA6E;
gFontLength:=8;
gFontWidth :=8;
End.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment