program agmath2; {produziert aus verschiedenen Ausgangsmengen verschiedene
weitere Grenz-Fraktale und gibt die Collage-Abbildungen numerisch und
graphisch aus.
An Stelle eines arrays werden die Bildschirmdaten in einer Datei erfaát.
Voreinstellung Optionen/Memory/Stack: 65520; Gilbert Helmberg, 21.11.2006}

uses crt,graph,graph0,dialog2,xpzeich1;

type triple = array[1..3] of word; {(tr[1],tr[2])=Pixel, tr[3]=Farbe}
     screenfile = file of triple;  {nimmt Pixelpunkte mit Farbe auf}
     matrix = array[1..2,1..2] of real;
     vector = array[1..2] of real;  {f�r affine Abbildung f(z)=A*z+b}
     vecarray = array[1..10] of vector; {registriert Fixpunkte der Collage}
     chart = array[0..9] of byte;   {registriert die Farben f�r IFS-Abb.}

var A:matrix;
    b,o,z0:vector;
    tr:triple;
    screen:screenfile;
    ch,chm,chc:char;
    i,am,g,h,hg,n,x0,y0,x1,y1,graphdriver,graphmode:integer;
    driverpath:string20;
    links,rechts,unten,oben,c,r,sc,t,phi,dim,tol:real;
    s:array[1..8] of real;  {Verk�rzungsfaktoren der Collage-Žhnlichkeiten}
    fix:vecarray;
    colorchart,colorchartold:chart;

procedure xpnumberxy(z:real;a,d,x,y,color:integer;var xarr:xarray);
  var i,j,k,xz,yz,n,c,code,
      oldcolor:integer;            {Ausgabe der Zahl z im Grafikmodus f�r}
      st:string;                   {das Betriebssystem XP; Anfang im linken}
      ch,chi:char;                 {oberen Pixelpunkt (x,y), in Farbe color}
begin
oldcolor:=getcolor;
setcolor(color);
xar(color,xarr);
str(z:a:d,st);
for i:=1 to length(st) do
  begin
  xz:=x+(i-1)*width;
  yz:=y;
  chi:=st[i];
  n:=ord(chi);
  for j:=0 to 7 do
    for k:=0 to 7 do
      begin
      xz:=x+(i-1)*8+k;
      yz:=y+j;
      c:=xarr[n,j,k];
      if c<>0 then c:=color;
      putpixel(xz,yz,c);
      end;   {k-Schleife}
  end;  {i-Schleife}
setcolor(oldcolor);
end;  {xpnumberxy}

procedure xptextxy(st:string;x,y,color:integer;var xarr:xarray);
  var i,j,k,xz,yz,n,
      c,oldcolor:integer;  {Ausgabe des Strings st im Grafikmodus f�r das}
      ch,chi:char;         {Betriebssystem XP; Anfang im linken}
                           {oberen Pixelpunkt (x,y), in Farbe color}
begin
setbkcolor(15);
oldcolor:=getcolor;
setcolor(color);
xar(color,xarr);
for i:=1 to length(st) do
  begin
  xz:=x+(i-1)*width;
  yz:=y;
  chi:=st[i];
  n:=ord(chi);
  if n>63 then outtextxy(xz,yz,chi)    {chi = gew”hnlicher Buchstabe}
    else                               {chi = Zeichen}
    for j:=0 to 7 do
      for k:=0 to 7 do
        begin
        xz:=x+(i-1)*8+k;
        yz:=y+j;
        putpixel(xz,yz,xarr[n,j,k]);
        end;   {k-Schleife}
  end;  {i-Schleife}
setcolor(oldcolor);
end;  {xptextxy}

procedure bild(var links,rechts,unten,oben:real;
               var x0,y0,x1,y1:integer);
begin
links:=-0.6;
rechts:=1.2;
unten:=-0.2;
oben:=1.2;
x0:=bildx(links,rechts,0);
y0:=bildy(unten,oben,0);
x1:=bildx(links,rechts,1);
y1:=bildy(unten,oben,1);
end;  {bild}

procedure affin(A:matrix;b:vector;var z,za:vector);
  var i:byte;                   {affine Abbildung z->za=A*z+b}
begin
for i:=1 to 2 do
  za[i]:=A[i,1]*z[1]+A[i,2]*z[2]+b[i];
end;  {affin}

procedure initiateaffine(g,h:integer;var hb:integer;t,phi:real;
                         var A:matrix;var b:vector);
  var w3,d,r:real;
