program fbv_demo; {Lutz Tautenhahn (c) 1995, 1999)}
uses dos,crt,graph;
const wmaxi=81;x0=230;y0=20;
const MaxRekTiefe=5;
      MaxPufferSchranke=35;
      KritischeHelligkeit=100;
      FormatSubF: array [1..8, 0..8] of shortint=
      (( 1, 1, 0, 0, 0, 0, 0, 0, 0),
       ( 1, 1, 1, 0, 0, 0, 0, 0, 0),
       ( 4, 4, 0, 0, 0, 0, 0, 0, 0),
       ( 1, 4, 4, 3, 0, 0, 0, 0, 0),
       ( 4, 1, 1, 2, 4, 4, 0, 0, 0),
       ( 4, 4, 4, 0, 0, 0, 0, 0, 0),
       ( 1, 4, 4, 3, 1, 1, 0, 0, 0),
       ( 1, 4, 4, 3, 1, 1, 1, 2, 2));

var i, j, from, ip, TempKrH: integer;
    imin, jmin, imax, jmax: longint;
    K, Format, MaxPuffer: shortint;
    Puffer: array [0..MaxPufferSchranke] of integer;
    H: array[0..3] of integer;
    BinFarbe: array[0..1] of integer;
    w: array[0..wmaxi] of byte;
    graphdriver,graphmode: integer;
    wmax,dx1,dy1,dx2,dy2,dx3,dy3: integer;
    i1,i2,i3,j1: integer;
    key: char;

{*******************************************************************}
function Helligkeit(ii: integer): integer;
begin
  Helligkeit:=0;
  if ii=0 then Helligkeit:=H[0];
  if ii=8 then Helligkeit:=H[1];
  if ii=7 then Helligkeit:=H[2];
  if ii=15 then Helligkeit:=H[3];
end;
{*******************************************************************}
procedure ig;
begin
  graphdriver:=detect;
  initgraph(graphdriver,graphmode,'d:\tp\bgi');
end;
{*******************************************************************}
procedure eingabe;
begin
  clrscr;
  writeln('Demonstrations-Programm zur fraktalen Bildverareitung            LT 1995');
  writeln;
  writeln('Das Programm zeichnet als Urbild den Menger-Schwamm in 4 Graustufen.');
  writeln('Anschlieáend wird das Bild binarisiert, d.h. es wird auf 2 Farbstufen');
  writeln('reduziert. Die Bildverarbeitung erfolgt entlang eines fraktalen Weges.');
  writeln;writeln;
  write('Helligkeitswert f�r     schwarz [0..100] ');readln(H[0]);
  write('Helligkeitswert f�r  dunkelgrau [0..100] ');readln(H[1]);
  write('Helligkeitswert f�r    hellgrau [0..100] ');readln(H[2]);
  write('Helligkeitswert f�r        weiá [0..100] ');readln(H[3]);
  writeln;
  write('Bin„rfarbe f�r           dunkel [0..15] ');readln(BinFarbe[0]);
  write('Bin„rfarbe f�r             hell [0..15] ');readln(BinFarbe[1]);
  writeln;
  write('Pufferl„nge f�r Verarbeitungstiefe [3..',MaxPufferSchranke,'] ');
  readln(MaxPuffer);
  writeln;
  write('Eingabe der Stufe des Menger- Schwammes [1...4]');
  repeat
    key:=readkey;
  until key in ['1'..'4'];
end;
{*******************************************************************}
procedure typinit;
begin
  if key='1' then begin
    wmax:=3;dx1:=120;dy1:=0;dx2:=0;dy2:=120;dx3:=-30;dy3:=30;
  end;
  if key='2' then begin
    wmax:=9;dx1:=40;dy1:=0;dx2:=0;dy2:=40;dx3:=-10;dy3:=10;
  end;
  if key='3' then begin
    wmax:=27;dx1:=12;dy1:=0;dx2:=0;dy2:=12;dx3:=-3;dy3:=3;
  end;
  if key='4' then begin
    wmax:=81;dx1:=4;dy1:=0;dx2:=0;dy2:=4;dx3:=-1;dy3:=1;
  end;
end;
{*******************************************************************}
function cantor(iix,iiy,iiz: integer): boolean;
var triad: array[1..3,0..6] of byte;
    tt: array[0..6] of integer;
    cc: array[1..3] of integer;
    ii,jj: integer;
begin
  cantor:=true;
  tt[0]:=1;
  tt[1]:=3;
  tt[2]:=9;
  tt[3]:=27;
  tt[4]:=81;
  tt[5]:=243;
  tt[6]:=729;
  cc[1]:=iix;cc[2]:=iiy;cc[3]:=iiz;
  for jj:=1 to 3 do begin
    for ii:=6 downto 0 do begin
      if cc[jj]>=2*tt[ii] then begin
        cc[jj]:=cc[jj]-2*tt[ii];
        triad[jj,ii]:=2;
      end
      else if cc[jj]>=tt[ii] then begin
        cc[jj]:=cc[jj]-tt[ii];
        triad[jj,ii]:=1;
      end
      else triad[jj,ii]:=0;
    end;
  end;
  for ii:=0 to 6 do begin
    jj:=0;
    if triad[1,ii]=1 then inc(jj);
    if triad[2,ii]=1 then inc(jj);
    if triad[3,ii]=1 then inc(jj);
    if jj>1 then cantor:=false;
  end;
