home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / turbo5 / arty.pas next >
Pascal/Delphi Source File  |  1988-10-09  |  9KB  |  382 lines
  1.  
  2. { Copyright (c) 1985, 88 by Borland International, Inc. }
  3.  
  4. program Arty;
  5. { This program is a demonstration of the Borland Graphics Interface
  6.   (BGI) provided with Turbo Pascal 5.0.
  7.  
  8.   To run this program you will need the following files:
  9.  
  10.     TURBO.EXE (or TPC.EXE)
  11.     TURBO.TPL - The standard units
  12.     GRAPH.TPU - The Graphics unit
  13.     *.BGI     - The graphics device drivers
  14.  
  15.   Runtime Commands for ARTY
  16.   -------------------------
  17.   <B>   - changes background color
  18.   <C>   - changes drawcolor
  19.   <ESC> - exits program
  20.   Any other key pauses, then regenerates the drawing
  21.  
  22.   Note: If a /H command-line parameter is specified, the highest
  23.         resolution mode will be used (if possible).
  24. }
  25.  
  26. uses
  27.   Crt, Graph;
  28.  
  29. const
  30.    Memory  = 100;
  31.    Windows =   4;
  32.  
  33. type
  34.   ResolutionPreference = (Lower, Higher);
  35.   ColorList = array [1..Windows] of integer;
  36.  
  37. var
  38.   Xmax,
  39.   Ymax,
  40.   ViewXmax,
  41.   ViewYmax : integer;
  42.  
  43.   Line:  array [1..Memory] of record
  44.                                 LX1,LY1: integer;
  45.                                 LX2,LY2: integer;
  46.                                 LColor : ColorList;
  47.                               end;
  48.   X1,X2,Y1,Y2,
  49.   CurrentLine,
  50.   ColorCount,
  51.   IncrementCount,
  52.   DeltaX1,DeltaY1,DeltaX2,DeltaY2: integer;
  53.   Colors: ColorList;
  54.   Ch: char;
  55.   BackColor:integer;
  56.   GraphDriver, GraphMode : integer;
  57.   MaxColors : word;
  58.   MaxDelta : integer;
  59.   ChangeColors: Boolean;
  60.  
  61. procedure Frame;
  62. begin
  63.   SetViewPort(0, 0, Xmax, Ymax-(TextHeight('M')+4)-1,ClipOn);
  64.   SetColor(MaxColors);
  65.   Rectangle(0, 0, Xmax-1, (Ymax-(TextHeight('M')+4)-1)-1);
  66.   SetViewPort(1, 1, Xmax-2, (Ymax-(TextHeight('M')+4)-1)-2,ClipOn);
  67. end  { Frame };
  68.  
  69. procedure FullPort;
  70. { Set the view port to the entire screen }
  71. begin
  72.   SetViewPort(0, 0, Xmax, Ymax, ClipOn);
  73. end; { FullPort }
  74.  
  75. procedure MessageFrame(Msg:string);
  76. begin
  77.   FullPort;
  78.   SetColor(MaxColors);
  79.   SetTextStyle(DefaultFont, HorizDir, 1);
  80.   SetTextJustify(CenterText, TopText);
  81.   SetLineStyle(SolidLn, 0, NormWidth);
  82.   SetFillStyle(EmptyFill, 0);
  83.   Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
  84.   Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
  85.   OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
  86.   { Go back to the main window }
  87.   Frame;
  88. end  { MessageFrame };
  89.  
  90. procedure WaitToGo;
  91. var
  92.   Ch : char;
  93. begin
  94.   MessageFrame('Press any key to continue... Esc aborts');
  95.   repeat until KeyPressed;
  96.   Ch := ReadKey;
  97.   if Ch = #27 then begin
  98.       CloseGraph;
  99.       Writeln('All done.');
  100.       Halt(1);
  101.     end
  102.   else
  103.     ClearViewPort;
  104.   MessageFrame('Press a key to stop action, Esc quits.');
  105. end; { WaitToGo }
  106.  
  107. procedure TestGraphError(GraphErr: integer);
  108. begin
  109.   if GraphErr <> grOk then begin
  110.     Writeln('Graphics error: ', GraphErrorMsg(GraphErr));
  111.     repeat until keypressed;
  112.     ch := readkey;
  113.     Halt(1);
  114.   end;
  115. end;
  116.  
  117. procedure Init;
  118. var
  119.   Err, I: integer;
  120.   StartX, StartY: integer;
  121.   Resolution: ResolutionPreference;
  122.   s: string;
  123. begin
  124.   Resolution := Lower;
  125.   if paramcount > 0 then begin
  126.     s := paramstr(1);
  127.     if s[1] = '/' then
  128.       if upcase(s[2]) = 'H' then
  129.         Resolution := Higher;
  130.   end;
  131.  
  132.   CurrentLine    := 1;
  133.   ColorCount     := 0;
  134.   IncrementCount := 0;
  135.   Ch := ' ';
  136.   GraphDriver := Detect;
  137.   DetectGraph(GraphDriver, GraphMode);
  138.   TestGraphError(GraphResult);
  139.   case GraphDriver of
  140.     CGA        : begin
  141.                    MaxDelta := 7;
  142.                    GraphDriver := CGA;
  143.                    GraphMode := CGAC1;
  144.                  end;
  145.  
  146.     MCGA       : begin
  147.                    MaxDelta := 7;
  148.                    case GraphMode of
  149.                      MCGAMed, MCGAHi: GraphMode := MCGAC1;
  150.                    end;
  151.                  end;
  152.  
  153.     EGA         : begin
  154.                     MaxDelta := 16;
  155.                     If Resolution = Lower then
  156.                       GraphMode := EGALo
  157.                     else
  158.                       GraphMode := EGAHi;
  159.                   end;
  160.  
  161.     EGA64       : begin
  162.                     MaxDelta := 16;
  163.                     If Resolution = Lower then
  164.                       GraphMode := EGA64Lo
  165.                     else
  166.                       GraphMode := EGA64Hi;
  167.                   end;
  168.  
  169.      HercMono   : MaxDelta := 16;
  170.      EGAMono    : MaxDelta := 16;
  171.      PC3270     : begin
  172.                    MaxDelta := 7;
  173.                    GraphDriver := CGA;
  174.                    GraphMode := CGAC1;
  175.                  end;
  176.  
  177.  
  178.      ATT400     : case GraphMode of
  179.                     ATT400C1,
  180.                     ATT400C2,
  181.                     ATT400Med,
  182.                     ATT400Hi  :
  183.                       begin
  184.                         MaxDelta := 7;
  185.                         GraphMode := ATT400C1;
  186.                       end;
  187.                   end;
  188.  
  189.      VGA         : begin
  190.                      MaxDelta := 16;
  191.                    end;
  192.   end;
  193.   InitGraph(GraphDriver, GraphMode, '');
  194.   TestGraphError(GraphResult);
  195.   SetTextStyle(DefaultFont, HorizDir, 1);
  196.   SetTextJustify(CenterText, TopText);
  197.  
  198.   MaxColors := GetMaxColor;
  199.   BackColor := 0;
  200.   ChangeColors := TRUE;
  201.   Xmax := GetMaxX;
  202.   Ymax := GetMaxY;
  203.   ViewXmax := Xmax-2;
  204.   ViewYmax := (Ymax-(TextHeight('M')+4)-1)-2;
  205.   StartX := Xmax div 2;
  206.   StartY := Ymax div 2;
  207.   for I := 1 to Memory do with Line[I] do begin
  208.       LX1 := StartX; LX2 := StartX;
  209.       LY1 := StartY; LY2 := StartY;
  210.     end;
  211.  
  212.    X1 := StartX;
  213.    X2 := StartX;
  214.    Y1 := StartY;
  215.    Y2 := StartY;
  216. end; {init}
  217.  
  218. procedure AdjustX(var X,DeltaX: integer);
  219. var
  220.   TestX: integer;
  221. begin
  222.   TestX := X+DeltaX;
  223.   if (TestX<1) or (TestX>ViewXmax) then begin
  224.     TestX := X;
  225.     DeltaX := -DeltaX;
  226.   end;
  227.   X := TestX;
  228. end;
  229.  
  230. procedure AdjustY(var Y,DeltaY: integer);
  231. var
  232.   TestY: integer;
  233. begin
  234.   TestY := Y+DeltaY;
  235.   if (TestY<1) or (TestY>ViewYmax) then begin
  236.     TestY := Y;
  237.     DeltaY := -DeltaY;
  238.   end;
  239.   Y := TestY;
  240. end;
  241.  
  242. procedure SelectNewColors;
  243. begin
  244.   if not ChangeColors then exit;
  245.   Colors[1] := Random(MaxColors)+1;
  246.   Colors[2] := Random(MaxColors)+1;
  247.   Colors[3] := Random(MaxColors)+1;
  248.   Colors[4] := Random(MaxColors)+1;
  249.   ColorCount := 3*(1+Random(5));
  250. end;
  251.  
  252. procedure SelectNewDeltaValues;
  253. begin
  254.   DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
  255.   DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
  256.   DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
  257.   DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
  258.   IncrementCount := 2*(1+Random(4));
  259. end;
  260.  
  261.  
  262. procedure SaveCurrentLine(CurrentColors: ColorList);
  263. begin
  264.   with Line[CurrentLine] do
  265.   begin
  266.     LX1 := X1;
  267.     LY1 := Y1;
  268.     LX2 := X2;
  269.     LY2 := Y2;
  270.     LColor := CurrentColors;
  271.   end;
  272. end;
  273.  
  274. procedure Draw(x1,y1,x2,y2,color:word);
  275. begin
  276.   SetColor(color);
  277.   Graph.Line(x1,y1,x2,y2);
  278. end;
  279.  
  280. procedure Regenerate;
  281. var
  282.   I: integer;
  283. begin
  284.   Frame;
  285.   for I := 1 to Memory do with Line[I] do begin
  286.     Draw(LX1,LY1,LX2,LY2,LColor[1]);
  287.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,LColor[2]);
  288.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,LColor[3]);
  289.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,LColor[4]);
  290.   end;
  291.   WaitToGo;
  292.   Frame;
  293. end;
  294.  
  295. procedure Updateline;
  296. begin
  297.   Inc(CurrentLine);
  298.   if CurrentLine > Memory then CurrentLine := 1;
  299.   Dec(ColorCount);
  300.   Dec(IncrementCount);
  301. end;
  302.  
  303. procedure CheckForUserInput;
  304. begin
  305.   if KeyPressed then begin
  306.     Ch := ReadKey;
  307.     if Upcase(Ch) = 'B' then begin
  308.       if BackColor > MaxColors then BackColor := 0 else Inc(BackColor);
  309.       SetBkColor(BackColor);
  310.     end
  311.     else
  312.     if Upcase(Ch) = 'C' then begin
  313.       if ChangeColors then ChangeColors := FALSE else ChangeColors := TRUE;
  314.       ColorCount := 0;
  315.     end
  316.     else if Ch<>#27 then Regenerate;
  317.   end;
  318. end;
  319.  
  320. procedure DrawCurrentLine;
  321. var c1,c2,c3,c4: integer;
  322. begin
  323.   c1 := Colors[1];
  324.   c2 := Colors[2];
  325.   c3 := Colors[3];
  326.   c4 := Colors[4];
  327.   if MaxColors = 1 then begin
  328.     c2 := c1; c3 := c1; c4 := c1;
  329.   end;
  330.  
  331.   Draw(X1,Y1,X2,Y2,c1);
  332.   Draw(ViewXmax-X1,Y1,ViewXmax-X2,Y2,c2);
  333.   Draw(X1,ViewYmax-Y1,X2,ViewYmax-Y2,c3);
  334.   if MaxColors = 3 then c4 := Random(3)+1; { alternate colors }
  335.   Draw(ViewXmax-X1,ViewYmax-Y1,ViewXmax-X2,ViewYmax-Y2,c4);
  336.   SaveCurrentLine(Colors);
  337. end;
  338.  
  339. procedure EraseCurrentLine;
  340. begin
  341.   with Line[CurrentLine] do begin
  342.     Draw(LX1,LY1,LX2,LY2,0);
  343.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,0);
  344.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,0);
  345.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,0);
  346.   end;
  347. end;
  348.  
  349.  
  350. procedure DoArt;
  351. begin
  352.   SelectNewColors;
  353.   repeat
  354.     EraseCurrentLine;
  355.     if ColorCount = 0 then SelectNewColors;
  356.  
  357.     if IncrementCount=0 then SelectNewDeltaValues;
  358.  
  359.     AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
  360.     AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
  361.  
  362.     if Random(5)=3 then begin
  363.       x1 := (x1+x2) div 2; { shorten the lines }
  364.       y2 := (y1+y2) div 2;
  365.     end;
  366.  
  367.     DrawCurrentLine;
  368.     Updateline;
  369.     CheckForUserInput;
  370.   until Ch=#27;
  371. end;
  372.  
  373. begin
  374.    Init;
  375.    Frame;
  376.    MessageFrame('Press a key to stop action, Esc quits.');
  377.    DoArt;
  378.    CloseGraph;
  379.    RestoreCrtMode;
  380.    Writeln('The End.');
  381. end.
  382.