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