home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FRACMNTS.ZIP / FRACMNT1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-05-05  |  6.4 KB  |  270 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..1700] 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.     clrscr;
  53.     write('Data set 1 or 2 ?');
  54.     read(kbd,ch);
  55.     if ch = '1' then
  56.     begin
  57.       a^[1].v1.x:=0.0;
  58.       a^[1].v1.y:=0.1;
  59.       a^[1].v2.x:=1.0;
  60.       a^[1].v2.y:=0.1;
  61.       a^[1].v3.x:=0.5;
  62.       a^[1].v3.y:=1.0;
  63.       NumOfPolys:=1;
  64.       end
  65.      else begin
  66.       a^[1].v1.x:=0.0;
  67.       a^[1].v1.y:=0.1;
  68.       a^[1].v2.x:=0.5;
  69.       a^[1].v2.y:=0.671428;
  70.       a^[1].v3.x:=0.3;
  71.       a^[1].v3.y:=0.9;
  72.       a^[2].v1.x:=0.5;
  73.       a^[2].v1.y:=0.671428;
  74.       a^[2].v2.x:=1.0;
  75.       a^[2].v2.y:=0.1;
  76.       a^[2].v3.x:=0.8;
  77.       a^[2].v3.y:=0.8;
  78.       a^[3].v1.x:=0.5;
  79.       a^[3].v1.y:=0.671428;
  80.       a^[3].v2.x:=0.0;
  81.       a^[3].v2.y:=0.1;
  82.       a^[3].v3.x:=1.0;
  83.       a^[3].v3.y:=0.1;
  84.       NumOfPolys:=3;
  85.       end;
  86.     end;
  87.   end;     { GetStartPoly }
  88.  
  89. Procedure Display;
  90. var
  91.   x1,y1,x2,y2,
  92.   x3,y3,i          :integer;
  93.  
  94. begin
  95.   clearscreen;
  96.   for i:= 1 to NumOfPolys do
  97.   begin
  98.     x1:=round(320*a^[i].v1.x);
  99.     y1:=round(200*a^[i].v1.y);
  100.     x2:=round(320*a^[i].v2.x);
  101.     y2:=round(200*a^[i].v2.y);
  102.     x3:=round(320*a^[i].v3.x);
  103.     y3:=round(200*a^[i].v3.y);
  104.     draw(x1,200-y1,x2,200-y2,3);
  105.     draw(x2,200-y2,x3,200-y3,3);
  106.     draw(x3,200-y3,x1,200-y1,3);
  107.     end;
  108.   end;
  109.  
  110. function normal(mu,sigma: real): real;
  111.  
  112.     var   z:real;
  113.  
  114.     begin
  115.       z:=sqrt(-2.0*ln(random))*cos(6.28319*random);
  116.       normal:=z*sigma+mu
  117.       end;
  118.  
  119. Procedure NewPoint(x1,y1,x2,y2  :real; var nx,ny  :real);
  120. var
  121.   dx,dy,
  122.   distance     :real;
  123.  
  124. begin
  125.   dx:=x2-x1;
  126.   dy:=y2-y1;
  127.   distance:=sqrt(dx*dx+dy*dy)*0.3;
  128.   nx:=(x1+x2)/2.0+normal(0.0,0.3)*distance;
  129.   ny:=(y1+y2)/2.0+normal(0.0,0.3)*distance;
  130.   end;
  131.  
  132.  
  133. Procedure ColorFractal;
  134. var
  135.   x1i,x2i,x3i,
  136.   y1i,y2i,y3i,
  137.   x,y,color,i      :integer;
  138.   level,x1,x2,x3,
  139.   y1,y2,y3         :real;
  140.  
  141. begin
  142.   for i:= 1 to NumOfPolys do
  143.   begin
  144.     x1:=a^[i].v1.x;
  145.     y1:=a^[i].v1.y;
  146.     x2:=a^[i].v2.x;
  147.     y2:=a^[i].v2.y;
  148.     x3:=a^[i].v3.x;
  149.     y3:=a^[i].v3.y;
  150.     level:=(y1+y2+y3)/3.0;
  151.     y:=round(200*level);
  152.     x:=round(320*((x1+x2+x3)/3.0));
  153.     level:=level+normal(0.0,0.25);
  154.     if level >= 0.8 then color:=3
  155.      else if level >= 0.45 then color:=2
  156.      else color:=1;
  157. {   x1i:=round(320*a^[i].v1.x);
  158.     y1i:=round(200*a^[i].v1.y);
  159.     x2i:=round(320*a^[i].v2.x);
  160.     y2i:=round(200*a^[i].v2.y);
  161.     x3i:=round(320*a^[i].v3.x);
  162.     y3i:=round(200*a^[i].v3.y);
  163.     draw(x1i,200-y1i,x2i,200-y2i,color);
  164.     draw(x2i,200-y2i,x3i,200-y3i,color);
  165.     draw(x3i,200-y3i,x1i,200-y1i,color);
  166.  }  FillShape(x,200-y,color,3);
  167.     end;
  168.   end;
  169.  
  170.  
  171. Procedure Fractalize;
  172. var
  173.   t1,t2,t3,t4      :poly;
  174.   k,i,j            :integer;
  175.   mkt1,mkt2,mkt3   :boolean;
  176.  
  177. begin
  178.   k:=1;
  179.   for i:= 1 to NumOfPolys do
  180.   begin
  181.     gotoxy(32,3);  write(k:4);
  182.     t1.v1:=a^[i].v1;
  183.     t1.v2:=a^[i].v2;
  184.     t2.v1:=a^[i].v2;
  185.     t2.v2:=a^[i].v3;
  186.     t3.v1:=a^[i].v3;
  187.     t3.v2:=a^[i].v1;
  188.     mkt1:=true;
  189.     mkt2:=true;
  190.     mkt3:=true;
  191.     for j:=1 to k-1  do
  192.     begin
  193.       if (((t1.v1.x = tp^[j].v1.x) and (t1.v2.x = tp^[j].v2.x)) and
  194.          ((t1.v1.y = tp^[j].v1.y) and (t1.v2.y = tp^[j].v2.y))) or
  195.          (((t1.v2.x = tp^[j].v1.x) and (t1.v1.x = tp^[j].v2.x)) and
  196.          ((t1.v2.y = tp^[j].v1.y) and (t1.v1.y = tp^[j].v2.y))) then
  197.       begin
  198.         t1.v3:=tp^[j].v3;
  199.         mkt1:=false;
  200.         end;
  201.       if (((t2.v1.x = tp^[j].v1.x) and (t2.v2.x = tp^[j].v2.x)) and
  202.          ((t2.v1.y = tp^[j].v1.y) and (t2.v2.y = tp^[j].v2.y))) or
  203.          (((t2.v2.x = tp^[j].v1.x) and (t2.v1.x = tp^[j].v2.x)) and
  204.          ((t2.v2.y = tp^[j].v1.y) and (t2.v1.y = tp^[j].v2.y))) then
  205.       begin
  206.         t2.v3:=tp^[j].v3;
  207.         mkt2:=false;
  208.         end;
  209.       if (((t3.v1.x = tp^[j].v1.x) and (t3.v2.x = tp^[j].v2.x)) and
  210.          ((t3.v1.y = tp^[j].v1.y) and (t3.v2.y = tp^[j].v2.y))) or
  211.          (((t3.v2.x = tp^[j].v1.x) and (t3.v1.x = tp^[j].v2.x)) and
  212.          ((t3.v2.y = tp^[j].v1.y) and (t3.v1.y = tp^[j].v2.y))) then
  213.       begin
  214.         t3.v3:=tp^[j].v3;
  215.         mkt3:=false;
  216.         end;
  217.       end;
  218.     if mkt1 then NewPoint(t1.v1.x,t1.v1.y,t1.v2.x,t1.v2.y,t1.v3.x,t1.v3.y);
  219.     if mkt2 then NewPoint(t2.v1.x,t2.v1.y,t2.v2.x,t2.v2.y,t2.v3.x,t2.v3.y);
  220.     if mkt3 then NewPoint(t3.v1.x,t3.v1.y,t3.v2.x,t3.v2.y,t3.v3.x,t3.v3.y);
  221.     t4.v1:=t1.v3;
  222.     t4.v2:=t2.v3;
  223.     t4.v3:=t3.v3;
  224.     b^[k].v1:=t1.v1; b^[k].v2:=t1.v3; b^[k].v3:=t3.v3;  tp^[k]:=t1; k:=k+1;
  225.     b^[k].v1:=t2.v1; b^[k].v2:=t2.v3; b^[k].v3:=t1.v3;  tp^[k]:=t2; k:=k+1;
  226.     b^[k].v1:=t3.v1; b^[k].v2:=t3.v3; b^[k].v3:=t2.v3;  tp^[k]:=t3; k:=k+1;
  227.     b^[k].v1:=t1.v3; b^[k].v2:=t2.v3; b^[k].v3:=t3.v3;  tp^[k]:=t4; k:=k+1;
  228.     end;
  229.   NumOfPolys:=k-1;
  230.   temp:=a;
  231.   a:=b;
  232.   b:=temp;
  233.   display;
  234. {  ColorFractal;  }
  235.   if NumOfPolys < 1000 then
  236.   begin
  237.     gotoxy(26,1);  write('Continue (Y/N)?');
  238.     read(kbd,ch);
  239.     if (ch = 'Y') or (ch = 'y') then
  240.     begin
  241.       gotoxy(26,1);  write('Working        ');
  242.       fractalize;
  243.       end;
  244.     end
  245.    else begin
  246.     gotoxy(26,1);  write('Press any key');
  247.     gotoxy(26,2);  write('  to exit.');
  248.     read(kbd,ch);
  249.     end;
  250.   end;
  251.  
  252.  
  253. begin       { Main program }
  254.   new(a);
  255.   new(b);
  256.   new(tp);
  257.   GetStartPoly;
  258.   graphmode;
  259. {  graphcolormode;
  260.   palette(2);
  261.  } Display;
  262.   gotoxy(26,1);  write('Continue (Y/N)?');
  263.   read(kbd,ch);
  264.   if (ch = 'Y') or (ch = 'y') then
  265.   begin
  266.     gotoxy(26,1);  write('Working        ');
  267.     fractalize;
  268.     end;
  269.   textmode;
  270.   end.