begin          { Definition der Abbildung f(z)=A.z+b mittels der Matrix A }
w3:=sqrt(3);   { und des Vektors b; g unterscheidet die Grenzwertmengen}
case g of
  1:begin      {Koch-Kurve}
    hg:=4;
    case h of           { h unterscheidet die Collage-Abbildungen }
      1:begin           { hg = Anzahl der Collage-Abbildungen }
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=0;
        b[2]:=0;
	end;
      2:begin
        A[1,1]:=1/6;
        A[1,2]:=-w3/6;
        A[2,1]:=w3/6;
        A[2,2]:=1/6;
        b[1]:=1/3;
        b[2]:=0;
	end;
      3:begin           { hg = Anzahl der Collage-Abbildungen }
        A[1,1]:=1/6;
        A[1,2]:=w3/6;
        A[2,1]:=-w3/6;
        A[2,2]:=1/6;
        b[1]:=1/3;
        b[2]:=0;
        b[1]:=1/2;
        b[2]:=w3/6;
	end;
      4:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=2/3;
        b[2]:=0;
	end;
      end; {case g=1, Koch-Kurve}
    end;
  2:begin        {Kurz-Fraktal}
    hg:=2;
    case h of
      1:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0;
       b[2]:=0;
       end; {l=1}
     2:begin
       A[1,1]:=0;
       A[1,2]:=-0.5;
       A[2,1]:=0.5;
       A[2,2]:=0;
       b[1]:=1;
       b[2]:=0.5;
       end;  {l=2}
     end;  {case h}
   end;  {g=2, Kurz-Fraktal}
  3:begin             {gls.Sierpinski-Dreieck}
    hg:=3;
    case h of
      1:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0;
       b[2]:=0;
       end;
     2:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0.5;
       b[2]:=0;
       end;
     3:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0.25;
       b[2]:=w3/4;
       end;
      end; {case h}
    end;  {g=3, gls. Sierpinski-Dreieck}
  4:begin                {rw. Sierpinski-Dreieck}
    hg:=3;
    case h of
      1:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0;
       b[2]:=0;
       end;
     2:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0.5;
       b[2]:=0;
       end;
     3:begin
       A[1,1]:=0.5;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=0.5;
       b[1]:=0;
       b[2]:=0.5;
       end;
      end; {case h}
    end;  {g=4, rechtw. Sierpinski-Dreieck}
  5:begin                {Cantor-Staub}
    hg:=4;
    case h of
    1:begin
        A[1,1]:=1/4;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/4;
        b[1]:=1/4;
        b[2]:=0;
        end;
      2:begin
        A[1,1]:=1/4;
        A[1,2]:=0;
        A[2,1]:=0;
	A[2,2]:=1/4;
	b[1]:=3/4;
	b[2]:=1/4;
        end;
      3:begin
        A[1,1]:=1/4;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/4;
        b[1]:=0;
        b[2]:=1/2;
        end;
      4:begin
        A[1,1]:=1/4;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/4;
        b[1]:=1/2;
        b[2]:=3/4;
        end;
      end; {case h}
    end; {g=5, Cantor-Staub}
  6:begin               {Sierpinski-Teppich}
    hg:=8;
    case h of
      1:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=0;
        b[2]:=0;
	end;
      2:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=1/3;
        b[2]:=0;
	end;
      3:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=2/3;
        b[2]:=0;
	end;
      4:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=0;
        b[2]:=1/3;
	end;
      5:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=2/3;
        b[2]:=1/3;
	end;
      6:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=0;
        b[2]:=2/3;
	end;
      7:begin
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=1/3;
        b[2]:=2/3;
	end;
      8:begin           { hg = Anzahl der Collage-Abbildungen }
        A[1,1]:=1/3;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=1/3;
        b[1]:=2/3;
        b[2]:=2/3;
	end;
      end;  {g=6, Sierpinski-Teppich}
    end;
  7:begin               { Kreuz}
    hg:=5;
    case h of
      1:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=0;
       end;
      2:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=2/3;
       b[2]:=1/3;
       end;
      3:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=2/3;
       end;
      4:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=0;
       b[2]:=1/3;
       end;
      5:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=1/3;
       end;
     end; {g=7, Kreuz}
   end;
  8:begin               { Ornament}
    hg:=4;
    case h of
      1:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=0;
       end;
      2:begin
       A[1,1]:=0;
       A[1,2]:=-1/3;
       A[2,1]:=1/3;
       A[2,2]:=0;
       b[1]:=1/3;
       b[2]:=0;
       end;
      3:begin
       A[1,1]:=0;
       A[1,2]:=1/3;
       A[2,1]:=-1/3;
       A[2,2]:=0;
       b[1]:=2/3;
       b[2]:=1/3;
       end;
      4:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=2/3;
       b[1]:=1/3;
       b[2]:=1/3;
       end;
     end;  {g=8, Ornament}
    end;
  9:begin               { Antenne}
    hg:=4;
    case h of
      1:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=0;
       end;
      2:begin
       A[1,1]:=0;
       A[1,2]:=1/3;
       A[2,1]:=-1/3;
       A[2,2]:=0;
       b[1]:=1/3;
       b[2]:=1/3;
       end;
      3:begin
       A[1,1]:=0;
       A[1,2]:=-1/3;
       A[2,1]:=1/3;
       A[2,2]:=0;
       b[1]:=2/3;
       b[2]:=1/3;
       end;
      4:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=2/3;
       b[1]:=1/3;
       b[2]:=1/3;
       end;
     end;  {g=9, Antenne}
   end;
 10:begin               { Ziergarten}
    hg:=3;
    case h of
      1:begin
       A[1,1]:=1/3;
       A[1,2]:=0;
       A[2,1]:=0;
       A[2,2]:=1/3;
       b[1]:=1/3;
       b[2]:=2/3;
       end;
      2:begin
       A[1,1]:=0;
       A[1,2]:=-1/3;
       A[2,1]:=1;
       A[2,2]:=0;
       b[1]:=1/3;
       b[2]:=0;
       end;
      3:begin
       A[1,1]:=0;
       A[1,2]:=1/3;
       A[2,1]:=-1;
       A[2,2]:=0;
       b[1]:=2/3;
       b[2]:=1;
       end;
    end;  {g=10, Ziergarten}
  end;
  11:begin                         {Zweig}
    hg:=3;
    case h of
       1:begin
        A[1,1]:=0.387;
        A[1,2]:=0.430;
        A[2,1]:=0.430;
        A[2,2]:=-0.387;
        b[1]:=0.1760;
        b[2]:=0.5220;
        end;
      2:begin
        A[1,1]:=0.441;
        A[1,2]:=-0.091;
        A[2,1]:=-0.009;
        A[2,2]:=-0.322;
        b[1]:=0.3419;
        b[2]:=0.5059;
        end;
      3:begin
        A[1,1]:=-0.468;
        A[1,2]:=0.02;
        A[2,1]:=-0.113;
        A[2,2]:=0.015;
        b[1]:=0.32;
        b[2]:=0.4;
        end;
      end{case h}
    end; {g=11, Zweig}
  12:begin                         {Baum}
    hg:=5;
    case h of    {Baum Peitgen/J�rgens/Saupe 1998}
        1:begin
        A[1,1]:=0.195;
        A[1,2]:=-0.488;
        A[2,1]:=0.344;
        A[2,2]:=0.443;
        b[1]:=0.4431;
        b[2]:=0.2452;
        end;
      2:begin
        A[1,1]:=0.462;
        A[1,2]:=0.414;
        A[2,1]:=-0.252;
        A[2,2]:=0.361;
        b[1]:=0.2511;
        b[2]:=0.5692;
        end;
      3:begin
        A[1,1]:=-0.058;
        A[1,2]:=-0.07;
        A[2,1]:=0.453;
        A[2,2]:=-0.111;
        b[1]:=0.5976;
        b[2]:=0.0969;
        end;
      4:begin
        A[1,1]:=-0.035;
        A[1,2]:=0.07;
        A[2,1]:=-0.469;
        A[2,2]:=-0.022;
        b[1]:=0.4884;
        b[2]:=0.5069;
        end;
      5:begin
        A[1,1]:=-0.637;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=0.501;
        b[1]:=0.8562;
        b[2]:=0.2513;
        end;
      end{case h}
    end; {g=12, Baum}
  13:begin                {Blatt}
    hg:=4;
    case h of
    1:begin
        A[1,1]:=0.6;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=0.6;
        b[1]:=0.18;
        b[2]:=0.36;
        end;
      2:begin
        A[1,1]:=0.6;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=0.6;
        b[1]:=0.18;
        b[2]:=0.12;
        end;
      3:begin
        A[1,1]:=0.4;
        A[1,2]:=0.3;
        A[2,1]:=-0.3;
        A[2,2]:=0.4;
        b[1]:=0.27;
        b[2]:=0.36;
        end;
      4:begin
        A[1,1]:=0.4;
        A[1,2]:=-0.3;
        A[2,1]:=0.3;
        A[2,2]:=0.4;
        b[1]:=0.27;
        b[2]:=0.09;
        end;
      end; {case h}
    end; {g=13, Blatt}
  14:begin                       { Barnsley-Farn }
    hg:=4;
    case h of
       1:begin
        A[1,1]:=0;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=0.16;
        b[1]:=0.5;
        b[2]:=0;
        end;
      2:begin
        A[1,1]:=0.849;
        A[1,2]:=0.037;
        A[2,1]:=-0.037;
        A[2,2]:=0.8495;
        b[1]:=0.075;
        b[2]:=0.183;
        end;
      3:begin
        A[1,1]:=0.197;
        A[1,2]:=-0.226;
        A[2,1]:=0.226;
        A[2,2]:=0.197;
        b[1]:=0.4;
        b[2]:=0.049;
        end;
      4:begin
        A[1,1]:=-0.15;
        A[1,2]:=0.283;
        A[2,1]:=0.26;
        A[2,2]:=0.237;
        b[1]:=0.575;
        b[2]:=-0.084;
        end;
      end{case h}
    end; {g=14, Barnsley-Farn }
  15:begin                         {Pentagon-Schneeflocke}
    hg:=5;
    d:=1/(2*(1+sin(pi/5)));
    r:=d*sin(pi/5);
    case h of
       1:begin
        A[1,1]:=2*t*r;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=2*t*r;
        b[1]:=1/2-d*sin(4*pi/5)-t*r;
        b[2]:=1/2+d*cos(4*pi/5)-t*r;
        end;
       2:begin
        A[1,1]:=2*t*r;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=2*t*r;
        b[1]:=1/2-d*sin(6*pi/5)-t*r;
        b[2]:=1/2+d*cos(6*pi/5)-t*r;
        end;
       3:begin
        A[1,1]:=2*t*r;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=2*t*r;
        b[1]:=1/2-d*sin(8*pi/5)-t*r;
        b[2]:=1/2+d*cos(8*pi/5)-t*r;
        end;
       4:begin
        A[1,1]:=2*t*r;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=2*t*r;
        b[1]:=1/2-t*r;
        b[2]:=1/2+d-t*r;
        end;
       5:begin
        A[1,1]:=2*t*r;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=2*t*r;
        b[1]:=1/2-d*sin(2*pi/5)-t*r;
        b[2]:=1/2+d*cos(2*pi/5)-t*r;
        end;
      end;  {g=15, Pentagon-Schneeflocke}
    end;
  16:begin                         {Flocke}
    hg:=3;
    d:=1/(2*(1+sin(pi/3)));
    r:=d*sin(pi/3);
    case h of
       1:begin
        A[1,1]:=0;
        A[1,2]:=2*t*r;
        A[2,1]:=-2*t*r;
        A[2,2]:=0;
        b[1]:=1/2-d*sin(2*pi/3)-t*r;
        b[2]:=1/2+d*cos(2*pi/3)+t*r;
        end;
       2:begin
        A[1,1]:=0;
        A[1,2]:=2*t*r;
        A[2,1]:=-2*t*r;
        A[2,2]:=0;
        b[1]:=1/2-d*sin(4*pi/3)-t*r;
        b[2]:=1/2+d*cos(4*pi/3)+t*r;
        end;
       3:begin
        A[1,1]:=0;
        A[1,2]:=2*t*r;
        A[2,1]:=-2*t*r;
        A[2,2]:=0;
        b[1]:=1/2-t*r;
        b[2]:=1/2+d+t*r;
        end;
      end; {g=16, Dreifach-Kontinent}
    end;
  17:begin             {Gras}
    hg:=4;
    case h of
       1:begin         {Stiel}
        A[1,1]:=0;
        A[1,2]:=0;
        A[2,1]:=0;
        A[2,2]:=0.3;
        b[1]:=0.5;
        b[2]:=0.11;
        end;
      2:begin          {Mittelteil}
        A[1,1]:=0.60*cos(phi)-0.0324*sin(phi);
        A[1,2]:=-0.6984*sin(phi);
        A[2,1]:=0.0324*cos(phi)+0.60*sin(phi);
        A[2,2]:=0.6984*cos(phi);
        b[1]:=-0.3*cos(phi)+0.1*sin(phi)+0.5;
        b[2]:=-0.04*cos(phi)-0.24*sin(phi)+0.3;
        end;
      3:begin          {linkes Blatt}
        A[1,1]:=0.3216;
        A[1,2]:=-0.414;
        A[2,1]:=0.2784;
        A[2,2]:=0.414;
        b[1]:=0.404;
        b[2]:=0.008;
        end;
      4:begin          {rechtes Blatt}
        A[1,1]:=0.246;
        A[1,2]:=0.4368;
        A[2,1]:=-0.2232;
        A[2,2]:=0.3492;
        b[1]:=0.3116;
        b[2]:=0.368;
        end;
      end{case h}
    end; {g=17, Gras}
  end; { case g}
