_RECURSIVE IMAGES_
by Steven Janke


[LISTING ONE]

PROGRAM RECURTRE;
  uses graph;
  var     inc,firstdirection :real;
          gd,gm,depth,scale  :integer;
          startx,starty      :integer;
          xasp,yasp          :word;
          asp                :real;
  const pi:real=3.14159;
  procedure TREE(X,Y:integer; DIR:real; LEVEL:integer);
    var xnew,ynew:integer;
    begin
      if level>0 then    {At level zero, recursion ends.}
        begin
          xnew:= round(level*scale*cos(dir))+x;      {Multiplying by level }
          ynew:= round(asp*level*scale*sin(dir))+y;  {varies the branch size.}
          if level<3 then setcolor(green) else setcolor(brown); {Green leaves}
          line(x,y,xnew,ynew);
          TREE(xnew,ynew,dir+random*inc,level-1); {Two recursive calls - one}
          TREE(xnew,ynew,dir-random*inc,level-1); {for each new branch.}
        end;
    end;
  procedure INIT;
    begin
      firstdirection:=-pi/2;  {Negative since y increases down the screen.}
      inc:=pi/4;
      scale:=5;
      depth:=10;
      startx:=round(GETMAXX/2); starty:=round(0.75*GETMAXY);
      GETAspectRatio(xasp,yasp); asp:=xasp/yasp; {Find aspect ratio}
    end;
  BEGIN
    gd:=detect;
    initgraph(gd,gm,'\tp\units');  {Graphic drivers kept in \tp\units.}
    cleardevice; randomize;
    INIT;
    TREE(startx, starty, firstdirection, depth);
    readln;
    closegraph;
  END.



[LISTING TWO]

