home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l043 / 3.ddi / ARTY4.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-15  |  9.1 KB  |  387 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.     RESERVED,
  145.     CGA        : begin
  146.                    MaxDelta := 7;
  147.                    GraphDriver := CGA;
  148.                    GraphMode := CGAC1;
  149.                  end;
  150.  
  151.     MCGA       : begin
  152.                    MaxDelta := 7;
  153.                    case GraphMode of
  154.                      MCGAMed, MCGAHi: GraphMode := MCGAC1;
  155.                    end;
  156.                  end;
  157.  
  158.     EGA         : begin
  159.                     MaxDelta := 16;
  160.                     If Resolution = Lower then
  161.                       GraphMode := EGALo
  162.                     else
  163.                       GraphMode := EGAHi;
  164.                   end;
  165.  
  166.     EGA64       : begin
  167.                     MaxDelta := 16;
  168.                     If Resolution = Lower then
  169.                       GraphMode := EGA64Lo
  170.                     else
  171.                       GraphMode := EGA64Hi;
  172.                   end;
  173.  
  174.      HercMono   : MaxDelta := 16;
  175.      EGAMono    : MaxDelta := 16;
  176.      PC3270     : begin
  177.                    MaxDelta := 7;
  178.                    GraphDriver := CGA;
  179.                    GraphMode := CGAC1;
  180.                  end;
  181.  
  182.  
  183.      ATT400     : case GraphMode of
  184.                     ATT400C1,
  185.                     ATT400C2,
  186.                     ATT400Med,
  187.                     ATT400Hi  :
  188.                       begin
  189.                         MaxDelta := 7;
  190.                         GraphMode := ATT400C1;
  191.                       end;
  192.                   end;
  193.  
  194.      VGA         : begin
  195.                      MaxDelta := 16;
  196.                    end;
  197.   end;
  198.   InitGraph(GraphDriver, GraphMode, '');
  199.   TestGraphError(GraphResult);
  200.   SetTextStyle(DefaultFont, HorizDir, 1);
  201.   SetTextJustify(CenterText, TopText);
  202.  
  203.   MaxColors := GetMaxColor;
  204.   BackColor := 0;
  205.   ChangeColors := TRUE;
  206.   Xmax := GetMaxX;
  207.   Ymax := GetMaxY;
  208.   ViewXmax := Xmax-2;
  209.   ViewYmax := (Ymax-(TextHeight('M')+4)-1)-2;
  210.   StartX := Xmax div 2;
  211.   StartY := Ymax div 2;
  212.   for I := 1 to Memory do with Line[I] do begin
  213.       LX1 := StartX; LX2 := StartX;
  214.       LY1 := StartY; LY2 := StartY;
  215.     end;
  216.  
  217.    X1 := StartX;
  218.    X2 := StartX;
  219.    Y1 := StartY;
  220.    Y2 := StartY;
  221. end; {init}
  222.  
  223. procedure AdjustX(var X,DeltaX: integer);
  224. var
  225.   TestX: integer;
  226. begin
  227.   TestX := X+DeltaX;
  228.   if (TestX<1) or (TestX>ViewXmax) then begin
  229.     TestX := X;
  230.     DeltaX := -DeltaX;
  231.   end;
  232.   X := TestX;
  233. end;
  234.  
  235. procedure AdjustY(var Y,DeltaY: integer);
  236. var
  237.   TestY: integer;
  238. begin
  239.   TestY := Y+DeltaY;
  240.   if (TestY<1) or (TestY>ViewYmax) then begin
  241.     TestY := Y;
  242.     DeltaY := -DeltaY;
  243.   end;
  244.   Y := TestY;
  245. end;
  246.  
  247. procedure SelectNewColors;
  248. begin
  249.   if not ChangeColors then exit;
  250.   Colors[1] := Random(MaxColors)+1;
  251.   Colors[2] := Random(MaxColors)+1;
  252.   Colors[3] := Random(MaxColors)+1;
  253.   Colors[4] := Random(MaxColors)+1;
  254.   ColorCount := 3*(1+Random(5));
  255. end;
  256.  
  257. procedure SelectNewDeltaValues;
  258. begin
  259.   DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
  260.   DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
  261.   DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
  262.   DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
  263.   IncrementCount := 2*(1+Random(4));
  264. end;
  265.  
  266.  
  267. procedure SaveCurrentLine(CurrentColors: ColorList);
  268. begin
  269.   with Line[CurrentLine] do
  270.   begin
  271.     LX1 := X1;
  272.     LY1 := Y1;
  273.     LX2 := X2;
  274.     LY2 := Y2;
  275.     LColor := CurrentColors;
  276.   end;
  277. end;
  278.  
  279. procedure Draw(x1,y1,x2,y2,color:word);
  280. begin
  281.   SetColor(color);
  282.   Graph.Line(x1,y1,x2,y2);
  283. end;
  284.  
  285. procedure Regenerate;
  286. var
  287.   I: integer;
  288. begin
  289.   Frame;
  290.   for I := 1 to Memory do with Line[I] do begin
  291.     Draw(LX1,LY1,LX2,LY2,LColor[1]);
  292.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,LColor[2]);
  293.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,LColor[3]);
  294.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,LColor[4]);
  295.   end;
  296.   WaitToGo;
  297.   Frame;
  298. end;
  299.  
  300. procedure Updateline;
  301. begin
  302.   Inc(CurrentLine);
  303.   if CurrentLine > Memory then CurrentLine := 1;
  304.   Dec(ColorCount);
  305.   Dec(IncrementCount);
  306. end;
  307.  
  308. procedure CheckForUserInput;
  309. begin
  310.   if KeyPressed then begin
  311.     Ch := ReadKey;
  312.     if Upcase(Ch) = 'B' then begin
  313.       if BackColor > MaxColors then BackColor := 0 else Inc(BackColor);
  314.       SetBkColor(BackColor);
  315.     end
  316.     else
  317.     if Upcase(Ch) = 'C' then begin
  318.       if ChangeColors then ChangeColors := FALSE else ChangeColors := TRUE;
  319.       ColorCount := 0;
  320.     end
  321.     else if Ch<>#27 then Regenerate;
  322.   end;
  323. end;
  324.  
  325. procedure DrawCurrentLine;
  326. var c1,c2,c3,c4: integer;
  327. begin
  328.   c1 := Colors[1];
  329.   c2 := Colors[2];
  330.   c3 := Colors[3];
  331.   c4 := Colors[4];
  332.   if MaxColors = 1 then begin
  333.     c2 := c1; c3 := c1; c4 := c1;
  334.   end;
  335.  
  336.   Draw(X1,Y1,X2,Y2,c1);
  337.   Draw(ViewXmax-X1,Y1,ViewXmax-X2,Y2,c2);
  338.   Draw(X1,ViewYmax-Y1,X2,ViewYmax-Y2,c3);
  339.   if MaxColors = 3 then c4 := Random(3)+1; { alternate colors }
  340.   Draw(ViewXmax-X1,ViewYmax-Y1,ViewXmax-X2,ViewYmax-Y2,c4);
  341.   SaveCurrentLine(Colors);
  342. end;
  343.  
  344. procedure EraseCurrentLine;
  345. begin
  346.   with Line[CurrentLine] do begin
  347.     Draw(LX1,LY1,LX2,LY2,0);
  348.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,0);
  349.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,0);
  350.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,0);
  351.   end;
  352. end;
  353.  
  354.  
  355. procedure DoArt;
  356. begin
  357.   SelectNewColors;
  358.   repeat
  359.     EraseCurrentLine;
  360.     if ColorCount = 0 then SelectNewColors;
  361.  
  362.     if IncrementCount=0 then SelectNewDeltaValues;
  363.  
  364.     AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
  365.     AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
  366.  
  367.     if Random(5)=3 then begin
  368.       x1 := (x1+x2) div 2; { shorten the lines }
  369.       y2 := (y1+y2) div 2;
  370.     end;
  371.  
  372.     DrawCurrentLine;
  373.     Updateline;
  374.     CheckForUserInput;
  375.   until Ch=#27;
  376. end;
  377.  
  378. begin
  379.    Init;
  380.    Frame;
  381.    MessageFrame('Press a key to stop action, Esc quits.');
  382.    DoArt;
  383.    CloseGraph;
  384.    RestoreCrtMode;
  385.    Writeln('The End.');
  386. end.
  387.