home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 07 / recursiv.asc < prev    next >
Text File  |  1991-06-11  |  22KB  |  610 lines
  1. _RECURSIVE IMAGES_
  2. by Steven Janke
  3.  
  4.  
  5. [LISTING ONE]
  6.  
  7. PROGRAM RECURTRE;
  8.   uses graph;
  9.   var     inc,firstdirection :real;
  10.           gd,gm,depth,scale  :integer;
  11.           startx,starty      :integer;
  12.           xasp,yasp          :word;
  13.           asp                :real;
  14.   const pi:real=3.14159;
  15.   procedure TREE(X,Y:integer; DIR:real; LEVEL:integer);
  16.     var xnew,ynew:integer;
  17.     begin
  18.       if level>0 then    {At level zero, recursion ends.}
  19.         begin
  20.           xnew:= round(level*scale*cos(dir))+x;      {Multiplying by level }
  21.           ynew:= round(asp*level*scale*sin(dir))+y;  {varies the branch size.}
  22.           if level<3 then setcolor(green) else setcolor(brown); {Green leaves}
  23.           line(x,y,xnew,ynew);
  24.           TREE(xnew,ynew,dir+random*inc,level-1); {Two recursive calls - one}
  25.           TREE(xnew,ynew,dir-random*inc,level-1); {for each new branch.}
  26.         end;
  27.     end;
  28.   procedure INIT;
  29.     begin
  30.       firstdirection:=-pi/2;  {Negative since y increases down the screen.}
  31.       inc:=pi/4;
  32.       scale:=5;
  33.       depth:=10;
  34.       startx:=round(GETMAXX/2); starty:=round(0.75*GETMAXY);
  35.       GETAspectRatio(xasp,yasp); asp:=xasp/yasp; {Find aspect ratio}
  36.     end;
  37.   BEGIN
  38.     gd:=detect;
  39.     initgraph(gd,gm,'\tp\units');  {Graphic drivers kept in \tp\units.}
  40.     cleardevice; randomize;
  41.     INIT;
  42.     TREE(startx, starty, firstdirection, depth);
  43.     readln;
  44.     closegraph;
  45.   END.
  46.  
  47.  
  48.  
  49. [LISTING TWO]
  50.  
  51. PROGRAM IFSDRAW; {Random Algorithm for drawing IFS attractor.}
  52.   uses graph;
  53.   var            gd, gm :integer;   {For graphics initialization}
  54.              xoff, yoff :integer;   {Offset to determine origin}
  55.                xsc, ysc :real;      {Scale variables}
  56.                   n, cl :integer;   {Index variable, color variable}
  57.                 x,y,asp :real;      {Starting point and aspect ratio}
  58.               xasp,yasp :word;      {Used to determine aspect ratio}
  59.   const {Normally, these constants would be read from a data file.  They
  60.          are listed as constants here only for illustration.  These
  61.          particular transformations form an IFS for Sierpinski's triangle.}
  62.         Totaltran:integer=3;
  63.                CT:array[1..3,1..7] of real =
  64.       {Format:  a,    b,     c,    d,     e,    f,  probability}
  65.            (( 0.5,    0,     0,    0,   0.5,    0,  0.33),
  66.             ( 0.5,    0,   100,    0,   0.5,    0,  0.33),
  67.             ( 0.5,    0,    50,    0,   0.5,  -100,  0.33));
  68.   procedure SETPROB;
  69.   {To get a running sum of the probabilities for random number generation.}
  70.     var   i:integer;
  71.         sum:real;
  72.     begin
  73.       sum:=0;
  74.       for i:=1 to totaltran-1 do
  75.         begin sum:=sum+CT[i,7]; CT[i,7]:=sum; end;
  76.       CT[totaltran,7]:=1; {This is set to 1 to avoid any round-off problem.}
  77.     end;
  78.   procedure MAKETRAN;
  79.     {Determine which transformation is next and then apply it.}
  80.     var nx,ny:real;
  81.             s:integer;
  82.     function FINDTRAN:integer;
  83.       {Return a random number between 1 and the number of transformations.}
  84.       var i:integer;
  85.           w:real;
  86.       begin
  87.         w:=random; i:=1;
  88.         while w>CT[i,7] do i:=i+1;
  89.         FINDTRAN:=i;
  90.       end;
  91.     begin
  92.       S:=FINDTRAN;
  93.       NX:=CT[S,1]*X + CT[S,2]*Y + CT[S,3];
  94.       NY:=CT[S,4]*X + CT[S,5]*Y + CT[S,6];
  95.       X:=NX; Y:=NY;
  96.     end;
  97.   procedure INIT;
  98.     begin
  99.       XSC:=1; YSC:=1; {Scale factors}
  100.       XOFF:=round(GETMAXX/2); YOFF:=round(GETMAXY/2);  {Determines origin}
  101.       X:=0; Y:=0; {Starting point}
  102.       cl:=white;
  103.       GETAspectRatio(xasp,yasp); {BGI function for determining aspect ratio}
  104.       asp:=xasp/yasp;
  105.     end;
  106.   BEGIN
  107.     gd:=detect; initgraph(gd,gm,' '); cleardevice;
  108.     INIT; SETPROB;
  109.     for N:=1 to 5000 do
  110.       begin
  111.         MAKETRAN;
  112.         putpixel(round(X*XSC)+XOFF, (round(asp*Y*YSC)+YOFF),cl);
  113.       end;
  114.     readln;
  115.     closegraph;
  116.   END.
  117.  
  118.  
  119.  
  120.  
  121. [LISTING THREE]
  122.  
  123. PROGRAM IFS; {ITERATED FUNCTION SYSTEM DESIGNER}
  124.   uses graph,crt;
  125.   type matrix = array[1..2,1..3] of real;
  126.   var   points:array[1..100,1..2] of integer; {Points and Pts store vertices}
  127.            pts:array[1..100,1..2] of real;    {of main figure.}
  128.          gd,gm: integer;    {For graphics initialization.}
  129.             cp:integer;     {Total number of vertices in main figure.}
  130.      xoff,yoff:integer;     {Offset for main figure placement.}
  131.      asp,xt,yt:real;        {Aspect ratio and offsets for transformation.}
  132.         select:boolean;     {For menu selection.}
  133.           tran:matrix;      {Coefficients of current transformation.}
  134.       tranlist: array[1..50] of matrix;     {List of transformations}
  135.      totaltran:integer;     {Total number of transformations.}
  136.   procedure APPLYTRAN; {--------------------------------------------}
  137.     {Applies the current transformation to the vertices of main figure.}
  138.     var i:integer;
  139.         a:real;
  140.     begin
  141.       for i:=1 to cp do
  142.         begin
  143.           a:=tran[1,1]*pts[i,1]+tran[1,2]*pts[i,2];
  144.           pts[i,2]:=tran[2,1]*pts[i,1]+tran[2,2]*pts[i,2];
  145.           pts[i,1]:=a;
  146.         end;
  147.     end;
  148.   procedure INIT; {-------------------------------------------------}
  149.     var xasp,yasp:word;
  150.     begin
  151.       cp:=1;
  152.       xoff:=round(GETMAXX/2); yoff:=round(GETMAXY/2);
  153.       xt:=0; yt:=0;
  154.       GETASPECTRATIO(Xasp,Yasp); asp:=xasp/yasp;
  155.       totaltran:=0;
  156.     end;
  157.   procedure INITTRAN; {---------------------------------------------}
  158.     begin
  159.       tran[1,1]:=1; tran[1,2]:=0; tran[2,1]:=0; tran[2,2]:=1;
  160.     end;
  161.   procedure SAVETRAN(n:integer); {----------------------------------}
  162.     begin
  163.       tranlist[n]:=tran;
  164.       tranlist[n,1,3]:=xt; tranlist[n,2,3]:=yt;
  165.       xt:=0; yt:=0;
  166.     end;
  167.   procedure CONVPOINTS; {-------------------------------------------}
  168.     {Converts screen coordinates in Points to world coordinates in Pts.}
  169.     var i:integer;
  170.     begin
  171.       for i:=1 to cp do
  172.         begin
  173.           pts[i,1]:=points[i,1]-xoff;
  174.           pts[i,2]:=(points[i,2]-yoff)/asp;
  175.         end;
  176.     end;
  177.   procedure DRAWFIG(col:integer); {---------------------------------}
  178.     var i,holdcol:integer;
  179.     begin
  180.       holdcol:=getcolor; setcolor(col);
  181.       for i:=1 to cp-1 do
  182.         line(round(pts[i,1]+xoff+xt),round(pts[i,2]*asp+yoff+yt*asp),
  183.              round(pts[i+1,1]+xoff+xt),round(pts[i+1,2]*asp+yoff+yt*asp));
  184.       setcolor(holdcol);
  185.     end;
  186.   procedure REDRAW(N:integer); {-------------------------------------}
  187.     {Redraws orignial figure plus the results of each transformation.}
  188.     {Transformation number N is not drawn.}
  189.     var i:integer;
  190.     begin
  191.       xt:=0; yt:=0;
  192.       cleardevice; CONVPOINTS; DRAWFIG(blue);
  193.       for i:=1 to totaltran do
  194.        if i<>n then
  195.         begin
  196.           CONVPOINTS; tran:=tranlist[i];
  197.           xt:=tranlist[i,1,3]; yt:=tranlist[i,2,3];
  198.           APPLYTRAN;
  199.           DRAWFIG(red);
  200.         end;
  201.       xt:=0; yt:=0;
  202.     end;
  203.   procedure SCALE(xsize,ysize:real); {-------------------------------}
  204.     {Changes the size of a figure.}
  205.     var i,j:integer;
  206.     begin
  207.       for i:=1 to cp do
  208.         begin pts[i,1]:=xsize*pts[i,1];
  209.               pts[i,2]:=ysize*pts[i,2];
  210.         end;
  211.       for i:=1 to 2 do tran[1,i]:=xsize*tran[1,i];
  212.       for i:=1 to 2 do tran[2,i]:=ysize*tran[2,i];
  213.     end;
  214.   procedure POSITION; {---------------------------------------------}
  215.     {Positions figure as a new transformation is constructed.}
  216.     var     k:char;
  217.         xx,yy:integer;
  218.  
  219.     procedure DIRECTIONS; {....................................}
  220.       begin
  221.         gotoxy(1,16); writeln('SCALE  (S/W)');
  222.                       writeln('SCALEX (A/Q)');
  223.                       writeln('SCALEY (D/E)');
  224.                       writeln('ROTATE  (R/F)');
  225.                       writeln('ROTATEX (T/G)');
  226.                       writeln('ROTATEY (Y/H)');
  227.                       writeln('REFLECT (X)');
  228.                       writeln('Use ARROWS to translate.');
  229.         gotoxy(1,25); write('... Press Enter when finished ...');
  230.       end;
  231.     procedure REFLECT;  {......................................}
  232.       {Flips the figure around the line x=y.}
  233.       var  i:integer;
  234.           xx:real;
  235.       begin
  236.         for i:=1 to cp do
  237.           begin  xx:=pts[i,1]; pts[i,1]:=pts[i,2]; pts[i,2]:=xx; end;
  238.           xx:=tran[1,1]; tran[1,1]:=tran[2,1]; tran[2,1]:=xx;
  239.           xx:=tran[1,2]; tran[1,2]:=tran[2,2]; tran[2,2]:=xx;
  240.       end;
  241.     procedure ROTATE(xangle,yangle:real);  {...................}
  242.       {Rotates the figure.  If xangle and yangle are unequal, rotation}
  243.       {is skewed.}
  244.       var i,j:integer;
  245.           a,b,xca,xsa,yca,ysa:real;
  246.       begin
  247.         xca:=cos(xangle); xsa:=sin(xangle);
  248.         yca:=cos(yangle); ysa:=sin(yangle);
  249.         for i:=1 to cp do
  250.           begin
  251.             a:=pts[i,1]*xca-pts[i,2]*ysa;
  252.             pts[i,2]:=pts[i,1]*xsa+pts[i,2]*yca;
  253.             pts[i,1]:=a;
  254.           end;
  255.         a:=tran[1,1]*xca-tran[2,1]*ysa;
  256.         b:=tran[1,2]*xca-tran[2,2]*ysa;
  257.         tran[2,1]:=tran[1,1]*xsa+tran[2,1]*yca;
  258.         tran[2,2]:=tran[1,2]*xsa+tran[2,2]*yca;
  259.         tran[1,1]:=a; tran[1,2]:=b;
  260.       end;
  261.     procedure WRITETRAN; {......................................}
  262.       var i,j:integer;
  263.       begin
  264.         gotoxy(1,3); writeln('Current Transformation: ');
  265.         for i:=1 to 2 do
  266.           begin
  267.             for j:=1 to 2 do
  268.               begin
  269.                 gotoxy(1+(j-1)*10, 5+(i-1));
  270.                 writeln(tran[i,j]:7:2);
  271.               end;
  272.             gotoxy(21, 5+(i-1));
  273.             if i=1 then writeln(xt:7:2) else writeln(yt:7:2);
  274.           end;
  275.       end;
  276.     begin
  277.       xx:=round(xt); yy:=round(asp*yt);
  278.       WRITETRAN; DIRECTIONS;
  279.       k:=readkey;
  280.       while ord(k)<>13 do
  281.         begin
  282.           DRAWFIG(green);
  283.           case ord(k) of
  284.             0: begin
  285.                   k:=readkey;
  286.                   case ord(k) of
  287.                     72: yy:=yy-3;
  288.                     77: xx:=xx+4;
  289.                     80: yy:=yy+3;
  290.                     75: xx:=xx-4;
  291.                   end;
  292.                 end;
  293.             83,115: scale(0.9,0.9);    { S for decrease }
  294.             87,119: scale(1.1,1.1);    { W for increase }
  295.             65,97 : scale(0.9,1);      { A for x decrease }
  296.             68,100: scale(1,0.9);      { D for y decrease }
  297.             81,113: scale(1.1,1);      { Q for x increase }
  298.             69,101: scale(1,1.1);      { E for y decrease }
  299.             82,114: rotate(0.1,0.1);   { R for rotate cw }
  300.             70,102: rotate(-0.1,-0.1); { F for rotate ccw }
  301.             84,116: rotate(-0.1,0);    { T for x rotate cw }
  302.             71,103: rotate(0.1,0);     { G for x rotate ccw }
  303.             89,121: rotate(0,-0.1);    { Y for y rotate cw }
  304.             72,104: rotate(0,0.1);     { H for y rotate ccw }
  305.             88,120: reflect;           { X to reflect in x=y }
  306.           end;
  307.           xt:=xx; yt:=yy/asp; DRAWFIG(green);
  308.           WRITETRAN;
  309.           k:=readkey;
  310.         end;
  311.     end;
  312.   procedure SHAPE; {-------- SECTION I ------------------------------}
  313.     {Sets up the main figure.}
  314.     var i,j,er:integer;
  315.              k:char;
  316.     procedure BOX(x,y,col:integer); {..........................}
  317.     var vs,hs,holdcol:integer;
  318.     begin
  319.       hs:=3; vs:=2; holdcol:=getcolor; setcolor(col);
  320.       line(x-hs,y-vs,x+hs,y-vs);
  321.       line(x+hs,y-vs,x+hs,y+vs);
  322.       line(x+hs,y+vs,x-hs,y+vs);
  323.       line(x-hs,y+vs,x-hs,y-vs);
  324.       setcolor(holdcol);
  325.     end;
  326.     begin
  327.       gotoxy(1,1); writeln('ITERATED FUNCTION SYSTEM DESIGNER');
  328.                    writeln('Section I: Draw outline of desired figure ....');
  329.       gotoxy(1,23); writeln('Use arrows to position cursor.');
  330.                     writeln('Press P to place a vertex.');
  331.                     write('Press Enter when finished.');
  332.       i:=xoff; j:=yoff; setwritemode(xorput);
  333.       BOX(i,j,white);
  334.       k:=readkey; er:=1;  {Variable er used to determine when to draw box.}
  335.       while ord(k)<>13 do
  336.         begin
  337.           case ord(k) of
  338.             0: begin if er=1 then BOX(i,j,white); er:=1;
  339.                   k:=readkey;
  340.                   case ord(k) of
  341.                     72: j:=j-6;
  342.                     77: i:=i+8;
  343.                     80: j:=j+6;
  344.                     75: i:=i-8;
  345.                   end;
  346.                   BOX(i,j,white);
  347.                 end;
  348.             80,112: begin er:=0; points[cp,1]:=i; points[cp,2]:=j;
  349.                           if cp>1 then begin setcolor(blue);
  350.                              line(points[cp-1,1],points[cp-1,2],
  351.                                   points[cp,1], points[cp,2]);
  352.                              setcolor(white); end;
  353.                           cp:=cp+1;
  354.                     end;
  355.             end;
  356.           k:=readkey;
  357.         end;
  358.       points[cp,1]:=points[1,1]; points[cp,2]:=points[1,2];
  359.       setcolor(blue);
  360.       line(points[cp-1,1],points[cp-1,2],points[1,1],points[1,2]);
  361.       setcolor(white); setwritemode(copyput);
  362.     end;
  363.   procedure MAKETRAN; {---------- SECTION II ------------------------}
  364.     {Allows construction and alteration of transformations.}
  365.     var  nt,choice:integer;
  366.               s,me:char;
  367.     function MENUII:integer; {........................................}
  368.       var xn:integer;
  369.       begin
  370.         gotoxy(1,1); writeln('1. Another Transformation');
  371.                       writeln('2. Next Transformation');
  372.                       writeln('3. Prepare to Draw');
  373.         gotoxy(1,5); writeln('Select Number: '); me:=readkey;
  374.         while (ord(me)<49) or (ord(me)>51) do me:=readkey;
  375.         MENUII:=ord(me)-48;
  376.         gotoxy(1,1);
  377.         for xn:=1 to 5 do writeln('                           ');
  378.       end;
  379.     begin
  380.       gotoxy(1,1); writeln('Section II: Build Transformations ...');
  381.       choice:=1; nt:=0;
  382.       if totaltran<>0 then choice:=2;
  383.       while choice<>3 do
  384.         begin
  385.           if choice=2 then
  386.               begin nt:=nt+1;
  387.                     if nt>totaltran then nt:=1;
  388.                     REDRAW(nt);
  389.                     tran:=tranlist[nt];
  390.                     xt:=tranlist[nt,1,3]; yt:=tranlist[nt,2,3];
  391.               end
  392.               else begin INITTRAN; totaltran:=totaltran+1;
  393.                          nt:=totaltran;end;
  394.           CONVPOINTS;
  395.           if choice=2 then APPLYTRAN else SCALE(0.5,0.5);
  396.           setwritemode(xorput);
  397.           DRAWFIG(green);
  398.           POSITION;
  399.           setwritemode(copyput);
  400.           SAVETRAN(NT);
  401.           REDRAW(0);
  402.           CHOICE:=MENUII;
  403.         end;
  404.       cleardevice;
  405.     end;
  406.   procedure GENERATE; {------------ SECTION III ---------------------}
  407.     {Draw the resulting picture by applying transformations at random.}
  408.     var xx,nm,wh,bd,cl,choice:integer;
  409.                           x,y:real;
  410.                            me:char;
  411.                         probs:array[1..50] of real;
  412.  
  413.     procedure ASSIGNPROB; {....................................}
  414.       {Determines probability of each transformation.}
  415.       var i:integer;
  416.           s:real;
  417.       begin
  418.         for i:=1 to totaltran do
  419.           begin
  420.             tran:=tranlist[i];
  421.             probs[i]:=abs(tran[1,1]*tran[2,2] - tran[1,2]*tran[2,1]);
  422.             if probs[i]<0.02 then probs[i]:=0.02;
  423.           end;
  424.         s:=0; for i:=1 to totaltran do s:=s+probs[i];
  425.         for i:=1 to totaltran do probs[i]:=probs[i]/s;
  426.         s:=0; for i:=1 to totaltran do begin s:=s+probs[i]; probs[i]:=s; end;
  427.         probs[i]:=1;
  428.       end;
  429.     function PICK:integer;  {..................................}
  430.       {Picks a transformation with designated probability distribution.}
  431.       var j:integer;
  432.           p:real;
  433.       begin
  434.         p:=random; j:=1;
  435.         while p>probs[j] do j:=j+1;
  436.         PICK:=j;
  437.       end;
  438.     procedure APPLY(w:integer); {..............................}
  439.       {Applies chosen transformation to current point X,Y.}
  440.       var z:real;
  441.       begin
  442.         tran:=tranlist[w];
  443.         z:=tran[1,1]*X+tran[1,2]*Y;
  444.         Y:=tran[2,1]*X+tran[2,2]*Y;
  445.         X:=z+tran[1,3];
  446.         Y:=Y+tran[2,3];
  447.       end;
  448.     procedure PUTIT(cc:integer); {.............................}
  449.       begin
  450.         if cl=0 then cc:=white;
  451.         putpixel(round(X+xoff),round(Y*asp+yoff),cc);
  452.       end;
  453.     procedure MENUIII; {.......................................}
  454.       var  s:string;
  455.           xx:integer;
  456.       begin
  457.         bd:=0;cl:=0;
  458.         gotoxy(1,3); write('1. Border (Toggles)');
  459.                      gotoxy(25,3); writeln('Excluded');
  460.                      write('2. Color  (Toggles)');
  461.                      gotoxy(25,4); writeln('No');
  462.                      writeln('3. Draw Image');
  463.                      writeln;writeln('Select Number: ');
  464.          me:='5';
  465.          while (ord(me)<>51) do
  466.            begin
  467.              me:=readkey;
  468.              while (ord(me)<49) or (ord(me)>51) do me:=readkey;
  469.              case ord(me) of
  470.                49: begin if bd=0 then begin bd:=1; s:='Included'; end
  471.                                  else begin bd:=0; s:='Excluded'; end;
  472.                          gotoxy(25,3);write(s);
  473.                    end;
  474.                50: begin if cl=0 then begin cl:=1; s:='Yes';end
  475.                                  else begin cl:=0; s:='No ';end;
  476.                          gotoxy(25,4);write(s);
  477.                    end;
  478.              end;
  479.            end;
  480.          gotoxy(1,3);
  481.          for xx:=1 to 5 do writeln('                                     ');
  482.       end;
  483.     begin
  484.       cleardevice; ASSIGNPROB; randomize;
  485.       gotoxy(1,1); writeln('Section III: Draw Image ... ');
  486.       MENUIII;
  487.       if bd=1 then begin  CONVPOINTS; DRAWFIG(blue); end;
  488.       nm:=3000;    {Number of points to plotted in final image.}
  489.       X:=0;Y:=0;   {Initial point drawn.}
  490.       PUTIT(7);
  491.       for xx:=1 to nm do
  492.         begin
  493.           wh:=PICK; APPLY(wh); PUTIT((wh mod 7)+1);
  494.         end;
  495.     end;
  496.   procedure FILESAVE;
  497.   {To save transformations on disk.}
  498.     var        i:integer;
  499.         tranfile:file of matrix;
  500.     begin
  501.       assign(tranfile, 'IFS.DAT');
  502.       rewrite(tranfile);
  503.       for i:=1 to totaltran do write(tranfile, tranlist[i]);
  504.       close(tranfile);
  505.     end;
  506.   function MENUIV:boolean; {.......................................}
  507.       var  s:string;
  508.           me:char;
  509.       begin
  510.         gotoxy(1,3); writeln('1. Return to Section II');
  511.                      writeln('2. Save transformations on file');
  512.                      writeln('3. Quit');
  513.                      writeln;writeln('Select Number: ');
  514.          me:='2';
  515.          while me='2' do
  516.            begin
  517.              me:=readkey;
  518.              while (ord(me)<49) or (ord(me)>51) do me:=readkey;
  519.              if me='2' then begin FILESAVE;
  520.                                   gotoxy(1,9); writeln('DATA SAVED');
  521.                             end;
  522.            end;
  523.          if me='1' then MENUIV:=true else MENUIV:=false;
  524.       end;
  525.   BEGIN  {----------------- Main Body ------------------------------}
  526.     gd:=detect; initgraph(gd,gm,'');
  527.     directvideo:=false; {Allows text using WRITE statements.}
  528.     INIT; cleardevice;
  529.     SHAPE;                 {... Section I   ...}
  530.     select:=true;
  531.     while select do
  532.        begin
  533.            REDRAW(0);
  534.            MAKETRAN;       {... Section II  ...}
  535.            GENERATE;       {... Section III ...}
  536.            select:=MENUIV;
  537.        end;
  538.     cleardevice; closegraph;
  539.   END.
  540.  
  541.  
  542.  
  543.  
  544. [LISTING FOUR]
  545.  
  546. PROGRAM FOREST; {A mixture of two systems to produce a forest of ferns}
  547.   uses graph;
  548.   var  n,xoff,yoff,gd,gm,cl: integer;
  549.                   xsc,ysc,x,y,bx,by,asp:real;
  550.                           xasp,yasp:word;
  551.   const
  552.         {CT holds the IFS for a fern}
  553.         CT:array[1..4,1..7] of real =
  554.            ((    0,    0,    0,    0, 0.16,     0, 0.02),
  555.             (  0.2,-0.26,    0, 0.23, 0.22,   -24, 0.065),
  556.             (-0.15, 0.28,    0, 0.26, 0.24,  -6.6, 0.065),
  557.             ( 0.85, 0.04,    0,-0.04, 0.85,   -24, 0.85));
  558.         {PL holds additional IFS functions to produce the forest}
  559.         PL:array[1..2,1..6] of real =
  560.            ((  0.8,  0,  80,  0, 0.8, -65),
  561.             (  0.8,  0, -80,  0, 0.8, -60));
  562.         PROB:array[1..6] of real = (0.008, 0.034, 0.06, 0.4, 0.7, 1.0);
  563.   procedure MAKETRAN;
  564.     var nx,ny:real;
  565.             s:integer;
  566.     function FINDTRAN:integer;
  567.       var i:integer;
  568.           w:real;
  569.       begin
  570.         w:=random; I:=1;
  571.         while w>PROB[i] do i:=i+1;
  572.         FINDTRAN:=i;
  573.       end;
  574.     begin
  575.       s:=FINDTRAN;
  576.       if s<5 then {Generate another point in the fern.}
  577.           begin
  578.             nx:=CT[s,1]*x + CT[s,2]*y + CT[s,3];
  579.             ny:=CT[s,4]*x + CT[S,5]*y + CT[s,6];
  580.             x:=nx; y:=ny; bx:=x; by:=y;
  581.           end
  582.          else     {Generate another point in the forest.}
  583.           begin
  584.            s:=s-4;
  585.            nx:=PL[s,1]*bx + PL[s,2]*by + PL[s,3];
  586.            ny:=PL[s,4]*bx + PL[s,5]*by + PL[s,6];
  587.            bx:=nx; by:=ny;
  588.           end;
  589.     end;
  590.   procedure INIT;
  591.     begin
  592.       xsc:=1.3; ysc:=1;
  593.       xoff:=round(GETMAXX/2); yoff:=GETMAXY-50;
  594.       x:=0; y:=0;
  595.       bx:=0; by:=0;
  596.       GETAspectRatio(xasp,yasp); asp:=xasp/yasp;
  597.     end;
  598.   BEGIN
  599.     gd:=detect; initgraph(gd,gm,' ');
  600.     INIT; cleardevice;
  601.     for N:=1 to 32000 do
  602.       begin
  603.         MAKETRAN;
  604.         putpixel(round(bx*xsc)+xoff,(round(asp*by*ysc)+yoff),green);
  605.       end;
  606.     readln; cleardevice; closegraph;
  607.   END.
  608.  
  609.  
  610.