cpanc.pas

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

{$I CPDIR.INC}


{*
   Ancestor functions for tree storage

   2/14/91

   3/39/91 CPSEARCH may call TreeToAncFunc with a
           pruned tree, so code added to check
           for nil NL[i] ptrs.

*}

unit cpanc;

{
   Ancestor function has the form

   n, m, f(1), f(2), ..., f(n), ...,f(n + m)

   where
      n    number of leaves
      m    number of internals
      f(i) ancestor of i

   The leaves <1,n> are stored first, and f(root) = 0.
}

interface

uses
   cpvars,
   cpmem,
   cptree;

const
   ANC_SIZE = MAXNODES + 2; {first two cells are for n and m }

type
   ANCFUNC = array[1..ANC_SIZE] of byte;

   ANCFUNC_PTR = ^ANCFUNCOBJ;
   ANCFUNCOBJ = object
      Error : integer;
      A: ANCFUNC;
      constructor Init;
      destructor Done;
      procedure TreeToAncFunc (var T:TREEOBJ);
      procedure AncFuncToTree (var T:TREEOBJ);
      procedure Show (var f:text);

      {$IFDEF debug}
      procedure Dump (var f:text);
      {$ENDIF}

      end;


implementation

   {---ANCFUNCOBJ---}

const
   erNOMEMORY = 1;

   constructor ANCFUNCOBJ.Init;
   begin
      Error := 0;
      FillChar (A, ANC_SIZE, 0);
   end;

   destructor ANCFUNCOBJ.Done;
   begin
   end;

   {$IFDEF debug}
   procedure ANCFUNCOBJ.Dump (var f:text);
   { Display ancestor function }
   var
      i, nodes: integer;
   begin
      writeln (f,A[1]:3,A[2]:3);
      nodes := A[1] + A[2];
      for i := 1 to nodes do
         write (f,i:3);
      writeln (f);
      for i := 1 to nodes do
         write (f,A[i+2]:3);
      writeln (f);
   end;
   {$ENDIF}

   procedure ANCFUNCOBJ.Show (var f:text);
   { Write ancestor function }
   var
      i, nodes: integer;
   begin
      nodes := A[1] + A[2];
      for i := 1 to nodes do
         write (f,A[i+2]:3);
      writeln (f);
   end;


   procedure ANCFUNCOBJ.TreeToAncFunc (var T:TREEOBJ);
   { Convert T to an ancestor function. }

   { Uses index fields for labeling internal nodes.
     Ensures they =0 before and after. }

   { Routine goes through the n leaves in order, going
     down to path to root. Each unlabeled internal node
     encountered is labeled with the next available label
     in the range <n+1,..,2n-1>. This ensures that
     each tree has a unique ancestor function regardless
     of its shape. }

   { 3/39/91

     cpsearch may call this routine with
     a pruned tree, so code added to check
     for nil NL[i] ptrs. }


   var
      j,i,
      Internal_Count: integer;
      p,q: NODE_PTR;

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

   begin
      { ensure }
      T.ClearIntIndex;


      Fillchar (A, ANC_SIZE, 0);
      A[1] := T.TreeLeaves;
      A[2] := T.TreeInternals;

      T.BuildLeafList;
      Internal_Count := Succ (A[1]);
      j := 0;
      for i := 1 to A[1] do begin
         repeat
            Inc (j);
            q := T.NL[j];
         until (q <> NIL);
         if Labeled (q^.NodeAncestor) then
            { Ancestor has already been labeled }
            A[i + 2] := q^.NodeAncestor^.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. }
            p := q;
            q := q^.NodeAncestor;
            while (q <> NIL) and not Labeled (q) do begin
               q^.SetIndex (Internal_Count);
               Inc (Internal_Count);
               if p^.IsLeaf then
                  A[i+2] := q^.NodeIndex
               else A[p^.NodeIndex + 2] := q^.NodeIndex;
               p := q;
               q := q^.NodeAncestor;
               end;
            if (q <> NIL) then
               A[p^.NodeIndex + 2] := q^.NodeIndex;
            end;
         end; { for i := }

      { ensure }
      T.ClearIntIndex;
   end;


   procedure ANCFUNCOBJ.AncFuncToTree (var T:TREEOBJ);
   { Convert ancestor function to a tree }
   var
      i, j, k: 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[A[node + 2]];   { 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;
      T.SetLeaves (A[1]);
      T.SetInternals (A[2]);
      NumNodes := A[1] + A[2];

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


      { Do the leaves... }
      for i := 1 to A[1] 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 (A[1]) to NumNodes do begin
         with T.NL[i]^ do begin
            SetInternal;
            SetNamePtr (0);
            SetIndex (i);
            end;
         if (A[i + 2] = 0) then
            T.SetRoot (T.NL[i])
         else InsertNode (i);
         end;

      T.CorrectWeights;
      T.BuildClusters;
   end;

end.