home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SVGABG.ZIP / VGADEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-25  |  46.9 KB  |  1,732 lines
  1. program BGIDemo;
  2. {
  3.  
  4.   Turbo Pascal Borland Graphics Interface (BGI) demonstration
  5.   program. This program shows how to use many features of
  6.   the Graph unit.
  7.  
  8.   Copyright (c) 1985-89 by Borland International, Inc.
  9.  
  10. }
  11.  
  12. uses
  13.   Crt, Dos, Graph;
  14.  
  15.  
  16. const
  17.   { The five fonts available }
  18.   Fonts : array[0..4] of string[13] =
  19.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  20.  
  21.   { The five predefined line styles supported }
  22.   LineStyles : array[0..4] of string[9] =
  23.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  24.  
  25.   { The twelve predefined fill styles supported }
  26.   FillStyles : array[0..11] of string[14] =
  27.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  28.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  29.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  30.  
  31.   { The two text directions available }
  32.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  33.  
  34.   { The Horizontal text justifications available }
  35.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  36.  
  37.   { The vertical text justifications available }
  38.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  39.  
  40. var
  41.   GraphDriver : integer;  { The Graphics device driver }
  42.   GraphMode   : integer;  { The Graphics mode value }
  43.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  44.   ErrorCode   : integer;  { Reports any graphics errors }
  45.   MaxColor    : word;     { The maximum color value available }
  46.   OldExitProc : Pointer;  { Saves exit procedure address }
  47.  
  48. function RealDrawColor(Color : Word) : Word;
  49. begin
  50.   if (GetMaxColor > 256) then
  51.     SetRgbPalette(1024,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31);
  52.   RealDrawColor := Color;
  53. end;
  54.  
  55. function RealFillColor(Color : Word) : Word;
  56. begin
  57.   if (GetMaxColor > 256) then
  58.     SetRgbPalette(1025,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31);
  59.   RealFillColor := Color;
  60. end;
  61.  
  62. function RealColor(Color : Word) : Word;
  63. begin
  64.   if (GetMaxColor > 256) then
  65.     SetRgbPalette(1026,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31);
  66.   RealColor := Color;
  67. end;
  68.  
  69. function WhitePixel : Word;
  70. var Clr : Word;
  71. begin
  72.   if (GetMaxColor > 256) then
  73.     Clr := 32767
  74.   else
  75.     Clr := 15;
  76.   WhitePixel := Clr;
  77. end;
  78.  
  79. function BluePixel : Word;
  80. var Clr : Word;
  81. begin
  82.   if (GetMaxColor > 256) then
  83.     Clr := 31
  84.   else
  85.     Clr := 1;
  86.   BluePixel := Clr;
  87. end;
  88.  
  89. function GreenPixel : Word;
  90. var Clr : Word;
  91. begin
  92.   if (GetMaxColor > 256) then
  93.     Clr := 31 SHL 5
  94.   else
  95.     Clr := 2;
  96.   GreenPixel := Clr;
  97. end;
  98.  
  99.  
  100. {$F+}
  101. procedure MyExitProc;
  102. begin
  103.   ExitProc := OldExitProc; { Restore exit procedure address }
  104.   CloseGraph;              { Shut down the graphics system }
  105. end; { MyExitProc }
  106. {$F-}
  107.  
  108. {$F+}
  109. function DetectVGA256 : integer;
  110. { Detects VGA or MCGA video cards }
  111. var
  112.   DetectedDriver : integer;
  113.   SuggestedMode  : integer;
  114. begin
  115.   DetectGraph(DetectedDriver, SuggestedMode);
  116.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  117.   begin
  118.     Writeln('Which video mode would you like to use?');
  119.     Writeln('  0) 320x200x256');
  120.     Writeln('  1) 640x400x256');
  121.     Writeln('  2) 640x480x256');
  122.     Writeln('  3) 800x600x256');
  123.     Writeln('  4) 1024x768x256');
  124.     Writeln('  5) 640x350x256');
  125.     Writeln('  6) 1280x1024x256');
  126.     Write('> ');
  127.     Readln(SuggestedMode);
  128.     DetectVGA256 := SuggestedMode;
  129.   end
  130.   else
  131.     DetectVGA256 := grError; { Couldn't detect hardware }
  132. end; { DetectVGA256 }
  133. {$F-}
  134.  
  135. {$F+}
  136. function DetectVGA32k : integer;
  137. { Detects VGA or MCGA video cards }
  138. var
  139.   DetectedDriver : integer;
  140.   SuggestedMode  : integer;
  141. begin
  142.   DetectGraph(DetectedDriver, SuggestedMode);
  143.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  144.   begin
  145.     Writeln('Which video mode would you like to use?');
  146.     Writeln('  0) 320x200x32k');
  147.     Writeln('  1) 640x350x32k');
  148.     Writeln('  2) 640x400x32k');
  149.     Writeln('  3) 640x480x32k');
  150.     Writeln('  4) 800x600x32k');
  151.     Write('> ');
  152.     Readln(SuggestedMode);
  153.     DetectVGA32k := SuggestedMode;
  154.   end
  155.   else
  156.     DetectVGA32k := grError; { Couldn't detect hardware }
  157. end; { DetectVGA32k }
  158. {$F-}
  159.  
  160. {$F+}
  161. function DetectTwk256 : integer;
  162. { Detects VGA or MCGA video cards }
  163. var
  164.   DetectedDriver : integer;
  165.   SuggestedMode  : integer;
  166. begin
  167.   DetectGraph(DetectedDriver, SuggestedMode);
  168.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  169.   begin
  170.     Writeln('Which video mode would you like to use?');
  171.     Writeln('  0) 320x400x256');
  172.     Writeln('  1) 320x480x256');
  173.     Writeln('  2) 360x480x256');
  174.     Writeln('  3) 376x564x256');
  175.     Writeln('  4) 400x564x256');
  176.     Writeln('  5) 400x600x256');
  177.     Writeln('  6) 320x240x256');
  178.     Write('> ');
  179.     Readln(SuggestedMode);
  180.     DetectTwk256 := SuggestedMode;
  181.   end
  182.   else
  183.     DetectTwk256 := grError; { Couldn't detect hardware }
  184. end; { DetectVGA256 }
  185. {$F-}
  186.  
  187. {$F+}
  188. function DetectVGA16 : integer;
  189. { Detects VGA or MCGA video cards }
  190. var
  191.   DetectedDriver : integer;
  192.   SuggestedMode  : integer;
  193. begin
  194.   DetectGraph(DetectedDriver, SuggestedMode);
  195.   if (DetectedDriver = EGA) or (DetectedDriver = VGA) then
  196.   begin
  197.     Writeln('Which video mode would you like to use?');
  198.     Writeln('  0) 320x200x16');
  199.     Writeln('  1) 640x200x16');
  200.     Writeln('  2) 640x350x16');
  201.     Writeln('  3) 640x480x16');
  202.     Writeln('  4) 800x600x16');
  203.     Writeln('  5) 1024x768x16');
  204.     Write('> ');
  205.     Readln(SuggestedMode);
  206.     DetectVGA16 := SuggestedMode;
  207.   end
  208.   else
  209.     DetectVGA16 := grError; { Couldn't detect hardware }
  210. end; { DetectVGA256 }
  211. {$F-}
  212.  
  213. {$F+}
  214. function DetectTwk16 : integer;
  215. { Detects VGA or MCGA video cards }
  216. var
  217.   DetectedDriver : integer;
  218.   SuggestedMode  : integer;
  219. begin
  220.   DetectGraph(DetectedDriver, SuggestedMode);
  221.   if (DetectedDriver = VGA) then
  222.   begin
  223.     Writeln('Which video mode would you like to use?');
  224.     Writeln('  0) 704x528x16');
  225.     Writeln('  1) 720x540x16');
  226.     Writeln('  2) 736x552x16');
  227.     Writeln('  3) 752x564x16');
  228.     Writeln('  4) 768x576x16');
  229.     Writeln('  5) 784x588x16');
  230.     Writeln('  6) 800x600x16');
  231.     Write('> ');
  232.     Readln(SuggestedMode);
  233.     DetectTwk16 := SuggestedMode;
  234.   end
  235.   else
  236.     DetectTwk16 := grError; { Couldn't detect hardware }
  237. end; { DetectVGA256 }
  238. {$F-}
  239.  
  240. {$F+}
  241. function DetectS3 : integer;
  242. { Detects VGA or MCGA video cards }
  243. var
  244.   DetectedDriver : integer;
  245.   SuggestedMode  : integer;
  246. begin
  247.   DetectGraph(DetectedDriver, SuggestedMode);
  248.   if (DetectedDriver = VGA) then
  249.   begin
  250.     Writeln('Which video mode would you like to use?');
  251.     Writeln('  0) 640x480x256');
  252.     Writeln('  1) 800x600x256');
  253.     Writeln('  2) 1024x768x256');
  254.     Writeln('  3) 800x600x16');
  255.     Writeln('  4) 1024x768x16');
  256.     Writeln('  5) 1280x960x16');
  257.     Writeln('  6) 1280x1024x16');
  258.     Writeln('  7) 640x480x32k');
  259.     Write('> ');
  260.     Readln(SuggestedMode);
  261.     DetectS3 := SuggestedMode;
  262.   end
  263.   else
  264.     DetectS3 := grError; { Couldn't detect hardware }
  265. end; { DetectVGA256 }
  266. {$F-}
  267.  
  268. var
  269.   AutoDetectPointer : pointer;
  270.  
  271. procedure Initialize;
  272. { Initialize graphics and report any errors that may occur }
  273. var
  274.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  275.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  276.   UseWhichDriver : integer;
  277. begin
  278.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  279.   DirectVideo := False;
  280.   OldExitProc := ExitProc;                { save previous exit proc }
  281.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  282.   PathToDriver := '';
  283.   repeat
  284.     Writeln('Which driver to use?');
  285.     Writeln('  0) Svga256');
  286.     Writeln('  1) Svga16');
  287.     Writeln('  2) Svga32k');
  288.     Writeln('  3) Tweak256');
  289.     Writeln('  4) Tweak16');
  290.     Writeln('  5) S3');
  291.     Write('>');
  292.     Readln(UseWhichDriver);
  293.     if (UseWhichDriver = 0) then
  294.     begin
  295.       AutoDetectPointer := @DetectVGA256;
  296.       GraphDriver := InstallUserDriver('Svga256',AutoDetectPointer);
  297.     end
  298.     else if (UseWhichDriver=1) then
  299.     begin
  300.       AutoDetectPointer := @DetectVGA16;   { Point to detection routine }
  301.       GraphDriver := InstallUserDriver('SVGA16', AutoDetectPointer);
  302.     end
  303.     else if (UseWhichDriver=2) then
  304.     begin
  305.       AutoDetectPointer := @DetectVGA32k;
  306.       GraphDriver := InstallUserDriver('Svga32k',AutoDetectPointer);
  307.     end
  308.  
  309.     else if (UseWhichDriver=3) then
  310.     begin
  311.       AutoDetectPointer := @DetectTwk256;
  312.       GraphDriver := InstallUserDriver('Twk256',AutoDetectPointer);
  313.     end
  314.     else if (UseWhichDriver=4) then
  315.     begin
  316.       AutoDetectPointer := @DetectTwk16;
  317.       GraphDriver := InstallUserDriver('Twk16',AutoDetectPointer);
  318.     end
  319.     else if (UseWhichDriver=5) then
  320.     begin
  321.       AutoDetectPointer := @DetectS3;
  322.       GraphDriver := InstallUserDriver('SvgaS3',AutoDetectPointer);
  323.     end;
  324.     GraphDriver := Detect;
  325.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  326.     ErrorCode := GraphResult;             { preserve error return }
  327.     if ErrorCode <> grOK then             { error? }
  328.     begin
  329.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  330.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  331.       begin
  332.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  333.         Readln(PathToDriver);
  334.         Writeln;
  335.       end
  336.       else
  337.         Halt(1);                          { Some other error: terminate }
  338.     end;
  339.   until ErrorCode = grOK;
  340.   Randomize;                { init random number generator }
  341.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  342.   MaxX := GetMaxX;          { Get screen resolution values }
  343.   MaxY := GetMaxY;
  344. end; { Initialize }
  345.  
  346. function Int2Str(L : LongInt) : string;
  347. { Converts an integer to a string for use with OutText, OutTextXY }
  348. var
  349.   S : string;
  350. begin
  351.   Str(L, S);
  352.   Int2Str := S;
  353. end; { Int2Str }
  354.  
  355. function RandColor : word;
  356. { Returns a Random non-zero color value that is within the legal
  357.   color range for the selected device driver and graphics mode.
  358.   MaxColor is set to GetMaxColor by Initialize }
  359. begin
  360.   RandColor := Random(MaxColor)+1;
  361. end; { RandColor }
  362.  
  363. procedure DefaultColors;
  364. { Select the maximum color in the Palette for the drawing color }
  365. begin
  366.   SetColor(RealDrawColor(WhitePixel));
  367. end; { DefaultColors }
  368.  
  369. procedure DrawBorder;
  370. { Draw a border around the current view port }
  371. var
  372.   ViewPort : ViewPortType;
  373. begin
  374.   DefaultColors;
  375.   SetLineStyle(SolidLn, 0, NormWidth);
  376.   GetViewSettings(ViewPort);
  377.   with ViewPort do
  378.     Rectangle(0, 0, x2-x1, y2-y1);
  379. end; { DrawBorder }
  380.  
  381. procedure FullPort;
  382. { Set the view port to the entire screen }
  383. begin
  384.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  385. end; { FullPort }
  386.  
  387. procedure MainWindow(Header : string);
  388. { Make a default window and view port for demos }
  389. begin
  390.   DefaultColors;                           { Reset the colors }
  391.   ClearDevice;                             { Clear the screen }
  392.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  393.   SetTextJustify(CenterText, TopText);     { Left justify text }
  394.   FullPort;                                { Full screen view port }
  395.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  396.   { Draw main window }
  397.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  398.   DrawBorder;                              { Put a border around it }
  399.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  400.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  401. end; { MainWindow }
  402.  
  403. procedure StatusLine(Msg : string);
  404. { Display a status line at the bottom of the screen }
  405. begin
  406.   FullPort;
  407.   DefaultColors;
  408.   SetTextStyle(DefaultFont, HorizDir, 1);
  409.   SetTextJustify(CenterText, TopText);
  410.   SetLineStyle(SolidLn, 0, NormWidth);
  411.   SetFillStyle(EmptyFill, RealFillColor(0));
  412.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  413.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  414.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  415.   { Go back to the main window }
  416.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  417. end; { StatusLine }
  418.  
  419. procedure WaitToGo;
  420. { Wait for the user to abort the program or continue }
  421. const
  422.   Esc = #27;
  423. var
  424.   Ch : char;
  425. begin
  426.   StatusLine('Esc aborts or press a key...');
  427.   repeat until KeyPressed;
  428.   Ch := ReadKey;
  429.   if Ch = Esc then
  430.     Halt(0)                           { terminate program }
  431.   else
  432.     ClearDevice;                      { clear screen, go on with demo }
  433. end; { WaitToGo }
  434.  
  435. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  436. { Return strings describing the current device driver and graphics mode
  437.   for display of status report }
  438. begin
  439.   DriveStr := GetDriverName;
  440.   ModeStr := GetModeName(GetGraphMode);
  441. end; { GetDriverAndMode }
  442.  
  443. procedure ReportStatus;
  444. { Display the status of all query functions after InitGraph }
  445. const
  446.   X = 10;
  447. var
  448.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  449.   LineInfo   : LineSettingsType;
  450.   FillInfo   : FillSettingsType;
  451.   TextInfo   : TextSettingsType;
  452.   Palette    : PaletteType;
  453.   DriverStr  : string;           { Driver and mode strings }
  454.   ModeStr    : string;
  455.   Y          : word;
  456.  
  457. procedure WriteOut(S : string);
  458. { Write out a string and increment to next line }
  459. begin
  460.   OutTextXY(X, Y, S);
  461.   Inc(Y, TextHeight('M')+2);
  462. end; { WriteOut }
  463.  
  464. begin { ReportStatus }
  465.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  466.   GetViewSettings(ViewInfo);
  467.   GetLineSettings(LineInfo);
  468.   GetFillSettings(FillInfo);
  469.   GetTextSettings(TextInfo);
  470.   GetPalette(Palette);
  471.  
  472.   Y := 4;
  473.   MainWindow('Status report after InitGraph');
  474.   SetTextJustify(LeftText, TopText);
  475.   WriteOut('Graphics device    : '+DriverStr);
  476.   WriteOut('Graphics mode      : '+ModeStr);
  477.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  478.   with ViewInfo do
  479.   begin
  480.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  481.     if ClipOn then
  482.       WriteOut('Clipping           : ON')
  483.     else
  484.       WriteOut('Clipping           : OFF');
  485.   end;
  486.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  487.   WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  488.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  489.   WriteOut('Current color      : '+Int2Str(GetColor));
  490.   with LineInfo do
  491.   begin
  492.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  493.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  494.   end;
  495.   with FillInfo do
  496.   begin
  497.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  498.     WriteOut('Current fill color : '+Int2Str(Color));
  499.   end;
  500.   with TextInfo do
  501.   begin
  502.     WriteOut('Current font       : '+Fonts[Font]);
  503.     WriteOut('Text direction     : '+TextDirect[Direction]);
  504.     WriteOut('Character size     : '+Int2Str(CharSize));
  505.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  506.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  507.   end;
  508.   WaitToGo;
  509. end; { ReportStatus }
  510.  
  511. procedure FillEllipsePlay;
  512. { Random filled ellipse demonstration }
  513. const
  514.   MaxFillStyles = 12; { patterns 0..11 }
  515. var
  516.   MaxRadius : word;
  517.   FillColor : integer;
  518. begin
  519.   MainWindow('FillEllipse demonstration');
  520.   StatusLine('Esc aborts or press a key');
  521.   MaxRadius := MaxY div 10;
  522.   SetLineStyle(SolidLn, 0, NormWidth);
  523.   repeat
  524.     FillColor := RandColor;
  525.     SetColor(RealDrawColor(FillColor));
  526.     SetFillStyle(Random(MaxFillStyles), RealFillColor(FillColor));
  527.     FillEllipse(Random(MaxX), Random(MaxY),
  528.                 Random(MaxRadius), Random(MaxRadius));
  529.   until KeyPressed;
  530.   WaitToGo;
  531. end; { FillEllipsePlay }
  532.  
  533. procedure SectorPlay;
  534. { Draw random sectors on the screen }
  535. const
  536.   MaxFillStyles = 12; { patterns 0..11 }
  537. var
  538.   MaxRadius : word;
  539.   FillColor : integer;
  540.   EndAngle  : integer;
  541. begin
  542.   MainWindow('Sector demonstration');
  543.   StatusLine('Esc aborts or press a key');
  544.   MaxRadius := MaxY div 10;
  545.   SetLineStyle(SolidLn, 0, NormWidth);
  546.   repeat
  547.     FillColor := RandColor;
  548.     SetColor(RealDrawColor(FillColor));
  549.     SetFillStyle(Random(MaxFillStyles), RealFillColor(FillColor));
  550.     EndAngle := Random(360);
  551.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  552.            Random(MaxRadius), Random(MaxRadius));
  553.   until KeyPressed;
  554.   WaitToGo;
  555. end; { SectorPlay }
  556.  
  557. procedure WriteModePlay;
  558. { Demonstrate the SetWriteMode procedure for XOR lines }
  559. const
  560.   DelayValue = 50;  { milliseconds to delay }
  561. var
  562.   ViewInfo      : ViewPortType;
  563.   Color         : word;
  564.   Left, Top     : integer;
  565.   Right, Bottom : integer;
  566.   Step          : integer; { step for rectangle shrinking }
  567. begin
  568.   MainWindow('SetWriteMode demonstration');
  569.   StatusLine('Esc aborts or press a key');
  570.   GetViewSettings(ViewInfo);
  571.   Left := 0;
  572.   Top := 0;
  573.   with ViewInfo do
  574.   begin
  575.     Right := x2-x1;
  576.     Bottom := y2-y1;
  577.   end;
  578.   Step := Bottom div 50;
  579.   SetColor(RealDrawColor(WhitePixel));
  580.   Line(Left, Top, Right, Bottom);
  581.   Line(Left, Bottom, Right, Top);
  582.   SetWriteMode(XORPut);                    { Set XOR write mode }
  583.   repeat
  584.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  585.     Line(Left, Bottom, Right, Top);
  586.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  587.     Delay(DelayValue);                     { Wait }
  588.     Line(Left, Top, Right, Bottom);        { Erase lines }
  589.     Line(Left, Bottom, Right, Top);
  590.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  591.     if (Left+Step < Right) and (Top+Step < Bottom) then
  592.       begin
  593.         Inc(Left, Step);                  { Shrink rectangle }
  594.         Inc(Top, Step);
  595.         Dec(Right, Step);
  596.         Dec(Bottom, Step);
  597.       end
  598.     else
  599.       begin
  600.         Color := RandColor;                { New color }
  601.         SetColor(RealDrawColor(Color));
  602.         Left := 0;                         { Original large rectangle }
  603.         Top := 0;
  604.         with ViewInfo do
  605.         begin
  606.           Right := x2-x1;
  607.           Bottom := y2-y1;
  608.         end;
  609.       end;
  610.   until KeyPressed;
  611.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  612.   WaitToGo;
  613. end; { WriteModePlay }
  614.  
  615. procedure AspectRatioPlay;
  616. { Demonstrate  SetAspectRatio command }
  617. var
  618.   ViewInfo   : ViewPortType;
  619.   CenterX    : integer;
  620.   CenterY    : integer;
  621.   Radius     : word;
  622.   Xasp, Yasp : word;
  623.   i          : integer;
  624.   RadiusStep : word;
  625. begin
  626.   MainWindow('SetAspectRatio demonstration');
  627.   GetViewSettings(ViewInfo);
  628.   with ViewInfo do
  629.   begin
  630.     CenterX := (x2-x1) div 2;
  631.     CenterY := (y2-y1) div 2;
  632.     Radius := 3*((y2-y1) div 5);
  633.   end;
  634.   RadiusStep := (Radius div 30);
  635.   Circle(CenterX, CenterY, Radius);
  636.   GetAspectRatio(Xasp, Yasp);
  637.   for i := 1 to 30 do
  638.   begin
  639.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  640.     Circle(CenterX, CenterY, Radius);
  641.     Dec(Radius, RadiusStep);                   { Shrink radius }
  642.   end;
  643.   Inc(Radius, RadiusStep*30);
  644.   for i := 1 to 30 do
  645.   begin
  646.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  647.     if Radius > RadiusStep then
  648.       Dec(Radius, RadiusStep);                 { Shrink radius }
  649.     Circle(CenterX, CenterY, Radius);
  650.   end;
  651.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  652.   WaitToGo;
  653. end; { AspectRatioPlay }
  654.  
  655. procedure TextPlay;
  656. { Demonstrate text justifications and text sizing }
  657. var
  658.   Size : word;
  659.   W, H, X, Y : word;
  660.   ViewInfo : ViewPortType;
  661. begin
  662.   MainWindow('SetTextJustify / SetUserCharSize demo');
  663.   GetViewSettings(ViewInfo);
  664.   with ViewInfo do
  665.   begin
  666.     SetTextStyle(TriplexFont, VertDir, 4);
  667.     Y := (y2-y1) - 2;
  668.     SetTextJustify(CenterText, BottomText);
  669.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  670.     SetTextStyle(TriplexFont, HorizDir, 4);
  671.     SetTextJustify(LeftText, TopText);
  672.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  673.     SetTextJustify(CenterText, CenterText);
  674.     X := (x2-x1) div 2;
  675.     Y := TextHeight('H');
  676.     for Size := 1 to 4 do
  677.     begin
  678.       SetTextStyle(TriplexFont, HorizDir, Size);
  679.       H := TextHeight('M');
  680.       W := TextWidth('M');
  681.       Inc(Y, H);
  682.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  683.     end;
  684.     Inc(Y, H div 2);
  685.     SetTextJustify(CenterText, TopText);
  686.     SetUserCharSize(5, 6, 3, 2);
  687.     SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  688.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  689.   end;
  690.   WaitToGo;
  691. end; { TextPlay }
  692.  
  693. procedure TextDump;
  694. { Dump the complete character sets to the screen }
  695. const
  696.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  697.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  698. var
  699.   Font : word;
  700.   ViewInfo : ViewPortType;
  701.   Ch : char;
  702. begin
  703.   for Font := 0 to 4 do
  704.   begin
  705.     MainWindow(Fonts[Font]+' character set');
  706.     GetViewSettings(ViewInfo);
  707.     with ViewInfo do
  708.     begin
  709.       SetTextJustify(LeftText, TopText);
  710.       MoveTo(2, 3);
  711.       if Font = DefaultFont then
  712.         begin
  713.           SetTextStyle(Font, HorizDir, 1);
  714.           Ch := #0;
  715.           repeat
  716.             OutText(Ch);
  717.             if (GetX + TextWidth('M')) > (x2-x1) then
  718.               MoveTo(2, GetY + TextHeight('M')+3);
  719.             Ch := Succ(Ch);
  720.           until (Ch >= #255);
  721.         end
  722.       else
  723.         begin
  724.           if MaxY < 200 then
  725.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  726.           else
  727.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  728.           Ch := '!';
  729.           repeat
  730.             OutText(Ch);
  731.             if (GetX + TextWidth('M')) > (x2-x1) then
  732.               MoveTo(2, GetY + TextHeight('M')+3);
  733.             Ch := Succ(Ch);
  734.           until (Ord(Ch) = Ord('~')+1);
  735.         end;
  736.     end; { with }
  737.     WaitToGo;
  738.   end; { for loop }
  739. end; { TextDump }
  740.  
  741. procedure LineToPlay;
  742. { Demonstrate MoveTo and LineTo commands }
  743. const
  744.   MaxPoints = 15;
  745. var
  746.   Points     : array[0..MaxPoints] of PointType;
  747.   ViewInfo   : ViewPortType;
  748.   I, J       : integer;
  749.   CenterX    : integer;   { The center point of the circle }
  750.   CenterY    : integer;
  751.   Radius     : word;
  752.   StepAngle  : word;
  753.   Xasp, Yasp : word;
  754.   Radians    : real;
  755.  
  756. function AdjAsp(Value : integer) : integer;
  757. { Adjust a value for the aspect ratio of the device }
  758. begin
  759.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  760. end; { AdjAsp }
  761.  
  762. begin
  763.   MainWindow('MoveTo, LineTo demonstration');
  764.   GetAspectRatio(Xasp, Yasp);
  765.   GetViewSettings(ViewInfo);
  766.   with ViewInfo do
  767.   begin
  768.     CenterX := (x2-x1) div 2;
  769.     CenterY := (y2-y1) div 2;
  770.     Radius := CenterY;
  771.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  772.       Inc(Radius);
  773.   end;
  774.   StepAngle := 360 div MaxPoints;
  775.   for I := 0 to MaxPoints - 1 do
  776.   begin
  777.     Radians := (StepAngle * I) * Pi / 180;
  778.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  779.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  780.   end;
  781.   Circle(CenterX, CenterY, Radius);
  782.   for I := 0 to MaxPoints - 1 do
  783.   begin
  784.     for J := I to MaxPoints - 1 do
  785.     begin
  786.       MoveTo(Points[I].X, Points[I].Y);
  787.       LineTo(Points[J].X, Points[J].Y);
  788.     end;
  789.   end;
  790.   WaitToGo;
  791. end; { LineToPlay }
  792.  
  793. procedure LineRelPlay;
  794. { Demonstrate MoveRel and LineRel commands }
  795. const
  796.   MaxPoints = 12;
  797. var
  798.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  799.   CurrPort : ViewPortType;
  800.  
  801. procedure DrawTesseract;
  802. { Draw a Tesseract on the screen with relative move and
  803.   line drawing commands, also create a polygon for filling }
  804. const
  805.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  806. var
  807.   X, Y, W, H   : integer;
  808.  
  809. begin
  810.   GetViewSettings(CurrPort);
  811.   with CurrPort do
  812.   begin
  813.     W := (x2-x1) div 9;
  814.     H := (y2-y1) div 8;
  815.     X := ((x2-x1) div 2) - round(2.5 * W);
  816.     Y := ((y2-y1) div 2) - (3 * H);
  817.  
  818.     { Border around viewport is outer part of polygon }
  819.     Poly[1].X := 0;     Poly[1].Y := 0;
  820.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  821.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  822.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  823.     Poly[5].X := 0;     Poly[5].Y := 0;
  824.     MoveTo(X, Y);
  825.  
  826.     { Grab the whole in the polygon as we draw }
  827.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  828.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  829.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  830.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  831.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  832.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  833.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  834.  
  835.     { Fill the polygon with a user defined fill pattern }
  836.     SetFillPattern(CheckerBoard, RealFillColor(GreenPixel));
  837.     FillPoly(12, Poly);
  838.  
  839.     MoveRel(W, -H);
  840.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  841.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  842.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  843.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  844.     LineRel(-W, 0);
  845.  
  846.     { Flood fill the center }
  847.     FloodFill((x2-x1) div 2, (y2-y1) div 2,RealColor(WhitePixel));
  848.   end;
  849. end; { DrawTesseract }
  850.  
  851. begin
  852.   MainWindow('LineRel / MoveRel demonstration');
  853.   GetViewSettings(CurrPort);
  854.   with CurrPort do
  855.     { Move the viewport out 1 pixel from each end }
  856.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  857.   DrawTesseract;
  858.   WaitToGo;
  859. end; { LineRelPlay }
  860.  
  861. procedure PiePlay;
  862. { Demonstrate  PieSlice and GetAspectRatio commands }
  863. var
  864.   ViewInfo   : ViewPortType;
  865.   CenterX    : integer;
  866.   CenterY    : integer;
  867.   Radius     : word;
  868.   Xasp, Yasp : word;
  869.   X, Y       : integer;
  870.  
  871. function AdjAsp(Value : integer) : integer;
  872. { Adjust a value for the aspect ratio of the device }
  873. begin
  874.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  875. end; { AdjAsp }
  876.  
  877. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  878. { Get the coordinates of text for pie slice labels }
  879. var
  880.   Radians : real;
  881. begin
  882.   Radians := AngleInDegrees * Pi / 180;
  883.   X := round(Cos(Radians) * Radius);
  884.   Y := round(Sin(Radians) * Radius);
  885. end; { GetTextCoords }
  886.  
  887. begin
  888.   MainWindow('PieSlice / GetAspectRatio demonstration');
  889.   GetAspectRatio(Xasp, Yasp);
  890.   GetViewSettings(ViewInfo);
  891.   with ViewInfo do
  892.   begin
  893.     CenterX := (x2-x1) div 2;
  894.     CenterY := ((y2-y1) div 2) + 20;
  895.     Radius := (y2-y1) div 3;
  896.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  897.       Inc(Radius);
  898.   end;
  899.   SetTextStyle(TriplexFont, HorizDir, 4);
  900.   SetTextJustify(CenterText, TopText);
  901.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  902.  
  903.   SetTextStyle(TriplexFont, HorizDir, 3);
  904.  
  905.   SetFillStyle(SolidFill, RealFillColor(RandColor));
  906.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  907.   GetTextCoords(45, Radius, X, Y);
  908.   SetTextJustify(LeftText, BottomText);
  909.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  910.  
  911.   SetFillStyle(HatchFill, RealFillColor(RandColor));
  912.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  913.   GetTextCoords(293, Radius, X, Y);
  914.   SetTextJustify(LeftText, TopText);
  915.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  916.  
  917.   SetFillStyle(InterleaveFill, RealFillColor(RandColor));
  918.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  919.   GetTextCoords(180, Radius, X, Y);
  920.   SetTextJustify(RightText, CenterText);
  921.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  922.  
  923.   SetFillStyle(WideDotFill, RealFillColor(RandColor));
  924.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  925.   GetTextCoords(112, Radius, X, Y);
  926.   SetTextJustify(RightText, BottomText);
  927.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  928.  
  929.   WaitToGo;
  930. end; { PiePlay }
  931.  
  932. procedure Bar3DPlay;
  933. { Demonstrate Bar3D command }
  934. const
  935.   NumBars   = 7;  { The number of bars drawn }
  936.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  937.   YTicks    = 5;  { The number of tick marks on the Y axis }
  938. var
  939.   ViewInfo : ViewPortType;
  940.   H        : word;
  941.   XStep    : real;
  942.   YStep    : real;
  943.   I, J     : integer;
  944.   Depth    : word;
  945.   Color    : word;
  946. begin
  947.   MainWindow('Bar3D / Rectangle demonstration');
  948.   H := 3*TextHeight('M');
  949.   GetViewSettings(ViewInfo);
  950.   SetTextJustify(CenterText, TopText);
  951.   SetTextStyle(TriplexFont, HorizDir, 4);
  952.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  953.   SetTextStyle(DefaultFont, HorizDir, 1);
  954.   with ViewInfo do
  955.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  956.   GetViewSettings(ViewInfo);
  957.   with ViewInfo do
  958.   begin
  959.     Line(H, H, H, (y2-y1)-H);
  960.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  961.     YStep := ((y2-y1)-(2*H)) / YTicks;
  962.     XStep := ((x2-x1)-(2*H)) / NumBars;
  963.     J := (y2-y1)-H;
  964.     SetTextJustify(CenterText, CenterText);
  965.  
  966.     { Draw the Y axis and ticks marks }
  967.     for I := 0 to Yticks do
  968.     begin
  969.       Line(H div 2, J, H, J);
  970.       OutTextXY(0, J, Int2Str(I));
  971.       J := Round(J-Ystep);
  972.     end;
  973.  
  974.  
  975.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  976.  
  977.     { Draw X axis, bars, and tick marks }
  978.     SetTextJustify(CenterText, TopText);
  979.     J := H;
  980.     for I := 1 to Succ(NumBars) do
  981.     begin
  982.       SetColor(RealDrawColor(WhitePixel));
  983.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  984.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  985.       if I <> Succ(NumBars) then
  986.       begin
  987.         Color := RandColor;
  988.         SetFillStyle(I, RealFillColor(Color));
  989.         SetColor(RealDrawColor(Color));
  990.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  991.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  992.         J := Round(J+Xstep);
  993.       end;
  994.     end;
  995.  
  996.   end;
  997.   WaitToGo;
  998. end; { Bar3DPlay }
  999.  
  1000. procedure SolidBarPlay;
  1001. { Draw random solid bars on the screen }
  1002. var
  1003.   MaxWidth  : integer;
  1004.   MaxHeight : integer;
  1005.   ViewInfo  : ViewPortType;
  1006.   Color     : word;
  1007. begin
  1008.   MainWindow('Random Solid Bars');
  1009.   StatusLine('Esc aborts or press a key');
  1010.   GetViewSettings(ViewInfo);
  1011.   with ViewInfo do
  1012.   begin
  1013.     MaxWidth := x2-x1;
  1014.     MaxHeight := y2-y1;
  1015.   end;
  1016.   repeat
  1017.     Color := Random(GetMaxColor);  { RandColor }
  1018.     SetColor(RealDrawColor(Color));
  1019.     SetFillStyle(SolidFill, RealFillColor(Color));
  1020.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1021.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1022.   until KeyPressed;
  1023.   WaitToGo;
  1024. end; { SolidBarPlay }
  1025.  
  1026. procedure BarPlay;
  1027. { Demonstrate Bar command }
  1028. const
  1029.   NumBars   = 5;
  1030.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  1031.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  1032. var
  1033.   ViewInfo  : ViewPortType;
  1034.   BarNum    : word;
  1035.   H         : word;
  1036.   XStep     : real;
  1037.   YStep     : real;
  1038.   I, J      : integer;
  1039.   Color     : word;
  1040. begin
  1041.   MainWindow('Bar / Rectangle demonstration');
  1042.   H := 3*TextHeight('M');
  1043.   GetViewSettings(ViewInfo);
  1044.   SetTextJustify(CenterText, TopText);
  1045.   SetTextStyle(TriplexFont, HorizDir, 4);
  1046.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  1047.   SetTextStyle(DefaultFont, HorizDir, 1);
  1048.   with ViewInfo do
  1049.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  1050.   GetViewSettings(ViewInfo);
  1051.   with ViewInfo do
  1052.   begin
  1053.     Line(H, H, H, (y2-y1)-H);
  1054.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  1055.     YStep := ((y2-y1)-(2*H)) / NumBars;
  1056.     XStep := ((x2-x1)-(2*H)) / NumBars;
  1057.     J := (y2-y1)-H;
  1058.     SetTextJustify(CenterText, CenterText);
  1059.  
  1060.     { Draw Y axis with tick marks }
  1061.     for I := 0 to NumBars do
  1062.     begin
  1063.       Line(H div 2, J, H, J);
  1064.       OutTextXY(0, J, Int2Str(i));
  1065.       J := Round(J-Ystep);
  1066.     end;
  1067.  
  1068.     { Draw X axis, bars, and tick marks }
  1069.     J := H;
  1070.     SetTextJustify(CenterText, TopText);
  1071.     for I := 1 to Succ(NumBars) do
  1072.     begin
  1073.       SetColor(RealDrawColor(WhitePixel));
  1074.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  1075.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  1076.       if I <> Succ(NumBars) then
  1077.       begin
  1078.         Color := RandColor;
  1079.         SetFillStyle(Styles[I], RealFillColor(Color));
  1080.         SetColor(RealDrawColor(Color));
  1081.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1082.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1083.       end;
  1084.       J := Round(J+Xstep);
  1085.     end;
  1086.  
  1087.   end;
  1088.   WaitToGo;
  1089. end; { BarPlay }
  1090.  
  1091. procedure CirclePlay;
  1092. { Draw random circles on the screen }
  1093. var
  1094.   MaxRadius : word;
  1095. begin
  1096.   MainWindow('Circle demonstration');
  1097.   StatusLine('Esc aborts or press a key');
  1098.   MaxRadius := MaxY div 10;
  1099.   SetLineStyle(SolidLn, 0, NormWidth);
  1100.   repeat
  1101.     SetColor(RealDrawColor(RandColor));
  1102.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  1103.   until KeyPressed;
  1104.   WaitToGo;
  1105. end; { CirclePlay }
  1106.  
  1107.  
  1108. procedure RandBarPlay;
  1109. { Draw random bars on the screen }
  1110. var
  1111.   MaxWidth  : integer;
  1112.   MaxHeight : integer;
  1113.   ViewInfo  : ViewPortType;
  1114.   Color     : word;
  1115. begin
  1116.   MainWindow('Random Bars');
  1117.   StatusLine('Esc aborts or press a key');
  1118.   GetViewSettings(ViewInfo);
  1119.   with ViewInfo do
  1120.   begin
  1121.     MaxWidth := x2-x1;
  1122.     MaxHeight := y2-y1;
  1123.   end;
  1124.   repeat
  1125.     Color := RandColor;
  1126.     SetColor(RealDrawColor(Color));
  1127.     SetFillStyle(Random(CloseDotFill)+1, RealFillColor(Color));
  1128.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1129.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1130.   until KeyPressed;
  1131.   WaitToGo;
  1132. end; { RandBarPlay }
  1133.  
  1134. procedure ArcPlay;
  1135. { Draw random arcs on the screen }
  1136. var
  1137.   MaxRadius : word;
  1138.   EndAngle : word;
  1139.   ArcInfo : ArcCoordsType;
  1140. begin
  1141.   MainWindow('Arc / GetArcCoords demonstration');
  1142.   StatusLine('Esc aborts or press a key');
  1143.   MaxRadius := MaxY div 10;
  1144.   repeat
  1145.     SetColor(RealDrawColor(RandColor));
  1146.     EndAngle := Random(360);
  1147.     SetLineStyle(SolidLn, 0, NormWidth);
  1148.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  1149.     GetArcCoords(ArcInfo);
  1150.     with ArcInfo do
  1151.     begin
  1152.       Line(X, Y, XStart, YStart);
  1153.       Line(X, Y, Xend, Yend);
  1154.     end;
  1155.   until KeyPressed;
  1156.   WaitToGo;
  1157. end; { ArcPlay }
  1158.  
  1159. procedure PutPixelPlay;
  1160. { Demonstrate the PutPixel and GetPixel commands }
  1161. const
  1162.   Seed   = 1962; { A seed for the random number generator }
  1163.   NumPts = 2000; { The number of pixels plotted }
  1164.   Esc    = #27;
  1165. var
  1166.   I : word;
  1167.   X, Y, Color : word;
  1168.   XMax, YMax  : integer;
  1169.   ViewInfo    : ViewPortType;
  1170. begin
  1171.   MainWindow('PutPixel / GetPixel demonstration');
  1172.   StatusLine('Esc aborts or press a key...');
  1173.  
  1174.   GetViewSettings(ViewInfo);
  1175.   with ViewInfo do
  1176.   begin
  1177.     XMax := (x2-x1-1);
  1178.     YMax := (y2-y1-1);
  1179.   end;
  1180.  
  1181.   while not KeyPressed do
  1182.   begin
  1183.     { Plot random pixels }
  1184.     RandSeed := Seed;
  1185.     I := 0;
  1186.     while (not KeyPressed) and (I < NumPts) do
  1187.     begin
  1188.       Inc(I);
  1189.       PutPixel(Random(XMax)+1, Random(YMax)+1, RealColor(RandColor));
  1190.     end;
  1191.  
  1192.     { Erase pixels }
  1193.     RandSeed := Seed;
  1194.     I := 0;
  1195.     while (not KeyPressed) and (I < NumPts) do
  1196.     begin
  1197.       Inc(I);
  1198.       X := Random(XMax)+1;
  1199.       Y := Random(YMax)+1;
  1200.       Color := GetPixel(X,Y);
  1201.       inline($89/$56/<Color);  (* Used to load 15-bit color value *)
  1202.       if Color = RandColor then
  1203.         PutPixel(X, Y, RealColor(0))
  1204.       else
  1205.         PutPixel(1024,32,0);
  1206.     end;
  1207.   end;
  1208.   WaitToGo;
  1209. end; { PutPixelPlay }
  1210.  
  1211. procedure PutImagePlay;
  1212. { Demonstrate the GetImage and PutImage commands }
  1213.  
  1214. const
  1215.   r  = 20;
  1216.   StartX = 100;
  1217.   StartY = 150;
  1218.  
  1219. var
  1220.   CurPort : ViewPortType;
  1221.  
  1222. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  1223. var
  1224.   Step : integer;
  1225. begin
  1226.   Step := Random(2*r);
  1227.   if Odd(Step) then
  1228.     Step := -Step;
  1229.   X := X + Step;
  1230.   Step := Random(r);
  1231.   if Odd(Step) then
  1232.     Step := -Step;
  1233.   Y := Y + Step;
  1234.  
  1235.   { Make saucer bounce off viewport walls }
  1236.   with CurPort do
  1237.   begin
  1238.     if (x1 + X + Width - 1 > x2) then
  1239.       X := x2-x1 - Width + 1
  1240.     else
  1241.       if (X < 0) then
  1242.         X := 0;
  1243.     if (y1 + Y + Height - 1 > y2) then
  1244.       Y := y2-y1 - Height + 1
  1245.     else
  1246.       if (Y < 0) then
  1247.         Y := 0;
  1248.   end;
  1249. end; { MoveSaucer }
  1250.  
  1251. var
  1252.   Pausetime : word;
  1253.   Saucer    : pointer;
  1254.   X, Y      : integer;
  1255.   ulx, uly  : word;
  1256.   lrx, lry  : word;
  1257.   Size      : word;
  1258.   I         : word;
  1259. begin
  1260.   ClearDevice;
  1261.   FullPort;
  1262.  
  1263.   { PaintScreen }
  1264.   ClearDevice;
  1265.   MainWindow('GetImage / PutImage Demonstration');
  1266.   StatusLine('Esc aborts or press a key...');
  1267.   GetViewSettings(CurPort);
  1268.  
  1269.   { DrawSaucer }
  1270.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1271.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1272.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1273.   Circle(StartX+10, StartY-12, 2);
  1274.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1275.   Circle(StartX-10, StartY-12, 2);
  1276.   SetFillStyle(SolidFill, RealFillColor(BluePixel));
  1277.   FloodFill(StartX+1, StartY+4, RealColor(WhitePixel));
  1278.  
  1279.   { ReadSaucerImage }
  1280.   ulx := StartX-(r+1);
  1281.   uly := StartY-14;
  1282.   lrx := StartX+(r+1);
  1283.   lry := StartY+(r div 3)+3;
  1284.  
  1285.   Size := ImageSize(ulx, uly, lrx, lry);
  1286.   GetMem(Saucer, Size);
  1287.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1288.   PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1289.   { Plot some "stars" }
  1290.   for I := 1 to 1000 do
  1291.     PutPixel(Random(MaxX), Random(MaxY), RealColor(RandColor));
  1292.   X := MaxX div 2;
  1293.   Y := MaxY div 2;
  1294.   PauseTime := 70;
  1295.  
  1296.   { Move the saucer around }
  1297.   repeat
  1298.     X := (X div 8)*8;
  1299.     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1300.     Delay(PauseTime);
  1301.     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1302.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1303.   until KeyPressed;
  1304.   FreeMem(Saucer, size);
  1305.   WaitToGo;
  1306. end; { PutImagePlay }
  1307.  
  1308. procedure PolyPlay;
  1309. { Draw random polygons with random fill styles on the screen }
  1310. const
  1311.   MaxPts = 5;
  1312. type
  1313.   PolygonType = array[1..MaxPts] of PointType;
  1314. var
  1315.   Poly : PolygonType;
  1316.   I, Color : word;
  1317. begin
  1318.   MainWindow('FillPoly demonstration');
  1319.   StatusLine('Esc aborts or press a key...');
  1320.   repeat
  1321.     Color := RandColor;
  1322.     SetFillStyle(Random(11)+1, RealFillColor(Color));
  1323.     SetColor(RealDrawColor(Color));
  1324.     for I := 1 to MaxPts do
  1325.       with Poly[I] do
  1326.       begin
  1327.         X := Random(MaxX);
  1328.         Y := Random(MaxY);
  1329.       end;
  1330.     FillPoly(MaxPts, Poly);
  1331.   until KeyPressed;
  1332.   WaitToGo;
  1333. end; { PolyPlay }
  1334.  
  1335. procedure FillStylePlay;
  1336. { Display all of the predefined fill styles available }
  1337. var
  1338.   Style    : word;
  1339.   Width    : word;
  1340.   Height   : word;
  1341.   X, Y     : word;
  1342.   I, J     : word;
  1343.   ViewInfo : ViewPortType;
  1344.  
  1345. procedure DrawBox(X, Y : word);
  1346. begin
  1347.   SetFillStyle(Style, RealFillColor(WhitePixel));
  1348.   with ViewInfo do
  1349.     Bar(X, Y, X+Width, Y+Height);
  1350.   Rectangle(X, Y, X+Width, Y+Height);
  1351.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1352.   Inc(Style);
  1353. end; { DrawBox }
  1354.  
  1355. begin
  1356.   MainWindow('Pre-defined fill styles');
  1357.   GetViewSettings(ViewInfo);
  1358.   with ViewInfo do
  1359.   begin
  1360.     Width := 2 * ((x2+1) div 13);
  1361.     Height := 2 * ((y2-10) div 10);
  1362.   end;
  1363.   X := Width div 2;
  1364.   Y := Height div 2;
  1365.   Style := 0;
  1366.   for J := 1 to 3 do
  1367.   begin
  1368.     for I := 1 to 4 do
  1369.     begin
  1370.       DrawBox(X, Y);
  1371.       Inc(X, (Width div 2) * 3);
  1372.     end;
  1373.     X := Width div 2;
  1374.     Inc(Y, (Height div 2) * 3);
  1375.   end;
  1376.   SetTextJustify(LeftText, TopText);
  1377.   WaitToGo;
  1378. end; { FillStylePlay }
  1379.  
  1380. procedure FillPatternPlay;
  1381. { Display some user defined fill patterns }
  1382. const
  1383.   Patterns : array[0..11] of FillPatternType = (
  1384.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1385.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1386.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1387.   (0, $10, $28, $44, $28, $10, 0, 0),
  1388.   (0, $70, $20, $27, $25, $27, $4, $4),
  1389.   (0, 0, 0, $18, $18, 0, 0, 0),
  1390.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1391.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1392.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1393.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1394.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1395.   (0, $42, $24, $18, $18, $24, $42, 0));
  1396. var
  1397.   Style    : word;
  1398.   Width    : word;
  1399.   Height   : word;
  1400.   X, Y     : word;
  1401.   I, J     : word;
  1402.   ViewInfo : ViewPortType;
  1403.  
  1404. procedure DrawBox(X, Y : word);
  1405. begin
  1406.   SetFillPattern(Patterns[Style], RealFillColor(WhitePixel));
  1407.   with ViewInfo do
  1408.     Bar(X, Y, X+Width, Y+Height);
  1409.   Rectangle(X, Y, X+Width, Y+Height);
  1410.   Inc(Style);
  1411. end; { DrawBox }
  1412.  
  1413. begin
  1414.   MainWindow('User defined fill styles');
  1415.   GetViewSettings(ViewInfo);
  1416.   with ViewInfo do
  1417.   begin
  1418.     Width := 2 * ((x2+1) div 13);
  1419.     Height := 2 * ((y2-10) div 10);
  1420.   end;
  1421.   X := Width div 2;
  1422.   Y := Height div 2;
  1423.   Style := 0;
  1424.   for J := 1 to 3 do
  1425.   begin
  1426.     for I := 1 to 4 do
  1427.     begin
  1428.       DrawBox(X, Y);
  1429.       Inc(X, (Width div 2) * 3);
  1430.     end;
  1431.     X := Width div 2;
  1432.     Inc(Y, (Height div 2) * 3);
  1433.   end;
  1434.   SetTextJustify(LeftText, TopText);
  1435.   WaitToGo;
  1436. end; { FillPatternPlay }
  1437.  
  1438. procedure ColorPlay;
  1439. { Display all of the colors available for the current driver and mode }
  1440. var
  1441.   Color    : word;
  1442.   Width    : word;
  1443.   Height   : word;
  1444.   X, Y     : word;
  1445.   I, J     : word;
  1446.   ViewInfo : ViewPortType;
  1447.  
  1448. procedure DrawBox(X, Y : word);
  1449. begin
  1450.   SetFillStyle(SolidFill, RealFillColor(Color));
  1451.   SetColor(RealDrawColor(Color));
  1452.   with ViewInfo do
  1453.     Bar(X, Y, X+Width, Y+Height);
  1454.   Rectangle(X, Y, X+Width, Y+Height);
  1455.   if Color = 0 then
  1456.   begin
  1457.     SetColor(RealDrawColor(WhitePixel));
  1458.     Rectangle(X, Y, X+Width, Y+Height);
  1459.   end;
  1460.   Color := Succ(Color);
  1461. end; { DrawBox }
  1462.  
  1463. begin
  1464.   begin
  1465.     MainWindow('256 Color demonstration');
  1466.     Color := $0;
  1467.     GetViewSettings(ViewInfo);
  1468.     with ViewInfo do
  1469.     begin
  1470.       Width := 2*((x2-x1+1) div 46);
  1471.       Height := 2*((y2-x1+1) div 47);
  1472.     end;
  1473.     X := Width div 3;
  1474.     Y := Height div 3;
  1475.     for J := 1 to 16 do
  1476.     begin
  1477.       for I := 1 to 16 do
  1478.       begin
  1479.         DrawBox(X, Y);
  1480.         Inc(X,(Width div 2)*3);
  1481.       end;
  1482.       X := Width div 3;
  1483.       Inc(Y,(Height div 2)*3);
  1484.     end;
  1485.   end;
  1486.   WaitToGo;
  1487. end; { ColorPlay }
  1488.  
  1489. procedure PalettePlay;
  1490. { Demonstrate the use of the SetRGBPalette command }
  1491. const
  1492.   XBars = 15;
  1493.   YBars = 10;
  1494. type
  1495.   RGBColor   = record
  1496.                  R, G, B : byte;
  1497.                end;
  1498.   VGAPalette = array[0..255] of RGBColor;
  1499.  
  1500. var
  1501.   I, J     : word;
  1502.   X, Y     : word;
  1503.   Color    : word;
  1504.   ViewInfo : ViewPortType;
  1505.   Width    : word;
  1506.   Height   : word;
  1507.   VGAPal   : VGAPalette;
  1508.   Rand     : integer;
  1509.  
  1510. procedure ReadDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1511. var
  1512.   Regs : Registers;
  1513. begin
  1514.   with Regs do
  1515.   begin
  1516.     AH := $10;
  1517.     AL := $17;
  1518.     BX := Start;
  1519.     CX := Count;
  1520.     ES := Seg(Pal);
  1521.     DX := Ofs(Pal);
  1522.   end;
  1523.   Intr($10, Regs);
  1524. end;
  1525.  
  1526. procedure SetDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1527. var
  1528.   Regs : Registers;
  1529. begin
  1530.   with Regs do
  1531.   begin
  1532.     AH := $10;
  1533.     AL := $12;
  1534.     BX := Start;
  1535.     CX := Count;
  1536.     ES := Seg(Pal);
  1537.     DX := Ofs(Pal);
  1538.   end;
  1539.   Intr($10, Regs);
  1540. end;
  1541.  
  1542. begin
  1543.   ReadDACBlock(0, 256, VGAPal);
  1544.   MainWindow('SetRGBPalette demonstration');
  1545.   StatusLine('Press any key...');
  1546.   GetViewSettings(ViewInfo);
  1547.   with ViewInfo do
  1548.   begin
  1549.     Width := (x2-x1) div XBars;
  1550.     Height := (y2-y1) div YBars;
  1551.   end;
  1552.   X := 0; Y := 0;
  1553.   Color := 0;
  1554.   for J := 1 to YBars do
  1555.   begin
  1556.     for I := 1 to XBars do
  1557.     begin
  1558.       SetFillStyle(SolidFill, RealFillColor(Color));
  1559.       Bar(X, Y, X+Width, Y+Height);
  1560.       Inc(X, Width+1);
  1561.       Inc(Color);
  1562.       Color := Color mod 16;
  1563.     end;
  1564.     X := 0;
  1565.     Inc(Y, Height+1);
  1566.   end;
  1567.   repeat
  1568.     {SetPalette(Random(16), VGAPal[Random(256)]);}
  1569.     with VGAPal[Random(16)] do
  1570.       SetRGBPalette(Random(16), R, G, B);
  1571.   until KeyPressed;
  1572.   SetDACBlock(0, 256, VGAPal);
  1573.   WaitToGo;
  1574. end; { PalettePlay }
  1575.  
  1576. procedure CrtModePlay;
  1577. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1578. var
  1579.   ViewInfo : ViewPortType;
  1580.   Ch       : char;
  1581. begin
  1582.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1583.   GetViewSettings(ViewInfo);
  1584.   SetTextJustify(CenterText, CenterText);
  1585.   with ViewInfo do
  1586.   begin
  1587.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1588.     StatusLine('Press any key for text mode...');
  1589.     repeat until KeyPressed;
  1590.     Ch := ReadKey;
  1591.     RestoreCrtmode;
  1592.     Writeln('Now you are in text mode.');
  1593.     Write('Press any key to go back to graphics...');
  1594.     repeat until KeyPressed;
  1595.     Ch := ReadKey;
  1596.     SetGraphMode(GetGraphMode);
  1597.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1598.     SetTextJustify(CenterText, CenterText);
  1599.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1600.   end;
  1601.   WaitToGo;
  1602. end; { CrtModePlay }
  1603.  
  1604. procedure LineStylePlay;
  1605. { Demonstrate the predefined line styles available }
  1606. var
  1607.   Style    : word;
  1608.   Step     : word;
  1609.   X, Y     : word;
  1610.   ViewInfo : ViewPortType;
  1611.  
  1612. begin
  1613.   ClearDevice;
  1614.   DefaultColors;
  1615.   MainWindow('Pre-defined line styles');
  1616.   GetViewSettings(ViewInfo);
  1617.   with ViewInfo do
  1618.   begin
  1619.     X := 35;
  1620.     Y := 10;
  1621.     Step := (x2-x1) div 11;
  1622.     SetTextJustify(LeftText, TopText);
  1623.     OutTextXY(X, Y, 'NormWidth');
  1624.     SetTextJustify(CenterText, TopText);
  1625.     for Style := 0 to 3 do
  1626.     begin
  1627.       SetLineStyle(Style, 0, NormWidth);
  1628.       Line(X, Y+20, X, Y2-40);
  1629.       OutTextXY(X, Y2-30, Int2Str(Style));
  1630.       Inc(X, Step);
  1631.     end;
  1632.     Inc(X, 2*Step);
  1633.     SetTextJustify(LeftText, TopText);
  1634.     OutTextXY(X, Y, 'ThickWidth');
  1635.     SetTextJustify(CenterText, TopText);
  1636.     for Style := 0 to 3 do
  1637.     begin
  1638.       SetLineStyle(Style, 0, ThickWidth);
  1639.       Line(X, Y+20, X, Y2-40);
  1640.       OutTextXY(X, Y2-30, Int2Str(Style));
  1641.       Inc(X, Step);
  1642.     end;
  1643.   end;
  1644.   SetTextJustify(LeftText, TopText);
  1645.   WaitToGo;
  1646. end; { LineStylePlay }
  1647.  
  1648. procedure UserLineStylePlay;
  1649. { Demonstrate user defined line styles }
  1650. var
  1651.   Style    : word;
  1652.   X, Y, I  : word;
  1653.   ViewInfo : ViewPortType;
  1654. begin
  1655.   MainWindow('User defined line styles');
  1656.   GetViewSettings(ViewInfo);
  1657.   with ViewInfo do
  1658.   begin
  1659.     X := 4;
  1660.     Y := 10;
  1661.     Style := 0;
  1662.     I := 0;
  1663.     while X < X2-4 do
  1664.     begin
  1665.       {$B+}
  1666.       Style := Style or (1 shl (I mod 16));
  1667.       {$B-}
  1668.       SetLineStyle(UserBitLn, Style, NormWidth);
  1669.       Line(X, Y, X, (y2-y1)-Y);
  1670.       Inc(X, 5);
  1671.       Inc(I);
  1672.       if Style = 65535 then
  1673.       begin
  1674.         I := 0;
  1675.         Style := 0;
  1676.       end;
  1677.     end;
  1678.   end;
  1679.   WaitToGo;
  1680. end; { UserLineStylePlay }
  1681.  
  1682.  
  1683. procedure SayGoodbye;
  1684. { Say goodbye and then exit the program }
  1685. var
  1686.   ViewInfo : ViewPortType;
  1687. begin
  1688.   MainWindow('');
  1689.   GetViewSettings(ViewInfo);
  1690.   SetTextStyle(TriplexFont, HorizDir, 4);
  1691.   SetTextJustify(CenterText, CenterText);
  1692.   with ViewInfo do
  1693.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1694.   StatusLine('Press any key to quit...');
  1695.   repeat until KeyPressed;
  1696. end; { SayGoodbye }
  1697.  
  1698. begin { program body }
  1699.   ClrScr;
  1700.   writeln('VGA BGI Demo Program  Copyright(c) 1987,1989 Borland International, Inc.');
  1701.   writeln;
  1702.   Initialize;
  1703.   ReportStatus;
  1704.   AspectRatioPlay;
  1705.   FillEllipsePlay;
  1706.   SectorPlay;
  1707.   WriteModePlay;
  1708.   ColorPlay;
  1709.   PalettePlay;
  1710.   PutPixelPlay;
  1711.   PutImagePlay;
  1712.   RandBarPlay;
  1713.   SolidBarPlay;
  1714.   BarPlay;
  1715.   Bar3DPlay;
  1716.   ArcPlay;
  1717.   CirclePlay;
  1718.   PiePlay;
  1719.   LineToPlay;
  1720.   LineRelPlay;
  1721.   LineStylePlay;
  1722.   UserLineStylePlay;
  1723.   TextDump;
  1724.   TextPlay;
  1725.   CrtModePlay;
  1726.   FillStylePlay;
  1727.   FillPatternPlay;
  1728.   PolyPlay;
  1729.   SayGoodbye;
  1730.   CloseGraph;
  1731. end.
  1732.