program q;
{ creates a quadtree for a binary image.
  Algorithm adapted from:
  Samet, H. Region Representation: Quadtrees from Binary Arrays
  Computer Graphics & Image Processing 13, 88-93 (1980)

  A. Herrmann  27 Jan 1987 }

const MAXLEV=5;                  { 2^MAXLEV = MAXSIZE: image size (resolution) }
      MAXSIZE=32;

type pixel = char;
     quadrant = (NW,NE,SW,SE);
     ntype = (WHITE,BLACK,GREY);
     nodepointer = ^node;
     node = record
            father:   nodepointer;
            son:      array[NW..SE] of nodepointer;
            nodetype: ntype;
            end;
     pair = record
            pairtype: ntype;
            pairptr:  nodepointer;
            end;
     str2 = string[2];

var root: nodepointer;                         { root of final quadtree }
    p: array[1..MAXLEV,NW..SE] of pair;        { global recursion stack }
    a: array[1..MAXSIZE,1..MAXSIZE] of pixel;  { image array }

var finame: string[12];
    string2: string[2];
    datei: text;                               { data file with 0's and 1's }
    level,size: integer;
    i,j,k: integer;                            { auxiliary indices }

var heapbot: ^integer;
    heaptop,heapbottom: integer;

{----------------------------------------------------------------------}
function Hex(i:integer):char;
begin inline ($CD/$48D); hex:=Chr(0); end; { function hex }
{----------------------------------------------------------------------}
function power2(n:integer):integer;
var i,p:integer;
begin p:=1; for i:=1 to n do p:=p*2; power2:=p; end; { function power2 }
{----------------------------------------------------------------------}
function color(a:pixel):ntype;
begin { function color }
case a of
'0': color:=WHITE;
'1': color:=BLACK;
else
    begin writeln('Non-binary pixel ',a); Halt; end;
end;
end; { function color }
{----------------------------------------------------------------------}
procedure diag(qq:str2;var pp:pair;l:integer);
begin { procedure diag }
write('after construct: level',l:2,'  p[',qq,']              ');
write('RecurPtr ',hex(RecurPtr),' Addr ',hex(Addr(pp)));
if pp.pairtype=BLACK then writeln(' BLACK')
                     else writeln(' WHITE');
end; { procedure diag }
{----------------------------------------------------------------------}
procedure createnode(var q:nodepointer);
{ add another node to the tree }
begin { procedure createnode }
New(q);
heaptop:=HeapPtr;
{write  ('Heaptop at ',Hex(heaptop));
}end; { procedure createnode }
{----------------------------------------------------------------------}

{$A-}                                 { Switch recursion on }

procedure construct(var pp:pair;level,x,y:integer);
{ construct the portion of a quadtree of size 2^level x 2^level
  having its southeasternmost pixel corresponding to entry a[x,y] of
  the image array. a is a global variable }

var i,j: quadrant;
    q,r: nodepointer;
    lvl: integer;

begin { procedure construct }

