module 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  02 Feb 1987 *)

from Terminal import Read,Write,WriteLn;
from OpSys import FCBFileName;
from FileNames import NameState,StrToFCB;
from FileSys import 
	File, PathType, 
	result, 
	SetSearchPath, UsesFile, ReadByte, 
	CloseFile, DisposeFile

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 = array[2] of char;

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: array[0..13] of char;
    finame: FCBFileName;
    string2: array[2] of char;
    input: File;			       (* data file with 0's and 1's *)
    level,size: integer;
    i,j,k: integer;                            (* auxiliary indices *)
    heaptop,heapbottom: integer;

(*----------------------------------------------------------------------*)
procedure powerof2(n:cardinal):cardinal;
var i,p:cardinal;
begin p:=1; 
for i:=1 to n do p:=p*2 end;
return p; 
end powerof2;
(*----------------------------------------------------------------------*)
procedure color(a:pixel):ntype;
begin 
case a of
'0': color:=WHITE |
'1': color:=BLACK
else
    begin writeln('Non-binary pixel ',a); Halt; end;
end;
end color;
(*----------------------------------------------------------------------*)
procedure createnode(var q:nodepointer);
(* add another node to the tree *)
begin 
New(q);
heaptop:=HeapPtr;
(*write  ('Heaptop at ',Hex(heaptop));*)
end 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-powerof2(lvl),y-powerof2(lvl));
(*    diag('NW',p[level,NW],level);*)
    construct(p[level,NE],lvl,x            ,y-powerof2(lvl));
(*    diag('NE',p[level,NE],level);*)
    construct(p[level,SW],lvl,x-powerof2(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,powerof2(level),powerof2(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:=powerof2(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 *)