end;   {initiateaffine}

procedure axes(color:word);
begin
setcolor(color);
line(width,y0,maxx-width,y0);  { x-Achse }
line(x0,height,x0,maxy-height);{ y-Achse }
vertmarkexy(x1,y0);            { Einheit auf der x-Achse }
horimarkexy(x0,y1);            { Einheit auf der y-Achse }
xpnumberxy(1,1,0,x0-2*width,y1-height,color,xarr);
xpnumberxy(1,1,0,x1+width div 2,y0+height,color,xarr);
end;  {axes}

procedure axesb(color:word);
  var x2,y2:integer;
      oldcolor:word;
begin
x2:=bildx(links,rechts,0.5);
y2:=bildy(unten,oben,0.16);
oldcolor:=getcolor;
setcolor(color);
line(width,y0,maxx-width,y0);
line(x0,height,x0,maxy-height);
line(x2,height,x2,y2);
line(x0,y2,x2,y2);
horimarkexy(x0,y1);
vertmarkexy(x1,y0);
xpnumberxy(1,1,0,x0-width,y1,7,xarr);
xpnumberxy(1,1,0,x1,y0+height,7,xarr);
xpnumberxy(0.16,4,2,x0-4*width,y2,7,xarr);
xpnumberxy(0.5,3,1,x2,y0+height,7,xarr);
outtextxy(x2-width,height,'u');
setcolor(oldcolor);
end;  {axesb}

