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