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