cpwntbuf.pas

生物信息学中的遗传数据分析的delphi源码。

   var
      t_div, t_mod: integer;
   begin
      t_div := t_num div BITS;
      t_mod := t_num mod BITS;
      { Only switch tree on if it is off... }
      if ((Active[t_div] and BITMASK[t_mod]) = NULL_MASK) then begin
         Active[t_div] := Active[t_div] or BITMASK[t_mod];
         Inc (Trees_Active);
         end;
   end;
{-----------------------------SwitchTreeOff--------------------------------}
   { Switch off the bit in the Active flag corresponding
     to tree t_num. Decrement count of active trees. }
   procedure TREE_BUFFEROBJ.SwitchTreeOff (t_num:integer);
   var
      t_div, t_mod: integer;
   begin
      t_div := t_num div BITS;
      t_mod := t_num mod BITS;
      { Only switch tree off if it is on... }
      if ((Active[t_div] and BITMASK[t_mod]) = BITMASK[t_mod]) then begin
         Active[t_div] := Active[t_div] and not BITMASK[t_mod];
         Dec (Trees_Active);
         end;
   end;
{-----------------------------ReverseSwitches------------------------------}
   { Reverse the current activities of all trees
     by XORing Active flags with FULL_MASK. }
   procedure TREE_BUFFEROBJ.ReverseSwitches;
   var
      i, j: 0..ACTIVECELLS;
   begin
      j := Buffer.Count div BITS;
      for i := 0 to j do
         Active[i] := Active[i] xor FULL_MASK;
      Trees_Active := Buffer.Count - Trees_Active;
   end;


(***)

