Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/vgafont/vgafont.pas

Pascal/Delphi Source File | 1994-04-11 | 11.1 KB | 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.