PROGRAM IFSDRAW; {Random Algorithm for drawing IFS attractor.}
  uses graph;
  var            gd, gm :integer;   {For graphics initialization}
             xoff, yoff :integer;   {Offset to determine origin}
               xsc, ysc :real;      {Scale variables}
                  n, cl :integer;   {Index variable, color variable}
                x,y,asp :real;      {Starting point and aspect ratio}
              xasp,yasp :word;      {Used to determine aspect ratio}
  const {Normally, these constants would be read from a data file.  They
         are listed as constants here only for illustration.  These
         particular transformations form an IFS for Sierpinski's triangle.}
        Totaltran:integer=3;
               CT:array[1..3,1..7] of real =
      {Format:  a,    b,     c,    d,     e,    f,  probability}
           (( 0.5,    0,     0,    0,   0.5,    0,  0.33),
            ( 0.5,    0,   100,    0,   0.5,    0,  0.33),
            ( 0.5,    0,    50,    0,   0.5,  -100,  0.33));
  procedure SETPROB;
  {To get a running sum of the probabilities for random number generation.}
    var   i:integer;
        sum:real;
    begin
      sum:=0;
      for i:=1 to totaltran-1 do
        begin sum:=sum+CT[i,7]; CT[i,7]:=sum; end;
      CT[totaltran,7]:=1; {This is set to 1 to avoid any round-off problem.}
    end;
  procedure MAKETRAN;
    {Determine which transformation is next and then apply it.}
    var nx,ny:real;
            s:integer;
    function FINDTRAN:integer;
      {Return a random number between 1 and the number of transformations.}
      var i:integer;
          w:real;
      begin
        w:=random; i:=1;
        while w>CT[i,7] do i:=i+1;
        FINDTRAN:=i;
      end;
    begin
      S:=FINDTRAN;
      NX:=CT[S,1]*X + CT[S,2]*Y + CT[S,3];
      NY:=CT[S,4]*X + CT[S,5]*Y + CT[S,6];
      X:=NX; Y:=NY;
    end;
  procedure INIT;
    begin
      XSC:=1; YSC:=1; {Scale factors}
      XOFF:=round(GETMAXX/2); YOFF:=round(GETMAXY/2);  {Determines origin}
      X:=0; Y:=0; {Starting point}
      cl:=white;
      GETAspectRatio(xasp,yasp); {BGI function for determining aspect ratio}
      asp:=xasp/yasp;
    end;
  BEGIN
    gd:=detect; initgraph(gd,gm,' '); cleardevice;
    INIT; SETPROB;
    for N:=1 to 5000 do
      begin
        MAKETRAN;
        putpixel(round(X*XSC)+XOFF, (round(asp*Y*YSC)+YOFF),cl);
      end;
    readln;
    closegraph;
  END.




[LISTING THREE]

PROGRAM IFS; {ITERATED FUNCTION SYSTEM DESIGNER}
  uses graph,crt;
  type matrix = array[1..2,1..3] of real;
  var   points:array[1..100,1..2] of integer; {Points and Pts store vertices}
           pts:array[1..100,1..2] of real;    {of main figure.}
         gd,gm: integer;    {For graphics initialization.}
            cp:integer;     {Total number of vertices in main figure.}
     xoff,yoff:integer;     {Offset for main figure placement.}
     asp,xt,yt:real;        {Aspect ratio and offsets for transformation.}
        select:boolean;     {For menu selection.}
          tran:matrix;      {Coefficients of current transformation.}
      tranlist: array[1..50] of matrix;     {List of transformations}
     totaltran:integer;     {Total number of transformations.}
  procedure APPLYTRAN; {--------------------------------------------}
    {Applies the current transformation to the vertices of main figure.}
    var i:integer;
        a:real;
    begin
      for i:=1 to cp do
        begin
          a:=tran[1,1]*pts[i,1]+tran[1,2]*pts[i,2];
          pts[i,2]:=tran[2,1]*pts[i,1]+tran[2,2]*pts[i,2];
          pts[i,1]:=a;
        end;
    end;
  procedure INIT; {-------------------------------------------------}
    var xasp,yasp:word;
    begin
      cp:=1;
      xoff:=round(GETMAXX/2); yoff:=round(GETMAXY/2);
      xt:=0; yt:=0;
      GETASPECTRATIO(Xasp,Yasp); asp:=xasp/yasp;
      totaltran:=0;
    end;
  procedure INITTRAN; {---------------------------------------------}
    begin
      tran[1,1]:=1; tran[1,2]:=0; tran[2,1]:=0; tran[2,2]:=1;
    end;
  procedure SAVETRAN(n:integer); {----------------------------------}
    begin
      tranlist[n]:=tran;
      tranlist[n,1,3]:=xt; tranlist[n,2,3]:=yt;
      xt:=0; yt:=0;
    end;
  procedure CONVPOINTS; {-------------------------------------------}
    {Converts screen coordinates in Points to world coordinates in Pts.}
    var i:integer;
    begin
      for i:=1 to cp do
        begin
          pts[i,1]:=points[i,1]-xoff;
          pts[i,2]:=(points[i,2]-yoff)/asp;
        end;
    end;
  procedure DRAWFIG(col:integer); {---------------------------------}
    var i,holdcol:integer;
    begin
      holdcol:=getcolor; setcolor(col);
      for i:=1 to cp-1 do
        line(round(pts[i,1]+xoff+xt),round(pts[i,2]*asp+yoff+yt*asp),
             round(pts[i+1,1]+xoff+xt),round(pts[i+1,2]*asp+yoff+yt*asp));
      setcolor(holdcol);
    end;
  procedure REDRAW(N:integer); {-------------------------------------}
    {Redraws orignial figure plus the results of each transformation.}
    {Transformation number N is not drawn.}
    var i:integer;
    begin
      xt:=0; yt:=0;
      cleardevice; CONVPOINTS; DRAWFIG(blue);
      for i:=1 to totaltran do
       if i<>n then
        begin
          CONVPOINTS; tran:=tranlist[i];
          xt:=tranlist[i,1,3]; yt:=tranlist[i,2,3];
          APPLYTRAN;
          DRAWFIG(red);
        end;
      xt:=0; yt:=0;
    end;
  procedure SCALE(xsize,ysize:real); {-------------------------------}
    {Changes the size of a figure.}
    var i,j:integer;
    begin
      for i:=1 to cp do
        begin pts[i,1]:=xsize*pts[i,1];
              pts[i,2]:=ysize*pts[i,2];
        end;
      for i:=1 to 2 do tran[1,i]:=xsize*tran[1,i];
      for i:=1 to 2 do tran[2,i]:=ysize*tran[2,i];
    end;
  procedure POSITION; {---------------------------------------------}
    {Positions figure as a new transformation is constructed.}
    var     k:char;
        xx,yy:integer;

    procedure DIRECTIONS; {....................................}
      begin
        gotoxy(1,16); writeln('SCALE  (S/W)');
                      writeln('SCALEX (A/Q)');
                      writeln('SCALEY (D/E)');
                      writeln('ROTATE  (R/F)');
                      writeln('ROTATEX (T/G)');
                      writeln('ROTATEY (Y/H)');
                      writeln('REFLECT (X)');
                      writeln('Use ARROWS to translate.');
        gotoxy(1,25); write('... Press Enter when finished ...');
      end;
    procedure REFLECT;  {......................................}
      {Flips the figure around the line x=y.}
      var  i:integer;
          xx:real;
      begin
        for i:=1 to cp do
          begin  xx:=pts[i,1]; pts[i,1]:=pts[i,2]; pts[i,2]:=xx; end;
          xx:=tran[1,1]; tran[1,1]:=tran[2,1]; tran[2,1]:=xx;
          xx:=tran[1,2]; tran[1,2]:=tran[2,2]; tran[2,2]:=xx;
      end;
    procedure ROTATE(xangle,yangle:real);  {...................}
      {Rotates the figure.  If xangle and yangle are unequal, rotation}
      {is skewed.}
      var i,j:integer;
          a,b,xca,xsa,yca,ysa:real;
      begin
        xca:=cos(xangle); xsa:=sin(xangle);
        yca:=cos(yangle); ysa:=sin(yangle);
        for i:=1 to cp do
          begin
            a:=pts[i,1]*xca-pts[i,2]*ysa;
            pts[i,2]:=pts[i,1]*xsa+pts[i,2]*yca;
            pts[i,1]:=a;
          end;
        a:=tran[1,1]*xca-tran[2,1]*ysa;
        b:=tran[1,2]*xca-tran[2,2]*ysa;
        tran[2,1]:=tran[1,1]*xsa+tran[2,1]*yca;
        tran[2,2]:=tran[1,2]*xsa+tran[2,2]*yca;
        tran[1,1]:=a; tran[1,2]:=b;
      end;
    procedure WRITETRAN; {......................................}
      var i,j:integer;
      begin
        gotoxy(1,3); writeln('Current Transformation: ');
        for i:=1 to 2 do
          begin
            for j:=1 to 2 do
              begin
                gotoxy(1+(j-1)*10, 5+(i-1));
                writeln(tran[i,j]:7:2);
              end;
            gotoxy(21, 5+(i-1));
            if i=1 then writeln(xt:7:2) else writeln(yt:7:2);
          end;
      end;
    begin
      xx:=round(xt); yy:=round(asp*yt);
      WRITETRAN; DIRECTIONS;
      k:=readkey;
      while ord(k)<>13 do
        begin
          DRAWFIG(green);
          case ord(k) of
            0: begin
                  k:=readkey;
                  case ord(k) of
                    72: yy:=yy-3;
                    77: xx:=xx+4;
                    80: yy:=yy+3;
                    75: xx:=xx-4;
                  end;
                end;
            83,115: scale(0.9,0.9);    { S for decrease }
            87,119: scale(1.1,1.1);    { W for increase }
            65,97 : scale(0.9,1);      { A for x decrease }
            68,100: scale(1,0.9);      { D for y decrease }
            81,113: scale(1.1,1);      { Q for x increase }
            69,101: scale(1,1.1);      { E for y decrease }
            82,114: rotate(0.1,0.1);   { R for rotate cw }
            70,102: rotate(-0.1,-0.1); { F for rotate ccw }
            84,116: rotate(-0.1,0);    { T for x rotate cw }
            71,103: rotate(0.1,0);     { G for x rotate ccw }
            89,121: rotate(0,-0.1);    { Y for y rotate cw }
            72,104: rotate(0,0.1);     { H for y rotate ccw }
            88,120: reflect;           { X to reflect in x=y }
          end;
          xt:=xx; yt:=yy/asp; DRAWFIG(green);
          WRITETRAN;
          k:=readkey;
        end;
    end;
  procedure SHAPE; {-------- SECTION I ------------------------------}
    {Sets up the main figure.}
    var i,j,er:integer;
             k:char;
    procedure BOX(x,y,col:integer); {..........................}
    var vs,hs,holdcol:integer;
    begin
      hs:=3; vs:=2; holdcol:=getcolor; setcolor(col);
      line(x-hs,y-vs,x+hs,y-vs);
      line(x+hs,y-vs,x+hs,y+vs);
      line(x+hs,y+vs,x-hs,y+vs);
      line(x-hs,y+vs,x-hs,y-vs);
      setcolor(holdcol);
    end;
    begin
      gotoxy(1,1); writeln('ITERATED FUNCTION SYSTEM DESIGNER');
                   writeln('Section I: Draw outline of desired figure ....');
      gotoxy(1,23); writeln('Use arrows to position cursor.');
                    writeln('Press P to place a vertex.');
                    write('Press Enter when finished.');
      i:=xoff; j:=yoff; setwritemode(xorput);
      BOX(i,j,white);
      k:=readkey; er:=1;  {Variable er used to determine when to draw box.}
      while ord(k)<>13 do
        begin
          case ord(k) of
            0: begin if er=1 then BOX(i,j,white); er:=1;
                  k:=readkey;
                  case ord(k) of
                    72: j:=j-6;
                    77: i:=i+8;
                    80: j:=j+6;
                    75: i:=i-8;
                  end;
                  BOX(i,j,white);
                end;
            80,112: begin er:=0; points[cp,1]:=i; points[cp,2]:=j;
                          if cp>1 then begin setcolor(blue);
                             line(points[cp-1,1],points[cp-1,2],
                                  points[cp,1], points[cp,2]);
                             setcolor(white); end;
                          cp:=cp+1;
                    end;
            end;
          k:=readkey;
        end;
      points[cp,1]:=points[1,1]; points[cp,2]:=points[1,2];
      setcolor(blue);
      line(points[cp-1,1],points[cp-1,2],points[1,1],points[1,2]);
      setcolor(white); setwritemode(copyput);
    end;
  procedure MAKETRAN; {---------- SECTION II ------------------------}
    {Allows construction and alteration of transformations.}
    var  nt,choice:integer;
              s,me:char;
    function MENUII:integer; {........................................}
      var xn:integer;
      begin
        gotoxy(1,1); writeln('1. Another Transformation');
                      writeln('2. Next Transformation');
                      writeln('3. Prepare to Draw');
        gotoxy(1,5); writeln('Select Number: '); me:=readkey;
        while (ord(me)<49) or (ord(me)>51) do me:=readkey;
        MENUII:=ord(me)-48;
        gotoxy(1,1);
        for xn:=1 to 5 do writeln('                           ');
      end;
    begin
      gotoxy(1,1); writeln('Section II: Build Transformations ...');
      choice:=1; nt:=0;
      if totaltran<>0 then choice:=2;
      while choice<>3 do
        begin
          if choice=2 then
              begin nt:=nt+1;
                    if nt>totaltran then nt:=1;
                    REDRAW(nt);
                    tran:=tranlist[nt];
                    xt:=tranlist[nt,1,3]; yt:=tranlist[nt,2,3];
              end
              else begin INITTRAN; totaltran:=totaltran+1;
                         nt:=totaltran;end;
          CONVPOINTS;
          if choice=2 then APPLYTRAN else SCALE(0.5,0.5);
          setwritemode(xorput);
          DRAWFIG(green);
          POSITION;
          setwritemode(copyput);
          SAVETRAN(NT);
          REDRAW(0);
          CHOICE:=MENUII;
        end;
      cleardevice;
    end;
  procedure GENERATE; {------------ SECTION III ---------------------}
    {Draw the resulting picture by applying transformations at random.}
    var xx,nm,wh,bd,cl,choice:integer;
                          x,y:real;
                           me:char;
                        probs:array[1..50] of real;

    procedure ASSIGNPROB; {....................................}
      {Determines probability of each transformation.}
      var i:integer;
          s:real;
      begin
        for i:=1 to totaltran do
          begin
            tran:=tranlist[i];
            probs[i]:=abs(tran[1,1]*tran[2,2] - tran[1,2]*tran[2,1]);
            if probs[i]<0.02 then probs[i]:=0.02;
          end;
        s:=0; for i:=1 to totaltran do s:=s+probs[i];
        for i:=1 to totaltran do probs[i]:=probs[i]/s;
        s:=0; for i:=1 to totaltran do begin s:=s+probs[i]; probs[i]:=s; end;
        probs[i]:=1;
      end;
    function PICK:integer;  {..................................}
      {Picks a transformation with designated probability distribution.}
      var j:integer;
          p:real;
      begin
        p:=random; j:=1;
        while p>probs[j] do j:=j+1;
        PICK:=j;
      end;
    procedure APPLY(w:integer); {..............................}
      {Applies chosen transformation to current point X,Y.}
      var z:real;
      begin
        tran:=tranlist[w];
        z:=tran[1,1]*X+tran[1,2]*Y;
        Y:=tran[2,1]*X+tran[2,2]*Y;
        X:=z+tran[1,3];
        Y:=Y+tran[2,3];
      end;
    procedure PUTIT(cc:integer); {.............................}
      begin
        if cl=0 then cc:=white;
        putpixel(round(X+xoff),round(Y*asp+yoff),cc);
      end;
    procedure MENUIII; {.......................................}
      var  s:string;
          xx:integer;
      begin
        bd:=0;cl:=0;
        gotoxy(1,3); write('1. Border (Toggles)');
                     gotoxy(25,3); writeln('Excluded');
                     write('2. Color  (Toggles)');
                     gotoxy(25,4); writeln('No');
                     writeln('3. Draw Image');
                     writeln;writeln('Select Number: ');
         me:='5';
         while (ord(me)<>51) do
           begin
             me:=readkey;
             while (ord(me)<49) or (ord(me)>51) do me:=readkey;
             case ord(me) of
               49: begin if bd=0 then begin bd:=1; s:='Included'; end
                                 else begin bd:=0; s:='Excluded'; end;
                         gotoxy(25,3);write(s);
                   end;
               50: begin if cl=0 then begin cl:=1; s:='Yes';end
                                 else begin cl:=0; s:='No ';end;
                         gotoxy(25,4);write(s);
                   end;
             end;
           end;
         gotoxy(1,3);
         for xx:=1 to 5 do writeln('                                     ');
      end;
    begin
      cleardevice; ASSIGNPROB; randomize;
      gotoxy(1,1); writeln('Section III: Draw Image ... ');
      MENUIII;
      if bd=1 then begin  CONVPOINTS; DRAWFIG(blue); end;
      nm:=3000;    {Number of points to plotted in final image.}
      X:=0;Y:=0;   {Initial point drawn.}
      PUTIT(7);
      for xx:=1 to nm do
        begin
          wh:=PICK; APPLY(wh); PUTIT((wh mod 7)+1);
        end;
    end;
  procedure FILESAVE;
  {To save transformations on disk.}
    var        i:integer;
        tranfile:file of matrix;
    begin
      assign(tranfile, 'IFS.DAT');
      rewrite(tranfile);
      for i:=1 to totaltran do write(tranfile, tranlist[i]);
      close(tranfile);
    end;
  function MENUIV:boolean; {.......................................}
      var  s:string;
          me:char;
      begin
        gotoxy(1,3); writeln('1. Return to Section II');
                     writeln('2. Save transformations on file');
                     writeln('3. Quit');
                     writeln;writeln('Select Number: ');
         me:='2';
         while me='2' do
           begin
             me:=readkey;
             while (ord(me)<49) or (ord(me)>51) do me:=readkey;
             if me='2' then begin FILESAVE;
                                  gotoxy(1,9); writeln('DATA SAVED');
                            end;
           end;
         if me='1' then MENUIV:=true else MENUIV:=false;
      end;
  BEGIN  {----------------- Main Body ------------------------------}
    gd:=detect; initgraph(gd,gm,'');
    directvideo:=false; {Allows text using WRITE statements.}
    INIT; cleardevice;
    SHAPE;                 {... Section I   ...}
    select:=true;
    while select do
       begin
           REDRAW(0);
           MAKETRAN;       {... Section II  ...}
           GENERATE;       {... Section III ...}
           select:=MENUIV;
       end;
    cleardevice; closegraph;
  END.




[LISTING FOUR]

PROGRAM FOREST; {A mixture of two systems to produce a forest of ferns}
  uses graph;
  var  n,xoff,yoff,gd,gm,cl: integer;
                  xsc,ysc,x,y,bx,by,asp:real;
                          xasp,yasp:word;
  const
        {CT holds the IFS for a fern}
        CT:array[1..4,1..7] of real =
           ((    0,    0,    0,    0, 0.16,     0, 0.02),
            (  0.2,-0.26,    0, 0.23, 0.22,   -24, 0.065),
            (-0.15, 0.28,    0, 0.26, 0.24,  -6.6, 0.065),
            ( 0.85, 0.04,    0,-0.04, 0.85,   -24, 0.85));
        {PL holds additional IFS functions to produce the forest}
        PL:array[1..2,1..6] of real =
           ((  0.8,  0,  80,  0, 0.8, -65),
            (  0.8,  0, -80,  0, 0.8, -60));
        PROB:array[1..6] of real = (0.008, 0.034, 0.06, 0.4, 0.7, 1.0);
  procedure MAKETRAN;
    var nx,ny:real;
            s:integer;
    function FINDTRAN:integer;
      var i:integer;
          w:real;
      begin
        w:=random; I:=1;
        while w>PROB[i] do i:=i+1;
        FINDTRAN:=i;
      end;
    begin
      s:=FINDTRAN;
      if s<5 then {Generate another point in the fern.}
          begin
            nx:=CT[s,1]*x + CT[s,2]*y + CT[s,3];
            ny:=CT[s,4]*x + CT[S,5]*y + CT[s,6];
            x:=nx; y:=ny; bx:=x; by:=y;
          end
         else     {Generate another point in the forest.}
          begin
           s:=s-4;
           nx:=PL[s,1]*bx + PL[s,2]*by + PL[s,3];
           ny:=PL[s,4]*bx + PL[s,5]*by + PL[s,6];
           bx:=nx; by:=ny;
          end;
    end;
  procedure INIT;
    begin
      xsc:=1.3; ysc:=1;
      xoff:=round(GETMAXX/2); yoff:=GETMAXY-50;
      x:=0; y:=0;
      bx:=0; by:=0;
      GETAspectRatio(xasp,yasp); asp:=xasp/yasp;
    end;
  BEGIN
    gd:=detect; initgraph(gd,gm,' ');
    INIT; cleardevice;
    for N:=1 to 32000 do
      begin
        MAKETRAN;
        putpixel(round(bx*xsc)+xoff,(round(asp*by*ysc)+yoff),green);
      end;
    readln; cleardevice; closegraph;
  END.