{-----------------------------NextActiveID---------------------------------}
   { Return the ID of the next active tree after Tree
     in the buffer. Tree is an absolute value (=TreeID of tree).}
   function TREE_BUFFEROBJ.NextActiveID (Tree:integer):integer;
   begin
      repeat
         Inc (Tree);
      until TreeIsActive (Tree);
      NextActiveID := Tree;
   end;
{-----------------------------IthActiveID----------------------------------}
   { Return the ID of the ith active tree in the buffer }
   function TREE_BUFFEROBJ.IthActiveID (ithTree:integer):integer;
   var
      i,j:integer;
   begin
      { Go through buffer for ith active tree }
      i := 0;
      j := 0;
      while (i < ithTree) do begin     { loop until ith active tree }
         repeat
            Inc(j);
         until (TreeIsActive (j));
         Inc (i);
         end;
      IthActiveID := j;
   end;
{-----------------------------GetActiveTree--------------------------------}
   { Return the ith ACTIVE tree in buffer. Update TreeID and Cur_tree. }
   procedure TREE_BUFFEROBJ.GetActiveTree (ithTree:integer; var T:TREEOBJ);
   var
      i, j: integer;
   begin
      { If all trees are active then simply get tree from buffer }
      if (Buffer.Count = Trees_Active) then
         TreeID := ithTree
      else TreeID := IthActiveID (ithTree);
      GetTree (TreeID, T);
      Cur_tree := ithTree;
   end;


   procedure TREE_BUFFEROBJ.FirstTree(var T:TREEOBJ);
   begin
      Cur_tree := 1;
      TreeID   := 1;
      GetTree (1, T);
   end;

   procedure TREE_BUFFEROBJ.NextTree (var T:TREEOBJ);
   begin
      Inc (Cur_tree);
      Inc (TreeID);
      GetTree (Cur_Tree, T);
   end;

   function TREE_BUFFEROBJ.MoreTrees:Boolean;
   begin
      MoreTrees := (Cur_tree < Buffer.Count);
   end;

   procedure TREE_BUFFEROBJ.FirstActiveTree (var T:TREEOBJ);
   { TreeID is absolute, Cur_Tree is relative.
     Orig_Active stores the current number of
     active trees so that calling routine
     can switch of some trees without
     affecting iterator. }
   begin
      Orig_Active := Trees_Active;
      Cur_tree := 0;
      TreeID   := 0;
      repeat
         Inc (TreeID);
      until TreeIsActive (TreeID);
      GetTree (TreeID, T);
      Inc (Cur_Tree);
   end;

   procedure TREE_BUFFEROBJ.NextActiveTree (var T:TREEOBJ);
   begin
      repeat
         Inc (TreeID);
      until TreeIsActive (TreeID);
      GetTree (TreeID, T);
      Inc (Cur_Tree);
   end;

   procedure TREE_BUFFEROBJ.PreviousActiveTree (var T:TREEOBJ);
   begin
      repeat
         Dec (TreeID);
      until TreeIsActive (TreeID);
      GetTree (TreeID, T);
      Dec (Cur_Tree);
   end;

   function TREE_BUFFEROBJ.MoreActiveTrees:Boolean;
   begin
      MoreActiveTrees := (Cur_tree < Orig_Active);
   end;

   function TREE_BUFFEROBJ.CurrentTree:integer;
   { Relative order of tree in buffer }
   begin
      CurrentTree := Cur_tree;
   end;

   function TREE_BUFFEROBJ.CurrentTreeID:integer;
   { Absolute order of tree in buffer }
   begin
      CurrentTreeID := TreeID;
   end;


   procedure TREE_BUFFEROBJ.ShowTrees (var f:text);
   var
      i: integer;
      T: TREEOBJ;
   begin
      for i := 0 to Pred (Buffer.Count) do begin
         StringToTree (PChar(Buffer.At(i)), T);
         write (f, i:3, ' ');
         T.WriteTree (f);
         T.Done;
         end;
   end;


   { Return the ancestor function of a tree T
     as a null terminated string. The ancestor
     function has the standard form

     n, m, l1, l2, ..., ln, i1, i2,..., im

     where
        n = number of leaves
        m = number of internals
        li = ancestors of leaves
        ii = ancestors of internals

     The root has the ancestor ROOT_CHAR (#0 would
     terminate the string!).
   }
   function TREE_BUFFEROBJ.TreeToString (var T:TREEOBJ):PChar;
   var
      A  : TString;
      i,
      m,
      n  : integer;
      p,
      q: NODE_PTR;

      function Labeled (p:NODE_PTR):Boolean;
      begin
         Labeled := (p^.NodeIndex <> 0);
      end;

   begin
      T.ClearIntIndex;
      n    := T.TreeLeaves;
      A[0] := chr (n);
      m    := Succ (n);
      for i := 1 to n do begin
         p := T.NL[i];
         q := p^.anc;
         if Labeled (q) then
            A[Succ(i)] := chr (q^.NodeIndex)
         else begin
            { Ancestor hasn't been labeled, go down
              tree labeling internals as we go until
              either the root or a labeled node is reached. }
            while (q <> NIL) and not Labeled (q) do begin
               q^.SetIndex (m);
               Inc (m);
               if p^.IsLeaf then
                  A[Succ(i)] := chr (q^.NodeIndex)
               else A[Succ(p^.NodeIndex)] := chr(q^.NodeIndex);
               p := q;
               q := q^.anc;
               end;
            if (q <> NIL) then
               A[Succ(P^.NodeIndex)] := chr(q^.NodeIndex);
            end;
         end; { for i := }

      { Ensure root has valid ancestor, update internals,
        and terminate string. }
      A[Succ (T.Root^.NodeIndex)] := ROOT_CHAR;
      A[1]     := chr (m - n - 1);
      A[m + 1] := #0;
      TreeToString := StrNew (A);
      { ensure }
      T.ClearIntIndex;
   end;


   { Convert a string ancestor function to a tree. }
   procedure TREE_BUFFEROBJ.StringToTree (A: PChar; var T:TREEOBJ);
   var
      i, j, k, n, m: integer;
      p: NODE_PTR;
      NumNodes,
      Start : integer;

      procedure InsertNode (node:integer);
      var
         p, q, r: NODE_PTR;
      begin
         r := T.NL[node];          { node }
         p := T.NL[ord (A[node + 1])];   { its ancestor }
         p^.IncDegree;
         r^.MakeAnc (p);
         if not p^.HasChild then
            p^.MakeChild(r)        { r is p's child }
         else begin
            q := p^.NodeChild;     { r is a sibling of p's child }
            while q^.HasSibling do
               q := q^.NodeSibling;
            q^.MakeSib(r);
            end;
      end;

   begin
      { Set up tree }
      T.Init;
      n := ord(A[0]);
      m := ord(A[1]);
      T.SetLeaves (n);
      T.SetInternals (m);
      NumNodes := n + m;

      T.AllocateNodeList(NumNodes);
      if (T.Error <> 0) then begin
         ErrorRec.UpDate (erNOMEMORY);
         Exit;
         end;


      { Do the leaves... }
      for i := 1 to n do begin
         with T.NL[i]^ do begin
            SetLeaf;
            SetNamePtr (i);
            SetLeafNum (i);
            SetIndex(i);
            end;
         InsertNode (i);
         end;

      { Now the internals... }
      for i := Succ (n) to NumNodes do begin
         with T.NL[i]^ do begin
            SetInternal;
            SetNamePtr (0);
            SetIndex (i);
            end;
         if (A[i + 1] = ROOT_CHAR) then
            T.SetRoot (T.NL[i])
         else InsertNode (i);
         end;

      T.CorrectWeights;
      T.BuildClusters;
   end;


   { Replace the tree "Index" with T. }
   procedure TREE_BUFFEROBJ.ReplaceTree (var T:TREEOBJ; Index:integer);
   begin
      Buffer.AtPut (Index, TreeToString (T));
   end;

begin
   RegisterType (RStrCollection);
   RegisterType (RTreeBufferObj);
end.