home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / field.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  5KB  |  162 lines
  1.  
  2. program LinesOfForce;
  3. { 'lines-of-force' from charged particles, by Bas van Gaalen, Holland, PD }
  4. uses
  5.   crt,graph;
  6.  
  7. const
  8.   Density = 16;
  9.   MaxPoints = 5;
  10.   Step = 10;
  11.   StPos : array[1..Density,1..2] of shortint = (
  12.     (-3, 3),(-2, 4),( 0, 5),( 2, 4),( 3, 3),
  13.     (-4, 2),                        ( 4, 2),
  14.     (-5, 0),                        ( 5, 0),
  15.     (-4,-2),                        ( 4,-2),
  16.     (-3,-3),(-2,-4),( 0,-5),( 2,-4),( 3,-3));
  17.  
  18. type
  19.   PointRec = record
  20.                Xpos,Ypos : integer;
  21.                Value : real;
  22.                Direction : shortint;
  23.              end;
  24.  
  25.   PointArr = array[1..MaxPoints] of PointRec;
  26.  
  27. var
  28.   Point : PointArr;
  29.   MaxX,MaxY,MidX,MidY : word;
  30.   NofPoints : byte;
  31.  
  32. {----------------------------------------------------------------------------}
  33.  
  34. procedure InitGraphics;
  35.  
  36. var
  37.   grDriver,grMode,I,J : integer;
  38.  
  39. begin
  40.   grDriver := detect;
  41.   initgraph(grDriver,grMode,'i:\bgi');
  42.   MaxX := getmaxx; MaxY := getmaxy;
  43.   MidX := MaxX div 2; MidY := MaxY div 2;
  44.   setcolor(lightgray);
  45.   line(MidX,MidY-20*Step,MidX,MidY+20*Step);
  46.   line(MidX-20*Step,MidY,MidX+20*Step,MidY);
  47.  
  48.   I := MidX-20*Step;
  49.   while I <= MidX+20*Step do begin line(I,MidY-1,I,MidY+1); inc(I,Step); end;
  50.   I := MidY-20*Step;
  51.   while I <= MidY+20*Step do begin line(MidX-1,I,MidX+1,I); inc(I,Step); end;
  52.  
  53.   I := MidX-20*Step;
  54.   while I <= MidX+20*Step do begin
  55.     J := MidY-20*Step;
  56.     while J <= MidY+20*Step do begin putpixel(I,J,darkgray); inc(J,Step); end;
  57.     inc(I,Step);
  58.   end;
  59.  
  60. end;
  61.  
  62. {----------------------------------------------------------------------------}
  63.  
  64. procedure InitPoints(var Pt : PointArr);
  65.  
  66. var
  67.   Tmp : string[10];
  68.   I : byte;
  69.  
  70. begin
  71.   randomize;
  72.   NofPoints := 1+random(MaxPoints);
  73.   for I := 1 to NofPoints do with Pt[I] do begin
  74.     Xpos := (random(30)-15)*Step;
  75.     Ypos := (random(30)-15)*Step;
  76.     Value := 1+random(10);
  77.     if random(2) = 1 then Direction := 1 else Direction := -1;
  78.     circle(MidX+Xpos,MidY-Ypos,4);
  79.     str(Direction*Value:1:2,Tmp);
  80.     outtextxy(MidX+Xpos-3*8,MidY-Ypos-2*8,Tmp);
  81.   end;
  82. end;
  83.  
  84. {----------------------------------------------------------------------------}
  85.  
  86. procedure DrawFieldLines(Pt : PointArr);
  87.  
  88. var
  89.   I,J : word;
  90.  
  91. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  92.  
  93. procedure CalcDest(Px,Py : real);
  94.  
  95. var
  96.   EiPoint : array[1..MaxPoints] of real;
  97.   EpX,EpY,Range : real;
  98.   J : word;
  99.   I : byte;
  100.   Terminate : boolean;
  101.  
  102. begin
  103.   moveto(MidX+round(Px),MidY-round(Py));
  104.   J := 1;
  105.   repeat
  106.     for I := 1 to NofPoints do begin
  107.       Range := sqrt(sqr(abs(Px)-abs(Pt[I].Xpos))+sqr(abs(Py)-abs(Pt[I].Ypos)));
  108.       if Range = 0 then EiPoint[I] := 0 else EiPoint[I] := Pt[I].Value/sqr(Range);
  109.     end;
  110.     EpX := 0; EpY := 0;
  111.     for I := 1 to NofPoints do begin
  112.       if Range = 0 then begin EpX := 0; EpY := 0; end
  113.       else begin
  114.         EpX := EpX+Pt[I].Direction*EiPoint[I]*((Px-Pt[I].Xpos)/Range);
  115.         EpY := EpY+Pt[I].Direction*EiPoint[I]*((Py-Pt[I].Ypos)/Range);
  116.       end
  117.     end;
  118.     EpX := EpX*1000; if EpX > 3 then EpX := 3 else if EpX < -3 then EpX := -3;
  119.     EpY := EpY*1000; if EpY > 3 then EpY := 3 else if EpY < -3 then EpY := -3;
  120.     lineto(MidX+round(Px+EpX),MidY-round(Py-EpY));
  121.     I := 1; Terminate := false;
  122.     repeat
  123.       Terminate := (abs(round(EpX)) >= abs(round(Pt[I].Xpos-Px)+1)) and
  124.                    (abs(round(EpY)) >= abs(round(Pt[I].Ypos-Py)+1));
  125.       inc(I);
  126.     until (I = NofPoints+1) or Terminate;
  127.     Px := Px+EpX; Py := Py+EpY;
  128.     if not Terminate then Terminate := ((MidX+Px) < (MidX-20*Step)) or
  129.                                        ((MidX+Px) > (MidX+20*Step)) or
  130.                                        ((MidY+Py) < (MidY-20*Step)) or
  131.                                        ((MidY+Py) > (MidY+20*Step));
  132.     if not Terminate then Terminate := keypressed;
  133.     inc(J);
  134.   until Terminate or (J = 500);
  135. end;
  136.  
  137. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  138.  
  139. begin
  140.   setcolor(green);
  141.  
  142.   for I := 1 to NofPoints do
  143.     if Pt[I].Direction > 0 then
  144.       for J := 1 to 16 do CalcDest(Pt[I].Xpos+StPos[J,1],Pt[I].Ypos+StPos[J,2]);
  145.  
  146.   setcolor(lightgray);
  147.   outtextxy(0,0,'Ready. Press a key...');
  148.   while not keypressed do;
  149. end;
  150.  
  151. {----------------------------------------------------------------------------}
  152.  
  153. begin
  154.   InitGraphics;
  155.   InitPoints(Point);
  156.   DrawFieldLines(Point);
  157.   closeGraph;
  158.   textmode(lastmode);
  159. end.
  160.  
  161. { Little bugged version. New one in the make }
  162.