procedure applyifs(g:integer;var screen:screenfile;colorchart:chart);
  var tr:triple;
      i,j,p:word;
      dx,dy,x,y,xf,yf:real;
      b,z,za:vector;
      A:matrix;
begin
dx:=(rechts-links)/maxx;
dy:=(oben-unten)/maxy;
assign(screen,'screen0');
rewrite(screen);
for i:=0 to maxx do
  begin
  z[1]:=dx*(i-x0);
  for j:=0 to maxy-10 do
    if getpixel(i,j)<>0 then
      begin
      z[2]:=dy*(y0-j);
      h:=0;
      repeat
        h:=h+1;
        tr[3]:=colorchart[h];
        initiateaffine(g,h,hg,t,phi,A,b);
        affin(A,b,z,za);
        tr[1]:=bildx(links,rechts,za[1]);
        tr[2]:=bildy(unten,oben,za[2]);
        write(screen,tr);
        until h=hg;  {h-Schleife}
      end;  {getpixel(i,j)<>0}
  end;  {i-Schleife}
close(screen);
cleardevice;
reset(screen);
repeat
  read(screen,tr);
  putpixel(tr[1],tr[2],tr[3]);
  until eof(screen);
close(screen);
end;  {applyifs}

procedure initiatescreen(var screen:screenfile;am:integer);
  var i,j:word;
      dx,dy,x,y,sqr3:real;
      tr:triple;
      boole1,boole2,boole3,boole4,boole:boolean;
