Liren Large Software Subsidy 9/09.iso/l/l043/3.ddi/GRDEMO.PAS

Pascal/Delphi Source File | 1987-11-02 | 35.7 KB | 1,289 lines

{           Copyright (c) 1985, 87 by Borland International, Inc.            }

program GrDemo;
{ Turbo Pascal 4.0 Graph unit demonstration program }

uses
  Crt, Dos, Graph;

const
  { The names of the various device drivers supported }
  DriverNames : array[0..10] of string[8] =
  ('Detect', 'CGA', 'MCGA', 'EGA', 'EGA64', 'EGAMono',
   'RESERVED', 'HercMono', 'ATT400', 'VGA', 'PC3270');

  { The five fonts available }
  Fonts : array[0..4] of string[13] =
  ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');

  { The five predefined line styles supported }
  LineStyles : array[0..4] of string[9] =
  ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');

  { The twelve predefined fill styles supported }
  FillStyles : array[0..11] of string[14] =
  ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
   'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
   'InterleaveFill', 'WideDotFill', 'CloseDotFill');

  { The two text directions available }
  TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');

  { The Horizontal text justifications available }
  HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');

  { The vertical text justifications available }
  VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');

var
  GraphDriver : integer;  { The Graphics device driver }
  GraphMode   : integer;  { The Graphics mode value }
  MaxX, MaxY  : word;     { The maximum resolution of the screen }
  ErrorCode   : integer;  { Reports any graphics errors }
  MaxColor    : word;     { The maximum color value available }
  OldExitProc : Pointer;  { Saves exit procedure address }

{$F+}
procedure MyExitProc;
begin
  ExitProc := OldExitProc; { Restore exit procedure address }
  CloseGraph;              { Shut down the graphics system }
end; { MyExitProc }
{$F-}

