Unit bTree; { Zak's Binary Tree Object / routines.. }

{$O+,F+} { allow overlays }

Interface
Type KeyType = String[35]; {This can be changed if needed .., int, word, etc}

Type StatusType = (Used,Free);
Type ShowAllFuncType = Function (k:keytype;var Data):boolean;

 LeafType = record    { A "living" leaf }
      Status: StatusType;        { Status of node .. unused but useful } 
      Mother,Left,Right:longint; { pointers to Parent, Left, and Right nodes }
      Key: KeyType;              { the keyed data }
     end;
 GenericProcedure = procedure;   { used to dispay balancing status }

 FileHeaderType = record      
      DataRecSize,               { size of data records }
      Root,                      { pointer to root node }
      NextFree: longint;         { next free, unused node }
     end;

 DirectionType = (Right,Left);   { the directions, duh }

 DeletedLeaf = record            { a "dead" leaf -- overlaps old LeafType }
      Status  : StatusType;      { node status, hopefully Free}
      NextFree: longint;         { pointer to next unused, free node }
      Filler  : array[1..2]
                  of longint;    { pad LeafType.Left and Right }
      Filler2 : KeyType;         { pad LeafType.Key }
      end;

 pbTreeObj = ^bTreeObj;
 bTreeObj = Object

  Constructor Init       ( filename:string ; DataRecSize_:longint );

     { Initialize the object.. DataRecSize_ is ignored if the file is not
       new (has been Init'd before)}

  Destructor Done;

     { unused the memory and close the file }

  Function  Add          (Key: keytype; Var Data):boolean;

     { Add Data by Key -- returns FALSE if key exists, otherwise TRUE }

  Function  Find         (key: keytype):boolean;

     { returns TRUE if key could be found, FALSE otherwise }

  Function  FindData     (key: keytype; var data):boolean;

     { if key is found, then returns TRUE and correct data, FALSE otherwise }

  Function  Delete       (key: keytype):boolean;

     { returns TRUE if successful, FALSE if key not found }

  Function  BalanceHeapReq:longint;

     { returns bytes of heap required for a Balance }

  Procedure Balance      (Reading,Sorting,Updating:GenericProcedure);

     { Makes the AVERAGE number of links needed to find a key the least
       possible }

  Procedure ShowAll (func:ShowAllFuncType);

     { cycles through all the nodes, calling func until it returns FALSE 
       or no more nodes.. }

  function Update(key:keytype; Var Data):boolean;

     { if key found, writes new Data to it, otherwise returns FALSE }

  private { INTERNAL to the object }
   f:file;                  { the file we're playing with }
   dataRecSize:longint;     { current data record size }
   Function RecOfs        (n:longint):longint;
      { returns offset of given record }
   Procedure ReadRecLeaf  (n:longint;var RecHdr:LeafType);
      { reads only the LeafType of record n }
   Procedure ReadRecBoth  (n:longint;var RecHdr:LeafType;var data);
      { reads both the LeafType and the data }
   Procedure WriteRecLeaf (n:longint;RecHdr:LeafType);
      { writes only the LeafType}
   Procedure WriteRecBoth (n:longint;RecHdr:LeafType;var data);
      { write both the LeafType and Data }
   Procedure WriteRecData (n:longint;var data);
      { just write the data for record n }
   Function  NumRecords   (filehdr:fileheadertype):longint;
      { returns number of total records in file }
   Function  GetNewRecNum (filehdr:fileheadertype):longint;
      { returns next free record number }
   Procedure ReadFileHdr  (var filehdr:fileheadertype);
      { reads the file header .. cryptic, eh? }
   Procedure WriteFileHdr (filehdr:fileheadertype);
      { writes the file's header }
   Procedure FindNewMother(r:longint;filehdr:fileheadertype);
      { reassign this node a new, more suitable, parent when orphaned :-) }
   Function  FindKeyRec   (key: keytype):longint;
      { returns record number with this key, 0 otherwise }
  end;

Implementation
uses Dos;

Constructor bTreeObj.Init( filename:string; datarecsize_:longint );
 var fileheader:fileheadertype;
  t:word;
 begin
 {$I-}
 assign(f,filename);
 reset(f,1);
 {$I+}
 t:=ioresult;
 Case t of
  0: begin { file exists.. ok so far }
     ReadFileHdr(fileheader);
     datarecsize:=fileheader.datarecsize;  { init. prv. datarecsize }
     end;
  2: begin { new file, let's initialize it, ok? }
     ReWrite(f,1);
     FileHeader.DataRecSize:=DataRecSize_; { setup header data }
     datarecsize:=datarecsize_;
     FileHeader.Root:=0;
     FileHeader.NextFree:=0;
     BlockWrite(f,FileHeader,Sizeof(FileHeader)) { write header data }
     end
  else RunError(t); { some other error .. }
  end
 end;

Procedure bTreeObj.ShowAll (func:ShowAllFuncType);
 var fileheader:fileheadertype;
     rh     :leaftype;
     data   :pointer;
     cont   :boolean;
 procedure climb(r:longint);
      var right:longint;
      begin
      ReadRecboth(r,rh,Data^);
      right:=rh.right;
      if not(rh.left=0) then
         begin
         Climb(rh.left);
         ReadRecBoth(r,rh,data^) { read back current data if needed }
         end;
      if not cont then exit; { "just checking" }
      cont := func(rh.key,data^);
      if not cont then exit;
      if not(right=0) then Climb(right);
      end;
 begin
 cont := true;
 ReadFileHdr(fileheader);
 GetMem(data,fileheader.datarecsize);
 if fileheader.root<>0 then Climb(fileheader.root);
 FreeMem(data,fileheader.datarecsize);
 end;


Destructor bTreeObj.Done;
  begin
  close(f) { just close the file.. no big deal }
  end;

Function  bTreeObj.Add(Key: keytype; var data):boolean;
  var FileHdr: FileHeaderType;
      RecHdr  : LeafType;
  Procedure AddNewRec;
    Function FindMother(var direction:directiontype):longint;
      var RecHdr  :leaftype;
          LastNode:longint;
      procedure Search_Tree(n:longint);
        begin
        ReadRecLeaf(n,RecHdr);
        if Key>RecHdr.Key then
             if not(RecHdr.Right=0) then Search_Tree(RecHdr.Right) else
                 begin
                 LastNode:=n;
                 Direction:=Right;
                 end
        else if Key<RecHdr.Key then
             if not(RecHdr.Left=0) then Search_Tree(RecHdr.Left) else
                 begin
                 LastNode:=n;
                 Direction:=left;
                 end;
        end;
      begin
      Search_Tree(filehdr.root);
      FindMother:=LastNode;
      end;
    var MotherRec      :longint;
        MotherRecHdr   :Leaftype;
        MotherDirection:directiontype;
        NewRecNum      :longint;
        NewRecHdr      :leaftype;
    begin
    MotherRec:=FindMother(MotherDirection); { find available mother node }
    ReadRecLeaf(MotherRec,MotherRecHdr);    { "read her data" }
    NewRecNum := GetNewRecNum(filehdr);     { get next free record number }
    if not(NewRecNum>NumRecords(filehdr)) then
      begin
      ReadRecLeaf(NewRecNum,NewRecHdr);
      FileHdr.NextFree:=DeletedLeaf(NewRecHdr).NextFree;
      end;
    Case MotherDirection of
       Right: MotherRecHdr.Right:=NewRecNum;
       Left : MotherRecHdr.Left :=NewRecNum;
       end;
    With NewRecHdr do { initialize record.. }
      begin
      Status := used;
      Right  := 0;
      Left   := 0;
      Mother := MotherRec;
      end;
    NewRecHdr.Key:=Key;
    WriteFileHdr(FileHdr);                  { update file header }
    WriteRecLeaf(MotherRec,MotherRecHdr);   { write mother }
    WriteRecBoth(newrecnum,NewRecHdr,Data); { write daughter }
    end;
  procedure AddFirstRec;
    begin { we're adding the first record in the file.. scary eh? }
    With RecHdr do { init. it }
      begin
      Status := Used;
      Right  := 0;
      Left   := 0;
      Mother := 0;
      end;
    RecHdr.key:=key;
    FileHdr.Root := 1;
    FileHdr.NextFree := 0;
    Seek(f,0);
    BlockWrite(f,Filehdr,sizeof(filehdr));
    BlockWrite(f,RecHdr,Sizeof(RecHdr));
    BlockWrite(f,data,filehdr.datarecsize);
    end;
  begin
  if not Find(key) then { if not found, then .. }
    begin
    ReadFileHdr(filehdr);
    if FileHdr.Root=0 then
       AddFirstRec
    else
       AddNewRec;
    add := true;
    end
  else Add := false;
  end;

Function  bTreeObj.Find     (key: keytype):boolean;
 begin
 Find:=FindKeyRec(key)>0; { or BOOLEAN(FindKey(key)) would work too }
 end;

Function bTreeObj.Update(key:keytype; Var Data):boolean;
 var i:longint;
 begin
 i:=FindKeyRec(key);
 if i=0 then
   begin
   Update:=False;
   end
 else
   begin
   WriteRecData(i,data);
   update:=true;
   end
 end;

Function  bTreeObj.FindData    (key: keytype; var data):boolean;
 var filehdr:fileheadertype;
     rechdr :leaftype;
     r      :longint;
 begin
 r:=FindKeyRec(key);
 if r>0 then
   begin
   ReadRecBoth(r,rechdr,data);
   FindData:=true;
   end
 else
   finddata:=false
 end;

Function bTreeObj.Delete(key: keytype):boolean;
 var filehdr:fileheadertype;
 procedure Unlink(r:longint;var delhdr:leaftype);
  Function GetDirection(sonhdr:leaftype):directiontype;
   var sonrighthdr,sonlefthdr,motherhdr:leaftype;
       sre,sle:boolean;
   begin
   ReadRecLeaf(sonhdr.mother,motherhdr);
   if not(motherhdr.left=0) then
     begin
     ReadRecLeaf(motherhdr.left,sonlefthdr);
     sle:=true
     end
     else sle:=false;
   if not(motherhdr.right=0) then
     begin
     ReadRecLeaf(motherhdr.right,sonrighthdr);
     sre:=true;
     end
     else sre:=false;
   {$B-}
   if      sle and not sre then GetDirection:=Left
   else if sre and not sle then GetDirection:=Right
   else if (sle and sre) and (sonrighthdr.key=sonhdr.key) then GetDirection:=Right
   else if (sle and sre) and (sonlefthdr.key=sonhdr.key) then GetDirection:=left;
   {$B+}
   end;

   var MotherHdr:leaftype;
       direction:directiontype;
   begin
   if not(DelHdr.Mother=0) then
     begin
     ReadRecLeaf(DelHdr.Mother,MotherHdr);
     Direction:=GetDirection(DelHdr);
     case Direction Of
       Left : MotherHdr.Left:=0;
       Right: MotherHdr.Right:=0;
       end;
     WriteRecLeaf(delhdr.mother,motherhdr);
     end
   end;

 Procedure UpdateFreeList(r:longint);
   function LastFree:longint;
    var rechdr:leaftype;n,ths:longint;
     begin
     n:=filehdr.nextfree;
     ths:=n;
     repeat
       begin
       ReadRecLeaf(n,rechdr);
       ths:=n;
       n:=deletedleaf(rechdr).nextfree;
       end
     until DeletedLeaf(RecHdr).nextfree=0;
     LastFree:=ths;
     end;

   Var updatedptrhdr:leaftype;lf:longint;
   begin
   if filehdr.nextfree=0 then
     begin
     filehdr.nextfree:=r;
     writefilehdr(filehdr);
     end
   else
     begin
     lf:=lastfree;
     ReadRecLeaf(Lf,updatedptrhdr);
     DeletedLeaf(updatedptrhdr).nextfree:=r;
     WriteRecLeaf(lf,updatedptrhdr);
     end;
   end;

 Procedure AddChildren(var dhdr:leaftype);
   begin
   if not(dhdr.left=0) then FindNewMother(dhdr.left,filehdr);
   if not(dhdr.right=0) then FindNewMother(dhdr.right,filehdr);
   end;

 Procedure ChangeMother(r,tor:longint);
  var rechdr:leaftype;
  begin
  ReadRecLeaf(r,rechdr);
  rechdr.mother:=tor;
  WriteRecLeaf(r,rechdr);
  end;

 { this is huge }

 var DelRecNum:longint;
     delhdr   :leaftype;
 begin
 ReadFileHdr(filehdr);
 DelRecNum:=FindKeyRec(key); { find the record we're refering to }
 DelHdr.Status:=Free; { change its status }
 if not(DelRecNum>0) then Delete:=False else
  begin
  ReadRecLeaf(delrecnum,delhdr); { read the dead-to-be's header }
  if delhdr.Mother=0 then
    { we're dealing with the ROOT node ! }
    begin
    Delete:=true;
    UpdateFreeList(delrecnum); { add to free list }
    if not(delhdr.Right=0) then
      begin
      FileHdr.Root := delhdr.Right;
      ChangeMother(delhdr.Right,0);
      if not(delhdr.left=0) then FindNewMother(delhdr.left,filehdr);
      end;
    if not(delhdr.left=0) and (delhdr.right=0) then
      begin
      FileHdr.Root := delhdr.Left;
      ChangeMother(delhdr.Left,0);
      end;
    if (delhdr.right=0) and (delhdr.left=0) then
      begin
      FileHdr.Root:=0;
      end;
    DelHdr.Status:=Free;
    WriteFileHdr(filehdr);
    DeletedLeaf(DelHdr).NextFree:=0;
    WriteRecLeaf(delrecnum,delhdr);
    end
  else
    { the easy part }
    begin
    Delete:=true;
    Unlink(DelRecNum,delhdr);         { unlink it from its parent }
    UpdateFreeList(delrecnum);        { add to free list }
    DeletedLeaf(DelHdr).NextFree:=0;  { this is the last in the chain .. }
    WriteRecLeaf(delrecnum,delhdr);
    AddChildren(delhdr);              { re-classify its offspring }
    end;
  end;
 end;

Function  bTreeObj.BalanceHeapReq:longint;
  var rechdr    :leaftype;
      filehdr   :fileheadertype;
      numnodes  :longint;
   procedure Climb(r:longint);
      begin
      ReadRecLeaf(r,rechdr);
      if not(rechdr.left=0) then Climb(rechdr.left);
      ReadRecLeaf(r,rechdr);
      inc(numnodes);
      if not(rechdr.right=0) then Climb(rechdr.right);
      end;
   begin
   numnodes:=0;
   readfilehdr(filehdr);
   if not(FileHdr.Root=0) then Climb(FileHdr.Root);
   balanceheapreq:=numnodes*20; { sizeof(ListRecType) }
   end;

Procedure bTreeObj.Balance(Reading,Sorting,Updating:GenericProcedure );
 type ToListRecType = ^ListRecType;
      ListRecType   = Record
         node,mother,left,right:longint;
         Next:ToListRecType;
         end;
 var filehdr     : fileheadertype;
     ListRecRoot : ToListRecType;
     NumNodes    : longint;
     MarkMem     : pointer;
 Procedure ReadFileToLL;
  var rechdr    :leaftype;
      curlistrec:tolistrectype;
   Procedure Add(r:longint);
     begin
     inc(NumNodes);
     if CurListRec=Nil then
       begin
       new(CurListRec);
       CurListRec^.Next := Nil;
       ListRecRoot := CurListRec;
       end
     else
       begin
       New(CurListRec^.next);
       CurListRec:=CurListRec^.Next;
       CurListRec^.Next := Nil;
       end;
     CurListRec^.Node:=r;
     CurListRec^.Mother:=0;
     CurListRec^.Left:=0;
     CurListRec^.Right:=0;
     end;
   procedure Climb(r:longint);
      begin
      ReadRecLeaf(r,rechdr);
      if not(rechdr.left=0) then Climb(rechdr.left);
      ReadRecLeaf(r,rechdr);
      Add(r);
      if not(rechdr.right=0) then Climb(rechdr.right);
      end;
   begin
   CurListRec:=ListRecRoot;
   if not(FileHdr.Root=0) then Climb(FileHdr.Root);
   end;
 Procedure GetRecNumInfo(n:longint; var mother,left,right:longint);
   var c:tolistrectype;
   begin
   c:=listrecroot;
   while c^.node<>n do c:=c^.next;
   mother:=c^.mother;
   left:=c^.left;
   right:=c^.right;
   end;
 Procedure PutRecNumInfo(n,mother,left,right:longint);
  var c:tolistrectype;
   begin
   c:=listrecroot;
   while c^.node<>n do c:=c^.next;
   c^.mother:=mother;
   c^.left:=left;
   c^.right:=right;
   end;
 Function Power(b,e:longint):longint;
   var t,c:longint;
   begin
   t:=b;
   if e=0 then begin power:=1 ; exit end;
   for c:=1 to e-1 do t:=t*b;
   power:=t;
   end;
 Procedure ProcessLL;
  var MaxNumNodes: longint;
      NumSubLevels  : longint;
      TempMother,TempRight,TempLeft:longint;
      Modifier   : longint;
  Function FindNumSubLevels(n:longint):longint;
    var i:longint;
    begin
    i:=1;
    repeat inc(i,1) until (power(2,i)>=n+1);
    FindNumSubLevels:=i-1;
    end;
  Function RightMod(root,modi:longint):longint;
    begin
    repeat
      begin
      modi := modi div 2;
      end
    until root+modi<=numnodes;
    RightMod := modi;
    end;
  Procedure FixSubTree(root:longint;mthr:longint);
     var sr:longint;
     begin
     if not(abs(mthr-root)=1) then
       begin
       modifier:=abs(mthr-root) div 2;
       templeft:=root-modifier;
       if (root+modifier<=NumNodes) then
          tempright:=root+modifier
       else
          begin
          modifier:=Rightmod(root,modifier);
          if not(modifier=0) then TempRight:=root+modifier else tempright:=0;
          end;
       tempmother:=mthr;
       PutRecNumInfo(root,tempmother,templeft,tempright);
       sr:=tempright;
       if not(templeft=0) then FixSubTree(templeft,root);
       if not(sr=0) then FixSubTree(sr,root);
       end
     else { lowest leaves }
       begin
       PutRecNumInfo(root,mthr,0,0);
       end;
     end;
   Function MaxNodes:longint;
    var i:longint;
    begin
    i:=0;
    repeat inc(i,1) until (power(2,i+1)-1)>=NumNodes;
    MaxNodes:= Power(2,i+1)-1;
    end;
  Var NewRoot:longint;
  begin
  MaxNumNodes := MaxNodes;
  NumSubLevels := FindNumSubLevels(MaxNumNodes); { number of "shelves" }
  if NumNodes<2 then NewRoot:=FileHdr.Root else NewRoot:=Power(2,NumSubLevels);
  FileHdr.Root := NewRoot;
  FixSubTree(NewRoot,0);
  end;
 Procedure WriteLLtoFile;
   var CurListRec: tolistrectype;
       l:leaftype;
   begin
   curlistrec:=listrecroot;
   while curlistrec<>nil do
      begin
      ReadRecLeaf(curlistrec^.node,l);
      l.left:=curlistrec^.left;
      l.right:=curlistrec^.right;
      l.mother:=curlistrec^.mother;
      WriteRecLeaf(curlistrec^.node,l);
      curlistrec:=curlistrec^.next;
      end;
   end;
 begin
 NumNodes := 0;
 ListRecRoot:=nil;
 Mark(MarkMem);
 ReadFileHdr(filehdr);
 reading; { status }
 if not(filehdr.root=0) then ReadFileToLL; { if there are >0 records then }
 sorting; { status }                       { read data into the linked list}
 if not(filehdr.root=0) then ProcessLL;    { change data in LL }
 updating; { status }
 if not(filehdr.root=0) then WriteLLtoFile; { updated disk with LL data }
 WriteFileHdr(filehdr);
 Release(MarkMem);
 end;

{privates}

Function bTreeObj.RecOfs(n:longint):longint;
 begin
 RecOfs:=Sizeof(FileHeaderType)+((n-1)*(DataRecSize+Sizeof(LeafType)));
 end;

Procedure bTreeObj.ReadRecLeaf(n:longint;var RecHdr:LeafType);
 begin
 seek(f,recofs(n));
 blockread(f,rechdr,sizeof(leaftype));
 end;

Procedure bTreeObj.ReadRecBoth(n:longint;var RecHdr:LeafType;var data);
 begin
 seek(f,recofs(n));
 blockread(f,rechdr,sizeof(rechdr));
 blockread(f,data,datarecsize);
 end;

Procedure bTreeObj.WriteRecLeaf(n:longint;RecHdr:LeafType);
 begin
 seek(f,recofs(n));
 blockwrite(f,rechdr,sizeof(rechdr));
 end;

Procedure bTreeObj.WriteRecBoth(n:longint;RecHdr:LeafType;var data);
 begin
 seek(f,recofs(n));
 blockwrite(f,rechdr,sizeof(rechdr));
 blockwrite(f,data,datarecsize);
 end;

Procedure bTreeObj.WriteRecData (n:longint;var data);
 begin
 Seek(f,recofs(n)+Sizeof(LeafType));
 blockwrite(f,data,datarecsize);
 end;

Function bTreeObj.NumRecords(filehdr:fileheadertype):longint;
 var tv:longint;
 begin
 NumRecords := (FileSize(f)-Sizeof(FileHdr)) div (Sizeof(LeafType)+FileHdr.DataRecSize);
 end;

Function bTreeObj.GetNewRecNum(filehdr:fileheadertype):longint;
 begin
 if filehdr.nextfree=0 then
  begin
  GetNewRecNum := NumRecords(filehdr)+1;
  exit
  end
 else
  GetNewRecNum := FileHdr.NextFree;
 end;

Procedure bTreeObj.ReadFileHdr(var filehdr:fileheadertype);
 begin
 seek(f,0);
 blockread(f,FileHdr, sizeof(filehdr));
 end;

Procedure bTreeObj.WriteFileHdr( filehdr:fileheadertype);
 begin
 seek(f,0);
 blockwrite(f,FileHdr, sizeof(filehdr));
 end;

Procedure bTreeObj.FindNewMother ( r:longint;filehdr:fileheadertype);
    var rechdr:leaftype;
    Function FindMother(var direction:directiontype):longint;
      var Hdr  :leaftype;
          LastNode:longint;
      procedure Search_Tree(n:longint);
        begin
        ReadRecLeaf(n,Hdr);
          if RecHdr.Key>Hdr.Key then
             if not(Hdr.Right=0) then Search_Tree(Hdr.Right) else
                 begin
                 LastNode:=n;
                 Direction:=Right;
                 end
          else if RecHdr.Key<Hdr.Key then
             if not(Hdr.Left=0) then Search_Tree(Hdr.Left) else
                 begin
                 LastNode:=n;
                 Direction:=left;
                 end;
        end;
      begin
      Search_Tree(filehdr.root);
      FindMother:=LastNode;
      end;

    var mhdr:leaftype;
        mrec:longint;
        motherdirection:directiontype;
    begin
    ReadRecLeaf(r,RecHdr);
    mrec:=FindMother(motherdirection);
    ReadRecLeaf(mrec,MHdr);
    RecHdr.Mother := mrec;
    Case MotherDirection of
       Right: MHdr.Right:=r;
       Left : MHdr.Left :=r;
       end;
    WriteRecLeaf(mrec,MHdr);
    WriteRecLeaf(r,RecHdr);
    end;

Function bTreeObj.FindKeyRec    (key: keytype):longint;
 var filehdr:fileheadertype;
     rechdr :leaftype;
   procedure FindKey(r:longint);
     begin
     ReadRecLeaf(r,RecHdr);
     if Key>RecHdr.Key then
        if not(RecHdr.Right=0) then FindKey(RecHdr.Right) else
               begin
               FindKeyRec:=0;
               end
        else if Key<RecHdr.Key then
             if not(RecHdr.Left=0) then FindKey(RecHdr.Left) else
               begin
               FindKeyRec:=0;
               end
        else if Key=RecHdr.Key then FindKeyRec:=r;
     end;
 begin
 ReadFileHdr(filehdr);
 if filehdr.root=0 then FindKeyRec:=0 else FindKey(filehdr.root)
 end;

end.