home *** CD-ROM | disk | FTP | other *** search
/ TopWare 18: Liquid / Image.iso / liquid / top1143 / gepackt.exe / BSPQTSW.EXE / ARTY.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-07-09  |  3.5 KB  |  169 lines

  1. (***************************************
  2. *                                      *
  3. * Grafikanimation für das Programm     *
  4. * SCREENSV.PAS                         *
  5. *                                      *
  6. *--------------------------------------*
  7. * (c) Borland International / M.Scholz *
  8. ***************************************)
  9.  
  10. {$I COMPILER.INC}
  11. {$F+,O+}
  12.  
  13. UNIT ARTY;
  14.  
  15. INTERFACE
  16.  
  17. uses crt,
  18.      graph;
  19.  
  20. procedure DoArt;
  21.  
  22. IMPLEMENTATION
  23.  
  24. type ColorList=array[1..4] of integer;
  25.  
  26. var Line:array[1..100] of record
  27.                             LX1,LY1: integer;
  28.                             LX2,LY2: integer;
  29.                             LColor : ColorList;
  30.                           end;
  31.     X1,X2,Y1,Y2,
  32.     CurrentLine,
  33.     ColorCount,
  34.     IncrementCount,
  35.     DeltaX1,DeltaY1,DeltaX2,DeltaY2:integer;
  36.     i,MaxDelta:integer;
  37.     Colors:ColorList;
  38.     ChangeColors:boolean;
  39.  
  40. procedure DoArt;
  41. var kb:char;
  42.  
  43. procedure AdjustX(var X,DeltaX:integer);
  44. var TestX:integer;
  45. begin
  46.   TestX:=X+DeltaX;
  47.   if (TestX<1) or (TestX>640) then
  48.    begin
  49.      TestX:=X;
  50.      DeltaX:=-DeltaX;
  51.    end;
  52.   X:=TestX;
  53. end;
  54.  
  55. procedure AdjustY(var Y,DeltaY:integer);
  56. var TestY:integer;
  57. begin
  58.   TestY:=Y+DeltaY;
  59.   if (TestY<1) or (TestY>480) then
  60.    begin
  61.      TestY:=Y;
  62.      DeltaY:=-DeltaY;
  63.    end;
  64.   Y:=TestY;
  65. end;
  66.  
  67. procedure SelectNewColors;
  68. begin
  69.   if not ChangeColors then Exit;
  70.   Colors[1]:=Random(16)+1;
  71.   Colors[2]:=Random(16)+1;
  72.   Colors[3]:=Random(16)+1;
  73.   Colors[4]:=Random(16)+1;
  74.   ColorCount:=3*(1+Random(5));
  75. end;
  76.  
  77. procedure SelectNewDeltaValues;
  78. begin
  79.   DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
  80.   DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
  81.   DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
  82.   DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
  83.   IncrementCount := 2*(1+Random(4));
  84. end;
  85.  
  86. procedure SaveCurrentLine(CurrentColors:ColorList);
  87. begin
  88.   with Line[CurrentLine] do
  89.    begin
  90.      LX1:=X1; LY1:=Y1;
  91.      LX2:=X2; LY2:=Y2;
  92.      LColor:=CurrentColors;
  93.    end;
  94. end;
  95.  
  96. procedure Draw(x1,y1,x2,y2,color:word);
  97. begin
  98.   SetColor(color);
  99.   graph.line(x1,y1,x2,y2);
  100. end;
  101.  
  102. procedure Updateline;
  103. begin
  104.   Inc(CurrentLine);
  105.   if CurrentLine>100 then CurrentLine:=1;
  106.   Dec(ColorCount);
  107.   Dec(IncrementCount);
  108. end;
  109.  
  110. procedure DrawCurrentLine;
  111. var c1,c2,c3,c4:integer;
  112. begin
  113.   c1:=Colors[1];
  114.   c2:=Colors[2];
  115.   c3:=Colors[3];
  116.   c4:=Colors[4];
  117.   Draw(X1,Y1,X2,Y2,c1);
  118.   Draw(640-X1,Y1,640-X2,Y2,c2);
  119.   Draw(X1,480-Y1,X2,480-Y2,c3);
  120.   Draw(640-X1,480-Y1,640-X2,480-Y2,c4);
  121.   SaveCurrentLine(Colors);
  122. end;
  123.  
  124. procedure EraseCurrentLine;
  125. begin
  126.   with Line[CurrentLine] do
  127.    begin
  128.      Draw(LX1,LY1,LX2,LY2,0);
  129.      Draw(640-LX1,LY1,640-LX2,LY2,0);
  130.      Draw(LX1,480-LY1,LX2,480-LY2,0);
  131.      Draw(640-LX1,480-LY1,640-LX2,480-LY2,0);
  132.    end;
  133. end;
  134.  
  135. {-------------------}
  136.  
  137. begin
  138.   CurrentLine:=1; ColorCount:=0;
  139.   IncrementCount:=0; ChangeColors:=true;
  140.   MaxDelta:=16;
  141.   for i := 1 to 100 do
  142.    with Line[i] do
  143.     begin
  144.       LX1:=320; LX2:=320;
  145.       LY1:=240; LY2:=240;
  146.     end;
  147.    X1:=320; X2:=320; Y1:=240; Y2:=240;
  148.   ClearViewport;
  149.   SelectNewColors;
  150.   repeat
  151.     EraseCurrentLine;
  152.     if ColorCount=0 then SelectNewColors;
  153.     if IncrementCount=0 then SelectNewDeltaValues;
  154.     AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
  155.     AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
  156.     if Random(5)=3 then
  157.      begin
  158.        x1:=(x1+x2) div 2;
  159.        y2:=(y1+y2) div 2;
  160.      end;
  161.     DrawCurrentLine;
  162.     Updateline;
  163.   until keypressed;
  164.   if keypressed then kb:=ReadKey;
  165. end;
  166.  
  167.  
  168. end.
  169.