procedure Initialize;
{ Initialize graphics and report any errors that may occur }
begin
  { when using Crt and graphics, turn off Crt's memory-mapped writes }
  DirectVideo := False;
  OldExitProc := ExitProc;                { save previous exit proc }
  ExitProc := @MyExitProc;                { insert our exit proc in chain }
  DetectGraph(GraphDriver, GraphMode);    { Test for RESERVED driver }
  if GraphDriver = RESERVED then
    begin
      GraphDriver := CGA;                 { Force RESERVED driver to }
      GraphMode := CGAHi;                 { CGA driver and mode!     }
    end
  else
    GraphDriver := Detect;                { use autodetection }
  InitGraph(GraphDriver, GraphMode, '');  { activate graphics }
  ErrorCode := GraphResult;               { error? }
  if ErrorCode <> grOk then
  begin
    Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
    Halt(1);
  end;
  Randomize;                { init random number generator }
  MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  MaxX := GetMaxX;          { Get screen resolution values }
  MaxY := GetMaxY;
end; { Initialize }

function Int2Str(L : LongInt) : string;
{ Converts an integer to a string for use with OutText, OutTextXY }
var
  S : string;
begin
  Str(L, S);
  Int2Str := S;
end; { Int2Str }

function RandColor : word;
{ Returns a Random non-zero color value that is within the legal
  color range for the selected device driver and graphics mode.
  MaxColor is set to GetMaxColor by Initialize }
begin
  RandColor := Random(MaxColor)+1;
end; { RandColor }

procedure DefaultColors;
{ Select the maximum color in the Palette for the drawing color }
begin
  SetColor(MaxColor);
end; { DefaultColors }

procedure DrawBorder;
{ Draw a border around the current view port }
var
  ViewPort : ViewPortType;
begin
  DefaultColors;
  SetLineStyle(SolidLn, 0, NormWidth);
  GetViewSettings(ViewPort);
  with ViewPort do
    Rectangle(0, 0, x2-x1, y2-y1);
end; { DrawBorder }

procedure FullPort;
{ Set the view port to the entire screen }
begin
  SetViewPort(0, 0, MaxX, MaxY, ClipOn);
end; { FullPort }

procedure MainWindow(Header : string);
{ Make a default window and view port for demos }
begin
  DefaultColors;                           { Reset the colors }
  ClearDevice;                             { Clear the screen }
  SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  SetTextJustify(CenterText, TopText);     { Left justify text }
  FullPort;                                { Full screen view port }
  OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  { Draw main window }
  SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  DrawBorder;                              { Put a border around it }
  { Move the edges in 1 pixel on all sides so border isn't in the view port }
  SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end; { MainWindow }

procedure StatusLine(Msg : string);
{ Display a status line at the bottom of the screen }
begin
  FullPort;
  DefaultColors;
  SetTextStyle(DefaultFont, HorizDir, 1);
  SetTextJustify(CenterText, TopText);
  SetLineStyle(SolidLn, 0, NormWidth);
  SetFillStyle(EmptyFill, 0);
  Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  { Go back to the main window }
  SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end; { StatusLine }

procedure WaitToGo;
{ Wait for the user to abort the program or continue }
const
  Esc = #27;
var
  Ch : char;
begin
  StatusLine('Esc aborts or press a key...');
  repeat until KeyPressed;
  Ch := ReadKey;
  if Ch = Esc then
    Halt(0)                           { terminate program }
  else
    ClearDevice;                      { clear screen, go on with demo }
end; { WaitToGo }

procedure GetDriverAndMode(var DriveStr, ModeStr : string);
{ Return strings describing the current device driver and graphics mode
  for display status report }
begin
  DriveStr := DriverNames[GraphDriver];
  GraphMode := GetGraphMode;
  case GraphDriver of
    CGA        : case GraphMode of
                   CGAC0 : ModeStr := 'CGAC0';
                   CGAC1 : ModeStr := 'CGAC1';
                   CGAC2 : ModeStr := 'CGAC2';
                   CGAC3 : ModeStr := 'CGAC3';
                   CGAHi : ModeStr := 'CGAHi';
                 end; { case }
    MCGA       : case GraphMode of
                   MCGAC0  : ModeStr := 'MCGAC0';
                   MCGAC1  : ModeStr := 'MCGAC1';
                   MCGAC2  : ModeStr := 'MCGAC2';
                   MCGAC3  : ModeStr := 'MCGAC3';
                   MCGAMed : ModeStr := 'MCGAMed';
                   MCGAHi  : ModeStr := 'MCGAHi';
                 end; { case }
    EGA         : case GraphMode of
                    EGALo : ModeStr := 'EGALo';
                    EGAHi : ModeStr := 'EGAHi';
                  end;
    EGA64       : case GraphMode of
                    EGA64Lo :  ModeStr := 'EGA64Lo';
                    EGA64Hi :  ModeStr := 'EGA64Hi';
                  end; { case }
     HercMono   : ModeStr := 'HercMonoHi';
     EGAMono    : ModeStr := 'EGAMonoHi';
     PC3270     : ModeStr := 'PC3270Hi';
     ATT400     : case GraphMode of
                    ATT400C0  : ModeStr := 'ATT400C0';
                    ATT400C1  : ModeStr := 'ATT400C1';
                    ATT400C2  : ModeStr := 'ATT400C2';
                    ATT400C3  : ModeStr := 'ATT400C3';
                    ATT400Med : ModeStr := 'ATT400Med';
                    ATT400Hi  : ModeStr := 'ATT400Hi';
                  end; { case }
     VGA         : case GraphMode of
                     VGALo  : ModeStr := 'VGALo';
                     VGAMed : ModeStr := 'VGAMed';
                     VGAHi  : ModeStr := 'VGAHi';
                   end; { case }
  end; { case }
end; { GetDriverAndMode }

procedure ReportStatus;
{ Display the status of all query functions after InitGraph }
const
  X = 10;
var
  ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  LineInfo   : LineSettingsType;
  FillInfo   : FillSettingsType;
  TextInfo   : TextSettingsType;
  Palette    : PaletteType;
  DriverStr  : string;           { Driver and mode strings }
  ModeStr    : string;
  Y          : word;

procedure WriteOut(S : string);
{ Write out a string and increment to next line }
begin
  OutTextXY(X, Y, S);
  Inc(Y, TextHeight('M')+2);
end; { WriteOut }

begin { ReportStatus }
  GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  GetViewSettings(ViewInfo);
  GetLineSettings(LineInfo);
  GetFillSettings(FillInfo);
  GetTextSettings(TextInfo);
  GetPalette(Palette);

  Y := 4;
  MainWindow('Status report after InitGraph');
  SetTextJustify(LeftText, TopText);
  WriteOut('Graphics device    : '+DriverStr);
  WriteOut('Graphics mode      : '+ModeStr);
  WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  with ViewInfo do
  begin
    WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
    if ClipOn then
      WriteOut('Clipping           : ON')
    else
      WriteOut('Clipping           : OFF');
  end;
  WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  WriteOut('Current color      : '+Int2Str(GetColor));
  with LineInfo do
  begin
    WriteOut('Line style         : '+LineStyles[LineStyle]);
    WriteOut('Line thickness     : '+Int2Str(Thickness));
  end;
  with FillInfo do
  begin
    WriteOut('Current fill style : '+FillStyles[Pattern]);
    WriteOut('Current fill color : '+Int2Str(Color));
  end;
  with TextInfo do
  begin
    WriteOut('Current font       : '+Fonts[Font]);
    WriteOut('Text direction     : '+TextDirect[Direction]);
    WriteOut('Character size     : '+Int2Str(CharSize));
    WriteOut('Horizontal justify : '+HorizJust[Horiz]);
    WriteOut('Vertical justify   : '+VertJust[Vert]);
  end;
  WaitToGo;
end; { ReportStatus }

procedure TextPlay;
{ Demonstrate text justifications and text sizing }
var
  Size : word;
  W, H, X, Y : word;
  ViewInfo : ViewPortType;
begin
  MainWindow('SetTextJustify / SetUserCharSize demo');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    SetTextStyle(TriplexFont, VertDir, 4);
    Y := (y2-y1) - 2;
    SetTextJustify(CenterText, BottomText);
    OutTextXY(2*TextWidth('M'), Y, 'Vertical');
    SetTextStyle(TriplexFont, HorizDir, 4);
    SetTextJustify(LeftText, TopText);
    OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
    SetTextJustify(CenterText, CenterText);
    X := (x2-x1) div 2;
    Y := TextHeight('H');
    for Size := 1 to 4 do
    begin
      SetTextStyle(TriplexFont, HorizDir, Size);
      H := TextHeight('M');
      W := TextWidth('M');
      Inc(Y, H);
      OutTextXY(X, Y, 'Size '+Int2Str(Size));
    end;
    Inc(Y, H div 2);
    SetTextJustify(CenterText, TopText);
    SetUserCharSize(5, 6, 3, 2);
    SetTextStyle(TriplexFont, HorizDir, UserCharSize);
    OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  end;
  WaitToGo;
end; { TextPlay }

procedure TextDump;
{ Dump the complete character sets to the screen }
const
  CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
var
  Font : word;
  ViewInfo : ViewPortType;
  Ch : char;
begin
  for Font := 0 to 4 do
  begin
    MainWindow(Fonts[Font]+' character set');
    GetViewSettings(ViewInfo);
    with ViewInfo do
    begin
      SetTextJustify(LeftText, TopText);
      MoveTo(2, 3);
      if Font = DefaultFont then
        begin
          SetTextStyle(Font, HorizDir, 1);
          Ch := #0;
          repeat
            OutText(Ch);
            if (GetX + TextWidth('M')) > (x2-x1) then
              MoveTo(2, GetY + TextHeight('M')+3);
            Ch := Succ(Ch);
          until (Ch >= #255);
        end
      else
        begin
          if MaxY < 200 then
            SetTextStyle(Font, HorizDir, CGASizes[Font])
          else
            SetTextStyle(Font, HorizDir, NormSizes[Font]);
          Ch := '!';
          repeat
            OutText(Ch);
            if (GetX + TextWidth('M')) > (x2-x1) then
              MoveTo(2, GetY + TextHeight('M')+3);
            Ch := Succ(Ch);
          until (Ord(Ch) = Ord('~')+1);
        end;
    end; { with }
    WaitToGo;
  end; { for loop }
end; { TextDump }

procedure LineToPlay;
{ Demonstrate MoveTo and LineTo commands }
const
  MaxPoints = 15;
var
  Points     : array[0..MaxPoints] of PointType;
  ViewInfo   : ViewPortType;
  I, J       : integer;
  CenterX    : integer;   { The center point of the circle }
  CenterY    : integer;
  Radius     : word;
  StepAngle  : word;
  Xasp, Yasp : word;
  Radians    : real;

function AdjAsp(Value : integer) : integer;
{ Adjust a value for the aspect ratio of the device }
begin
  AdjAsp := (LongInt(Value) * Xasp) div Yasp;
end; { AdjAsp }

begin
  MainWindow('MoveTo, LineTo demonstration');
  GetAspectRatio(Xasp, Yasp);
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    CenterX := (x2-x1) div 2;
    CenterY := (y2-y1) div 2;
    Radius := CenterY;
    while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
      Inc(Radius);
  end;
  StepAngle := 360 div MaxPoints;
  for I := 0 to MaxPoints - 1 do
  begin
    Radians := (StepAngle * I) * Pi / 180;
    Points[I].X := CenterX + round(Cos(Radians) * Radius);
    Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  end;
  Circle(CenterX, CenterY, Radius);
  for I := 0 to MaxPoints - 1 do
  begin
    for J := I to MaxPoints - 1 do
    begin
      MoveTo(Points[I].X, Points[I].Y);
      LineTo(Points[J].X, Points[J].Y);
    end;
  end;
  WaitToGo;
end; { LineToPlay }

procedure LineRelPlay;
{ Demonstrate MoveRel and LineRel commands }
const
  MaxPoints = 12;
var
  Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  CurrPort : ViewPortType;

procedure DrawTesseract;
{ Draw a Tesseract on the screen with relative move and
  line drawing commands, also create a polygon for filling }
const
  CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
var
  X, Y, W, H   : integer;

begin
  GetViewSettings(CurrPort);
  with CurrPort do
  begin
    W := (x2-x1) div 9;
    H := (y2-y1) div 8;
    X := ((x2-x1) div 2) - round(2.5 * W);
    Y := ((y2-y1) div 2) - (3 * H);

    { Border around viewport is outer part of polygon }
    Poly[1].X := 0;     Poly[1].Y := 0;
    Poly[2].X := x2-x1; Poly[2].Y := 0;
    Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
    Poly[4].X := 0;     Poly[4].Y := y2-y1;
    Poly[5].X := 0;     Poly[5].Y := 0;
    MoveTo(X, Y);

    { Grab the whole in the polygon as we draw }
    MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
    MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
    MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
    MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
    MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
    MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
    MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;

    { Fill the polygon with a user defined fill pattern }
    SetFillPattern(CheckerBoard, MaxColor);
    FillPoly(12, Poly);

    MoveRel(W, -H);
    LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
    LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
    LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
    MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
    LineRel(-W, 0);

    { Flood fill the center }
    FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor);
  end;
end; { DrawTesseract }

begin
  MainWindow('LineRel / MoveRel demonstration');
  GetViewSettings(CurrPort);
  with CurrPort do
    { Move the viewport out 1 pixel from each end }
    SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  DrawTesseract;
  WaitToGo;
end; { LineRelPlay }

procedure PiePlay;
{ Demonstrate  PieSlice and GetAspectRatio commands }
var
  ViewInfo   : ViewPortType;
  CenterX    : integer;
  CenterY    : integer;
  Radius     : word;
  Xasp, Yasp : word;
  X, Y       : integer;

function AdjAsp(Value : integer) : integer;
{ Adjust a value for the aspect ratio of the device }
begin
  AdjAsp := (LongInt(Value) * Xasp) div Yasp;
end; { AdjAsp }

procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
{ Get the coordinates of text for pie slice labels }
var
  Radians : real;
begin
  Radians := AngleInDegrees * Pi / 180;
  X := round(Cos(Radians) * Radius);
  Y := round(Sin(Radians) * Radius);
end; { GetTextCoords }

begin
  MainWindow('PieSlice / GetAspectRatio demonstration');
  GetAspectRatio(Xasp, Yasp);
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    CenterX := (x2-x1) div 2;
    CenterY := ((y2-y1) div 2) + 20;
    Radius := (y2-y1) div 3;
    while AdjAsp(Radius) < round((y2-y1) / 3.6) do
      Inc(Radius);
  end;
  SetTextStyle(TriplexFont, HorizDir, 4);
  SetTextJustify(CenterText, TopText);
  OutTextXY(CenterX, 0, 'This is a pie chart!');

  SetTextStyle(TriplexFont, HorizDir, 3);

  SetFillStyle(SolidFill, RandColor);
  PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  GetTextCoords(45, Radius, X, Y);
  SetTextJustify(LeftText, BottomText);
  OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');

  SetFillStyle(HatchFill, RandColor);
  PieSlice(CenterX, CenterY, 225, 360, Radius);
  GetTextCoords(293, Radius, X, Y);
  SetTextJustify(LeftText, TopText);
  OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');

  SetFillStyle(InterleaveFill, RandColor);
  PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  GetTextCoords(180, Radius, X, Y);
  SetTextJustify(RightText, CenterText);
  OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');

  SetFillStyle(WideDotFill, RandColor);
  PieSlice(CenterX, CenterY, 90, 135, Radius);
  GetTextCoords(112, Radius, X, Y);
  SetTextJustify(RightText, BottomText);
  OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');

  WaitToGo;
end; { PiePlay }

procedure Bar3DPlay;
{ Demonstrate Bar3D command }
const
  NumBars   = 7;  { The number of bars drawn }
  BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  YTicks    = 5;  { The number of tick marks on the Y axis }
var
  ViewInfo : ViewPortType;
  H        : word;
  XStep    : real;
  YStep    : real;
  I, J     : integer;
  Depth    : word;
  Color    : word;
begin
  MainWindow('Bar3D / Rectangle demonstration');
  H := 3*TextHeight('M');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, TopText);
  SetTextStyle(TriplexFont, HorizDir, 4);
  OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  SetTextStyle(DefaultFont, HorizDir, 1);
  with ViewInfo do
    SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Line(H, H, H, (y2-y1)-H);
    Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
    YStep := ((y2-y1)-(2*H)) / YTicks;
    XStep := ((x2-x1)-(2*H)) / NumBars;
    J := (y2-y1)-H;
    SetTextJustify(CenterText, CenterText);

    { Draw the Y axis and ticks marks }
    for I := 0 to Yticks do
    begin
      Line(H div 2, J, H, J);
      OutTextXY(0, J, Int2Str(I));
      J := Round(J-Ystep);
    end;


    Depth := trunc(0.25 * XStep);    { Calculate depth of bar }

    { Draw X axis, bars, and tick marks }
    SetTextJustify(CenterText, TopText);
    J := H;
    for I := 1 to Succ(NumBars) do
    begin
      SetColor(MaxColor);
      Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
      OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
      if I <> Succ(NumBars) then
      begin
        Color := RandColor;
        SetFillStyle(I, Color);
        SetColor(Color);
        Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
                 round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
        J := Round(J+Xstep);
      end;
    end;

  end;
  WaitToGo;
end; { Bar3DPlay }

procedure BarPlay;
{ Demonstrate Bar command }
const
  NumBars   = 5;
  BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
var
  ViewInfo  : ViewPortType;
  BarNum    : word;
  H         : word;
  XStep     : real;
  YStep     : real;
  I, J      : integer;
  Color     : word;
begin
  MainWindow('Bar / Rectangle demonstration');
  H := 3*TextHeight('M');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, TopText);
  SetTextStyle(TriplexFont, HorizDir, 4);
  OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  SetTextStyle(DefaultFont, HorizDir, 1);
  with ViewInfo do
    SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Line(H, H, H, (y2-y1)-H);
    Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
    YStep := ((y2-y1)-(2*H)) / NumBars;
    XStep := ((x2-x1)-(2*H)) / NumBars;
    J := (y2-y1)-H;
    SetTextJustify(CenterText, CenterText);

    { Draw Y axis with tick marks }
    for I := 0 to NumBars do
    begin
      Line(H div 2, J, H, J);
      OutTextXY(0, J, Int2Str(i));
      J := Round(J-Ystep);
    end;

    { Draw X axis, bars, and tick marks }
    J := H;
    SetTextJustify(CenterText, TopText);
    for I := 1 to Succ(NumBars) do
    begin
      SetColor(MaxColor);
      Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
      OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
      if I <> Succ(NumBars) then
      begin
        Color := RandColor;
        SetFillStyle(Styles[I], Color);
        SetColor(Color);
        Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
        Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
      end;
      J := Round(J+Xstep);
    end;

  end;
  WaitToGo;
