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