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