end; { BarPlay }

procedure CirclePlay;
{ Draw random circles on the screen }
var
  MaxRadius : word;
begin
  MainWindow('Circle demonstration');
  StatusLine('Esc aborts or press a key');
  MaxRadius := MaxY div 10;
  SetLineStyle(SolidLn, 0, NormWidth);
  repeat
    SetColor(RandColor);
    Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  until KeyPressed;
  WaitToGo;
end; { CirclePlay }

procedure RandBarPlay;
{ Draw random bars on the screen }
var
  MaxWidth  : integer;
  MaxHeight : integer;
  ViewInfo  : ViewPortType;
  Color     : word;
begin
  MainWindow('Random Bars');
  StatusLine('Esc aborts or press a key');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    MaxWidth := x2-x1;
    MaxHeight := y2-y1;
  end;
  repeat
    Color := RandColor;
    SetColor(Color);
    SetFillStyle(Random(CloseDotFill)+1, Color);
    Bar3D(Random(MaxWidth), Random(MaxHeight),
          Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  until KeyPressed;
  WaitToGo;
end; { RandBarPlay }

procedure ArcPlay;
{ Draw random arcs on the screen }
var
  MaxRadius : word;
  EndAngle : word;
  ArcInfo : ArcCoordsType;
begin
  MainWindow('Arc / GetArcCoords demonstration');
  StatusLine('Esc aborts or press a key');
  MaxRadius := MaxY div 10;
  repeat
    SetColor(RandColor);
    EndAngle := Random(360);
    SetLineStyle(SolidLn, 0, NormWidth);
    Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
    GetArcCoords(ArcInfo);
    with ArcInfo do
    begin
      Line(X, Y, XStart, YStart);
      Line(X, Y, Xend, Yend);
    end;
  until KeyPressed;
  WaitToGo;
end; { ArcPlay }

procedure PutPixelPlay;
{ Demonstrate the PutPixel and GetPixel commands }
const
  Seed   = 1962; { A seed for the random number generator }
  NumPts = 2000; { The number of pixels plotted }
  Esc    = #27;
var
  I : word;
  X, Y, Color : word;
  XMax, YMax  : integer;
  ViewInfo    : ViewPortType;
begin
  MainWindow('PutPixel / GetPixel demonstration');
  StatusLine('Esc aborts or press a key...');

  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    XMax := (x2-x1-1);
    YMax := (y2-y1-1);
  end;

  while not KeyPressed do
  begin
    { Plot random pixels }
    RandSeed := Seed;
    I := 0;
    while (not KeyPressed) and (I < NumPts) do
    begin
      Inc(I);
      PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
    end;

    { Erase pixels }
    RandSeed := Seed;
    I := 0;
    while (not KeyPressed) and (I < NumPts) do
    begin
      Inc(I);
      X := Random(XMax)+1;
      Y := Random(YMax)+1;
      Color := GetPixel(X, Y);
      if Color = RandColor then
        PutPixel(X, Y, 0);
    end;
  end;
  WaitToGo;
end; { PutPixelPlay }

procedure PutImagePlay;
{ Demonstrate the GetImage and PutImage commands }

const
  r  = 20;
  StartX = 100;
  StartY = 50;

var
  CurPort : ViewPortType;

procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
var
  Step : integer;
begin
  Step := Random(2*r);
  if Odd(Step) then
    Step := -Step;
  X := X + Step;
  Step := Random(r);
  if Odd(Step) then
    Step := -Step;
  Y := Y + Step;

  { Make saucer bounce off viewport walls }
  with CurPort do
  begin
    if (x1 + X + Width - 1 > x2) then
      X := x2-x1 - Width + 1
    else
      if (X < 0) then
        X := 0;
    if (y1 + Y + Height - 1 > y2) then
      Y := y2-y1 - Height + 1
    else
      if (Y < 0) then
        Y := 0;
  end;
end; { MoveSaucer }

var
  Pausetime : word;
  Saucer    : pointer;
  X, Y      : integer;
  ulx, uly  : word;
  lrx, lry  : word;
  Size      : word;
  I         : word;
begin
  ClearDevice;
  FullPort;

  { PaintScreen }
  ClearDevice;
  MainWindow('GetImage / PutImage Demonstration');
  StatusLine('Esc aborts or press a key...');
  GetViewSettings(CurPort);

  { DrawSaucer }
  Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  Line(StartX+7, StartY-6, StartX+10, StartY-12);
  Circle(StartX+10, StartY-12, 2);
  Line(StartX-7, StartY-6, StartX-10, StartY-12);
  Circle(StartX-10, StartY-12, 2);
  SetFillStyle(SolidFill, MaxColor);
  FloodFill(StartX+1, StartY+4, GetColor);

  { ReadSaucerImage }
  ulx := StartX-(r+1);
  uly := StartY-14;
  lrx := StartX+(r+1);
  lry := StartY+(r div 3)+3;

  Size := ImageSize(ulx, uly, lrx, lry);
  GetMem(Saucer, Size);
  GetImage(ulx, uly, lrx, lry, Saucer^);
  PutImage(ulx, uly, Saucer^, XORput);               { erase image }

  { Plot some "stars" }
  for I := 1 to 1000 do
    PutPixel(Random(MaxX), Random(MaxY), RandColor);
  X := MaxX div 2;
  Y := MaxY div 2;
  PauseTime := 70;

  { Move the saucer around }
  repeat
    PutImage(X, Y, Saucer^, XORput);                 { draw image }
    Delay(PauseTime);
    PutImage(X, Y, Saucer^, XORput);                 { erase image }
    MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  until KeyPressed;
  FreeMem(Saucer, size);
  WaitToGo;
end; { PutImagePlay }

procedure PolyPlay;
{ Draw random polygons with random fill styles on the screen }
const
  MaxPts = 5;
type
  PolygonType = array[1..MaxPts] of PointType;
var
  Poly : PolygonType;
  I, Color : word;
begin
  MainWindow('FillPoly demonstration');
  StatusLine('Esc aborts or press a key...');
  repeat
    Color := RandColor;
    SetFillStyle(Random(11)+1, Color);
    SetColor(Color);
    for I := 1 to MaxPts do
      with Poly[I] do
      begin
        X := Random(MaxX);
        Y := Random(MaxY);
      end;
    FillPoly(MaxPts, Poly);
  until KeyPressed;
  WaitToGo;
end; { PolyPlay }

procedure FillStylePlay;
{ Display all of the predefined fill styles available }
var
  Style    : word;
  Width    : word;
  Height   : word;
  X, Y     : word;
  I, J     : word;
  ViewInfo : ViewPortType;

procedure DrawBox(X, Y : word);
begin
  SetFillStyle(Style, MaxColor);
  with ViewInfo do
    Bar(X, Y, X+Width, Y+Height);
  Rectangle(X, Y, X+Width, Y+Height);
  OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  Inc(Style);
end; { DrawBox }

begin
  MainWindow('Pre-defined fill styles');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Width := 2 * ((x2+1) div 13);
    Height := 2 * ((y2-10) div 10);
  end;
  X := Width div 2;
  Y := Height div 2;
  Style := 0;
  for J := 1 to 3 do
  begin
    for I := 1 to 4 do
    begin
      DrawBox(X, Y);
      Inc(X, (Width div 2) * 3);
    end;
    X := Width div 2;
    Inc(Y, (Height div 2) * 3);
  end;
  SetTextJustify(LeftText, TopText);
  WaitToGo;
end; { FillStylePlay }

procedure FillPatternPlay;
{ Display some user defined fill patterns }
const
  Patterns : array[0..11] of FillPatternType = (
  ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  (0, $10, $28, $44, $28, $10, 0, 0),
  (0, $70, $20, $27, $25, $27, $4, $4),
  (0, 0, 0, $18, $18, 0, 0, 0),
  (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  (0, 0, $22, $8, 0, $22, $1C, 0),
  ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  (0, $10, $10, $7C, $10, $10, 0, 0),
  (0, $42, $24, $18, $18, $24, $42, 0));
var
  Style    : word;
  Width    : word;
  Height   : word;
  X, Y     : word;
  I, J     : word;
  ViewInfo : ViewPortType;

procedure DrawBox(X, Y : word);
begin
  SetFillPattern(Patterns[Style], MaxColor);
  with ViewInfo do
    Bar(X, Y, X+Width, Y+Height);
  Rectangle(X, Y, X+Width, Y+Height);
  Inc(Style);
end; { DrawBox }

begin
  MainWindow('User defined fill styles');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Width := 2 * ((x2+1) div 13);
    Height := 2 * ((y2-10) div 10);
  end;
  X := Width div 2;
  Y := Height div 2;
  Style := 0;
  for J := 1 to 3 do
  begin
    for I := 1 to 4 do
    begin
      DrawBox(X, Y);
      Inc(X, (Width div 2) * 3);
    end;
    X := Width div 2;
    Inc(Y, (Height div 2) * 3);
  end;
  SetTextJustify(LeftText, TopText);
  WaitToGo;
end; { FillPatternPlay }

procedure ColorPlay;
{ Display all of the colors available for the current driver and mode }
var
  Color    : word;
  Width    : word;
  Height   : word;
  X, Y     : word;
  I, J     : word;
  ViewInfo : ViewPortType;

procedure DrawBox(X, Y : word);
begin
  SetFillStyle(SolidFill, Color);
  SetColor(Color);
  with ViewInfo do
    Bar(X, Y, X+Width, Y+Height);
  Rectangle(X, Y, X+Width, Y+Height);
  Color := GetColor;
  if Color = 0 then
  begin
    SetColor(MaxColor);
    Rectangle(X, Y, X+Width, Y+Height);
  end;
  OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Color));
  Color := Succ(Color) mod (MaxColor + 1);
