bgidemo.pas

还是一个词法分析程序

  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;
    if ch = #0 then ch := readkey;    { trap function keys }
    RestoreCrtmode;
    Writeln('Now you are in text mode.');
    Write('Press any key to go back to graphics...');
    repeat until KeyPressed;
    Ch := ReadKey;
    if ch = #0 then ch := readkey;    { trap function keys }
    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;

  AspectRatioPlay;
  FillEllipsePlay;
  SectorPlay;
  WriteModePlay;

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