Turbo Toolbox/Turbo_Toolbox.iso/turbo4/grdemo.pas

Pascal/Delphi Source File | 1987-12-08 | 37.6 KB | 1,290 lines

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

program GrDemo;
{ Demonstration für das Unit Graph von Turbo Pascal 4.0 }

uses
  Crt, Dos, Graph;

const
  { Namen der diversen Treiber, die Graph unterstützt: }
  DriverNames : array[0..10] of string[8] =   ('Detect', 'CGA', 'MCGA',
                                               'EGA', 'EGA64', 'EGAMono',
                                               'RESERVED', 'HercMono',
                                               'ATT400', 'VGA', 'PC3270');

  { Die fünf Zeichensätze: }
  Fonts : array[0..4] of string[13] =     ('DefaultFont', 'TriplexFont',
                                           'SmallFont', 'SansSerifFont',
                                           'GothicFont');

  { Die fünf vorgegebenen Linienarten: }
  LineStyles : array[0..4] of string[9] =  ('SolidLn', 'DottedLn', 'CenterLn',
                                            'DashedLn', 'UserBitLn');

  { Die zwölf vordefinierten Füll-Muster }
  FillStyles : array[0..11] of string[14] =  ('EmptyFill', 'SolidFill', 'LineFill',
                                              'LtSlashFill', 'SlashFill',
                                              'BkSlashFill', 'LtBkSlashFill',
                                              'HatchFill', 'XHatchFill',
                                              'InterleaveFill', 'WideDotFill',
                                              'CloseDotFill');

  { Die beiden Schreibrichtungen für Text: }
  TextDirect : array[0..1] of string[8] =    ('HorizDir', 'VertDir');

  { Die horizontalen Justierungsmöglichkeiten für Text: }
  HorizJust  : array[0..2] of string[10] =   ('LeftText', 'CenterText',
                                              'RightText');

  { Die vertikalen Justierungsmöglichkeiten für Text: }
  VertJust   : array[0..2] of string[10] =   ('BottomText', 'CenterText',
                                              'TopText');
  { Aufforderung für den Benutzer }
  GOAHEAD = 'ESC -> Ende  Jede andere Taste -> Weiter';

var
  GraphDriver : Integer;  { Nummer des Grafik-Treibers }
  GraphMode   : Integer;  { Grafik-Modus }
  MaxX, MaxY  : Word;     { Maximal-Koordinaten des Bildschirms }
  ErrorCode   : Integer;  { für Grafik-Fehlercodes }
  MaxColor    : Word;     { Nummer der "höchsten" Farbe }
  OldExitProc : Pointer;  { speichert die "alte" Exit-Prozedur }

{$F+}
procedure MyExitProc;      { Wird als Exit-Prozedur aufgerufen (s. Kap. 25) }
begin
  ExitProc := OldExitProc; { "alte" Exit-Prozedur wieder einsetzen }
  CloseGraph;              { Grafik-Paket beenden }
end;                       { führt zum Aufruf der "alten" Exit-Prozedur }
{$F-}

