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