cpbtree.pas

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

{*********************************************}
{                                             }
{    COMPONENT for MS DOS and MS WINDOWS      }
{                                             }
{    Source code for Turbo Pascal 6.0 and     }
{    Turbo Pasacal for Windows 1.0 compilers. }
{                                             }
{    (c) 1991, Roderic D. M. Page             }
{                                             }
{*********************************************}

{$I CPDIR.INC}

unit cpbtree;


{ Binary tree

   <\b History>

   5/22/91  Sketched out

    4 Dec 1991 Code for random trees added, code cleaned up.
   26 Jun 1992 ReRootAt function added from NEIGHBOR.PAS.
   15 Jul 1992 AnyTwo- and AnyThreeLeafTree added to facilitate
               tree building with random order addition of leaves.

*}


interface

uses
   cpvars,
   cpwrand,
   cperror,
   cptree,
   cplabels;

type
   { binary n-tree }
   BIN_TREEOBJ_PTR = ^BIN_TREEOBJ;
   {Pointer to [BIN_TREEOBJ]}
   BIN_TREEOBJ = object(TREEOBJ)
      { Binary n-tree }
      constructor Init;
      {Call TREEOBJ.Init}
      destructor Done;virtual;
      {Call TREEOBJ.Done}
      function ReRootAt (Outgroup:NODE_PTR):NODE_PTR;
         { Reroot tree using <\b Outgroup> and return the previous outgroup,

           1  2  3       3   1  2
           \   \/         \   \/
            \  /    -\>    \  /
             \/             \/

           <\b Outgroup>=3    ReRoot=1
          }
      procedure AddNodeBelow (Node, NodeAnc, Below:NODE_PTR);
         {Add <\b Node> and its ancestor <\b NodeAnc> below node <\b Below>

          \\<bml btree.bmp\\>

          None of the tree's fields are updated.}
      procedure RandomRooted (var U:UNIFORM; n:integer);
         {Generate a random, rooted, labeled binary tree with <\b n>
           leaves from a uniform distribution <\b U>. }
      procedure RandomUnrooted (var U:UNIFORM; n:integer);
         {Generate a random, unrooted, labeled binary tree with <\b n>
           leaves from a uniform distribution <\b U>. }
      function RemoveNode (Node:NODE_PTR):NODE_PTR;
         {Remove <\b Node> and its ancestor from tree and return the
          node below which <\b Node>'s anc was removed. Preserve the
          <\b Node>^.anc = NodeAnc relationship, and the direction of
          the descendant.}
      procedure ThreeLeafTree (nLeaves:integer);
   { Make a three leaf unrooted tree for use in generating
     unrooted trees. Call [TwoLeafTree] to set up [NL].

          2---3
            \
        1---m+1
         \
          m
   }

         {}
      procedure TwoLeafTree (nleaves:integer);
      {
      Allocate n=<\b nleaves> leaves and n-1 internals, make nodes m,...,m+n
      ancestors of leaves 1,..,n, and those leaves are left desc of the
      nodes, i.e.:
      
      1  2  3  ...   n
      .  .           .
      .  .           .
      m  m m+1     m+n-2
      
      and create 2-tree:

         NL1--s--NL2
           \.      .
            \a    a
             c.  .
              \..
              NLm
               .
               .
               .
               =
   }
      procedure AnyThreeLeafTree (nLeaves, L1, L2, L3:integer);
      {Create a 3-leaf tree with leaves L1 and L2 and all other leaves
       allocated as for [ThreeLeafTree] }
      procedure AnyTwoLeafTree (nleaves, L1, L2:integer);
      {Create a 2-leaf tree with leaves L1 and L2 and all other leaves
       allocated as for [TwoLeafTree] }
      procedure UnlabeledMarkovian (var U:UNIFORM;n:integer);
         { Generate a random unlabeled rooted binary tree with the toplogy
           drawn from the Markovian distribution (= stripped dendrogram).}
      end;

   DENDROGRAM_PTR = ^DENDROGRAM;
   {Pointer to [DENDROGRAM]}
   DENDROGRAM = object(BIN_TREEOBJ)
      {Binary dendrogram. Abstract as yet }
      constructor Init;
      {}
      destructor Done;virtual;
      {}
      end;


   ALLTREES = object
      {Object that generates all possible trees }
      Error : integer;
      { Error status}
      T: BIN_TREEOBJ;
      { A tree }
      constructor Init (n:integer;LPtr:LABELOBJ_PTR);
      {Sets the size of the trees to <\b n>, stores a pointer to the labels,
      and sets [[Error]] to [erOK:cperror.erOK.erOK]}
      destructor Done;
      {Abstract}
      function TreeOK:Boolean;virtual;
      {Returns true. Place holder for descendants to override if want to
       select from among the trees.}
      procedure TreeOp;virtual;
      {Place holder for descendants to override with an operation on
       the current tree}
      procedure MakeTrees (MakeRooted:Boolean);
      {Recursively generates all binary trees, calling [TreeOK] and [TreeOp]. If
      <\b MakeRoot> is true then trees are rooted, otherwise they are unrooted.}
      private
      L: LABELOBJ_PTR;
      Size: integer;
      end;

implementation

{**********************}
{                      }
{  BIN_TREEOBJ object  }
{                      }
{**********************}

{-----------------------------Init-----------------------------------------}

   constructor BIN_TREEOBJ.Init;
   begin
      TREEOBJ.Init;
   end;

{-----------------------------Done-----------------------------------------}

   destructor BIN_TREEOBJ.Done;
   begin
      TREEOBJ.Done;
   end;

{-----------------------------AddNodeBelow---------------------------------}

   procedure BIN_TREEOBJ.AddNodeBelow (Node, NodeAnc, Below:NODE_PTR);

   { Given Node and its ancestor NodeAnc, add to tree. Assumes
     Node^.anc = NodeAnc.

     Two cases:

     Left desc               Right desc
     ---------               ----------

     Node                         Node
      \.                     =    .
       \.            and      \  .
        \.                     \.
      NodeAnc--||            NodeAnc--||


    Node is added below Below, e.g. (for left desc):

                            \   /
          Node  NIL          \ /
            \   /           Below
             \ /             /
            NodeAnc ---->   /
              |            /
             NIL          /
                      Below^.anc

     NOTE:
     ====

     1. Tree's weights, etc, are not corrected.

   }
   begin
      NodeAnc^.MakeAnc (NIL);
      NodeAnc^.MakeAnc (Below^.NodeAncestor);

      if (NodeAnc^.NodeChild <> NIL) then begin  { node is left desc }
         NodeAnc^.MakeRight (Below);
         NodeAnc^.MakeSib (Below^.NodeSibling);
         Below^.MakeSib (NIL);
         end
      else begin                                 { node is right desc }
         NodeAnc^.MakeLeft (Below);
         NodeAnc^.MakeSib (Below^.NodeSibling);
         Below^.MakeSib (Node);
         end;


      if (Below^.NodeAncestor = NIL) then
         Root := NodeAnc
      else
         if IsChild (Below) then
            Below^.NodeAncestor^.MakeLeft (NodeAnc)
         else
            Below^.NodeAncestor^.MakeRight (NodeAnc);
      NodeAnc^.MakeAnc (Below^.NodeAncestor);
      Below^.MakeAnc (NodeAnc);
   end;

{-----------------------------RemoveNode-----------------------------------}
   {
     Remove node Node and its ancestor from tree and return the
     node (p) below which Node's anc was removed.
     Preserve the Node^.anc = NodeAnc relationship, and
     the direction of the descendant. Two results:

     Left desc               Right desc
     ---------               ----------

     Node                         Node
      \.     p                p    .
       \.   /        and      \  .
        \. /                   \.
      NodeAnc--||            NodeAnc--||

   }

   function BIN_TREEOBJ.RemoveNode (Node:NODE_PTR):NODE_PTR;
   var
      NodeAnc, p, q: NODE_PTR;
   begin
      NodeAnc := Node^.anc;
      if IsChild (Node) then
         p := NodeAnc^.RightDesc
      else begin
         p := NodeAnc^.LeftDesc;
         NodeAnc^.child := NIL;
         end;

      q := NodeAnc^.anc;

      if (q = NIL) then begin   { NodeAnc is Root }
         p^.MakeSib (NIL);
         Root := p;
         end
      else
         if IsChild (NodeAnc) then
            q^.MakeChild (p)
         else q^.MakeRight (p);

      p^.MakeSib (NodeAnc^.NodeSibling);
      p^.MakeAnc (q);

      { ensure }
      NodeAnc^.MakeSib (NIL);

      RemoveNode := p;
   end;

{-----------------------------TwoLeafTree----------------------------------}

   {
      Allocate n leaves and n-1 internals, make nodes m,...,m+n
      ancestors of leaves 1,..,n, and those leaves are
      left desc of the nodes, i.e.:



      1  2  3  ...   n
      .  .           .
      .  .           .
      m  m m+1     m+n-2


      and create 2-tree:

         NL[1]--s-->NL[2]
           \.      .
            \a    a
             c.  .
              \..
              NL[m]
               .
               .
               .
               =

   }
   procedure BIN_TREEOBJ.TwoLeafTree (nleaves:integer);
   var
      i, m: integer;
   begin
      AllocateNodeList (Pred (2 * nleaves));
      m := Succ (nleaves);

      for i := 2 to nleaves do begin
         NL[i]^.MakeAnc (NL[m + (i-2)]);
         NL[m+i-2]^.MakeLeft (NL[i]);
         NL[i]^.SetLeaf;
         NL[i]^.SetNamePtr(i);
         NL[i]^.SetLeafNum(i);
         NL[i]^.Mark;
         NL[m + i - 2]^.SetNamePtr (m+i-2);
         NL[m + i - 2]^.Mark;
         end;
      NL[1]^.SetLeaf;
      NL[1]^.MakeAnc (NL[m]);
      NL[1]^.SetNamePtr (1);
      NL[1]^.SetLeafNum (1);