procedure Initialize;
{ Initialisierung des Grafik-Pakets und Ausgabe eventueller Fehlermeldungen }
begin
  DirectVideo := False;     { Ausgaben über Crt dürfen bei der gleichzeitigen
                              Verwendung von Graph NICHT direkt in den
                              Bildspeicher schreiben - sonst landen Sie im
                              TEXT-Speicherbereich des Adapters! }
  OldExitProc := ExitProc;         { Installation der eigenen Exit-Prozedur: }
  ExitProc := @MyExitProc;         { "alte" Prozedur speichern und eigene
                                      Prozedur setzen }
  DetectGraph(GraphDriver, GraphMode);    { Treiber RESERVED ?}
  if GraphDriver = RESERVED then
    begin
      GraphDriver := CGA;                 { -> Ja, wird als CGA-Treiber und }
      GraphMode := CGAHi;                 { entsprechender Modus gesetzt! }
    end
  else GraphDriver := Detect;             { ansonsten automatische Erkennung }

  InitGraph(GraphDriver, GraphMode, '');  { Grafik aktivieren: Der Treiber
                                            (.BGI-Datei muß hier im selben
                                            Directory wie das Prog. stehen }
  ErrorCode := GraphResult;               { Fehler? }
  if ErrorCode <> grOk then
  begin
    Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
    Halt(1);
  end;
  Randomize;                { "Zufallszahlen"-Generator initialisieren }
  MaxColor := GetMaxColor;  { höchste erlaubte Farbnummer }
  MaxX := GetMaxX;          { Maximal-Koordinaten des Bildschirms }
  MaxY := GetMaxY;
end;

function Int2Str(L : LongInt) : string;
{ Konvertiert einen Integerwert in einen String für die Ausgabe mit OutText }
var S: string;
begin
  Str(L, S);
  Int2Str := S;
end;

function RandColor : Word;
{ Liefert einen Farbwert im Bereich von 1..MaxColor zurück, wobei
  MaxColor durch Initialize auf die höchste erlaubte Farbnummer gesetzt ist }
begin
  RandColor := Random(MaxColor)+1;
end;

procedure DefaultColors;
{ Setzt die höchste Farbnummer der Palette als Zeichenfarbe }
begin
  SetColor(MaxColor);
end;

procedure DrawBorder;
{ Zeichnet einen Rahmen um das momentane Zeichenfenster herum }
var ViewPort: ViewPortType;
begin
  DefaultColors;
  SetLineStyle(SolidLn, 0, NormWidth);
  GetViewSettings(ViewPort);
  with ViewPort do
    Rectangle(0, 0, x2-x1, y2-y1);
end;

procedure FullPort;
{ Setzt dem gesamten Bildschirm als Zeichenfenster }
begin
  SetViewPort(0, 0, MaxX, MaxY, ClipOn);
end;

procedure MainWindow(Header : string);
{ Erzeugt ein "Standard"-Fenster für die Demos }
begin
  DefaultColors;                           { Standard-Zeichenfarbe }
  ClearDevice;                             { Bildschirm löschen }
  SetTextStyle(DefaultFont, HorizDir, 1);  { Standard-Zeichensatz }
  SetTextJustify(CenterText, TopText);     { linksbündiger Text }
  FullPort;                                { Zeichenfenster: gesamter Schirm }
  OutTextXY(MaxX div 2, 2, Header);        { Überschrift }
  { das Fenster daselbst }
  SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  DrawBorder;                              { ein Rahmen drumherum }
  { Die Ecken des Fensters um ein Pixel nach innen verschieben, damit
    der Rahmen von Zeichenaktionen unbeeinflußt bleibt }
  SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end;

procedure StatusLine(Msg : string);
{ Ausgabe einer Statuszeile in der untersten Zeile des Bildschirms }
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);      { löscht die alte Zeile }
  Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  { Standard-Zeichenfenster erneut setzen }
  SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end;

procedure WaitToGo;
{ Wartet auf einen Tastendruck des Benutzers. Bei ESC: Abbruch des Programms }
const Esc = #27;
var Ch: Char;
begin
  StatusLine(GOAHEAD);
  repeat until KeyPressed;
  Ch := ReadKey;
  if Ch = Esc then Halt(0)    { Programmende }
   else ClearDevice;          { sonst Bildschirm löschen, weiter im Programm }
end;

procedure GetDriverAndMode(var DriveStr, ModeStr : string);
{ Liefert den momentan benutzten Treiber und Grafikmodus als String
  für den Statusreport zurück }
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;
{ Gibt den Status des Grafikpakets nach dem Aufruf von InitGraph aus }
const
  X = 10;
var
  ViewInfo   : ViewPortType;     { Parameter für die diversen Abfragen }
  LineInfo   : LineSettingsType;
  FillInfo   : FillSettingsType;
  TextInfo   : TextSettingsType;
  Palette    : PaletteType;
  DriverStr  : string;           { Grafik-Treiber und -modus }
  ModeStr    : string;
  Y          : Word;

