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