end;
{*******************************************************************}
procedure wuerfel(ii,jj: integer);
var ii1:integer;
begin
  setcolor(15);
  for ii1:=1 to dx1 do line(ii-ii1,jj,ii-dx3-ii1,jj-dy3);
  setcolor(7);
  for ii1:=1 to dy2 do line(ii,jj+ii1,ii-dx3,jj-dy3+ii1);
  setcolor(8);
  for ii1:=0 to dx1 do line(ii-ii1,jj,ii-ii1,jj+dy2);
end;
{*******************************************************************}
procedure FormatAnalyse(ii,jj: integer);
var kki, kkj, iik, jjk: shortint;
    ppotenz3i, ppotenz3j: integer;

begin
  ppotenz3i:=1;
  iik:=1;
  kki:=-1;
  while ii>=ppotenz3i do begin
    ppotenz3i:=ppotenz3i*3;
    inc(kki);
  end;
  iik:= (3*ii) div ppotenz3i;

  ppotenz3j:=1;
  jjk:=1;
  kkj:=-1;
  while jj>=ppotenz3j do begin
    ppotenz3j:=ppotenz3j*3;
    inc(kkj);
  end;
  jjk:= (3*jj) div ppotenz3j;

  if kki>kkj then begin
    if iik=1 then Format:=1 else Format:=2;
    K:=kki;
  end else if kki<kkj then begin
    if jjk=1 then Format:=3 else Format:=6;
    K:=kkj;
  end else begin
    K:=kki;
    if iik=1 then begin
      if jjk=1 then begin
        Format:=4;
      end else begin
        Format:=7;
      end;
    end else begin
      if jjk=1 then begin
        Format:=5;
      end else begin
        Format:=8;
      end;
    end;
  end;
end;
{*******************************************************************}
procedure Bildverarbeitung(ii, jj: integer);
begin
  Puffer[0]:=Puffer[0]-Puffer[MaxPuffer];
  for ip:=MaxPuffer downto 2 do Puffer[ip]:=Puffer[ip-1];
  Puffer[1]:=0;
  if ((i<=imax) and (j<=jmax)) then begin
    Puffer[1]:=Helligkeit(getpixel(i,j));
    Puffer[0]:=Puffer[0]+Puffer[1];
    if Puffer[0]<KritischeHelligkeit then putpixel(i,j,BinFarbe[0])
    else begin
      Puffer[0]:=Puffer[0]-KritischeHelligkeit;
      for ip:=MaxPuffer downto 1 do begin
        TempKrH:=KritischeHelligkeit; {LT 2003: Seems this must be done 1 line above!} 
        if Puffer[ip]<TempKrH then begin
          TempKrH:=TempKrH-Puffer[ip];
          Puffer[ip]:=0;
        end else begin
          Puffer[ip]:=Puffer[ip]-TempKrH;
          TempKrH:=0;
        end;
      end;
      putpixel(i,j,BinFarbe[1]);
    end;
  end;
end;
{*******************************************************************}
procedure Go(Richtung, Tiefe: shortint);
begin
  if Tiefe>0 then begin
    if Richtung=1 then begin
      Go(1, Tiefe-1); Go(4, Tiefe-1); Go(4, Tiefe-1);
      Go(3, Tiefe-1); Go(1, Tiefe-1); Go(1, Tiefe-1);
      Go(1, Tiefe-1); Go(2, Tiefe-1); Go(2, Tiefe-1);
    end else if Richtung=2 then begin
      Go(3, Tiefe-1); Go(3, Tiefe-1); Go(2, Tiefe-1);
      Go(2, Tiefe-1); Go(2, Tiefe-1); Go(4, Tiefe-1);
      Go(1, Tiefe-1); Go(1, Tiefe-1); Go(2, Tiefe-1);
    end else if Richtung=3 then begin
      Go(3, Tiefe-1); Go(2, Tiefe-1); Go(2, Tiefe-1);
      Go(1, Tiefe-1); Go(3, Tiefe-1); Go(3, Tiefe-1);
      Go(3, Tiefe-1); Go(4, Tiefe-1); Go(4, Tiefe-1);
    end else if Richtung=4 then begin
      Go(1, Tiefe-1); Go(1, Tiefe-1); Go(4, Tiefe-1);
      Go(4, Tiefe-1); Go(4, Tiefe-1); Go(2, Tiefe-1);
      Go(3, Tiefe-1); Go(3, Tiefe-1); Go(4, Tiefe-1);
    end;
  end else begin
    Bildverarbeitung(i, j);
    if Richtung=1 then begin
      if from <= 2 then inc(i)
      else inc(j);
    end else if Richtung=2 then begin
      if from <= 2 then dec(j)
      else dec(i);
    end else if Richtung=3 then begin
      if from <= 2 then dec(j)
      else dec(i);
    end else if Richtung=4 then begin
      if from <= 2 then inc(i)
      else inc(j);
    end;
    from:=Richtung;
  end;
end;
{*******************************************************************}
procedure  work;
var ff: integer;
begin
  imin:=0;
  jmin:=0;
  imax:=640;
  jmax:=480;
  FormatAnalyse(imax-imin, jmax-jmin);
  i:=imin;
  j:=jmin;
  from:=1;
  for ff:=0 to MaxPuffer do Puffer[ff]:=0;
  for ff:=0 to 8 do Go(FormatSubF[Format,ff],K);
end;
{*******************************************************************}
begin {Hauptprogramm}
  eingabe;
  typinit;
  ig;
  for i1:=0 to wmax-1 do begin
    for i2:=wmax-1 downto 0 do begin
      for i3:=0 to wmax-1 do begin
        if cantor(i1,i2,i3) then
          wuerfel(x0+dx1*i1+dx2*i2+dx3*i3,y0+dy1*i1+dy2*i2+dy3*i3);
      end;
    end;
  end;
  readln;
  work;
  readln;
  closegraph;
end.