procedure WriteOut(S : string);  { Ausgabe eines Strings und "Zeilenvorschub" }
begin
  OutTextXY(X, Y, S);
  Inc(Y, TextHeight('M')+2);
end; { WriteOut }

begin { ReportStatus }
  GetDriverAndMode(DriverStr, ModeStr);   { ermittelt Treiber und Modus }
  GetViewSettings(ViewInfo);
  GetLineSettings(LineInfo);
  GetFillSettings(FillInfo);
  GetTextSettings(TextInfo);
  GetPalette(Palette);

  Y := 4;
  MainWindow('Status des Grafikpakets nach Aufruf von InitGraph');
  SetTextJustify(LeftText, TopText);
  WriteOut('Grafik-Treiber     : '+DriverStr);
  WriteOut('Grafikmodus        : '+ModeStr);
  WriteOut('Bildschirmgröße    : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  with ViewInfo do
  begin
    WriteOut('Zeichenfenster     : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
    if ClipOn then
      WriteOut('Clipping           : aktiv (ClipOn)')
    else
      WriteOut('Clipping           : nicht aktiv (ClipOff)');
  end;
  WriteOut('Cursorposition     : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  WriteOut('Paletten-Einträge  : '+Int2Str(Palette.Size));
  WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  WriteOut('Zeichenfarbe       : '+Int2Str(GetColor));
  with LineInfo do
  begin
    WriteOut('Linienart          : '+LineStyles[LineStyle]);
    WriteOut('Liniendicke        : '+Int2Str(Thickness));
  end;
  with FillInfo do
  begin
    WriteOut('Füll-Muster        : '+FillStyles[Pattern]);
    WriteOut('Füll-Farbe         : '+Int2Str(Color));
  end;
  with TextInfo do
  begin
    WriteOut('Zeichensatz        : '+Fonts[Font]);
    WriteOut('Schreibrichtung    : '+TextDirect[Direction]);
    WriteOut('Zeichengröße       : '+Int2Str(CharSize));
    WriteOut('Justierung hor.    : '+HorizJust[Horiz]);
    WriteOut('Justierung vert.   : '+VertJust[Vert]);
  end;
  WaitToGo;
end; { ReportStatus }

procedure TextPlay;
{ Demonstration der Textformatierung und -größe }
var
  Size : Word;
  W, H, X, Y : Word;
  ViewInfo : ViewPortType;
begin
  MainWindow('Demo für SetTextJustify / SetUserCharSize');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    SetTextStyle(TriplexFont, VertDir, 4);
    Y := (y2-y1) - 2;
    SetTextJustify(CenterText, BottomText);
    OutTextXY(2*TextWidth('M'), Y, 'Vertikal');
    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, 'Faktor '+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, 'Vom Benutzer festgelegt!');
  end;
  WaitToGo;
end; { TextPlay }

procedure TextDump;
{ Ausgabe aller definierten Zeichen }
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('Zeichensatz: '+ Fonts[Font]);
    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);   { neue Zeile }
            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 }
end; { TextDump }

procedure LineToPlay;
{ Demo für MoveTo und LineTo }
const
  MaxPoints = 15;
var
  Points     : array[0..MaxPoints] of PointType;
  ViewInfo   : ViewPortType;
  I, J       : Integer;
  CenterX    : Integer;   { Kreismittelpunkt }
  CenterY    : Integer;
  Radius     : Word;
  StepAngle  : Word;
  Xasp, Yasp : Word;
  Radians    : real;

function AdjAsp(Value : Integer) : Integer;
{ Anpassung an das Höhen-/Seitenverhältnis des Bildschirms }
begin
  AdjAsp := (LongInt(Value) * Xasp) div Yasp;
end;

begin
  MainWindow('Demonstration von MoveTo und LineTo');
  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;

procedure LineRelPlay;
{ Demo für MoveRel und LineRel }
const
  MaxPoints = 12;