end; { DrawBox }

begin
  MainWindow('Color demonstration');
  Color := 1;
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Width := 2 * ((x2+1) div 16);
    Height := 2 * ((y2-10) div 10);
  end;
  X := Width div 2;
  Y := Height div 2;
  for J := 1 to 3 do
  begin
    for I := 1 to 5 do
    begin
      DrawBox(X, Y);
      Inc(X, (Width div 2) * 3);
    end;
    X := Width div 2;
    Inc(Y, (Height div 2) * 3);
  end;
  WaitToGo;
end; { ColorPlay }

procedure PalettePlay;
{ Demonstrate the use of the SetPalette command }
const
  XBars = 15;
  YBars = 10;
var
  I, J     : word;
  X, Y     : word;
  Color    : word;
  ViewInfo : ViewPortType;
  Width    : word;
  Height   : word;
  OldPal   : PaletteType;
begin
  GetPalette(OldPal);
  MainWindow('Palette demonstration');
  StatusLine('Press any key...');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    Width := (x2-x1) div XBars;
    Height := (y2-y1) div YBars;
  end;
  X := 0; Y := 0;
  Color := 0;
  for J := 1 to YBars do
  begin
    for I := 1 to XBars do
    begin
      SetFillStyle(SolidFill, Color);
      Bar(X, Y, X+Width, Y+Height);
      Inc(X, Width+1);
      Inc(Color);
      Color := Color mod (MaxColor+1);
    end;
    X := 0;
    Inc(Y, Height+1);
  end;
  repeat
    SetPalette(Random(GetMaxColor + 1), Random(65));
  until KeyPressed;
  SetAllPalette(OldPal);
  WaitToGo;