begin
dx:=(rechts-links)/maxx;
dy:=(oben-unten)/maxy;
tr[3]:=4;
sqr3:=sqrt(3);
randomize;
assign(screen,'screen0');
rewrite(screen);
for i:=0 to maxx do
  begin
  tr[1]:=i;
  x:=dx*(i-x0);
  for j:=0 to maxy -2*height do
    begin
    tr[2]:=j;
    y:=dy*(y0-j);
    case am of                                               {Quadratseiten}
      1:begin
        boole1:=((abs(x-0.5)<=0.5) and (abs(y)<0.005));
        boole2:=((abs(x-0.5)<=0.5) and (abs(y-1)<0.005));
        boole3:=((abs(y-0.5)<=0.5) and (abs(x)<0.005));
        boole4:=((abs(y-0.5)<=0.5) and (abs(x-1)<0.005));
        boole:=(boole1 or boole2 or boole3 or boole4)
        end;  {1}
      2:boole:=((abs(x-0.5)<=0.5) and (abs(y-0.5)<=0.5));    {Vollquadrat}
      3:boole:=((y>=0) and (y<=sqr3*x) and (y<=sqr3*(1-x))); {gls.Dreieck}
      4:boole:=((x>=0) and (y>=0) and (x+y<=1));             {rw.Dreieck}
      5:boole:=(x-0.5)*(x-0.5)+(y-0.5)*(y-0.5)<=0.25;        {Vollkreis}
      6:boole:=((x>=0) and (y>=0) and (x*x+y*y<=1));         {Viertelkreis}
      7:boole:=((abs(x-0.5)<=0.5) and (abs(y-0.5)<=0.5) and (random(n)=1));
      8:begin
        boole1:=((abs(x-0.5)<=0.25) and (abs(y-0.25)<0.005)); {Quadratseiten}
        boole2:=((abs(x-0.5)<=0.25) and (abs(y-0.75)<0.005)); {Kleinquadrat}
        boole3:=((abs(y-0.5)<=0.25) and (abs(x-0.25)<0.005));
        boole4:=((abs(y-0.5)<=0.25) and (abs(x-0.75)<0.005));
        boole:=(boole1 or boole2 or boole3 or boole4)
        end;
      9:boole:=((abs(x-0.5)<=0.25) and (abs(y-0.5)<=0.25)); {kleines Vollqu.}
     10:boole:=((abs(x-0.5)<=0.5) and (abs(y)<0.005));    {Einheitsintervall}
      end;  {case}
    if boole then
      begin
      putpixel(i,j,1);
      write(screen,tr);
      end;  {boole}
    end;  {j-Schleife}
  end;    {i-Schelife}
close(screen);
end;  {initiatescreen}

procedure abbildungswahl(var g,h:integer;sc:real);
begin
clrscr;
writeln;
initiateaffine(g,h,hg,t,phi,A,b);
writeln(' Verk�rzungsfaktor der Collage: sc ó ',sc:4:2);
writeln(' Anzahl der Collage-Abbildungen hg = ',hg);
write(' Ausgegeben wird die Abbildung mit der Nummer h = ');
repeat readgwritexy(wherex,wherey,1,h)
  until ((0<h) and (h<=hg));
