Haven't used this in a while but I wrote/compiled it years and years ago. It is mostly in assembly and does many graphics routines fast. I have to give credit for some of this stuff to Asphixia Trainers where I learned alot about graphics programming. Google it for more info.
Here is a sample of how to use it:
USES Crt, Dos, Graphics;
VAR
X1, Y1, X2, Y2 : Integer;
Color1, Color2 : Byte;
Begin
{ These are imaginary screens. We draw everything to them, then copy them to the real screen to avoid flicker. We can have up to 4. }
If GetVideoPages(2) <> 2 Then
Begin
WriteLn(' Not enough memory for 2 pages (128k of memory needed)');
Halt;
End;
InitVGA; { Gets us into graphics mode }
{ First we will draw random rectangles the old style way FLICKER! }
Repeat
{ Create our four points for a random rectangle }
X1 := Random(ScreenWidth);
Y1 := Random(ScreenHeight);
X2 := Random(ScreenWidth-X1);
Y2 := Random(ScreenHeight-Y1);
{ Color1 is border, Color2 is fill color }
Color1 := Random(15);
Color2 := Random(15);
{ Draw it! Set method to 0 for normal. Other numbers are supposed to do see-through type effects. }
FillRectangle(X1, Y1, X2, Y2, Color1, Color2, 0, VGA);
Until Keypressed;
While keypressed Do readkey;
{ AND NOW with Virtual screens! NO FLICKER! }
CLRVID(VAddr1, 0); { Clear Video Page # 1 to black (color 0) }
Repeat
{ Create our four points for a random rectangle }
X1 := Random(ScreenWidth);
Y1 := Random(ScreenHeight);
X2 := Random(ScreenWidth-X1);
Y2 := Random(ScreenHeight-Y1);
{ Color1 is border, Color2 is fill color }
Color1 := Random(15);
Color2 := Random(15);
{ Draw it! Set method to 0 for normal. Other numbers are supposed to do see-through type effects. }
FillRRectangle(X1, Y1, X2, Y2, Color1, Color2, 0, VAddr1);
{ Copies our virtual screen onto our real screen so we actually see it }
CopyPage(VAddr1, VGA);
Until Keypressed;
Readkey;
CloseGraphics;
End.
and here it is (
Make sure to save it as GRAPHICS.PAS):
{$N+,G+}
UNIT Graphics;
INTERFACE
USES Dos, Crt;
PROCEDURE InitVGA;
PROCEDURE InitSVGA(Mode : Word);
PROCEDURE CloseGraphics;
PROCEDURE WaitRetrace;
PROCEDURE CLRVID(Where : Word;Color : Byte);
FUNCTION GetVideoPages(NumPages : Byte) : Byte;
PROCEDURE DisposeVideoPages;
PROCEDURE CopyPage(Source,Dest : Word);
PROCEDURE PutPixel(X,Y : LongInt;Color, Method : Byte;Where : Word);
PROCEDURE PutPixelW(X,Y : LongInt;Color : Byte;Where : Word);
PROCEDURE Line(X1,Y1,X2,Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
PROCEDURE VLine(Y1,Y2,X : Integer;Color : Byte;Method : Byte;Where : Word);
PROCEDURE HLine(X1,X2,Y : Integer;Color : Byte;Method : Byte;Where : Word);
PROCEDURE Rectangle(X1, Y1, X2, Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
PROCEDURE RRectangle(X1, Y1, X2, Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
PROCEDURE FillRectangle(X1, Y1, X2, Y2 : Integer;Color, Fill : Byte;Method : Byte;Where : Word);
PROCEDURE FillRRectangle(X1, Y1, X2, Y2 : Integer;Color, Fill : Byte;Method : Byte;Where : Word);
PROCEDURE Circle(X, Y, Rad : Word; Color, Method : Byte; Where : Word);
PROCEDURE FillCircle(X, Y, Rad : Word; Color, Fill, Method : Byte;Where : Word);
PROCEDURE SetColor(Color, R, G, B : Byte);
PROCEDURE GetColor(Color : Byte; VAR R, G, B : Byte);
PROCEDURE WriteText(X,Y : Integer; S : String; Color : Byte;Size : Byte;Method : Byte;Where : Word);
FUNCTION Sqrt(Num : Double) : Real;
CONST
VGA = $A000;
TYPE
VPage = Array[0..63999] Of Byte;
VPagePtr = ^VPage;
VAR
VAddr1,
VAddr2,
VAddr3,
VAddr4 : Word;
VirScr1,
VirScr2,
VirScr3,
VirScr4 : VPagePtr;
ScrHeight,
ScrWidth : Word;
SinLook : Array[0..255] Of Real;
CosLook : Array[0..255] Of Real;
IMPLEMENTATION
VAR
CharSet : Array[0..255,0..15] Of Byte;
OldBank : Byte;
NumVidPages : Byte;
F : File;
FontSeg,
FontOfs : Word;
PROCEDURE InitVGA; Assembler;
ASM
Mov Ax, 13h
Int 10h
Mov ScrWidth, 320
Mov ScrHeight, 200
END;
PROCEDURE InitSVGA; Assembler;
ASM
Mov Ax, $4F02
Mov Bx, Mode
Int 10h
Cmp Mode, 100h
Jb @Error
Ja @Check640x480
Mov ScrWidth, 640
Mov ScrHeight, 400
Jmp @Error
@Check640x480:
Cmp Mode, 102h
Ja @Check800x600
Mov ScrWidth, 640
Mov ScrHeight, 480
Jmp @Error
@Check800x600:
Cmp Mode, 104h
Ja @Check1024x768
Mov ScrWidth, 800
Mov ScrHeight, 600
Jmp @Error
@Check1024x768:
Mov ScrWidth, 1024
Mov ScrHeight, 768
Jmp @Error
@Error:
END;
PROCEDURE CloseGraphics; Assembler;
ASM
Mov Ax, 03h
Int 10h
END;
PROCEDURE WaitRetrace; Assembler;
ASM
Mov dx,3DAh
@l1:
In al,dx
And al,08h
Jnz @l1
@l2:
In al,dx
And al,08h
Jz @l2
END;
PROCEDURE CLRVID; Assembler;
ASM
Mov Di, Where
Mov Es, Di
Xor Di, Di
Mov Al, Color
Mov Ah, Al
Mov Cx, 32000
REP STOSW
END;
FUNCTION GetVideoPages;
Begin
If MaxAvail < 64000 Then Begin GetVideoPages := 0; Exit; End;
If (MaxAvail > 256000) and (NumPages >= 4) Then
Begin
New(VirScr4);VAddr4 := Seg(VirScr4^);
New(VirScr3);VAddr3 := Seg(VirScr3^);
New(VirScr2);VAddr2 := Seg(VirScr2^);
New(VirScr1);VAddr1 := Seg(VirScr1^);
NumVidPages := 4;
End ELSE
If (MaxAvail > 192000) and (NumPages >= 3) Then
Begin
New(VirScr3);VAddr3 := Seg(VirScr3^);
New(VirScr2);VAddr2 := Seg(VirScr2^);
New(VirScr1);VAddr1 := Seg(VirScr1^);
NumVidPages := 3;
End ELSE
If (MaxAvail > 128000) and (NumPages >= 2) Then
Begin
New(VirScr2);VAddr2 := Seg(VirScr2^);
New(VirScr1);VAddr1 := Seg(VirScr1^);
NumVidPages := 2;
End ELSE
If (MaxAvail > 64000) and (NumPages >= 1) Then
Begin
New(VirScr1);VAddr1 := Seg(VirScr1^);
NumVidPages := 1;
End;
GetVideoPages := NumVidPages;
End;
PROCEDURE DisposeVideoPages;
Begin
If NumVidPages > 3 Then Dispose(VirScr4);
If NumVidPages > 2 Then Dispose(VirScr3);
If NumVidPages > 1 Then Dispose(VirScr2);
If NumVidPages > 0 Then Dispose(VirScr1);
End;
PROCEDURE CopyPage; Assembler;
ASM
Push Ds
Cld
Mov Si, Source
Mov Ds, Si
Xor Si, Si
Mov Di, Dest
Mov Es, Di
Xor Di, Di
Mov Cx, 32000
@Transfer:
LODSW
STOSW
Loop @Transfer
Pop Ds
END;
PROCEDURE PutPixel(X,Y : LongInt;Color, Method : Byte;Where : Word);
VAR Bank : Word;
Begin
If ScrWidth <= 320 Then
Begin
If Method = 0 Then
Mem[Where:X+Y*ScrWidth] := Color
ELSE If Method = 1 Then
Mem[Where:X+Y*ScrWidth] := Mem[Where:X+Y*ScrWidth] XOR Color
ELSE If Method = 2 Then
Mem[Where:X+Y*ScrWidth] := Mem[Where:X+Y*ScrWidth] + Color
ELSE
Mem[Where:X+Y*ScrWidth] := Mem[Where:X+Y*ScrWidth] - Color;
End
ELSE
Begin
Bank := (Y*ScrWidth+X) Shr 16;
If OldBank <> Bank Then
Begin
ASM
Mov Ax, $4f05
Xor Bh, Bh
Mov Dx, Bank
Int $10
END;
OldBank := Bank;
End;
If Method = 0 Then
Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] := Color
ELSE If Method = 1 Then
Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] := Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] XOR Color
ELSE If Method = 2 Then
Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] := Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] + Color
ELSE
Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] := Mem[Where:X+Y*ScrWidth-(Bank Shl 16)] - Color;
End;
End;
PROCEDURE PutPixelW(X,Y : LongInt;Color : Byte;Where : Word);
Begin
MemW[Where:X+Y*ScrWidth] := Color+Color SHL 8;
End;
PROCEDURE Line(X1,Y1,X2,Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
{ This draws a solid line from X1,Y1 to X2,Y2 in COLOR }
FUNCTION SGN(X1 : Real) : Integer;
Begin
if X1>0 then SGN := 1;
if X1<0 then SGN := -1;
if X1=0 then SGN := 0;
End;
VAR
i, s,
d1x, d1y, d2x, d2y,
u, v, m, n : Integer;
Begin
u:= X2 - X1;
v:= Y2 - Y1;
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
If (X1 >= 0) and (X1 < 320) and (Y1 >= 0) and (Y1 < 200) then
PutPixel(X1,Y1,Color,Method,Where);
s := s + n;
If NOT(s < m) Then
Begin
s := s - m;
X1:= X1 + d1x;
Y1 := Y1 + d1y;
End
ELSE
Begin
X1 := X1 + d2x;
Y1 := Y1 + d2y;
End;
End;
End;
PROCEDURE VLine(Y1,Y2,X : Integer;Color : Byte;Method : Byte;Where : Word); Assembler;
ASM
Mov Bx, Where
Mov Es, Bx
Mov Al, Color
Mov Cx, X
Mov Dx, Y1
@YCOORDINATE:
Push Ax
Push Dx
Mov Ax, Dx
Mul ScrWidth
Mov Bx, Ax
Pop Dx
Pop Ax
Add Bx, Cx
Cmp Method, 1
Jb @Normal
Ja @Subtract
Add [ES:Bx], Al
Jmp @Continue
@Subtract:
Sub ES:[Bx], Al
Jmp @Continue
@Normal:
Mov [ES:Bx], Al
@Continue:
INC Dx
CMP Dx, Y2
JNA @YCOORDINATE
END;
PROCEDURE HLine(X1,X2,Y : Integer;Color : Byte;Method : Byte;Where : Word); Assembler;
ASM
Mov Bx, Where
Mov Es, Bx
Mov Cx, X1
Mov Dx, Y
Mov Ax, Dx
Mul ScrWidth
Mov Bx, Ax
Mov Al, Color
@XCOORDINATE:
Push Bx
Add Bx, Cx
Cmp Method, 1
Jb @Normal
Ja @Subtract
Add ES:[Bx], Al
Jmp @Continue
@Subtract:
Sub ES:[Bx], Al
Jmp @Continue
@Normal:
Mov ES:[Bx], Al
@Continue:
Inc Cx
Pop Bx
Cmp Cx, X2
Jna @XCOORDINATE
END;
PROCEDURE Rectangle(X1, Y1, X2, Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
Begin
VLine(Y1,Y2,X1,Color,Method,Where);
VLine(Y1,Y2,X2,Color,Method,Where);
HLine(X1+1,X2-1,Y1,Color,Method,Where);
HLine(X1+1,X2-1,Y2,Color,Method,Where);
End;
PROCEDURE RRectangle(X1, Y1, X2, Y2 : Integer;Color : Byte;Method : Byte;Where : Word);
Begin
VLine(Y1+1,Y2-1,X1,Color,Method,Where);
VLine(Y1+1,Y2-1,X2,Color,Method,Where);
HLine(X1+1,X2-1,Y1,Color,Method,Where);
HLine(X1+1,X2-1,Y2,Color,Method,Where);
End;
PROCEDURE FillRectangle(X1, Y1, X2, Y2 : Integer;Color, Fill : Byte;Method : Byte;Where : Word);
VAR
X, Y : Integer;
Begin
If (Method = 1) or (Method = 3) Then
Rectangle(X1,Y1,X2,Y2,Color,1,Where)
ELSE If (Method = 4) or (Method = 6) Then
Rectangle(X1,Y1,X2,Y2,Color,2,Where)
ELSE If (Method = 2) or (Method = 5) Then
Rectangle(X1,Y1,X2,Y2,Color,0,Where);
If (Method = 5) or (Method = 6) Then Method := 2;
If (Method = 1) or (Method = 4) Then Method := 0;
For X := X1+1 to X2-1 Do
VLine(Y1+1,Y2-1,X,Fill,Method,Where);
End;
PROCEDURE FillRRectangle(X1, Y1, X2, Y2 : Integer;Color, Fill : Byte;Method : Byte;Where : Word);
VAR
X, Y : Integer;
Begin
If (Method = 1) or (Method = 3) Then
RRectangle(X1,Y1,X2,Y2,Color,1,Where)
ELSE If (Method = 4) or (Method = 6) Then
RRectangle(X1,Y1,X2,Y2,Color,2,Where)
ELSE If (Method = 2) or (Method = 5) Then
RRectangle(X1,Y1,X2,Y2,Color,0,Where)
ELSE
RRectangle(X1,Y1,X2,Y2,Color,0,Where);
If (Method = 5) or (Method = 6) Then Method := 2;
If (Method = 1) or (Method = 4) Then Method := 0;
For X := X1+1 to X2-1 Do
VLine(Y1+1,Y2-1,X,Fill,Method,Where);
End;
PROCEDURE Circle(X, Y, Rad : Word; Color, Method : Byte; Where : Word);
VAR
W : Byte;
Z : Real;
Z2 : Real;
Begin
For W := 0 to 255 Do
Begin
Z := (Rad*SinLook[W])/2.85;
Z2 := (Rad*CosLook[W])/2.85;
PutPixel(X+Round(Z-Z2),Y+Round(Z+Z2),Color,Method,Where);
End;
End;
PROCEDURE FillCircle(X, Y, Rad : Word; Color, Fill, Method : Byte;Where : Word);
VAR
W : Byte;
W2 : Integer;
Z : Real;
Z2 : Real;
Begin
For W := 0 to 255 Do
Begin
If Rad > 2 Then
Begin
Z := ((Rad-2)*SinLook[W])/2.85;
Z2 := ((Rad-2)*CosLook[W])/2.85;
For W2 := 0-Round(Z+Z2) to Round(Z+Z2) Do
PutPixel(X+W2,Y+Round(Z-Z2),Fill,Method,Where);
End;
Z := (Rad*SinLook[W])/2.85;
Z2 := (Rad*CosLook[W])/2.85;
PutPixel(X+Round(Z+Z2),Y+Round(Z-Z2),Color,Method,Where);
End;
End;
PROCEDURE SetColor(Color, R, G, B : Byte); Assembler;
ASM
Mov Dx, 3c8h
Mov Al, Color
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 GetColor(Color : Byte; VAR R, G, B : Byte);
Begin
Port[$3c7] := Color;
R := Port[$3c9];
G := Port[$3c9];
B := Port[$3c9];
End;
{PROCEDURE GetColor(Color : Byte; VAR R, G, B : Byte); Assembler;
ASM
Mov Dx, 3c7h
Mov Al, Color
Out Dx, Al
Mov Dx, 3c9h
In
END;}
PROCEDURE WriteText(X,Y : Integer; S : String; Color : Byte;Size : Byte;Method : Byte;Where : Word);
CONST
Mask : Array[0..7] Of Byte = (1,2,4,8,16,32,64,128);
VAR
C, C1, C2 : Byte;
Begin
{
for i:=1 to length(txt) do
for j:=0 to 15 do
for k:=0 to 7 do
if ((mem[fseg:fofs+ord(txt[i])*16+j] shl k) and 128) <> 0 then
begin
mem[$a000:(y+j+1)*320+(i*8)+x+k+1]:=0;
mem[$a000:(y+j)*320+(i*8)+x+k]:=70-j-k+random(2*dither);
end;
}
If Size = 0 Then Size := 1;
If Length(S) = 0 Then Exit;
For C := 0 to Length(S)-1 Do
For C2 := 0 to 15*Size Do
For C1 := 0 to 7*Size Do
If Mem[FontSeg:FontOfs + ORD(S[C+1])*16+C2 DIV Size] AND Mask[C1 DIV Size] <> 0 Then
If Method = 0 Then
Mem[Where:(X+C1+C*8*Size)+(Y+C2)*320] := Color
ELSE If Method = 1 Then
Mem[Where:(X+C1+C*8*Size)+(Y+C2)*320] := Mem[Where:(X+C1+C*8)+(Y+C2)*320] XOR Color
ELSE If Method = 2 Then
Mem[Where:(X+C1+C*8*Size)+(Y+C2)*320] := Mem[Where:(X+C1+C*8)+(Y+C2)*320] OR Color
ELSE If Method = 3 Then
Mem[Where:(X+C1+C*8*Size)+(Y+C2)*320] := Mem[Where:(X+C1+C*8)+(Y+C2)*320] AND Color
ELSE If Method = 4 Then
Mem[Where:(X+C1+C*8*Size)+(Y+C2)*320] := Mem[Where:(X+C1+C*8)+(Y+C2)*320]+Color;
End;
FUNCTION Sqrt(Num : Double) : Real; {23 Clock Ticks, CRT.TPU uses 27}
CONST CG : Double = 1.0;
VAR NewGuess : Double;
Begin
While (ABS(CG-NewGuess) > 0.00005) Do
Begin
CG := NewGuess;
NewGuess := 0.5*(CG+Num/CG)
End;
Sqrt := NewGuess;
End;
Begin
{ Assign(F,'GAMEFONT.FNT');Reset(F,1);
BlockRead(F,CharSet,SizeOf(CharSet));
Close(F);}
{ asm
Mov Ax, $1130
Mov Bh, $06
Int $10
Mov FontSeg, Es
Mov FontOfs, Bp
end;}
For OldBank := 0 to 255 Do
Begin
SinLook[OldBank] := Sin(2*PI*OldBank/256);
CosLook[OldBank] := Cos(2*PI*OldBank/256);
End;
End.
I had an updated version of this, but not sure where. I would recommed changing the virtual screens from VAddr1, VAddr2, VAddr3, VAddr4 to an array: VAddr[1..4] Of Word; and VirScr1, VirScr2, ... to VirScr[1..4] Of VPagePtr;
Easier to work with when coding.
There could be other little bugs in here. Like I said I haven't used it in quite a while.
