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