writeln;
end;  {abbildungswahl}

procedure nameimage(A:matrix;b:vector;z1,z2:real;var x,y:integer;
                    name:string); {benennt Bildpunkt von z}
  var z,za:vector;
begin
z[1]:=z1;
z[2]:=z2;
affin(A,b,z,za);
x:=bildx(links,rechts,za[1]);
y:=bildy(unten,oben,za[2]);
outtextxy(x-width,y-height,name);
end;  {nameimage}

procedure invers(var A,AI:matrix);
  var d:real;     {A*AI=I}
      i,j:byte;
begin
d:=A[1,1]*A[2,2]-A[1,2]*A[2,1];
for i:=1 to 2 do
  AI[i,i]:=A[3-i,3-i]/d;
AI[1,2]:=-A[1,2]/d;
AI[2,1]:=-A[2,1]/d;
end;   {invers}

procedure showfix(fix:vecarray;k:integer;colorchart:chart);
  var h:integer; {markiert Fixpunkte von k Abbildungen durch Kreuze}
begin
for h:=1 to k do
  kreuz(bildx(links,rechts,fix[h,1]),bildy(unten,oben,fix[h,2]),
    colorchart[h]);
end;  {showfix}

procedure fixpunkt(A:matrix;var b,z:vector);
var C,CI:matrix;
begin
C[1,1]:=1-A[1,1];
C[1,2]:=-A[1,2];
C[2,1]:=-A[2,1];
C[2,2]:=1-A[2,2];
invers(C,CI);
affin(CI,o,b,z);
end;

procedure farbwechsel(var colorchart:chart);
  var i:integer;
begin
if colorchart[0]=0 then
  for i:=0 to 9 do colorchart[i]:=1
    else for i:=0 to 9 do colorchart[i]:=i;
end;  {farbwechsel}

procedure contraction(A:matrix;var s:real);
var i,j:integer;                   {zahlenm„áige Ausgabe der Eigenwerte}
   ew1,ew2,b1,b2,b3:real;          {ew1>=ew2 von A^t.A und des}
begin                              {Kontraktionsfaktors s=sqrt(ew1)}
b1:=sqr(A[1,1])+sqr(A[2,1]);
b2:=sqr(A[1,2])+sqr(A[2,2]);
b3:=A[1,1]*A[1,2]+A[2,1]*A[2,2];
ew1:=(b1+b2+sqrt(sqr(b1-b2)+4*sqr(b3)))/2;
ew2:=(b1+b2-sqrt(sqr(b1-b2)+4*sqr(b3)))/2;
s:=sqrt(ew1);
end;  {contraction}

procedure collagecontraction(g:integer;var sc:real);
  var A:matrix;     {berechnet den Kontraktionsfaktor der Collage}
      b:vector;
      s:real;
      h:integer;
begin
sc:=0;
h:=0;
  repeat
  h:=h+1;
  initiateaffine(g,h,hg,t,phi,A,b);
  contraction(A,s);
  if s>sc then sc:=s;
  until h=hg;
end;  {collagecontraction}

procedure zeigeabbildung(A:matrix;var b,z0:vector);
  var i,j,xa,xb,xc,ya,yb,yc, {zahlenm„áige Ausgabe der Matrix A, des}
      x,y:integer;            {Vektors b, der Determinante, der Eigenwerte}
      det,s:real;            {ew1>=ew2 von A^t.A und des Kontraktionsfaktors}
begin                        {s=sqrt(ew1)}
det:=A[1,1]*A[2,2]-A[1,2]*A[2,1];
contraction(A,s);
fixpunkt(A,b,z0);
clrscr;
writeln;              {Ausgabe der Matrix A und des Verschiebungsvektors b}
writeln
('     ',chr(218),A[1,1]:6:3,'   ',A[1,2]:6:3,' ',chr(191),
    '           ',chr(218),b[1]:6:3,' ',chr(191));
writeln(' A = ',chr(179),'                ',chr(179),
       ';     b  = ',chr(179),'       ',chr(179));
writeln
('     ',chr(192),A[2,1]:6:3,'   ',A[2,2]:6:3,' ',chr(217),
    '           ',chr(192),b[2]:6:3,' ',chr(217));
writeln;
writeln(' det(A) = ',det:6:3);
writeln(' Verk�rzungsfaktor s = ',s:6:3);
writeln(' Fixpunkt z0 = [',z0[1]:6:3,',',z0[2]:6:3,']');
ch:=readkey;
setgraphmode(graphmode);
setbkcolor(15);
axes(7);
setcolor(3);
line(x0,y0,x1,y0);
line(x0,y0,x0,y1);
line(x1,y0,x0,y1);
outtextxy(x0-width,y0+height,'C');
outtextxy(x1-width,y0+height,'A');
outtextxy(x0-width,y1-height,'B');
setcolor(4);
nameimage(A,b,0,0,xc,yc,'c');
nameimage(A,b,1,0,xa,ya,'a');
nameimage(A,b,0,1,xb,yb,'b');
line(xa,ya,xb,yb);
line(xb,yb,xc,yc);
line(xc,yc,xa,ya);
x:=bildx(links,rechts,z0[1]);
y:=bildy(unten,oben,z0[2]);
kreuz(x,y,2);
ch:=readkey;
restorecrtmode;
end;  {zeigeabbildung}