end; { PalettePlay }

procedure CrtModePlay;
{ Demonstrate the use of RestoreCrtMode and SetGraphMode }
var
  ViewInfo : ViewPortType;
  Ch       : char;
begin
  MainWindow('SetGraphMode / RestoreCrtMode demo');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, CenterText);
  with ViewInfo do
  begin
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
    StatusLine('Press any key for text mode...');
    repeat until KeyPressed;
    Ch := ReadKey;
    RestoreCrtmode;
    Writeln('Now you are in text mode.');
    Write('Press any key to go back to graphics...');
    repeat until KeyPressed;
    Ch := ReadKey;
    SetGraphMode(GetGraphMode);
    MainWindow('SetGraphMode / RestoreCrtMode demo');
    SetTextJustify(CenterText, CenterText);
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  end;
  WaitToGo;
end; { CrtModePlay }

procedure LineStylePlay;
{ Demonstrate the predefined line styles available }
var
  Style    : word;
  Step     : word;
  X, Y     : word;
  ViewInfo : ViewPortType;

begin
  ClearDevice;
  DefaultColors;
  MainWindow('Pre-defined line styles');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    X := 35;
    Y := 10;
    Step := (x2-x1) div 11;
    SetTextJustify(LeftText, TopText);
    OutTextXY(X, Y, 'NormWidth');
    SetTextJustify(CenterText, TopText);
    for Style := 0 to 3 do
    begin
      SetLineStyle(Style, 0, NormWidth);
      Line(X, Y+20, X, Y2-40);
      OutTextXY(X, Y2-30, Int2Str(Style));
      Inc(X, Step);
    end;
    Inc(X, 2*Step);
    SetTextJustify(LeftText, TopText);
    OutTextXY(X, Y, 'ThickWidth');
    SetTextJustify(CenterText, TopText);
    for Style := 0 to 3 do
    begin
      SetLineStyle(Style, 0, ThickWidth);
      Line(X, Y+20, X, Y2-40);
      OutTextXY(X, Y2-30, Int2Str(Style));
      Inc(X, Step);
    end;
  end;
  SetTextJustify(LeftText, TopText);
  WaitToGo;
