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