home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
VGA_FONT.ZIP
/
VGAFONT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1990-02-12
|
11KB
|
318 lines
Program VGAfont;
Uses Crt,V_font_U,Dos;
{ See V_font_U.PAS for information about itself and the author. This }
{ program demonstrates the use of V_FONT_U. Has been tested on a 256K }
{ VGA system. Should work on an EGA, although the EGA_VGA flag should be }
{ configured for EGA mode. Compile using Turbo Pascal, version 5.0. }
{ May also work with other versions of Turbo Pascal. }
{ VGAfont demonstrates the use of using graphics on standard text-mode }
{ displays. }
{$R-} {$S-} {$I-}
Var
Buffer: array[1..FontSize] of byte; { 384 8x16 chars }
Buffer2: array[1..4096] of byte; { 80x25 screen save }
TotalX,TotalY: integer; { MaxX+1,MaxY+1 }
Procedure Swap(Var n1,n2: integer);
Var
Temp: integer;
Begin
Temp:=n1;
n1:=n2;
n2:=Temp
End;
Procedure PsetDemo;
{ Displays random dots. The display is reset (ClearChars) whenever all }
{ 384 characters have been used up. }
Var
ch: char;
Begin
ClearChars(@Buffer2); { Clear the character set }
While not keypressed do
Begin
Pset(random(TotalX),random(TotalY),random(15)+1);
GotoXY(1,25); TextColor(5); Write('Characters used: ',TotalUsed);
if TotalUsed>=384 then ClearChars(@Buffer2)
End;
ch:=readkey
End;
Procedure RandomDemo;
{ Demonstrates Line,Box,Hlin,Vlin, and Ellipse procedures. }
{ The display is reset whenever all characters have been allocated. }
Var
ch: char;
x1,y1,x2,y2,r1,r2: integer;
Begin
ClearChars(@Buffer2);
While not keypressed do
Begin
Case random(5) of
0: Line(random(TotalX),random(TotalY),random(TotalX),
random(TotalY),random(15)+1);
1: Begin
Repeat
x1:=random(TotalX);
y1:=random(TotalY);
x2:=random(TotalX);
y2:=random(TotalY)
Until (abs(x1-x2)<100) and (abs(y1-y2)<100);
Box(x1,y1,x2,y2,random(15)+1)
End;
2: Hlin(random(TotalX),random(TotalY),random(TotalX),random(15)+1);
3: Vlin(random(TotalX),random(TotalY),random(TotalY),random(15)+1);
4: Begin
Repeat
r1:=random(45)+2;
r2:=random(45)+2;
x1:=random(TotalX);
y1:=random(TotalX)
Until (x1-r1>=0) and (x1+r1<=MaxX) and (y1-r2>=0) and (y1+r2<=MaxY);
Ellipse(x1,y1,r1,r2,(random(2) shl 7) or random(16))
End
End;
GotoXY(1,25); TextColor(4); Write('Chars Used: ',TotalUsed);
if TotalUsed>=384 then
ClearChars(@Buffer2)
End;
ch:=readkey
End;
Procedure LineDemo;
{ Demonstrates the Line procedure. Freeze & Unfreeze are used to minimize }
{ flickering. Unfortunately, the BIOS resets the current video page to 0 }
{ whenever the font is updated, resulting in a FORCED UnFreeze whenever the}
{ ClearChars procedure is called. Therefore, flicker is not totally }
{ minimized. }
Var
Color,X1inc,X2inc,Y1inc,Y2inc: integer;
ch: char;
x1,y1,x2,y2: integer;
Begin
x1:=0; y1:=0; x2:=MaxX; y2:=MaxY;
X1inc:=5; X2inc:=-5; Y1inc:=0; Y2Inc:=0;
Color:=1;
While not keypressed do
Begin
Freeze;
ClearChars(@Buffer2);
Freeze;
Line(x1,y1,x2,y2,Color);
Unfreeze;
Inc(x1,X1inc); Inc(x2,X2inc); Inc(Y1,Y1Inc); Inc(Y2,Y2inc);
if x1>=MaxX then
Begin
Dec(x1,X1inc); Dec(x2,X2inc); Dec(y1,Y1inc); Dec(y2,Y2inc);
X1inc:=0; Y1inc:=5; X2inc:=0; Y2inc:=-5
End;
if y1>=MaxY then
Begin
Dec(x1,X1inc); Dec(x2,X2inc); Dec(y1,Y1inc); Dec(y2,Y2inc);
X1inc:=5; X2inc:=-5; Y1inc:=0; Y2Inc:=0;
Swap(x1,x2); Swap(y1,y2)
End;
Inc(Color); If Color=16 then Color:=1
End;
ch:=readkey
End;
Procedure CursDemo;
{ Allows the user to move around a rectangle with the mouse. Because }
{ this is graphics, this may be the first time cursor control has ever }
{ been so smooth in text-mode before. Only one pixel has to be moved }
{ each time the cursor is moved, whereas before the cursor must remain }
{ on a character boundary. }
Const
SizeX=30;
SizeY=25;
HalfX=SizeX div 2;
HalfY=SizeY div 2;
Var
reg: registers;
x,y,xt,yt,i: integer;
ReadingMouse,Start: boolean;
ch: char;
Begin
ClearChars(@Buffer2);
GotoXY(1,25); TextColor(2); Write('Do you have a Microsoft-compatible mouse? ');
Repeat
ch:=upcase(readkey)
Until ch in ['Y','N'];
if ch='N' then
Begin
TextMode(co80);
WriteLn('Sorry, you can''t do the next demo! -- press a key');
ch:=readkey;
Halt
End;
DelLine; GotoXY(19,24);
Write('Move the box around the screen with the mouse.');
GetScrn(@Buffer2);
reg.ax:=0;
Intr($33,reg);
x:=TotalX shr 1; y:=TotalY shr 1; Start:=TRUE;
While not keypressed do
Begin
ReadingMouse:=TRUE;
While (ReadingMouse) and (not Keypressed) and (not Start) Do
Begin
reg.ax:=11;
Intr($33,reg);
xt:=x+integer(reg.cx); yt:=y+integer(reg.dx);
if (xt<>x) or (yt<>y) then
Begin
x:=xt;
y:=yt;
ReadingMouse:=FALSE
End
End;
if x<(HalfX) then x:=HalfX;
if y<(HalfY) then y:=HalfY;
if x>MaxX-(HalfX) then x:=MaxX-(HalfX);
if y>MaxY-(HalfY) then y:=MaxY-(HalfY);
ClearChars(@Buffer2);
For i:=0 to 2 do
OpenBox((x-HalfX)+i,(y-HalfY)+i,(x+HalfX)-i,(y+HalfY)-i,14);
Start:=FALSE
End;
ch:=readkey
End;
Procedure BounceBallDemo;
{ Demonstrates a bouncing ball. Animation is very tricky when dealing with }
{ graphics in text-mode (see the LineDemo procedure). The Freeze & UnFreeze }
{ procedures must be used to minimize flickering. Unfortunatly, all graphics}
{ primitives use BIOS to update the character font, which results in the }
{ video page being reset to page 0; the equivalent of the UnFreeze procedure.}
{ Because of this, flickering is not fully eliminated. I also noticed another}
{ bothersome thing: when the pause key is pressed and then de-pressed during }
{ this demonstration, the graphics seem to get permanently garbled (until the }
{ program exits). }
Var
dx,x,y,a,v,i: integer;
ch: char;
Ycoord: integer;
Shift: byte;
Begin
TextMode(co80);
if MaxY=199 then
Begin
Ycoord:=144;
Shift:=0
End
else
Begin
Ycoord:=275;
Shift:=1
End;
Vlin(0,0,Ycoord,DarkGray);
Vlin(639,0,Ycoord,DarkGray);
Hlin(0,Ycoord,639,DarkGray);
GotoXY(30,21); TextColor(Red); Write('This is TEXT mode, mode 3');
GetScrn(@Buffer2);
dx:=4; x:=8; y:=0; a:=2; v:=0;
Repeat
UnFreeze;
Freeze;
Ellipse(x+5,(y shl Shift)+5,7,5,$8f);
Freeze;
if y=132 then
Begin
v:=-v;
if v=0 then v:=-20
End;
if x>618 then dx:=-dx;
if x<6 then dx:=-dx;
v:=v+a;
Box(x-2,(y shl Shift),x+12,(y shl Shift)+10,0);
inc(y,v); inc(x,dx)
Until keypressed;
UnFreeze;
TextMode(co80);
ch:=readkey
End;
Procedure EllipseDemo;
{ This procedure continuosly updates an ellipse. The procedure MaskColors }
{ is also demonstrated. MaskColors forces a maximum of 8 colors to be }
{ displayed at once (bit 3 is masked). Failure to use MaskColors in this }
{ deomonstration results in the Ellipse being displayed in a blend of two }
{ colors, instead of one. This is because characters from the lower-order }
{ character set are needed to make-up part of the picture. Since these }
{ characters are always displayed with low-intesity (as opposed to the }
{ upper 256 characters which are high-intensity), more than two colors }
{ get used. }
{ Pay attention to the # of characters used that is recorded at the bottom }
{ right of the screen. Note that when the ellipse is colored black, the }
{ number gets lower because of the de-allocated characters. Also note }
{ the slow speed of the ellipse (it's hard to ignore!). Finally, note that}
{ the numbers of characters used vary depending on the # of lines on the }
{ screen. This is because the # of lines per character (points) also }
{ changes. Therefore, the less pixels/character to choose from, the more }
{ charcters end up getting used. }
Var
ch: char;
i: integer;
Cx,Cy,r1,r2: integer;
Aspect: real;
Begin
Cx:=MaxX div 2;
Cy:=MaxY div 2;
Aspect:=MaxY/MaxX;
r1:=105;
r2:=trunc(r1*Aspect);
MaskColors;
ClearChars(@Buffer2);
GotoXY(33,25); TextColor(3); Write('Ellipse demo');
GotoXY(32,12); Write('One second ...');
For i:=0 to 5 do
OpenBox((Cx-r1)+i-20,(Cy-r2)+i-20,(r1+Cx)-i+20,(r2+Cy)-i+20,7);
Repeat
Ellipse(Cx,Cy,r1,r2,(random(7) or $80));
GotoXY(1,25); Write(TotalUsed,' characters used. ')
Until keypressed;
ch:=readkey;
ClearChars(@Buffer2);
TextMode(co80);
End;
Begin
Make8bitChars(350); { Set 8-bits/char, 350 lines }
TextMode(co80); { Erase screen }
TotalX:=Succ(MaxX); TotalY:=succ(MaxY); { Important values }
Randomize; { Randomize }
TextColor(2); { Green }
WriteLn('This is text mode!!!!');
TextColor($87); { Blinking white }
WriteLn; WriteLn;
Write('See! '); TextColor(7); { Non-blinking white }
WriteLn('The blink attribute!');
FontInit(@Buffer,@Buffer2); { Initialize the unit }
{ Do demos: }
EllipseDemo;
PsetDemo;
RandomDemo;
LineDemo;
BounceBallDemo;
CursDemo;
{ Restore default text-mode values and quit: }
TextMode(co80)
End.