home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FRACMNTS.ZIP / FRACMNT2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-15  |  5.8 KB  |  242 lines
  1. Program SolidFractal;
  2. {$C-,V-,K-}
  3. {
  4.        Dirk W. Howard
  5.        CS 542
  6.        Winter 87
  7.  
  8.        Assignment Number 1
  9.        Due January 16, 1987
  10.  
  11. }
  12. {$I GRAPH.P }
  13.  
  14. type
  15.   vertex         = record
  16.                    x,y  :real;
  17.                    end;
  18.   poly           = record
  19.                    v1,v2,v3  :vertex;
  20.                    end;
  21.   storarray      = array[1..1100] of poly;
  22.   polystorage    = ^storarray;
  23.  
  24. var
  25.   a,b,temp,tp      :polystorage;
  26.   ch               :char;
  27.   NumOfPolys       :integer;
  28.  
  29. Procedure GetStartPoly;
  30. var
  31.   filein           :text;
  32.   filename         :string[14];
  33.  
  34. begin
  35.   clrscr;
  36.   write(' Is data to be read in from a file? (Y/N) ');
  37.   read(kbd,ch);
  38.   if (ch = 'Y') or (ch = 'y') then
  39.   begin
  40.     writeln;
  41.     write('Enter filename : ');
  42.     readln(filename);
  43.     assign(filein,filename);
  44.     reset(filein);
  45.     readln(filein,a^[1].v1.x,a^[1].v1.y);
  46.     readln(filein,a^[1].v2.x,a^[1].v2.y);
  47.     readln(filein,a^[1].v3.x,a^[1].v3.y);
  48.     NumOfPolys:=1;
  49.     close(filein);
  50.     end
  51.    else begin
  52.     a^[1].v1.x:=0.0;
  53.     a^[1].v1.y:=0.1;
  54.     a^[1].v2.x:=1.0;
  55.     a^[1].v2.y:=0.1;
  56.     a^[1].v3.x:=0.5;
  57.     a^[1].v3.y:=1.0;
  58.     NumOfPolys:=1;
  59.     end;
  60.   end;     { GetStartPoly }
  61.  
  62. Procedure Display;
  63. var
  64.   x1,y1,x2,y2,
  65.   x3,y3,i          :integer;
  66.  
  67. begin
  68.   clearscreen;
  69.   for i:= 1 to NumOfPolys do
  70.   begin
  71.     x1:=round(320*a^[i].v1.x);
  72.     y1:=round(200*a^[i].v1.y);
  73.     x2:=round(320*a^[i].v2.x);
  74.     y2:=round(200*a^[i].v2.y);
  75.     x3:=round(320*a^[i].v3.x);
  76.     y3:=round(200*a^[i].v3.y);
  77.     draw(x1,200-y1,x2,200-y2,3);
  78.     draw(x2,200-y2,x3,200-y3,3);
  79.     draw(x3,200-y3,x1,200-y1,3);
  80.     end;
  81.   end;
  82.  
  83. function normal(mu,sigma: real): real;
  84.  
  85.     var   z:real;
  86.  
  87.     begin
  88.       z:=sqrt(-2.0*ln(random))*cos(6.28319*random);
  89.       normal:=z*sigma+mu
  90.       end;
  91.  
  92. Procedure NewPoint(x1,y1,x2,y2  :real; var nx,ny  :real);
  93. var
  94.   dx,dy,
  95.   distance     :real;
  96.  
  97. begin
  98.   dx:=x2-x1;
  99.   dy:=y2-y1;
  100.   distance:=sqrt(dx*dx+dy*dy)*0.3;
  101.   nx:=(x1+x2)/2.0+normal(0.0,0.3)*distance;
  102.   ny:=(y1+y2)/2.0+normal(0.0,0.3)*distance;
  103.   end;
  104.  
  105.  
  106. Procedure ColorFractal;
  107. var
  108.   x1i,x2i,x3i,
  109.   y1i,y2i,y3i,
  110.   x,y,color,i      :integer;
  111.   level,x1,x2,x3,
  112.   y1,y2,y3         :real;
  113.  
  114. begin
  115.   for i:= 1 to NumOfPolys do
  116.   begin
  117.     x1:=a^[i].v1.x;
  118.     y1:=a^[i].v1.y;
  119.     x2:=a^[i].v2.x;
  120.     y2:=a^[i].v2.y;
  121.     x3:=a^[i].v3.x;
  122.     y3:=a^[i].v3.y;
  123.     level:=(y1+y2+y3)/3.0;
  124.     y:=round(200*level);
  125.     x:=round(320*((x1+x2+x3)/3.0));
  126.     level:=level+normal(0.0,0.25);
  127.     if level >= 0.8 then color:=3
  128.      else if level >= 0.45 then color:=2
  129.      else color:=1;
  130.     x1i:=round(320*a^[i].v1.x);
  131.     y1i:=round(200*a^[i].v1.y);
  132.     x2i:=round(320*a^[i].v2.x);
  133.     y2i:=round(200*a^[i].v2.y);
  134.     x3i:=round(320*a^[i].v3.x);
  135.     y3i:=round(200*a^[i].v3.y);
  136.     draw(x1i,200-y1i,x2i,200-y2i,color);
  137.     draw(x2i,200-y2i,x3i,200-y3i,color);
  138.     draw(x3i,200-y3i,x1i,200-y1i,color);
  139.     FillShape(x,200-y,color,color);
  140.     end;
  141.   end;
  142.  
  143.  
  144. Procedure Fractalize;
  145. var
  146.   t1,t2,t3,t4      :poly;
  147.   k,i,j            :integer;
  148.   mkt1,mkt2,mkt3   :boolean;
  149.  
  150. begin
  151.   k:=1;
  152.   for i:= 1 to NumOfPolys do
  153.   begin
  154.     gotoxy(32,3);  write(k:4);
  155.     t1.v1:=a^[i].v1;
  156.     t1.v2:=a^[i].v2;
  157.     t2.v1:=a^[i].v2;
  158.     t2.v2:=a^[i].v3;
  159.     t3.v1:=a^[i].v3;
  160.     t3.v2:=a^[i].v1;
  161.     mkt1:=true;
  162.     mkt2:=true;
  163.     mkt3:=true;
  164.     for j:=1 to k-1  do
  165.     begin
  166.       if (((t1.v1.x = tp^[j].v1.x) and (t1.v2.x = tp^[j].v2.x)) and
  167.          ((t1.v1.y = tp^[j].v1.y) and (t1.v2.y = tp^[j].v2.y))) or
  168.          (((t1.v2.x = tp^[j].v1.x) and (t1.v1.x = tp^[j].v2.x)) and
  169.          ((t1.v2.y = tp^[j].v1.y) and (t1.v1.y = tp^[j].v2.y))) then
  170.       begin
  171.         t1.v3:=tp^[j].v3;
  172.         mkt1:=false;
  173.         end;
  174.       if (((t2.v1.x = tp^[j].v1.x) and (t2.v2.x = tp^[j].v2.x)) and
  175.          ((t2.v1.y = tp^[j].v1.y) and (t2.v2.y = tp^[j].v2.y))) or
  176.          (((t2.v2.x = tp^[j].v1.x) and (t2.v1.x = tp^[j].v2.x)) and
  177.          ((t2.v2.y = tp^[j].v1.y) and (t2.v1.y = tp^[j].v2.y))) then
  178.       begin
  179.         t2.v3:=tp^[j].v3;
  180.         mkt2:=false;
  181.         end;
  182.       if (((t3.v1.x = tp^[j].v1.x) and (t3.v2.x = tp^[j].v2.x)) and
  183.          ((t3.v1.y = tp^[j].v1.y) and (t3.v2.y = tp^[j].v2.y))) or
  184.          (((t3.v2.x = tp^[j].v1.x) and (t3.v1.x = tp^[j].v2.x)) and
  185.          ((t3.v2.y = tp^[j].v1.y) and (t3.v1.y = tp^[j].v2.y))) then
  186.       begin
  187.         t3.v3:=tp^[j].v3;
  188.         mkt3:=false;
  189.         end;
  190.       end;
  191.     if mkt1 then NewPoint(t1.v1.x,t1.v1.y,t1.v2.x,t1.v2.y,t1.v3.x,t1.v3.y);
  192.     if mkt2 then NewPoint(t2.v1.x,t2.v1.y,t2.v2.x,t2.v2.y,t2.v3.x,t2.v3.y);
  193.     if mkt3 then NewPoint(t3.v1.x,t3.v1.y,t3.v2.x,t3.v2.y,t3.v3.x,t3.v3.y);
  194.     t4.v1:=t1.v3;
  195.     t4.v2:=t2.v3;
  196.     t4.v3:=t3.v3;
  197.     b^[k].v1:=t1.v1; b^[k].v2:=t1.v3; b^[k].v3:=t3.v3;  tp^[k]:=t1; k:=k+1;
  198.     b^[k].v1:=t2.v1; b^[k].v2:=t2.v3; b^[k].v3:=t1.v3;  tp^[k]:=t2; k:=k+1;
  199.     b^[k].v1:=t3.v1; b^[k].v2:=t3.v3; b^[k].v3:=t2.v3;  tp^[k]:=t3; k:=k+1;
  200.     b^[k].v1:=t1.v3; b^[k].v2:=t2.v3; b^[k].v3:=t3.v3;  tp^[k]:=t4; k:=k+1;
  201.     end;
  202.   NumOfPolys:=k-1;
  203.   temp:=a;
  204.   a:=b;
  205.   b:=temp;
  206.   display;
  207.   ColorFractal;
  208.   if NumOfPolys < 1000 then
  209.   begin
  210.     gotoxy(26,1);  write('Continue (Y/N)?');
  211.     read(kbd,ch);
  212.     if (ch = 'Y') or (ch = 'y') then
  213.     begin
  214.       gotoxy(26,1);  write('Working        ');
  215.       fractalize;
  216.       end;
  217.     end
  218.    else begin
  219.     gotoxy(26,1);  write('Press any key');
  220.     gotoxy(26,2);  write('  to exit.');
  221.     read(kbd,ch);
  222.     end;
  223.   end;
  224.  
  225.  
  226. begin       { Main program }
  227.   new(a);
  228.   new(b);
  229.   new(tp);
  230.   GetStartPoly;
  231.   graphcolormode;
  232.   palette(2);
  233.   Display;
  234.   gotoxy(26,1);  write('Continue (Y/N)?');
  235.   read(kbd,ch);
  236.   if (ch = 'Y') or (ch = 'y') then
  237.   begin
  238.     gotoxy(26,1);  write('Working        ');
  239.     fractalize;
  240.     end;
  241.   textmode;
  242.   end.