home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / turbo4 / grdemo.pas < prev    next >
Pascal/Delphi Source File  |  1987-12-08  |  39KB  |  1,290 lines
  1.  
  2. {           Copyright (c) 1985, 87 by Borland International, Inc.            }
  3.  
  4. program GrDemo;
  5. { Demonstration für das Unit Graph von Turbo Pascal 4.0 }
  6.  
  7. uses
  8.   Crt, Dos, Graph;
  9.  
  10. const
  11.   { Namen der diversen Treiber, die Graph unterstützt: }
  12.   DriverNames : array[0..10] of string[8] =   ('Detect', 'CGA', 'MCGA',
  13.                                                'EGA', 'EGA64', 'EGAMono',
  14.                                                'RESERVED', 'HercMono',
  15.                                                'ATT400', 'VGA', 'PC3270');
  16.  
  17.   { Die fünf Zeichensätze: }
  18.   Fonts : array[0..4] of string[13] =     ('DefaultFont', 'TriplexFont',
  19.                                            'SmallFont', 'SansSerifFont',
  20.                                            'GothicFont');
  21.  
  22.   { Die fünf vorgegebenen Linienarten: }
  23.   LineStyles : array[0..4] of string[9] =  ('SolidLn', 'DottedLn', 'CenterLn',
  24.                                             'DashedLn', 'UserBitLn');
  25.  
  26.   { Die zwölf vordefinierten Füll-Muster }
  27.   FillStyles : array[0..11] of string[14] =  ('EmptyFill', 'SolidFill', 'LineFill',
  28.                                               'LtSlashFill', 'SlashFill',
  29.                                               'BkSlashFill', 'LtBkSlashFill',
  30.                                               'HatchFill', 'XHatchFill',
  31.                                               'InterleaveFill', 'WideDotFill',
  32.                                               'CloseDotFill');
  33.  
  34.   { Die beiden Schreibrichtungen für Text: }
  35.   TextDirect : array[0..1] of string[8] =    ('HorizDir', 'VertDir');
  36.  
  37.   { Die horizontalen Justierungsmöglichkeiten für Text: }
  38.   HorizJust  : array[0..2] of string[10] =   ('LeftText', 'CenterText',
  39.                                               'RightText');
  40.  
  41.   { Die vertikalen Justierungsmöglichkeiten für Text: }
  42.   VertJust   : array[0..2] of string[10] =   ('BottomText', 'CenterText',
  43.                                               'TopText');
  44.   { Aufforderung für den Benutzer }
  45.   GOAHEAD = 'ESC -> Ende  Jede andere Taste -> Weiter';
  46.  
  47. var
  48.   GraphDriver : Integer;  { Nummer des Grafik-Treibers }
  49.   GraphMode   : Integer;  { Grafik-Modus }
  50.   MaxX, MaxY  : Word;     { Maximal-Koordinaten des Bildschirms }
  51.   ErrorCode   : Integer;  { für Grafik-Fehlercodes }
  52.   MaxColor    : Word;     { Nummer der "höchsten" Farbe }
  53.   OldExitProc : Pointer;  { speichert die "alte" Exit-Prozedur }
  54.  
  55. {$F+}
  56. procedure MyExitProc;      { Wird als Exit-Prozedur aufgerufen (s. Kap. 25) }
  57. begin
  58.   ExitProc := OldExitProc; { "alte" Exit-Prozedur wieder einsetzen }
  59.   CloseGraph;              { Grafik-Paket beenden }
  60. end;                       { führt zum Aufruf der "alten" Exit-Prozedur }
  61. {$F-}
  62.  
  63. procedure Initialize;
  64. { Initialisierung des Grafik-Pakets und Ausgabe eventueller Fehlermeldungen }
  65. begin
  66.   DirectVideo := False;     { Ausgaben über Crt dürfen bei der gleichzeitigen
  67.                               Verwendung von Graph NICHT direkt in den
  68.                               Bildspeicher schreiben - sonst landen Sie im
  69.                               TEXT-Speicherbereich des Adapters! }
  70.   OldExitProc := ExitProc;         { Installation der eigenen Exit-Prozedur: }
  71.   ExitProc := @MyExitProc;         { "alte" Prozedur speichern und eigene
  72.                                       Prozedur setzen }
  73.   DetectGraph(GraphDriver, GraphMode);    { Treiber RESERVED ?}
  74.   if GraphDriver = RESERVED then
  75.     begin
  76.       GraphDriver := CGA;                 { -> Ja, wird als CGA-Treiber und }
  77.       GraphMode := CGAHi;                 { entsprechender Modus gesetzt! }
  78.     end
  79.   else GraphDriver := Detect;             { ansonsten automatische Erkennung }
  80.  
  81.   InitGraph(GraphDriver, GraphMode, '');  { Grafik aktivieren: Der Treiber
  82.                                             (.BGI-Datei muß hier im selben
  83.                                             Directory wie das Prog. stehen }
  84.   ErrorCode := GraphResult;               { Fehler? }
  85.   if ErrorCode <> grOk then
  86.   begin
  87.     Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  88.     Halt(1);
  89.   end;
  90.   Randomize;                { "Zufallszahlen"-Generator initialisieren }
  91.   MaxColor := GetMaxColor;  { höchste erlaubte Farbnummer }
  92.   MaxX := GetMaxX;          { Maximal-Koordinaten des Bildschirms }
  93.   MaxY := GetMaxY;
  94. end;
  95.  
  96. function Int2Str(L : LongInt) : string;
  97. { Konvertiert einen Integerwert in einen String für die Ausgabe mit OutText }
  98. var S: string;
  99. begin
  100.   Str(L, S);
  101.   Int2Str := S;
  102. end;
  103.  
  104. function RandColor : Word;
  105. { Liefert einen Farbwert im Bereich von 1..MaxColor zurück, wobei
  106.   MaxColor durch Initialize auf die höchste erlaubte Farbnummer gesetzt ist }
  107. begin
  108.   RandColor := Random(MaxColor)+1;
  109. end;
  110.  
  111. procedure DefaultColors;
  112. { Setzt die höchste Farbnummer der Palette als Zeichenfarbe }
  113. begin
  114.   SetColor(MaxColor);
  115. end;
  116.  
  117. procedure DrawBorder;
  118. { Zeichnet einen Rahmen um das momentane Zeichenfenster herum }
  119. var ViewPort: ViewPortType;
  120. begin
  121.   DefaultColors;
  122.   SetLineStyle(SolidLn, 0, NormWidth);
  123.   GetViewSettings(ViewPort);
  124.   with ViewPort do
  125.     Rectangle(0, 0, x2-x1, y2-y1);
  126. end;
  127.  
  128. procedure FullPort;
  129. { Setzt dem gesamten Bildschirm als Zeichenfenster }
  130. begin
  131.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  132. end;
  133.  
  134. procedure MainWindow(Header : string);
  135. { Erzeugt ein "Standard"-Fenster für die Demos }
  136. begin
  137.   DefaultColors;                           { Standard-Zeichenfarbe }
  138.   ClearDevice;                             { Bildschirm löschen }
  139.   SetTextStyle(DefaultFont, HorizDir, 1);  { Standard-Zeichensatz }
  140.   SetTextJustify(CenterText, TopText);     { linksbündiger Text }
  141.   FullPort;                                { Zeichenfenster: gesamter Schirm }
  142.   OutTextXY(MaxX div 2, 2, Header);        { Überschrift }
  143.   { das Fenster daselbst }
  144.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  145.   DrawBorder;                              { ein Rahmen drumherum }
  146.   { Die Ecken des Fensters um ein Pixel nach innen verschieben, damit
  147.     der Rahmen von Zeichenaktionen unbeeinflußt bleibt }
  148.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  149. end;
  150.  
  151. procedure StatusLine(Msg : string);
  152. { Ausgabe einer Statuszeile in der untersten Zeile des Bildschirms }
  153. begin
  154.   FullPort;
  155.   DefaultColors;
  156.   SetTextStyle(DefaultFont, HorizDir, 1);
  157.   SetTextJustify(CenterText, TopText);
  158.   SetLineStyle(SolidLn, 0, NormWidth);
  159.   SetFillStyle(EmptyFill, 0);
  160.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { löscht die alte Zeile }
  161.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  162.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  163.   { Standard-Zeichenfenster erneut setzen }
  164.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  165. end;
  166.  
  167. procedure WaitToGo;
  168. { Wartet auf einen Tastendruck des Benutzers. Bei ESC: Abbruch des Programms }
  169. const Esc = #27;
  170. var Ch: Char;
  171. begin
  172.   StatusLine(GOAHEAD);
  173.   repeat until KeyPressed;
  174.   Ch := ReadKey;
  175.   if Ch = Esc then Halt(0)    { Programmende }
  176.    else ClearDevice;          { sonst Bildschirm löschen, weiter im Programm }
  177. end;
  178.  
  179. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  180. { Liefert den momentan benutzten Treiber und Grafikmodus als String
  181.   für den Statusreport zurück }
  182. begin
  183.   DriveStr := DriverNames[GraphDriver];
  184.   GraphMode := GetGraphMode;
  185.   case GraphDriver of
  186.     CGA        : case GraphMode of
  187.                    CGAC0 : ModeStr := 'CGAC0';
  188.                    CGAC1 : ModeStr := 'CGAC1';
  189.                    CGAC2 : ModeStr := 'CGAC2';
  190.                    CGAC3 : ModeStr := 'CGAC3';
  191.                    CGAHi : ModeStr := 'CGAHi';
  192.                  end; { case }
  193.     MCGA       : case GraphMode of
  194.                    MCGAC0  : ModeStr := 'MCGAC0';
  195.                    MCGAC1  : ModeStr := 'MCGAC1';
  196.                    MCGAC2  : ModeStr := 'MCGAC2';
  197.                    MCGAC3  : ModeStr := 'MCGAC3';
  198.                    MCGAMed : ModeStr := 'MCGAMed';
  199.                    MCGAHi  : ModeStr := 'MCGAHi';
  200.                  end; { case }
  201.     EGA         : case GraphMode of
  202.                     EGALo : ModeStr := 'EGALo';
  203.                     EGAHi : ModeStr := 'EGAHi';
  204.                   end;
  205.     EGA64       : case GraphMode of
  206.                     EGA64Lo :  ModeStr := 'EGA64Lo';
  207.                     EGA64Hi :  ModeStr := 'EGA64Hi';
  208.                   end; { case }
  209.      HercMono   : ModeStr := 'HercMonoHi';
  210.      EGAMono    : ModeStr := 'EGAMonoHi';
  211.      PC3270     : ModeStr := 'PC3270Hi';
  212.      ATT400     : case GraphMode of
  213.                     ATT400C0  : ModeStr := 'ATT400C0';
  214.                     ATT400C1  : ModeStr := 'ATT400C1';
  215.                     ATT400C2  : ModeStr := 'ATT400C2';
  216.                     ATT400C3  : ModeStr := 'ATT400C3';
  217.                     ATT400Med : ModeStr := 'ATT400Med';
  218.                     ATT400Hi  : ModeStr := 'ATT400Hi';
  219.                   end; { case }
  220.      VGA         : case GraphMode of
  221.                      VGALo  : ModeStr := 'VGALo';
  222.                      VGAMed : ModeStr := 'VGAMed';
  223.                      VGAHi  : ModeStr := 'VGAHi';
  224.                    end; { case }
  225.   end; { case }
  226. end; { GetDriverAndMode }
  227.  
  228. procedure ReportStatus;
  229. { Gibt den Status des Grafikpakets nach dem Aufruf von InitGraph aus }
  230. const
  231.   X = 10;
  232. var
  233.   ViewInfo   : ViewPortType;     { Parameter für die diversen Abfragen }
  234.   LineInfo   : LineSettingsType;
  235.   FillInfo   : FillSettingsType;
  236.   TextInfo   : TextSettingsType;
  237.   Palette    : PaletteType;
  238.   DriverStr  : string;           { Grafik-Treiber und -modus }
  239.   ModeStr    : string;
  240.   Y          : Word;
  241.  
  242. procedure WriteOut(S : string);  { Ausgabe eines Strings und "Zeilenvorschub" }
  243. begin
  244.   OutTextXY(X, Y, S);
  245.   Inc(Y, TextHeight('M')+2);
  246. end; { WriteOut }
  247.  
  248. begin { ReportStatus }
  249.   GetDriverAndMode(DriverStr, ModeStr);   { ermittelt Treiber und Modus }
  250.   GetViewSettings(ViewInfo);
  251.   GetLineSettings(LineInfo);
  252.   GetFillSettings(FillInfo);
  253.   GetTextSettings(TextInfo);
  254.   GetPalette(Palette);
  255.  
  256.   Y := 4;
  257.   MainWindow('Status des Grafikpakets nach Aufruf von InitGraph');
  258.   SetTextJustify(LeftText, TopText);
  259.   WriteOut('Grafik-Treiber     : '+DriverStr);
  260.   WriteOut('Grafikmodus        : '+ModeStr);
  261.   WriteOut('Bildschirmgröße    : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  262.   with ViewInfo do
  263.   begin
  264.     WriteOut('Zeichenfenster     : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  265.     if ClipOn then
  266.       WriteOut('Clipping           : aktiv (ClipOn)')
  267.     else
  268.       WriteOut('Clipping           : nicht aktiv (ClipOff)');
  269.   end;
  270.   WriteOut('Cursorposition     : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  271.   WriteOut('Paletten-Einträge  : '+Int2Str(Palette.Size));
  272.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  273.   WriteOut('Zeichenfarbe       : '+Int2Str(GetColor));
  274.   with LineInfo do
  275.   begin
  276.     WriteOut('Linienart          : '+LineStyles[LineStyle]);
  277.     WriteOut('Liniendicke        : '+Int2Str(Thickness));
  278.   end;
  279.   with FillInfo do
  280.   begin
  281.     WriteOut('Füll-Muster        : '+FillStyles[Pattern]);
  282.     WriteOut('Füll-Farbe         : '+Int2Str(Color));
  283.   end;
  284.   with TextInfo do
  285.   begin
  286.     WriteOut('Zeichensatz        : '+Fonts[Font]);
  287.     WriteOut('Schreibrichtung    : '+TextDirect[Direction]);
  288.     WriteOut('Zeichengröße       : '+Int2Str(CharSize));
  289.     WriteOut('Justierung hor.    : '+HorizJust[Horiz]);
  290.     WriteOut('Justierung vert.   : '+VertJust[Vert]);
  291.   end;
  292.   WaitToGo;
  293. end; { ReportStatus }
  294.  
  295. procedure TextPlay;
  296. { Demonstration der Textformatierung und -größe }
  297. var
  298.   Size : Word;
  299.   W, H, X, Y : Word;
  300.   ViewInfo : ViewPortType;
  301. begin
  302.   MainWindow('Demo für SetTextJustify / SetUserCharSize');
  303.   GetViewSettings(ViewInfo);
  304.   with ViewInfo do
  305.   begin
  306.     SetTextStyle(TriplexFont, VertDir, 4);
  307.     Y := (y2-y1) - 2;
  308.     SetTextJustify(CenterText, BottomText);
  309.     OutTextXY(2*TextWidth('M'), Y, 'Vertikal');
  310.     SetTextStyle(TriplexFont, HorizDir, 4);
  311.     SetTextJustify(LeftText, TopText);
  312.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  313.     SetTextJustify(CenterText, CenterText);
  314.     X := (x2-x1) div 2;
  315.     Y := TextHeight('H');
  316.     for Size := 1 to 4 do
  317.     begin
  318.       SetTextStyle(TriplexFont, HorizDir, Size);
  319.       H := TextHeight('M');
  320.       W := TextWidth('M');
  321.       Inc(Y, H);
  322.       OutTextXY(X, Y, 'Faktor '+Int2Str(Size));
  323.     end;
  324.     Inc(Y, H div 2);
  325.     SetTextJustify(CenterText, TopText);
  326.     SetUserCharSize(5, 6, 3, 2);
  327.     SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  328.     OutTextXY((x2-x1) div 2, Y, 'Vom Benutzer festgelegt!');
  329.   end;
  330.   WaitToGo;
  331. end; { TextPlay }
  332.  
  333. procedure TextDump;
  334. { Ausgabe aller definierten Zeichen }
  335. const
  336.   CGASizes  : array[0..4] of Word = (1, 3, 7, 3, 3);
  337.   NormSizes : array[0..4] of Word = (1, 4, 7, 4, 4);
  338. var
  339.   Font : Word;
  340.   ViewInfo : ViewPortType;
  341.   Ch : Char;
  342. begin
  343.   for Font := 0 to 4 do
  344.   begin
  345.     MainWindow('Zeichensatz: '+ Fonts[Font]);
  346.     GetViewSettings(ViewInfo);
  347.     with ViewInfo do
  348.     begin
  349.       SetTextJustify(LeftText, TopText);
  350.       MoveTo(2, 3);
  351.       if Font = DefaultFont then
  352.         begin
  353.           SetTextStyle(Font, HorizDir, 1);
  354.           Ch := #0;
  355.           repeat
  356.             OutText(Ch);
  357.             if (GetX + TextWidth('M')) > (x2-x1) then
  358.               MoveTo(2, GetY + TextHeight('M')+3);   { neue Zeile }
  359.             Ch := Succ(Ch);
  360.           until (Ch >= #255);
  361.         end
  362.       else
  363.         begin
  364.           if MaxY < 200 then
  365.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  366.           else
  367.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  368.           Ch := '!';
  369.           repeat
  370.             OutText(Ch);
  371.             if (GetX + TextWidth('M')) > (x2-x1) then
  372.               MoveTo(2, GetY + TextHeight('M')+3);
  373.             Ch := Succ(Ch);
  374.           until (Ord(Ch) = Ord('~')+1);
  375.         end;
  376.     end; { with }
  377.     WaitToGo;
  378.   end; { for }
  379. end; { TextDump }
  380.  
  381. procedure LineToPlay;
  382. { Demo für MoveTo und LineTo }
  383. const
  384.   MaxPoints = 15;
  385. var
  386.   Points     : array[0..MaxPoints] of PointType;
  387.   ViewInfo   : ViewPortType;
  388.   I, J       : Integer;
  389.   CenterX    : Integer;   { Kreismittelpunkt }
  390.   CenterY    : Integer;
  391.   Radius     : Word;
  392.   StepAngle  : Word;
  393.   Xasp, Yasp : Word;
  394.   Radians    : real;
  395.  
  396. function AdjAsp(Value : Integer) : Integer;
  397. { Anpassung an das Höhen-/Seitenverhältnis des Bildschirms }
  398. begin
  399.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  400. end;
  401.  
  402. begin
  403.   MainWindow('Demonstration von MoveTo und LineTo');
  404.   GetAspectRatio(Xasp, Yasp);
  405.   GetViewSettings(ViewInfo);
  406.   with ViewInfo do
  407.   begin
  408.     CenterX := (x2-x1) div 2;
  409.     CenterY := (y2-y1) div 2;
  410.     Radius := CenterY;
  411.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  412.       Inc(Radius);
  413.   end;
  414.   StepAngle := 360 div MaxPoints;
  415.   for I := 0 to MaxPoints - 1 do
  416.   begin
  417.     Radians := (StepAngle * I) * Pi / 180;
  418.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  419.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  420.   end;
  421.   Circle(CenterX, CenterY, Radius);
  422.   for I := 0 to MaxPoints - 1 do
  423.   begin
  424.     for J := I to MaxPoints - 1 do
  425.     begin
  426.       MoveTo(Points[I].X, Points[I].Y);
  427.       LineTo(Points[J].X, Points[J].Y);
  428.     end;
  429.   end;
  430.   WaitToGo;
  431. end;
  432.  
  433. procedure LineRelPlay;
  434. { Demo für MoveRel und LineRel }
  435. const
  436.   MaxPoints = 12;
  437. var
  438.   Poly     : array[1..MaxPoints] of PointType; { das zu füllende Polygon }
  439.   CurrPort : ViewPortType;
  440.  
  441. procedure DrawTesseract;  { lokal zu LineRelPlay }
  442. { Zeichnet einen Tesserakt mit relativen Bewegungen und hält den Umriß
  443.   dabei als zu füllendes Polygon fest. }
  444. const
  445.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  446. var
  447.   X, Y, W, H   : Integer;
  448.  
  449. begin
  450.   GetViewSettings(CurrPort);
  451.   with CurrPort do
  452.   begin
  453.     W := (x2-x1) div 9;
  454.     H := (y2-y1) div 8;
  455.     X := ((x2-x1) div 2) - round(2.5 * W);
  456.     Y := ((y2-y1) div 2) - (3 * H);
  457.  
  458.     { Der äußere Rand des Polygons ist das Zeichenfenster }
  459.     Poly[1].X := 0;     Poly[1].Y := 0;
  460.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  461.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  462.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  463.     Poly[5].X := 0;     Poly[5].Y := 0;
  464.     MoveTo(X, Y);
  465.  
  466.     { Der innere Rand wird während des Zeichnens festgehalten ... }
  467.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  468.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  469.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  470.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  471.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  472.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  473.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  474.  
  475.     { ... und danach mit dem benutzerdefinierten Muster gefüllt }
  476.     SetFillPattern(CheckerBoard, MaxColor);
  477.     FillPoly(12, Poly);
  478.  
  479.     MoveRel(W, -H);
  480.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  481.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  482.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  483.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  484.     LineRel(-W, 0);
  485.  
  486.     { Das Innere des Tesserakts wird mit FloodFill gefüllt }
  487.     FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor);
  488.   end;
  489. end; { DrawTesseract }
  490.  
  491. begin { LineRelPlay }
  492.   MainWindow('Demonstration von LineRel und MoveRel');
  493.   GetViewSettings(CurrPort);
  494.   with CurrPort do
  495.     { Zeichenfenster um jeweils ein Pixel verkleinern }
  496.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  497.   DrawTesseract;
  498.   WaitToGo;
  499. end; { LineRelPlay }
  500.  
  501. procedure PiePlay;
  502. { Demonstration von PieSlice and GetAspectRatio }
  503. var
  504.   ViewInfo   : ViewPortType;
  505.   CenterX    : Integer;
  506.   CenterY    : Integer;
  507.   Radius     : Word;
  508.   Xasp, Yasp : Word;
  509.   X, Y       : Integer;
  510.  
  511. function AdjAsp(Value : Integer) : Integer;
  512. { Anpassung an das Höhen-/Seitenverhältnis des Bildschirms }
  513. begin
  514.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  515. end; { AdjAsp }
  516.  
  517. procedure GetTextCoords(AngleInDegrees, Radius : Word; var X, Y : Integer);
  518. { Koordinaten für die Beschriftung }
  519. var
  520.   Radians : real;
  521. begin
  522.   Radians := AngleInDegrees * Pi / 180;
  523.   X := round(Cos(Radians) * Radius);
  524.   Y := round(Sin(Radians) * Radius);
  525. end; { GetTextCoords }
  526.  
  527. begin { PiePlay }
  528.   MainWindow('Demonstration von PieSlice / GetAspectRatio');
  529.   GetAspectRatio(Xasp, Yasp);
  530.   GetViewSettings(ViewInfo);
  531.   with ViewInfo do
  532.   begin
  533.     CenterX := (x2-x1) div 2;
  534.     CenterY := ((y2-y1) div 2) + 20;
  535.     Radius := (y2-y1) div 3;
  536.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  537.       Inc(Radius);
  538.   end;
  539.   SetTextStyle(TriplexFont, HorizDir, 4);
  540.   SetTextJustify(CenterText, TopText);
  541.   OutTextXY(CenterX, 0, 'Ein Kuchendiagramm!');
  542.  
  543.   SetTextStyle(TriplexFont, HorizDir, 3);
  544.  
  545.   SetFillStyle(SolidFill, RandColor);
  546.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  547.   GetTextCoords(45, Radius, X, Y);
  548.   SetTextJustify(LeftText, BottomText);
  549.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  550.  
  551.   SetFillStyle(HatchFill, RandColor);
  552.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  553.   GetTextCoords(293, Radius, X, Y);
  554.   SetTextJustify(LeftText, TopText);
  555.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  556.  
  557.   SetFillStyle(InterleaveFill, RandColor);
  558.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  559.   GetTextCoords(180, Radius, X, Y);
  560.   SetTextJustify(RightText, CenterText);
  561.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  562.  
  563.   SetFillStyle(WideDotFill, RandColor);
  564.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  565.   GetTextCoords(112, Radius, X, Y);
  566.   SetTextJustify(RightText, BottomText);
  567.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  568.  
  569.   WaitToGo;
  570. end; { PiePlay }
  571.  
  572. procedure Bar3DPlay;
  573. { Demo für Bar3D }
  574. const
  575.   NumBars   = 7;  { Anzahl der zu zeichnenden Balken }
  576.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  577.   YTicks    = 5;  { Einteilung der Y-Achse }
  578. var
  579.   ViewInfo : ViewPortType;
  580.   H        : Word;
  581.   XStep    : real;
  582.   YStep    : real;
  583.   I, J     : Integer;
  584.   Depth    : Word;
  585.   Color    : Word;
  586. begin
  587.   MainWindow('Demonstration von Bar3D / Rectangle');
  588.   H := 3*TextHeight('M');
  589.   GetViewSettings(ViewInfo);
  590.   SetTextJustify(CenterText, TopText);
  591.   SetTextStyle(TriplexFont, HorizDir, 4);
  592.   OutTextXY(MaxX div 2, 6, 'Dreidimensionale Balken!');
  593.   SetTextStyle(DefaultFont, HorizDir, 1);
  594.   with ViewInfo do
  595.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  596.   GetViewSettings(ViewInfo);
  597.   with ViewInfo do
  598.   begin
  599.     Line(H, H, H, (y2-y1)-H);
  600.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  601.     YStep := ((y2-y1)-(2*H)) / YTicks;
  602.     XStep := ((x2-x1)-(2*H)) / NumBars;
  603.     J := (y2-y1)-H;
  604.     SetTextJustify(CenterText, CenterText);
  605.  
  606.     { Zeichnen der Y-Achse und ihrer Einteilung }
  607.     for I := 0 to Yticks do
  608.     begin
  609.       Line(H div 2, J, H, J);
  610.       OutTextXY(0, J, Int2Str(I));
  611.       J := Round(J-Ystep);
  612.     end;
  613.  
  614.  
  615.     Depth := trunc(0.25 * XStep);    { Räumliche Tiefe eines Balkens }
  616.  
  617.     { X-Achse und die Balken }
  618.     SetTextJustify(CenterText, TopText);
  619.     J := H;
  620.     for I := 1 to Succ(NumBars) do
  621.     begin
  622.       SetColor(MaxColor);
  623.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  624.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  625.       if I <> Succ(NumBars) then
  626.       begin
  627.         Color := RandColor;
  628.         SetFillStyle(I, Color);
  629.         SetColor(Color);
  630.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  631.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  632.         J := Round(J+Xstep);
  633.       end;
  634.     end;
  635.  
  636.   end;
  637.   WaitToGo;
  638. end; { Bar3DPlay }
  639.  
  640. procedure BarPlay;
  641. { Demo für Bar }
  642. const
  643.   NumBars   = 5;
  644.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  645.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  646. var
  647.   ViewInfo  : ViewPortType;
  648.   BarNum    : Word;
  649.   H         : Word;
  650.   XStep     : real;
  651.   YStep     : real;
  652.   I, J      : Integer;
  653.   Color     : Word;
  654. begin
  655.   MainWindow('Demonstration von Bar / Rectangle');
  656.   H := 3*TextHeight('M');
  657.   GetViewSettings(ViewInfo);
  658.   SetTextJustify(CenterText, TopText);
  659.   SetTextStyle(TriplexFont, HorizDir, 4);
  660.   OutTextXY(MaxX div 2, 6, 'Zweidimensionale Balken...');
  661.   SetTextStyle(DefaultFont, HorizDir, 1);
  662.   with ViewInfo do
  663.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  664.   GetViewSettings(ViewInfo);
  665.   with ViewInfo do
  666.   begin
  667.     Line(H, H, H, (y2-y1)-H);
  668.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  669.     YStep := ((y2-y1)-(2*H)) / NumBars;
  670.     XStep := ((x2-x1)-(2*H)) / NumBars;
  671.     J := (y2-y1)-H;
  672.     SetTextJustify(CenterText, CenterText);
  673.  
  674.     { Zeichnen der Y-Achse und ihrer Einteilung }
  675.     for I := 0 to NumBars do
  676.     begin
  677.       Line(H div 2, J, H, J);
  678.       OutTextXY(0, J, Int2Str(i));
  679.       J := Round(J-Ystep);
  680.     end;
  681.  
  682.     { Die X-Achse und die Balken }
  683.     J := H;
  684.     SetTextJustify(CenterText, TopText);
  685.     for I := 1 to Succ(NumBars) do
  686.     begin
  687.       SetColor(MaxColor);
  688.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  689.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  690.       if I <> Succ(NumBars) then
  691.       begin
  692.         Color := RandColor;
  693.         SetFillStyle(Styles[I], Color);
  694.         SetColor(Color);
  695.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  696.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  697.       end;
  698.       J := Round(J+Xstep);
  699.     end;
  700.  
  701.   end;
  702.   WaitToGo;
  703. end;
  704.  
  705. procedure CirclePlay;
  706. { Zeichnet viele Kreise, deren Farbe, Mittelpunkt und Radius
  707.   durch den Zufallszahlengenerator bestimmt werden }
  708. var
  709.   MaxRadius : Word;
  710. begin
  711.   MainWindow('Circle-Demo');
  712.   StatusLine(GOAHEAD);
  713.   MaxRadius := MaxY div 10;
  714.   SetLineStyle(SolidLn, 0, NormWidth);
  715.   repeat
  716.     SetColor(RandColor);
  717.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  718.   until KeyPressed;
  719.   WaitToGo;
  720. end;
  721.  
  722. procedure RandBarPlay;
  723. { Zeichnet viele Balken, deren Farbe, Breite und Höhe
  724.   durch den Zufallszahlengenerator bestimmt werden }
  725. var
  726.   MaxWidth  : Integer;
  727.   MaxHeight : Integer;
  728.   ViewInfo  : ViewPortType;
  729.   Color     : Word;
  730. begin
  731.   MainWindow('Bar/Bar3D-Demo');
  732.   StatusLine(GOAHEAD);
  733.   GetViewSettings(ViewInfo);
  734.   with ViewInfo do
  735.   begin
  736.     MaxWidth := x2-x1;
  737.     MaxHeight := y2-y1;
  738.   end;
  739.   repeat
  740.     Color := RandColor;
  741.     SetColor(Color);
  742.     SetFillStyle(Random(CloseDotFill)+1, Color);
  743.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  744.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  745.   until KeyPressed;
  746.   WaitToGo;
  747. end;
  748.  
  749. procedure ArcPlay;
  750. { Zeichnet viele Kreisausschnitte, deren Parameter (Farbe, Mittelpunkt, Radius,
  751.   Start- und Endwinkel) durch den Zufallszahlengenerator bestimmt werden }
  752. var
  753.   MaxRadius : Word;
  754.   EndAngle : Word;
  755.   ArcInfo : ArcCoordsType;
  756. begin
  757.   MainWindow('Arc / GetArcCoords');
  758.   StatusLine(GOAHEAD);
  759.   MaxRadius := MaxY div 10;
  760.   repeat
  761.     SetColor(RandColor);
  762.     EndAngle := Random(360);
  763.     SetLineStyle(SolidLn, 0, NormWidth);
  764.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  765.     GetArcCoords(ArcInfo);
  766.     with ArcInfo do
  767.     begin
  768.       Line(X, Y, XStart, YStart);
  769.       Line(X, Y, Xend, Yend);
  770.     end;
  771.   until KeyPressed;
  772.   WaitToGo;
  773. end;
  774.  
  775. procedure PutPixelPlay;
  776. { Demo für PutPixel und GetPixel }
  777. const
  778.   Seed   = 1962; { Startwert für den Zufallszahlen-Generator }
  779.   Esc    = #27;
  780. var
  781.   NumPts      : Word;    { Anzahl der zu zeichnenden Pixel }
  782.   I, X, Y, Color : Word;
  783.   XMax, YMax  : Integer;
  784.   ViewInfo    : ViewPortType;
  785. begin
  786.   MainWindow('PutPixel / GetPixel');
  787.   StatusLine(GOAHEAD);
  788.  
  789.   GetViewSettings(ViewInfo);
  790.   with ViewInfo do
  791.   begin
  792.     XMax := (x2-x1-1);
  793.     YMax := (y2-y1-1);
  794.     NumPts := YMax * 20;
  795.   end;
  796.  
  797.   while not KeyPressed do
  798.   begin
  799.     { Zeichnen "zufälliger" Pixel }
  800.     RandSeed := Seed;
  801.     I := 0;
  802.     while (not KeyPressed) and (I < NumPts) do
  803.     begin
  804.       Inc(I);
  805.       PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
  806.     end;
  807.  
  808.     { Zufallsgenerator wieder auf denselben Startwert setzen }
  809.     RandSeed := Seed;
  810.     I := 0;
  811.     while (not KeyPressed) and (I < NumPts) do
  812.     begin
  813.       Inc(I);
  814.       X := Random(XMax)+1;
  815.       Y := Random(YMax)+1;
  816.       Color := GetPixel(X, Y);
  817.       if Color = RandColor then PutPixel(X, Y, 0);  { und Löschen }
  818.     end;
  819.     Delay(500);
  820.   end;
  821.   WaitToGo;
  822. end;
  823.  
  824. procedure PutImagePlay;
  825. { Demo für GetImage und PutImage }
  826.  
  827. const
  828.   r  = 20;
  829.   StartX = 100;
  830.   StartY = 50;
  831.  
  832. var
  833.   CurPort : ViewPortType;
  834.  
  835. procedure MoveSaucer(var X, Y : Integer; Width, Height : Integer);
  836. { Bewegt die fliegende Untertasse }
  837. var
  838.   Step : Integer;
  839. begin
  840.   Step := Random(2*r);
  841.   if Odd(Step) then Step := -Step;
  842.   X := X + Step;
  843.   Step := Random(r);
  844.   if Odd(Step) then Step := -Step;
  845.   Y := Y + Step;
  846.  
  847.   { Das UFO wird von den Grenzen des Zeichenfensters "reflektiert" }
  848.   with CurPort do
  849.   begin
  850.     if (x1 + X + Width - 1 > x2) then X := x2-x1 - Width + 1
  851.      else if (X < 0) then X := 0;
  852.     if (y1 + Y + Height - 1 > y2) then Y := y2-y1 - Height + 1
  853.      else if (Y < 0) then Y := 0;
  854.   end;
  855. end; { MoveSaucer }
  856.  
  857. var                   { PutImagePlay }
  858.   Pausetime : Word;
  859.   Saucer    : Pointer;
  860.   X, Y      : Integer;
  861.   ulx, uly  : Word;
  862.   lrx, lry  : Word;
  863.   Size      : Word;
  864.   I         : Word;
  865. begin
  866.   ClearDevice;  { Bildschirm löschen }
  867.   MainWindow('GetImage / PutImage');
  868.   StatusLine(GOAHEAD);
  869.   GetViewSettings(CurPort);
  870.  
  871.   { UFO zeichnen }
  872.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  873.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  874.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  875.   Circle(StartX+10, StartY-12, 2);
  876.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  877.   Circle(StartX-10, StartY-12, 2);
  878.   SetFillStyle(SolidFill, MaxColor);
  879.   FloodFill(StartX+1, StartY+4, GetColor);
  880.  
  881.   { UFO "einfangen" }
  882.   ulx := StartX-(r+1);
  883.   uly := StartY-14;
  884.   lrx := StartX+(r+1);
  885.   lry := StartY+(r div 3)+3;
  886.  
  887.   Size := ImageSize(ulx, uly, lrx, lry);
  888.   GetMem(Saucer, Size);
  889.   GetImage(ulx, uly, lrx, lry, Saucer^);
  890.   PutImage(ulx, uly, Saucer^, XORput);               { und mit XOR löschen }
  891.  
  892.   { Hintergrund zeichnen (ein Sternenhimmel) }
  893.   for I := 1 to 1000 do
  894.     PutPixel(Random(MaxX), Random(MaxY), RandColor);
  895.   X := MaxX div 2;
  896.   Y := MaxY div 2;
  897.   PauseTime := 70;
  898.  
  899.   { und das UFO in diesem Bild bewegen }
  900.   repeat
  901.     PutImage(X, Y, Saucer^, XORput);                 { Zeichnen mit XOR }
  902.     Delay(PauseTime);
  903.     PutImage(X, Y, Saucer^, XORput);                 { Löschen mit XOR }
  904.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { Breite/Höhe }
  905.   until KeyPressed;
  906.   FreeMem(Saucer, size);
  907.   WaitToGo;
  908. end; { PutImagePlay }
  909.  
  910. procedure PolyPlay;
  911. { zeichnet viele Polygone, deren Farbe, Größe und Eckpunkte durch
  912.   den Zufallszahlen-Generator festgelegt werden }
  913. const
  914.   MaxPts = 5;
  915. type
  916.   PolygonType = array[1..MaxPts] of PointType;
  917. var
  918.   Poly : PolygonType;
  919.   I, Color : Word;
  920. begin
  921.   MainWindow('Demonstration von FillPoly');
  922.   StatusLine(GOAHEAD);
  923.   repeat
  924.     Color := RandColor;
  925.     SetFillStyle(Random(11)+1, Color);
  926.     SetColor(Color);
  927.     for I := 1 to MaxPts do
  928.       with Poly[I] do
  929.       begin
  930.         X := Random(MaxX);
  931.         Y := Random(MaxY);
  932.       end;
  933.     FillPoly(MaxPts, Poly);
  934.   until KeyPressed;
  935.   WaitToGo;
  936. end;
  937.  
  938. procedure FillStylePlay;
  939. { Demo der vordefinierten Füll-Muster }
  940. var
  941.   Style    : Word;
  942.   Width    : Word;
  943.   Height   : Word;
  944.   X, Y     : Word;
  945.   I, J     : Word;
  946.   ViewInfo : ViewPortType;
  947.  
  948. procedure DrawBox(X, Y : Word);   { Zeichnet ein gefülltes Rechteck }
  949. begin
  950.   SetFillStyle(Style, MaxColor);
  951.   with ViewInfo do
  952.     Bar(X, Y, X+Width, Y+Height);
  953.   Rectangle(X, Y, X+Width, Y+Height);
  954.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  955.   Inc(Style);
  956. end;
  957.  
  958. begin
  959.   MainWindow('Vordefinierte Füll-Muster');
  960.   GetViewSettings(ViewInfo);
  961.   with ViewInfo do
  962.   begin
  963.     Width := 2 * ((x2+1) div 13);
  964.     Height := 2 * ((y2-10) div 10);
  965.   end;
  966.   X := Width div 2;
  967.   Y := Height div 2;
  968.   Style := 0;
  969.   for J := 1 to 3 do
  970.   begin
  971.     for I := 1 to 4 do
  972.     begin
  973.       DrawBox(X, Y);
  974.       Inc(X, (Width div 2) * 3);
  975.     end;
  976.     X := Width div 2;
  977.     Inc(Y, (Height div 2) * 3);
  978.   end;
  979.   SetTextJustify(LeftText, TopText);
  980.   WaitToGo;
  981. end;
  982.  
  983. procedure FillPatternPlay;
  984. { Zeigt einige benutzerdefinierte Füll-Muster }
  985. const
  986.   Patterns : array[0..11] of FillPatternType = (
  987.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  988.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  989.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  990.   (0, $10, $28, $44, $28, $10, 0, 0),
  991.   (0, $70, $20, $27, $25, $27, $4, $4),
  992.   (0, 0, 0, $18, $18, 0, 0, 0),
  993.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  994.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  995.   (0, 0, $22, $8, 0, $22, $1C, 0),
  996.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  997.   (0, $10, $10, $7C, $10, $10, 0, 0),
  998.   (0, $42, $24, $18, $18, $24, $42, 0));
  999. var
  1000.   Style    : Word;
  1001.   Width    : Word;
  1002.   Height   : Word;
  1003.   X, Y     : Word;
  1004.   I, J     : Word;
  1005.   ViewInfo : ViewPortType;
  1006.  
  1007. procedure DrawBox(X, Y : Word);
  1008. begin
  1009.   SetFillPattern(Patterns[Style], MaxColor);
  1010.   with ViewInfo do
  1011.     Bar(X, Y, X+Width, Y+Height);
  1012.   Rectangle(X, Y, X+Width, Y+Height);
  1013.   Inc(Style);
  1014. end; { DrawBox }
  1015.  
  1016. begin
  1017.   MainWindow('Benutzerdefinierte Füll-Muster');
  1018.   GetViewSettings(ViewInfo);
  1019.   with ViewInfo do
  1020.   begin
  1021.     Width := 2 * ((x2+1) div 13);
  1022.     Height := 2 * ((y2-10) div 10);
  1023.   end;
  1024.   X := Width div 2;
  1025.   Y := Height div 2;
  1026.   Style := 0;
  1027.   for J := 1 to 3 do
  1028.   begin
  1029.     for I := 1 to 4 do
  1030.     begin
  1031.       DrawBox(X, Y);
  1032.       Inc(X, (Width div 2) * 3);
  1033.     end;
  1034.     X := Width div 2;
  1035.     Inc(Y, (Height div 2) * 3);
  1036.   end;
  1037.   SetTextJustify(LeftText, TopText);
  1038.   WaitToGo;
  1039. end; { FillPatternPlay }
  1040.  
  1041. procedure ColorPlay;
  1042. { Zeigt alle verfügbaren Farben für den verwendeten Treiber und Grafikmodus }
  1043. var
  1044.   Color    : Word;
  1045.   Width    : Word;
  1046.   Height   : Word;
  1047.   X, Y     : Word;
  1048.   I, J     : Word;
  1049.   ViewInfo : ViewPortType;
  1050.  
  1051. procedure DrawBox(X, Y : Word);
  1052. begin
  1053.   SetFillStyle(SolidFill, Color);
  1054.   SetColor(Color);
  1055.   with ViewInfo do
  1056.     Bar(X, Y, X+Width, Y+Height);
  1057.   Rectangle(X, Y, X+Width, Y+Height);
  1058.   Color := GetColor;
  1059.   if Color = 0 then
  1060.   begin
  1061.     SetColor(MaxColor);
  1062.     Rectangle(X, Y, X+Width, Y+Height);
  1063.   end;
  1064.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Color));
  1065.   Color := Succ(Color) mod (MaxColor + 1);
  1066. end; { DrawBox }
  1067.  
  1068. begin
  1069.   MainWindow('Verfügbare Zeichenfarben');
  1070.   Color := 1;
  1071.   GetViewSettings(ViewInfo);
  1072.   with ViewInfo do
  1073.   begin
  1074.     Width := 2 * ((x2+1) div 16);
  1075.     Height := 2 * ((y2-10) div 10);
  1076.   end;
  1077.   X := Width div 2;
  1078.   Y := Height div 2;
  1079.   for J := 1 to 3 do
  1080.   begin
  1081.     for I := 1 to 5 do
  1082.     begin
  1083.       DrawBox(X, Y);
  1084.       Inc(X, (Width div 2) * 3);
  1085.     end;
  1086.     X := Width div 2;
  1087.     Inc(Y, (Height div 2) * 3);
  1088.   end;
  1089.   WaitToGo;
  1090. end; { ColorPlay }
  1091.  
  1092. procedure PalettePlay;
  1093. { Demo für die Verwendung von SetPalette }
  1094. const
  1095.   XBars = 15;
  1096.   YBars = 10;
  1097. var
  1098.   I, J     : Word;
  1099.   X, Y     : Word;
  1100.   Color    : Word;
  1101.   ViewInfo : ViewPortType;
  1102.   Width    : Word;
  1103.   Height   : Word;
  1104.   OldPal   : PaletteType;
  1105. begin
  1106.   GetPalette(OldPal);
  1107.   MainWindow('Über Farb-Paletten und ihre Möglichkeiten...');
  1108.   StatusLine(GOAHEAD);
  1109.   GetViewSettings(ViewInfo);
  1110.   with ViewInfo do
  1111.   begin
  1112.     Width := (x2-x1) div XBars;
  1113.     Height := (y2-y1) div YBars;
  1114.   end;
  1115.   X := 0; Y := 0;
  1116.   Color := 0;
  1117.   for J := 1 to YBars do           { Füllt den Bildschirm mit Quadraten }
  1118.   begin
  1119.     for I := 1 to XBars do
  1120.     begin
  1121.       SetFillStyle(SolidFill, Color);
  1122.       Bar(X, Y, X+Width, Y+Height);
  1123.       Inc(X, Width+1);
  1124.       Inc(Color);
  1125.       Color := Color mod (MaxColor+1);
  1126.     end;
  1127.     X := 0;
  1128.     Inc(Y, Height+1);
  1129.   end;
  1130.   repeat        { zufälliger Wechsel der Farben }
  1131.     SetPalette(Random(GetMaxColor + 1), Random(65));
  1132.   until KeyPressed;
  1133.   SetAllPalette(OldPal);
  1134.   WaitToGo;
  1135. end;
  1136.  
  1137. procedure CrtModePlay;
  1138. { Demo für die Umschaltung mit RestoreCrtMode und SetGraphMode }
  1139. var
  1140.   ViewInfo : ViewPortType;
  1141.   Ch       : Char;
  1142. begin
  1143.   MainWindow('Demo für SetGraphMode und RestoreCrtMode');
  1144.   GetViewSettings(ViewInfo);
  1145.   SetTextJustify(CenterText, CenterText);
  1146.   with ViewInfo do
  1147.   begin
  1148.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Wir sind im Grafikmodus');
  1149.     StatusLine('Weiter mit einem beliebigen Tastendruck...');
  1150.     repeat until KeyPressed;
  1151.     Ch := ReadKey;
  1152.     RestoreCrtmode;
  1153.     Writeln('Jetzt sind wir im Textmodus...');
  1154.     Write('Zurück zur Grafik mit einem beliebigen Tastendruck...');
  1155.     repeat until KeyPressed;
  1156.     Ch := ReadKey;
  1157.     SetGraphMode(GetGraphMode);
  1158.     MainWindow('Demo für SetGraphMode und RestoreCrtMode');
  1159.     SetTextJustify(CenterText, CenterText);
  1160.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, '... und wieder in der Grafik!');
  1161.   end;
  1162.   WaitToGo;
  1163. end;
  1164.  
  1165. procedure LineStylePlay;
  1166. { Demo der vordefinierten Linienarten }
  1167. var
  1168.   Style    : Word;
  1169.   Step     : Word;
  1170.   X, Y     : Word;
  1171.   ViewInfo : ViewPortType;
  1172.  
  1173. begin
  1174.   ClearDevice;
  1175.   DefaultColors;
  1176.   MainWindow('Vordefinierte Linienarten und -Konstanten');
  1177.   GetViewSettings(ViewInfo);
  1178.   with ViewInfo do
  1179.   begin
  1180.     X := 35;
  1181.     Y := 10;
  1182.     Step := (x2-x1) div 11;
  1183.     SetTextJustify(LeftText, TopText);
  1184.     OutTextXY(X, Y, 'NormWidth');
  1185.     SetTextJustify(CenterText, TopText);
  1186.     for Style := 0 to 3 do
  1187.     begin
  1188.       SetLineStyle(Style, 0, NormWidth);
  1189.       Line(X, Y+20, X, Y2-40);
  1190.       OutTextXY(X, Y2-30, Int2Str(Style));
  1191.       Inc(X, Step);
  1192.     end;
  1193.     Inc(X, 2*Step);
  1194.     SetTextJustify(LeftText, TopText);
  1195.     OutTextXY(X, Y, 'ThickWidth');
  1196.     SetTextJustify(CenterText, TopText);
  1197.     for Style := 0 to 3 do
  1198.     begin
  1199.       SetLineStyle(Style, 0, ThickWidth);
  1200.       Line(X, Y+20, X, Y2-40);
  1201.       OutTextXY(X, Y2-30, Int2Str(Style));
  1202.       Inc(X, Step);
  1203.     end;
  1204.   end;
  1205.   SetTextJustify(LeftText, TopText);
  1206.   WaitToGo;
  1207. end;
  1208.  
  1209. procedure UserLineStylePlay;
  1210. { Benutzerdefinierte Linienarten }
  1211. var
  1212.   Style    : Word;
  1213.   X, Y, I  : Word;
  1214.   ViewInfo : ViewPortType;
  1215. begin
  1216.   MainWindow('Eine benutzerdefinierte Linienart');
  1217.   GetViewSettings(ViewInfo);
  1218.   with ViewInfo do
  1219.   begin
  1220.     X := 4;
  1221.     Y := 10;
  1222.     Style := 0;
  1223.     I := 0;
  1224.     while X < X2-4 do
  1225.     begin
  1226.       Style := Style or (1 shl (I mod 16));
  1227.       SetLineStyle(UserBitLn, Style, NormWidth);
  1228.       Line(X, Y, X, (y2-y1)-Y);
  1229.       Inc(X, 5);
  1230.       Inc(I);
  1231.       if Style = 65535 then
  1232.       begin
  1233.         I := 0;
  1234.         Style := 0;
  1235.       end;
  1236.     end;
  1237.   end;
  1238.   WaitToGo;
  1239. end;
  1240.  
  1241. procedure SayGoodbye;
  1242. { Verabschiedet sich artig und beendet das Programm }
  1243. var
  1244.   ViewInfo : ViewPortType;
  1245.   Ch: Char;
  1246. begin
  1247.   MainWindow('');
  1248.   GetViewSettings(ViewInfo);
  1249.   SetTextStyle(TriplexFont, HorizDir, 4);
  1250.   SetTextJustify(CenterText, CenterText);
  1251.   with ViewInfo do
  1252.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Das war''s!');
  1253.   StatusLine('Aus und vorbei mit einem beliebigen Tastendruck...');
  1254.   repeat until KeyPressed;
  1255.   Ch:= ReadKey;
  1256. end; { SayGoodbye }
  1257.  
  1258. { *********************************************************** }
  1259. { *********************************************************** }
  1260. begin { Hauptprogramm }
  1261.   Initialize;
  1262.   ReportStatus;
  1263.   ColorPlay;
  1264.   { PalettePlay ist nur für die folgenden Treiber gedacht (bzw. auf
  1265.     monochromen Video-Adaptern nicht sonderlich eindrucksvoll): }
  1266.   if (GraphDriver = EGA) or (GraphDriver = EGA64) or (GraphDriver = VGA) then
  1267.         PalettePlay;
  1268.   PutPixelPlay;
  1269.   PutImagePlay;
  1270.   RandBarPlay;
  1271.   BarPlay;
  1272.   Bar3DPlay;
  1273.   ArcPlay;
  1274.   CirclePlay;
  1275.   PiePlay;
  1276.   LineToPlay;
  1277.   LineRelPlay;
  1278.   LineStylePlay;
  1279.   UserLineStylePlay;
  1280.   TextDump;
  1281.   TextPlay;
  1282.   CrtModePlay;
  1283.   FillStylePlay;
  1284.   FillPatternPlay;
  1285.   PolyPlay;
  1286.   SayGoodbye;
  1287.      { CloseGraph wird über die zu Anfang des Programms installierte
  1288.        Exit-Prozedur aufgerufen }
  1289. end.
  1290.