{writeln;
 write  ('construct enters level',level:2,'  Pixel (x,y)',x:3,y:3);
 write  ('  RecurPtr ',hex(RecurPtr),' Addr ',hex(Addr(pp)));
}
if level=0 then                         { process the pixel }
    begin
    pp.pairtype:=color(a[x,y]);
    pp.pairptr:=nil;
{    if pp.pairtype=BLACK then write(' BLACK')
                         else write(' WHITE');
}    end
else
    begin
    lvl:=level-1;
    construct(p[level,NW],lvl,x-power2(lvl),y-power2(lvl));
{    diag('NW',p[level,NW],level);}
    construct(p[level,NE],lvl,x            ,y-power2(lvl));
{    diag('NE',p[level,NE],level);}
    construct(p[level,SW],lvl,x-power2(lvl),y              );
{    diag('SW',p[level,SW],level);}
    construct(p[level,SE],lvl,x            ,y              );
{    diag('SE',p[level,SE],level);}
{    writeln;
}    if (p[level,NW].pairtype<>GREY) and
       (p[level,NW].pairtype=p[level,NE].pairtype) and
       (p[level,NE].pairtype=p[level,SW].pairtype) and
       (p[level,SW].pairtype=p[level,SE].pairtype) then  { all brothers are of same type }
        begin
        pp:=p[level,NW];
{        write('***** All same type');
        if pp.pairtype=BLACK then writeln('  BLACK')
                             else writeln('  WHITE');
}        end
    else
        begin                           { create a non-terminal GREY node }
        createnode(q);
{        writeln('   GREY  node created');
}        for i:=NW to SE do
            begin
            if p[level,i].pairtype=GREY then  { link p[i] to its father node }
                begin
{                writeln(' - linked to GREY node ',Hex(Addr(p[level,i].pairptr^)));
}                q^.son[i]:=p[level,i].pairptr;
                p[level,i].pairptr^.father:=q;
                end
            else
                begin                   { create a maximal node for p[i] }
                createnode(r);
{                if p[level,i].pairtype=BLACK then write  ('   BLACK')
                                             else write  ('   WHITE');
                write  (' node created - linked at GREY node ');
}                r^.nodetype:=p[level,i].pairtype;
                for j:=NW to SE do r^.son[j]:=nil;
                q^.son[i]:=r;
                r^.father:=q;
{                writeln(Hex(Addr(q^)));
}                end;
            end;
        q^.nodetype:=GREY;
        pp.pairtype:=GREY;
        pp.pairptr:=q;
        end;
    end;
{write(' construct exits level',level:2,'  Pixel (x,y)',x:3,y:3);
 write('  RecurPtr ',hex(RecurPtr),' Addr ',hex(Addr(pp)));
}
end; { procedure construct }

{$A+}                                     { Switch recursion off }

{----------------------------------------------------------------------}

procedure quadtree(var qnode:nodepointer;level:integer);

{ find the quadtree corresponding to the binary array a of
  size 2^level x 2^level. a is a global variable. }

var i: quadrant;
    p: pair;
    q: nodepointer;

begin { procedure quadtree }

construct(p,level,power2(level),power2(level));

if p.pairtype=GREY then
    begin
    p.pairptr^.father:=nil;
    qnode:=p.pairptr;
    end
else
    begin                         { the entire image is BLACK or WHITE }
    createnode(q);
    q^.nodetype:=p.pairtype;
    for i:=NW to SE do q^.son[i]:=nil;
    q^.father:=nil;
    qnode:=q;
    end;
end; { procedure quadtree }

{----------------------------------------------------------------------}

procedure show_tree_list(head,tail:nodepointer);
var np: nodepointer;
    i:  quadrant;
begin { procedure show_tree_list }
np:=head;
repeat
    write  (Hex(Ord(np)),': ',Hex(Ord(np^.father)),' ');
    for i:=NW to SE do write  (' ',Hex(Ord(np^.son[i])));
    case np^.nodetype of
    WHITE: writeln('  WHITE');
    BLACK: writeln('  BLACK');
    GREY:  writeln('  GREY');
    end;
    np:=Ptr(Ord(np)+12);
until Ord(np) >= Ord(tail);
end; { procedure show_tree_list }
{----------------------------------------------------------------------}

begin { program q }

finame:='IMAGE.  ';
write('Image size as log2: '); readln(level);
size:=power2(level);

str(size,string2);
insert(string2,finame,7);
writeln('Filename is ',finame);

{ Read binary image from file }

assign(datei,finame);
{$I-} reset(datei) {$I+};
if Ioresult<>0 then
    begin writeln('Datei ',finame,' nicht gefunden.'); Halt; end;

for i:=1 to size do
    begin
    for j:=1 to size do read(datei,a[j,i]);
    readln(datei);
    end;
close(datei);

{ Show image }

for i:=1 to size do
    begin
    for j:=1 to size do write(ord(color(a[j,i])));
    writeln;
    end;
writeln;

{ Mark Bottom of heap }

Mark(heapbot);
heapbottom:=Ord(heapbot);
writeln('Heapbottom at ',hex(heapbottom));

{ Create quadtree }

quadtree(root,level);

{ Show tree }

writeln; writeln('Root at ',hex(ord(root)));
{show_tree_list(Ptr(heapbottom),Ptr(heaptop));
}
k:=Trunc((heaptop-heapbottom)/12);

writeln('No. of nodes: ',k:5,'    Ratio: ',k/(size*size):5:3);
writeln(' Memory available ',MemAvail);

{ Release heap }

Release(heapbot); writeln('Heap released at ',hex(heapbottom));
end. { program q }