procedure dimension(var dim:real;g:integer;t,phi,tol:real); {berechnet die Hausdorff-
dimension eines Fraktals, wenn die Collage aus hg Žhnlichkeiten mit den
Verk�rzungsfaktoren s[.] besteht: ä s[i]^dim=1}
  var zaehler,nenner,bruch,r,s,u,x,xneu:real;
      i:integer;
begin
x:=1;
repeat                  { Newton-Verfahren f�r f(x)=ä s[i]^x-1 }
  zaehler:=-1;
  nenner:=0;
  h:=0;
  repeat
    h:=h+1;
    initiateaffine(g,h,hg,t,phi,A,b);
    contraction(A,s);
    r:=Ln(s);
    u:=exp(x*r);          { u=s[i]^x }
    zaehler:=zaehler+u;
    nenner:=nenner+u*r;
    until h=hg;  {h-Schleife}
  bruch:=zaehler/nenner;
  xneu:=x-bruch;
  x:=xneu;
  until abs(bruch)<tol;
dim:=x;
end;  {dimension}

procedure menu(var g,am,n:integer;var t,phi:real;var chm:char);
begin
c:=1;
t:=1;
clrscr;
writeln;
writeln(' Grenzmenge:');
writeln(' Koch-Kurve ................ 1; Zweig ..................11;');
writeln(' Kurz-Fraktal .............. 2; Baum .................. 12;');
writeln(' Sierpinski-Dreieck (gls.) . 3; Blatt ................. 13;');
writeln(' Sierpinski-Dreieck (rw.) .. 4; Barnsley-Fan........... 14;');
writeln(' Cantor-Staub .............. 5; Pentagon-Schneeflocke . 15;');
writeln(' Sierpinski-Teppich ........ 6; Dreifach-Kontinent .... 16;');
writeln(' Kreuz .............. ...... 7; Gras im Wind .......... 17;');
writeln(' Ornament .................. 8; Programm-Ende ......... 0;');
writeln(' Antenne ................... 9;');
writeln(' Ziergarten ................10;');
writeln;
write(' Gew„hlt wird g = ');
repeat readgwritexy(wherex,wherey,1,g)
  until ((0<=g) and (g<18));
writeln;
writeln;
if g=15 then                         {Pentagon-Schneeflocke}
  begin
  write(' W„hle den Parameter t im Intervall [1,1.0319]: t = ');
  repeat readrwritexy(wherex,wherey,6,4,t)
         until ((1<=t) and (t<=1.0319));
  writeln;
  end;
if g=16 then                          {Dreifach-Kontinent}
  begin
  write(' W„hle den Parameter t im Intervall [1,1.244]: t = ');
  repeat readrwritexy(wherex,wherey,6,4,t)
         until ((1<=t) and (t<=1.244));
  writeln;
  end;
if g=17 then                           {Gras im Wind}
  begin
  write(' W„hle den Winkel phi im Intervall [0ø,45ø]: phi = ');
  repeat readrwritexy(wherex,wherey,2,0,phi)
         until ((0<=phi) and (phi<=45));
  phi:=phi*pi/180;
  writeln;
  end;
writeln;
if g>0 then                             {g=18 ... Programmende}
  begin
{  initiateaffine(g,1,hg,t,phi,A,b);}
  writeln(' Iteration ................. i');
  writeln(' Abbildungs-Ausgabe ........ a');
  writeln(' Dimension ................. d');
  repeat chm:=readkey
    until chm in ['a','i','d'];
  if chm='i' then
    begin
    clrscr;
    writeln;
    writeln(' Ausgangsmenge: Quadratrand groá........ 1');
    writeln('                Vollquadrat groá........ 2');
    writeln('                gls.Dreieck ............ 3');
    writeln('                rw. Dreieck ............ 4');
    writeln('                Vollkreis .............. 5');
    writeln('                Viertelkreis ........... 6');
    writeln('                Zufallsmenge ........... 7');
    writeln('                Quadratrand klein ...... 8');
    writeln('                Vollquadrat klein ...... 9');
    writeln('                Einheitsintervall ......10');
    writeln;
    write(' Gew„hlt wird am = ');
    repeat readgwritexy(wherex,wherey,1,am)
     until ((0<am) and (am<=10));
    writeln;
    writeln;
    if am=7 then
      begin
      write(' Dichte der Menge 1/n: n = ');
      repeat readgwritexy(wherex,wherey,2,n)
        until 0<n;
      end;  {am=5}
    end;  {'i'}
  end; {g>0}
