home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 13 / CDA13.ISO / cdactual / demobin / share / program / Pascal / BGI256.ZIP / ANIMATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-24  |  7.2 KB  |  311 lines
  1.  
  2. { Animation line/ellipse demo program for BGI256 }
  3. { as of 24 April 1993  written by Michael Day }
  4.  
  5. program Animate;
  6. uses crt,graph,WrMode;
  7.  
  8. type ByteArray = array[0..64520] of byte;
  9.  
  10. const DrawColor : word = white;
  11.  
  12. var gm,gd:integer;
  13.     done : boolean;
  14.     bx,by,kx,ky:integer;
  15.     oldbx,oldby,OldKx,OldKy:integer;
  16.     PO:^ByteArray;
  17.     Auto : boolean;
  18.     alldone : boolean;
  19.     delaytime: integer;
  20.     TopPoint : boolean;
  21.     s : string[10];
  22.     LineType : word;
  23.     index : word;
  24.     oldindex : word;
  25.     ch : char;
  26.     OldHow,how : word;
  27.     OldDrawColor : word;
  28.  
  29. const
  30.     UpArrow = char(72+128);
  31.     DnArrow = char(80+128);
  32.     LeftArrow = char(75+128);
  33.     RightArrow = char(77+128);
  34.  
  35.  
  36. procedure PlotPixel(Draw:boolean; X,Y:integer);
  37. begin
  38.   if Draw then
  39.   begin
  40.     Po^[Index] := GetPixel(x,y);         {plot the pixel}
  41.   end
  42.   else
  43.   begin
  44.     if Po^[Index] <> OldDrawColor then  {is it ok to undraw?}
  45.       PutPixel(x,y,Po^[Index]);         {yes, undraw the pixel}
  46.   end;
  47.   inc(Index);
  48. end;
  49.  
  50. {--------------------------------------------}
  51. {plot a line on screen }
  52. procedure doline(Draw:boolean; x1,y1,x2,y2:integer);
  53. var  x,y,xstep,ystep,deltax,deltay,direction : integer;
  54. begin
  55.   SetWriteMode(MiscCommand+SetGetPixelReadWrite);
  56.   SetColor(DrawColor);
  57.   x := x1;
  58.   y := y1;
  59.   if x1 = x2 then xstep := 0
  60.     else if x1 > x2 then xstep := -1
  61.       else xstep := 1;
  62.   if y1 = y2 then ystep := 0
  63.     else if y1 > y2 then ystep := -1
  64.       else ystep := 1;
  65.   deltax := abs(x2 - x1);
  66.   deltay := abs(y2 - y1);
  67.   if deltax = 0 then direction := -1
  68.     else direction := 0;
  69.   PlotPixel(Draw,X,Y);
  70.   repeat
  71.     if direction < 0 then
  72.     begin
  73.       y := y + ystep;
  74.       direction := direction + deltax;
  75.       if ((direction >= 0) or (LineType > 0)) then
  76.         PlotPixel(Draw,X,Y);
  77.     end
  78.     else
  79.     begin
  80.       x := x + xstep;
  81.       direction := direction - deltay;
  82.       if ((direction >= 0) or (LineType > 1)) then
  83.         PlotPixel(Draw,X,Y);
  84.     end;
  85.   until ((y = y2) and (x = x2));
  86. end;
  87.  
  88. {----------------------------------------------------}
  89. {draw a rectangle}
  90. procedure dorect(Draw:boolean; x1,y1,x2,y2:integer);
  91. begin
  92.   doline(Draw,x1,y1,x2,y1);
  93.   doline(Draw,x2,y1,x2,y2);
  94.   doline(Draw,x2,y2,x1,y2);
  95.   doline(Draw,x1,y2,x1,y1);
  96. end;
  97.  
  98. {----------------------------------------------------}
  99. {draw an ellipse}
  100. procedure DoEllipse(Draw:boolean; x,y,Rx,Ry:integer);
  101. var xo,yo : integer;
  102.   procedure SetQuad;
  103.   begin
  104.     PlotPixel(Draw,x-xo,y-yo);
  105.     PlotPixel(Draw,x+xo,y+yo);
  106.     if (xo = 0) or (yo = 0) then Exit;
  107.     PlotPixel(Draw,x+xo,y-yo);
  108.     PlotPixel(Draw,x-xo,y+yo);
  109.   end;
  110.  
  111. var d,dx,dy,RxSqr,RySqr,RxSqr2,RySqr2: longint;
  112. begin
  113.   SetWriteMode(MiscCommand+SetGetPixelReadWrite);
  114.   SetColor(DrawColor);
  115.   xo := 0;
  116.   yo := Ry;
  117.   RxSqr  := Rx*Rx;
  118.   RxSqr2 := RxSqr*2;
  119.   RySqr  := Ry*Ry;
  120.   RySqr2 := RySqr*2;
  121.   d := RySqr-(RxSqr*Ry)+(RxSqr div 4);
  122.   dx := 0;
  123.   dy := Ry*RxSqr2;
  124.   while dx < dy do
  125.   begin
  126.     SetQuad;
  127.     if d > 0 then
  128.     begin
  129.       dec(yo);
  130.       dy := dy-RxSqr2;
  131.       d := d-dy;
  132.     end;
  133.     inc(xo);
  134.     dx := dx+RySqr2;
  135.     d := d+dx+RySqr;
  136.   end;
  137.   d := d + ((((3*(RxSqr-RySqr)) div 2)-(dx+dy)) div 2);
  138.   while yo >= 0 do
  139.   begin
  140.     SetQuad;
  141.     if d < 0 then
  142.     begin
  143.       inc(xo);
  144.       dx := dx+RySqr2;
  145.       d := d+dx;
  146.     end;
  147.     dec(yo);
  148.     dy := dy-RxSqr2;
  149.     d := d-dy+RxSqr;
  150.   end;
  151. end;
  152.  
  153.  
  154. {-----------------------------------------------------}
  155. {convert integer to string}
  156. function fstr(I:integer):string;
  157. var s : string;
  158. begin
  159.   str(I,S);
  160.   fstr := S;
  161. end;
  162.  
  163. {your basic limit function}
  164. function Limit(Num,Start,Stop:integer):integer;
  165. begin
  166.   if Num < Start then Limit := Start
  167.   else if Num > Stop then Limit := Stop
  168.   else Limit := Num;
  169. end;
  170.  
  171.  
  172. {put a background on the screen}
  173. procedure MakeScreen;
  174. begin
  175.   SetColor(Red);
  176.   setfillstyle(SolidFill,red);
  177.   bar(GetMaxX div 3,GetMaxY div 3,(GetMaxX div 3)*2,(GetMaxY div 3)*2);
  178.   SetColor(Yellow);
  179.   rectangle(GetMaxX div 4,GetMaxY div 4,(GetMaxX div 4)*3,(GetMaxY div 4)*3);
  180.   setColor(Green);
  181.   Circle(GetMaxX div 2,GetMaxY div 2,GetMaxY div 2);
  182.   setcolor(blue);
  183.   OutTextxy(0,GetMaxY-10,#24+#25+#26+#27+'=MovPt "T"=CtrlPt "A"=Ani 0-9=Spd');
  184.   OutTextxy(0,0,'X:'+fstr(GetMaxX+1)+' Y:'+fstr(GetMaxY+1));
  185. end;
  186.  
  187. {process keyboard input}
  188. procedure GetKey;
  189. var Tx,Ty : integer;
  190. begin
  191.   Tx := 0;
  192.   Ty := 0;
  193.   ch := readkey;
  194.   if ch = #0 then
  195.     ch := char(ord(readkey)+$80);
  196.   case upcase(ch) of
  197.     'Q',#$1b   : done := true;
  198.     UpArrow    : Ty := -5;
  199.     DnArrow    : Ty := 5;
  200.     LeftArrow  : Tx := -5;
  201.     RightArrow : Tx := 5;
  202.            'A' : Auto := not(Auto);
  203.       '0'..'9' : DelayTime := sqr(ord(ch) and $f)*5;
  204.            'T' : TopPoint := not(TopPoint);
  205.            'C' : DrawColor := limit(succ(DrawColor) and $f,1,GetMaxColor);
  206.            'L' : How := 0;
  207.            'R' : How := 1;
  208.            'E' : How := 2;
  209.   end;  {case}
  210.   if TopPoint then
  211.   begin
  212.     Bx := Limit(Bx+Tx,0,GetMaxX);
  213.     By := Limit(By+Ty,0,GetMaxY);
  214.   end
  215.   else
  216.   begin
  217.     Kx := Limit(Kx+Tx,0,GetMaxX);
  218.     Ky := Limit(Ky+Ty,0,GetMaxY);
  219.   end;
  220. end;
  221.  
  222. {----------------------------------------------------------}
  223. {handle object request}
  224. procedure DoIt(How:word; Draw:boolean; x1,y1,x2,y2:integer);
  225. var a,b,c,d:integer;
  226. begin
  227.   index := 0;
  228.   case How of
  229.     0:doline(Draw,x1,y1,x2,y2);
  230.     1:dorect(Draw,x1,y1,x2,y2);
  231.     2:begin
  232.         a := (x1 div 4)+(getmaxX div 3);
  233.         b := (y1 div 4)+(getmaxy div 3);
  234.         c := abs(x2 - x1) div 4;
  235.         d := abs(y2 - y1) div 4;
  236.         doellipse(Draw,a,b,c,d);
  237.       end;
  238.   end;
  239. end;
  240.  
  241. {do the demo}
  242. procedure doDemo;
  243. begin
  244.   Kx := GetMaxX div 2;
  245.   Ky := GetMaxY div 2;
  246.   OldKx := Kx;
  247.   OldKy := Ky;
  248.   Bx := 240;
  249.   By := 150;
  250.   OldBx := Bx;
  251.   OldBy := By;
  252.   OldHow := 0;
  253.   How := 0;
  254.   Auto := false;
  255.   DelayTime := 100;
  256.   LineType := 3;
  257.   OldDrawColor := DrawColor;
  258.  
  259.   done := false;
  260.   doit(How,true,Bx,By,Kx,Ky);  {draw initial line}
  261.   repeat
  262.     if KeyPressed then GetKey;
  263.     if Auto then
  264.     begin
  265.       How := random(3);
  266.       Kx := random(GetMaxX);
  267.       Ky := random(GetMaxY);
  268.       Bx := random(GetMaxX);
  269.       By := random(GetMaxY);
  270.       delay(DelayTime);
  271.     end;
  272.     if (Bx <> OldBx) or (By <> OldBy) or (Kx <> OldKx) or (Ky <> OldKy) then
  273.     begin
  274.       doit(OldHow,false,OldBx,OldBy,OldKx,OldKy);  {undraw the line}
  275.       doit(How,true,Bx,By,Kx,Ky);   {draw new line}
  276.       OldHow := How;
  277.       OldBx := Bx;
  278.       OldBy := By;
  279.       OldKx := Kx;
  280.       OldKy := Ky;
  281.       OldDrawColor := DrawColor;
  282.  
  283.       if oldindex < index then
  284.       begin
  285.         setfillstyle(SolidFill,black);
  286.         bar((GetMaxX div 3)*2,0,GetMaxX,10);
  287.         outtextxy((GetMaxX div 3)*2,0,'Index:'+Fstr(OldIndex));
  288.         oldindex := index;
  289.       end;
  290.     end;
  291.   until done;
  292. end;
  293.  
  294. {----------------------------}
  295. {main code starts here}
  296. begin
  297.   new(PO);
  298.   fillchar(PO^,sizeof(PO^),0);
  299.   gm := 0;
  300.   if ParamCount > 0 then
  301.   begin
  302.     S := ParamStr(1);
  303.     gm := ord(s[1]) and $0f;
  304.   end;
  305.   gd := InstallUserDriver('BGI256',nil);
  306.   initGraph(gd,gm,'');
  307.   MakeScreen;
  308.   DoDemo;
  309.   CloseGraph;
  310. end.
  311.