var
  Poly     : array[1..MaxPoints] of PointType; { das zu füllende Polygon }
  CurrPort : ViewPortType;

procedure DrawTesseract;  { lokal zu LineRelPlay }
{ Zeichnet einen Tesserakt mit relativen Bewegungen und hält den Umriß
  dabei als zu füllendes Polygon fest. }
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);

    { Der äußere Rand des Polygons ist das Zeichenfenster }
    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);

    { Der innere Rand wird während des Zeichnens festgehalten ... }
    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;

    { ... und danach mit dem benutzerdefinierten Muster gefüllt }
    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);

    { Das Innere des Tesserakts wird mit FloodFill gefüllt }
    FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor);
  end;
end; { DrawTesseract }

begin { LineRelPlay }
  MainWindow('Demonstration von LineRel und MoveRel');
  GetViewSettings(CurrPort);
  with CurrPort do
    { Zeichenfenster um jeweils ein Pixel verkleinern }
    SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  DrawTesseract;
  WaitToGo;
end; { LineRelPlay }

procedure PiePlay;
{ Demonstration von PieSlice and GetAspectRatio }
var
  ViewInfo   : ViewPortType;
  CenterX    : Integer;
  CenterY    : Integer;
  Radius     : Word;
  Xasp, Yasp : Word;
  X, Y       : Integer;

function AdjAsp(Value : Integer) : Integer;
{ Anpassung an das Höhen-/Seitenverhältnis des Bildschirms }
begin
  AdjAsp := (LongInt(Value) * Xasp) div Yasp;
end; { AdjAsp }

procedure GetTextCoords(AngleInDegrees, Radius : Word; var X, Y : Integer);
{ Koordinaten für die Beschriftung }
var
  Radians : real;
begin
  Radians := AngleInDegrees * Pi / 180;
  X := round(Cos(Radians) * Radius);
  Y := round(Sin(Radians) * Radius);
end; { GetTextCoords }

begin { PiePlay }
  MainWindow('Demonstration von PieSlice / GetAspectRatio');
  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, 'Ein Kuchendiagramm!');

  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;
{ Demo für Bar3D }
const
  NumBars   = 7;  { Anzahl der zu zeichnenden Balken }
  BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  YTicks    = 5;  { Einteilung der Y-Achse }
var
  ViewInfo : ViewPortType;
  H        : Word;
  XStep    : real;
  YStep    : real;
  I, J     : Integer;
  Depth    : Word;
  Color    : Word;
begin
  MainWindow('Demonstration von Bar3D / Rectangle');
  H := 3*TextHeight('M');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, TopText);
  SetTextStyle(TriplexFont, HorizDir, 4);
  OutTextXY(MaxX div 2, 6, 'Dreidimensionale Balken!');
  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);

    { Zeichnen der Y-Achse und ihrer Einteilung }
    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);    { Räumliche Tiefe eines Balkens }

    { X-Achse und die Balken }
    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;
{ Demo für Bar }
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('Demonstration von Bar / Rectangle');
  H := 3*TextHeight('M');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, TopText);
  SetTextStyle(TriplexFont, HorizDir, 4);
  OutTextXY(MaxX div 2, 6, 'Zweidimensionale Balken...');
  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);

    { Zeichnen der Y-Achse und ihrer Einteilung }
    for I := 0 to NumBars do
    begin
      Line(H div 2, J, H, J);
      OutTextXY(0, J, Int2Str(i));
      J := Round(J-Ystep);
    end;

    { Die X-Achse und die Balken }
    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;

procedure CirclePlay;
{ Zeichnet viele Kreise, deren Farbe, Mittelpunkt und Radius
  durch den Zufallszahlengenerator bestimmt werden }
var
  MaxRadius : Word;
begin
  MainWindow('Circle-Demo');
  StatusLine(GOAHEAD);
  MaxRadius := MaxY div 10;
  SetLineStyle(SolidLn, 0, NormWidth);
  repeat
    SetColor(RandColor);
    Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  until KeyPressed;
  WaitToGo;