end;  {menu}

begin{main}
graphdriver:=9;        {bgi-Datei egavga.bgi muá im aktuellen Ordner sein}
graphmode:=2;
initgraph(graphdriver,graphmode,'');
graphvariables(maxx,maxy,width,height);
restorecrtmode;
o[1]:=0;                  {Nullvektor}
o[2]:=0;
t:=1;                     {Zoomfaktor f�r Collagen}
phi:=0;                   {Winkel f�r Collage 17, Gras im Wind}
g:=1;                     {Nummer der Collage}
h:=1;                     {Nummer der Abbildung}
am:=1;                    {Nummer der Ausgangsmenge}
n:=2;                     {1/n=Dichte der Zufalls-Ausgangsmenge}
tol:=0.001;               {Toleranz f�r Dimensionsberechnung}
for i:=0 to 9 do
  colorchart[i]:=i;        {vielf„rbige Initialisierung}
repeat
  menu(g,am,n,t,phi,chm);
  bild(links,rechts,unten,oben,x0,y0,x1,y1);
  if g=0 then halt;
  case chm of
    'i':begin
        h:=0;
        repeat
          h:=h+1;
          initiateaffine(g,h,hg,t,phi,A,b);
          fixpunkt(A,b,fix[h]);
          until h=hg;
      setgraphmode(graphmode);
      setbkcolor(15);
      initiatescreen(screen,am);
      setcolor(7);
      outtextxy(width,maxy-height,'Taste');
      ch:=readkey;
      clearwindow(width,maxy-height,8*width, maxy);
      if ch='a' then
        begin
        axes(7);
        ch:=readkey;
        end;  {'a'}
      n:=0;
      repeat
        n:=n+1;
        applyifs(g,screen,colorchart);
        setcolor(7);
        clearwindow(0,maxy-2*height,maxx,maxy);
        xptextxy('N„chste Stufe:''j''',54*width,maxy-2*height,7,xarr);
        xptextxy('Stufe:',width,maxy-height,7,xarr);
        xpnumberxy(n,3,0,6*width,maxy-height,7,xarr);
        xptextxy('Achsen:''a''',11*width,maxy-height,7,xarr);
        xptextxy('Fixpunkte:''f''',23*width,maxy-height,7,xarr);
        xptextxy('Farbwechsel:''w''',37*width,maxy-height,7,xarr);
        xptextxy('Menu:''m''',54*width,maxy-height,7,xarr);
        xptextxy('Programm-Ende:''e''',63*width,maxy-height,7,xarr);
        repeat
          repeat ch:=readkey until ch in ['a','b','e','f','j','m','w'];
          case ch of
            'a':begin
              axes(7);
              chc:=readkey;
              axes(0);
              end;
            'b':axesb(7);
            'f':begin
              showfix(fix,hg,colorchart);
              chc:=readkey;
              colorchartold:=colorchart;
              for i:=0 to 9 do colorchart[i]:=0;
              showfix(fix,hg,colorchart);
              colorchart:=colorchartold;
              end;
            'w':farbwechsel(colorchart);
            end;  {case ch}
          until ch in ['e','j','m'];
        clearwindow(0,maxy-2*height,maxx,maxy);
        until ((ch='e') or (ch='m'));
      restorecrtmode;
      end;  {chm='i'}
    'a':begin
      collagecontraction(g,sc); {berechnet den Kontraktionsfakter des IFS g}
      repeat
	abbildungswahl(g,h,sc);  {Wahl der Kontraktionsabbildung h}
	initiateaffine(g,h,hg,t,phi,A,b); {Einlesen von A(h),b(h)}
	zeigeabbildung(A,b,z0);  {Grafik-Demo der Abbildung}
        writeln(' Ausgabe einer weiteren Collage-Abbildung (j/n) ?');
        repeat ch:=readkey until ch in ['j','n'];
        until ch='n';
      end;  {chm='a'}
    'd':begin
      clrscr;
      writeln;
      writeln
      (' Die Berechnung der Dimension ist nur dann mathematisch begr�ndet,');
      writeln
    (' wenn das Fraktal A die Vereinigung von endlich vielen Bildern von A');
      writeln
(' unter Žhnlichkeitstransformationen mit Žhnlichkeitsfaktoren s[i]<1 ist,');
      writeln
      (' und wenn die offene-Mengen-Bedingung erf�llt ist.');
      dimension(dim,g,t,phi,tol);
      writeln;
      writeln
   (' Wenn diese Bedingungen erf�llt sind, ergibt sich f�r den Attraktor A');
      writeln(' dieser Collage die Dimension dim(A) = ',dim:4:2);
      ch:=readkey;
      end;
    end;  {case chm}
  until ch='e';
ch:=readkey;
end.  {agmath2}