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