end;

procedure RandBarPlay;
{ Zeichnet viele Balken, deren Farbe, Breite und Höhe
  durch den Zufallszahlengenerator bestimmt werden }
var
  MaxWidth  : Integer;
  MaxHeight : Integer;
  ViewInfo  : ViewPortType;
  Color     : Word;
begin
  MainWindow('Bar/Bar3D-Demo');
  StatusLine(GOAHEAD);
  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;

procedure ArcPlay;
{ Zeichnet viele Kreisausschnitte, deren Parameter (Farbe, Mittelpunkt, Radius,
  Start- und Endwinkel) durch den Zufallszahlengenerator bestimmt werden }
var
  MaxRadius : Word;
  EndAngle : Word;
  ArcInfo : ArcCoordsType;
begin
  MainWindow('Arc / GetArcCoords');
  StatusLine(GOAHEAD);
  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;

procedure PutPixelPlay;
{ Demo für PutPixel und GetPixel }
const
  Seed   = 1962; { Startwert für den Zufallszahlen-Generator }
  Esc    = #27;
var
  NumPts      : Word;    { Anzahl der zu zeichnenden Pixel }
  I, X, Y, Color : Word;
  XMax, YMax  : Integer;
  ViewInfo    : ViewPortType;
begin
  MainWindow('PutPixel / GetPixel');
  StatusLine(GOAHEAD);

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

  while not KeyPressed do
  begin
    { Zeichnen "zufälliger" Pixel }
    RandSeed := Seed;
    I := 0;
    while (not KeyPressed) and (I < NumPts) do
    begin
      Inc(I);
      PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
    end;

    { Zufallsgenerator wieder auf denselben Startwert setzen }
    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);  { und Löschen }
    end;
    Delay(500);
  end;
  WaitToGo;
end;

procedure PutImagePlay;
{ Demo für GetImage und PutImage }

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

var
  CurPort : ViewPortType;

procedure MoveSaucer(var X, Y : Integer; Width, Height : Integer);
{ Bewegt die fliegende Untertasse }
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;

  { Das UFO wird von den Grenzen des Zeichenfensters "reflektiert" }
  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                   { PutImagePlay }
  Pausetime : Word;
  Saucer    : Pointer;
  X, Y      : Integer;
  ulx, uly  : Word;
  lrx, lry  : Word;
  Size      : Word;
  I         : Word;
begin
  ClearDevice;  { Bildschirm löschen }
  MainWindow('GetImage / PutImage');
  StatusLine(GOAHEAD);
  GetViewSettings(CurPort);

  { UFO zeichnen }
  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);

  { UFO "einfangen" }
  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);               { und mit XOR löschen }

  { Hintergrund zeichnen (ein Sternenhimmel) }
  for I := 1 to 1000 do
    PutPixel(Random(MaxX), Random(MaxY), RandColor);
  X := MaxX div 2;
  Y := MaxY div 2;
  PauseTime := 70;

  { und das UFO in diesem Bild bewegen }
  repeat
    PutImage(X, Y, Saucer^, XORput);                 { Zeichnen mit XOR }
    Delay(PauseTime);
    PutImage(X, Y, Saucer^, XORput);                 { Löschen mit XOR }
    MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { Breite/Höhe }
  until KeyPressed;
  FreeMem(Saucer, size);
  WaitToGo;
end; { PutImagePlay }

procedure PolyPlay;
{ zeichnet viele Polygone, deren Farbe, Größe und Eckpunkte durch
  den Zufallszahlen-Generator festgelegt werden }
const
  MaxPts = 5;
type
  PolygonType = array[1..MaxPts] of PointType;
var
  Poly : PolygonType;
  I, Color : Word;
begin
  MainWindow('Demonstration von FillPoly');
  StatusLine(GOAHEAD);
  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;

