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