cpwsbuf.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             }
{                                             }
{*********************************************}


{*
   Unit to store trees as ancestor function strings
   in a Turbo Pascal TStrCollection object.

   To be used in tree search operations.

   Has the advantage that automatically stores only duplicates,
   hence I don't have to write code for that, and by using
   null-terminated strings it dynamically sizes the memory
   needed to store each tree (might investigate using it for
   primary tree buffer as well).


   11 Sep 1991   Written.

   21 Apr 1992   Code added in InsertTree to check for buffer
                 overflow (how could I forget this?!),
                 need to let user know that this has happened.
   31 Dec 1991 Bug in TreeToString fixed. If tree was pruned
               the existence of NIL leaves would cause UAE.
*}

{$I cpdir.inc}

unit cpwsbuf;

interface

uses
	{$IFDEF BWCC}  { use Borland-style dialogs }
   {$IFDEF VER10} { TPW 1.0 }
   WObjectB,
   BWCC,
	{$ELSE}        { TPW 1.5 } 
   WObjects,
   {$ENDIF}
	{$ELSE}         
   WObjects,
	{$ENDIF}		   {use standard dialogs }
	Strings,
   cpvars,
   cperror,
   cptree,
	cpanc;

const
   MAXTREES = 1000;

type
   PTREEBUF = ^TREEBUF;
   TREEBUF = object 
      Buffer   : TStrCollection;
      Collapse : Boolean;
      constructor Init (BufferSize: integer);
      destructor Done;
      procedure Clear;
      function InsertTree (var T:TREEOBJ):PChar;
      function GetLimit:integer;
      procedure ShowTrees (var f:text);
      function TreeToString (var T:TREEOBJ):PChar;
      function SupportedAnc (p:NODE_PTR):NODE_PTR;
      procedure StringToTree (A:PChar; var T:TREEOBJ);
      procedure StringToDrawTree (A:PChar; var T:DRAW_TREEOBJ);
      procedure StringToAnc (A: PChar; var Anc: ANCFUNCOBJ);
      end;

implementation

const
   MAXCHARS  = MAXNODES + 3;
   ROOT_CHAR = #219;

type
   TSTRING = array[0..MAXCHARS] of char;

   constructor TREEBUF.Init (BufferSize: integer);
   begin
      Buffer.Init (BufferSize, 0);
      Collapse := False;
   end;

   destructor TREEBUF.Done;
   begin
      Buffer.Done;
   end;

   function TREEBUF.GetLimit:integer;
   begin
      GetLimit := Buffer.Limit;
   end;

   procedure TREEBUF.Clear;
   begin
      Buffer.FreeAll;  { delete and dispose of all items }
   end;

   { Return NIL if T is already in buffer,
     otherwise store T and return a pointer to the
     description. }
   function TREEBUF.InsertTree (var T:TREEOBJ):PChar;
   var
      Item  : PChar;
      Index : integer;
   begin
      InsertTree := NIL;
      Item := TreeToString (T);
      if not Buffer.Search (Buffer.KeyOf (Item), Index) then
         { Tree is new... }
         if (Buffer.Count < Buffer.Limit) then begin
            { and we have room in the buffer. }
            Buffer.AtInsert (Index, Item);
            InsertTree := Item;
            end;
   end;

   procedure TREEBUF.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;


   { If Collapse is False then just return p^.anc,
     otherwise return the first ancestor of p for
     which there is evidence (i.e., node is marked).
   }
   function TREEBUF.SupportedAnc (p:NODE_PTR):NODE_PTR;
   var
      q: NODE_PTR;
   begin
      if not Collapse then
         SupportedAnc := p^.anc
      else begin
         q := p;
         repeat
            q := q^.anc;
         until (q = NIL) or (q^.IsMarked);
         SupportedAnc := q;
         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 TREEBUF.TreeToString (var T:TREEOBJ):PChar;
   var
      A  : TString;
      i,j,
      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);
      i := 0;
      j := 0;
      while (i < n) do begin
         { Bug fix 31 Dec 1991 }
         { get active leaf }
         repeat
            Inc (j);
            p := T.NL[j];
         until (p <> NIL);
         Inc (i);

         q := SupportedAnc (p);
         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 := SupportedAnc (q);
               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 TREEBUF.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;


   { Convert a string ancestor function to a tree. }
   procedure TREEBUF.StringToDrawTree (A: PChar; var T:DRAW_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;



   { Return a string ancestor function as an ANCFUNCOBJ }
   procedure TREEBUF.StringToAnc (A: PChar; var Anc: ANCFUNCOBJ);
   var
      i, j, k : integer;
   begin
      Anc.A[1] := ord(A[0]);
      Anc.A[2] := ord(A[1]);
      j := Anc.A[1] + 1;
      for i := 2 to j do
         Anc.A[Succ(i)] := ord(A[i]);
      k := j + 1;
      j := k + Anc.A[2] - 1;
      for i := k to j do
         if (A[i] = ROOT_CHAR) then
            Anc.A[i+1] := 0
         else Anc.A[i+1] := ord(A[i]);
   end;

begin
end.