[net.sources.mac] Fractal demo program

jwp@utah-cs.UUCP (John W Peterson) (06/27/85)

Since there seems to be so much interest in fractals at the moment, I
thought people might enjoy this quick hack.  This draws successive
fractal (or at least "stochastic") mountains, using the algorithm Mike
Rivero described.

This is in Macintosh Pascal, though it shouldn't be too hard to translate
to other systems/languages.  Hold the mouse button down to see the
next iteration.

The program is based on another one written by Shoichi Kitaoka.  If it
seems a bit terse, it's because it was written on a 128K mac...

------------------------------------------------------------------
{ Fractal demo, based on a program by Shoichi Kitoaka.}
program fractal;
 const
  MaxLevel = 5;
  GridSize = 32;
 type
  point = record
    x, y, z : real;
   end;

{Half of this is wasted...}
  grid = array[0..GridSize, 0..GridSize] of point;

 var
  t : grid;
  L1, L2, L3 : real;
  curLevel : integer;

{Translate a point from 3D to 2D}

 procedure Translate (pt : Point;
         var nX, nY : integer);
  const
   r3 = 1.7320508;
  var
   x1, x2, x3 : real;
 begin
  with pt do
   begin {Rotate some...}
    nX := 2 * (trunc(x * 2.0) + 256) div 4;
    nY := 2 * (trunc(r3 * y - z) + 188) div 4;
   end;
 end;

 procedure Draw3D (pt : point;
         penDown : boolean);
  var
   iX, iY : integer;
 begin
  Translate(pt, iX, iY);
  if penDown then
   LineTo(iX, iY)
  else
   MoveTo(iX, iY);
 end;

 procedure Line3D (StartPt, EndPt : point);
 begin
  Draw3D(StartPt, false);
  Draw3D(EndPt, true);
 end;

 function f_rand (offset, range : real) : real;
 begin
  f_rand := ((random mod 1000) - 499.5) * range / 249.5 + offset;
 end;

 procedure make_next (level : integer);
  var
   dim, i, m, n, NextM, NextN : integer;

  procedure displace (midM, midN, M1, N1, M2, N2 : integer;
          amount : real);
  begin
   with t[midM, midN] do
    begin
     x := 0.5 * (t[M1, N1].X + t[M2, N2].X);
     y := 0.5 * (t[M1, N1].Y + t[M2, N2].Y);
     Z := f_rand(0.5 * (t[M1, N1].Z + t[M2, N2].Z), amount);
    end;
  end;

 begin
  dim := 1;
  for i := 0 to level - 1 do
   dim := dim * 2;

  for m := dim downto 0 do
   for n := m downto 0 do
    with t[2 * m, 2 * n] do
     begin
      x := t[m, n].x;
      y := t[m, n].y;
      z := t[m, n].z;
     end;

  for m := 1 to dim do
   for n := 0 to m - 1 do
    begin
     NextM := 2 * m;
     NextN := 2 * n;
     displace(NextM, NextN + 1, NextM, NextN, NextM, NextN + 2, L3 / dim);
    end;

  for m := 0 to dim - 1 do
   for n := 0 to m do
    begin
     NextM := 2 * m;
     NextN := 2 * n;
     displace(NextM + 1, NextN, NextM, NextN, NextM + 2, NextN, L1 / Dim);
     displace(NextM + 1, NextN + 1, NextM, NextN, NextM + 2, NextN + 2, L2 / dim);
    end;
 end;

 procedure InitData;
 begin
  with t[0, 0] do
   begin
    X := 0.0;
    Y := -100.0;
    Z := 0.0;
   end;
  with t[1, 0] do
   begin
    X := -100.0;
    Y := 100.0;
    Z := 0.0;
   end;
  with t[1, 1] do
   begin
    X := 100.0;
    Y := 100.0;
    Z := 0.0;
   end;

 { Displacements allowed }
  L1 := 141.4 / 3.0;
  L2 := L1;
  L3 := 200 / 3.0;
 end;

 procedure draw_mountain (level : integer);
  var
   dim, n, m, i : integer;
 begin
  dim := 1;
  for i := 0 to level - 1 do
   dim := dim * 2;

  for m := 0 to dim do
   for n := 0 to m do
    begin
     if m < dim then
      begin
       Line3D(t[m, n], t[m + 1, n]);
       Line3D(t[m, n], t[m + 1, n + 1]);
      end;
     if (n < m) then
      Line3D(t[m, n], t[m, n + 1]);
    end;
 end;

begin
 InitData;
 for curLevel := 0 to MaxLevel do
  begin
   EraseRect(0, 0, 512, 512);
   draw_mountain(curLevel);
   if curLevel < MaxLevel then
    begin
     make_next(curLevel);
{SysBeep(1);}
     while not button do
      ;
    end;
  end;
end.