[Back to POINTERS SWAG index] [Back to Main SWAG index] [Original]

    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.

[Back to POINTERS SWAG index] [Back to Main SWAG index] [Original]