end; { LineStylePlay }

procedure UserLineStylePlay;
{ Demonstrate user defined line styles }
var
  Style    : word;
  X, Y, I  : word;
  ViewInfo : ViewPortType;
begin
  MainWindow('User defined line styles');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    X := 4;
    Y := 10;
    Style := 0;
    I := 0;
    while X < X2-4 do
    begin
      {$B+}
      Style := Style or (1 shl (I mod 16));
      {$B-}
      SetLineStyle(UserBitLn, Style, NormWidth);
      Line(X, Y, X, (y2-y1)-Y);
      Inc(X, 5);
      Inc(I);
      if Style = 65535 then
      begin
        I := 0;
        Style := 0;
      end;
    end;
  end;
  WaitToGo;
end; { UserLineStylePlay }

procedure SayGoodbye;
{ Say goodbye and then exit the program }
var
  ViewInfo : ViewPortType;
begin
  MainWindow('');
  GetViewSettings(ViewInfo);
  SetTextStyle(TriplexFont, HorizDir, 4);
  SetTextJustify(CenterText, CenterText);
  with ViewInfo do
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  StatusLine('Press any key to quit...');
  repeat until KeyPressed;
end; { SayGoodbye }

begin { program body }
  Initialize;
  ReportStatus;
  ColorPlay;
  { PalettePlay only intended to work on these drivers: }
  if (GraphDriver = EGA) or
     (GraphDriver = EGA64) or
     (GraphDriver = VGA) then
    PalettePlay;
  PutPixelPlay;
  PutImagePlay;
  RandBarPlay;
  BarPlay;
  Bar3DPlay;
  ArcPlay;
  CirclePlay;
  PiePlay;
  LineToPlay;
  LineRelPlay;
  LineStylePlay;
  UserLineStylePlay;
  TextDump;
  TextPlay;
  CrtModePlay;
  FillStylePlay;
  FillPatternPlay;
  PolyPlay;
  SayGoodbye;
  CloseGraph;
end.