procedure FillStylePlay;
{ Demo der vordefinierten Füll-Muster }
var
  Style    : Word;
  Width    : Word;
  Height   : Word;
  X, Y     : Word;
  I, J     : Word;
  ViewInfo : ViewPortType;

procedure DrawBox(X, Y : Word);   { Zeichnet ein gefülltes Rechteck }
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;

begin
  MainWindow('Vordefinierte Füll-Muster');
  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;

procedure FillPatternPlay;
{ Zeigt einige benutzerdefinierte Füll-Muster }
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('Benutzerdefinierte Füll-Muster');
  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;
{ Zeigt alle verfügbaren Farben für den verwendeten Treiber und Grafikmodus }
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('Verfügbare Zeichenfarben');
  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;
{ Demo für die Verwendung von SetPalette }
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('Über Farb-Paletten und ihre Möglichkeiten...');
  StatusLine(GOAHEAD);
  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           { Füllt den Bildschirm mit Quadraten }
  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        { zufälliger Wechsel der Farben }
    SetPalette(Random(GetMaxColor + 1), Random(65));
  until KeyPressed;
  SetAllPalette(OldPal);
  WaitToGo;
end;

procedure CrtModePlay;
{ Demo für die Umschaltung mit RestoreCrtMode und SetGraphMode }
var
  ViewInfo : ViewPortType;
  Ch       : Char;
begin
  MainWindow('Demo für SetGraphMode und RestoreCrtMode');
  GetViewSettings(ViewInfo);
  SetTextJustify(CenterText, CenterText);
  with ViewInfo do
  begin
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Wir sind im Grafikmodus');
    StatusLine('Weiter mit einem beliebigen Tastendruck...');
    repeat until KeyPressed;
    Ch := ReadKey;
    RestoreCrtmode;
    Writeln('Jetzt sind wir im Textmodus...');
    Write('Zurück zur Grafik mit einem beliebigen Tastendruck...');
    repeat until KeyPressed;
    Ch := ReadKey;
    SetGraphMode(GetGraphMode);
    MainWindow('Demo für SetGraphMode und RestoreCrtMode');
    SetTextJustify(CenterText, CenterText);
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, '... und wieder in der Grafik!');
  end;
  WaitToGo;
end;

procedure LineStylePlay;
{ Demo der vordefinierten Linienarten }
var
  Style    : Word;
  Step     : Word;
  X, Y     : Word;
  ViewInfo : ViewPortType;

begin
  ClearDevice;
  DefaultColors;
  MainWindow('Vordefinierte Linienarten und -Konstanten');
  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;

procedure UserLineStylePlay;
{ Benutzerdefinierte Linienarten }
var
  Style    : Word;
  X, Y, I  : Word;
  ViewInfo : ViewPortType;
begin
  MainWindow('Eine benutzerdefinierte Linienart');
  GetViewSettings(ViewInfo);
  with ViewInfo do
  begin
    X := 4;
    Y := 10;
    Style := 0;
    I := 0;
    while X < X2-4 do
    begin
      Style := Style or (1 shl (I mod 16));
      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;

procedure SayGoodbye;
{ Verabschiedet sich artig und beendet das Programm }
var
  ViewInfo : ViewPortType;
  Ch: Char;
begin
  MainWindow('');
  GetViewSettings(ViewInfo);
  SetTextStyle(TriplexFont, HorizDir, 4);
  SetTextJustify(CenterText, CenterText);
  with ViewInfo do
    OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Das war''s!');
  StatusLine('Aus und vorbei mit einem beliebigen Tastendruck...');
  repeat until KeyPressed;
  Ch:= ReadKey;
end; { SayGoodbye }

{ *********************************************************** }
{ *********************************************************** }
begin { Hauptprogramm }
  Initialize;
  ReportStatus;
  ColorPlay;
  { PalettePlay ist nur für die folgenden Treiber gedacht (bzw. auf
    monochromen Video-Adaptern nicht sonderlich eindrucksvoll): }
  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 wird über die zu Anfang des Programms installierte
       Exit-Prozedur aufgerufen }
end.