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.