cpwntbuf.pas

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

{$I CPDIR.INC}

{*
   Experimental unit using collections to store n-trees as
   null terminated strings.

   Hope to gain speed by O(1) look up of trees, and no ancestor
   function conversions.
*}

unit cpwntbuf;

interface

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

const
   ABSOLUTEMAXTREES = 16384;
   ACTIVECELLS      =  1024; { 16384 div 16 }
   MAXTREES = 1000;
   DELTA    =  100;

type
   ACTIVITIES = array[0..1024] of word;

   PTREE_BUFFEROBJ = ^TREE_BUFFEROBJ;
   TREE_BUFFEROBJ = object
      constructor Init;
      constructor Load (var S: TStream);
         {Loads object from the stream <\b S> }
      procedure Store (var S: TStream);virtual;
         {Stores object on the stream <\b S>}

      destructor Done;
      function BufferError:integer;
      procedure Clear;
      function CurrentTree:integer;
      function CurrentTreeID:integer;
      procedure FirstActiveTree (var T:TREEOBJ);
      procedure FirstTree (var T:TREEOBJ);
      procedure GetActiveTree (ithTree:integer;var T:TREEOBJ);
      procedure GetTree (ithTree:integer; var T:TREEOBJ);
      procedure GetDrawTree (ithTree:integer; T:DRAW_TREEOBJ_PTR);
      function IthActiveID (ithTree:integer):integer;
      function MoreActiveTrees:Boolean;
      function MoreTrees:Boolean;
      function NextActiveID (Tree:integer):integer;
      procedure NextActiveTree (var T:TREEOBJ);
      procedure NextTree (var T:TREEOBJ);
      procedure PreviousActiveTree (var T:TREEOBJ);
      procedure PutTree (var T:TREEOBJ);
      procedure ReplaceTree (var T:TREEOBJ; Index:integer);
      procedure ReverseSwitches;
      procedure SwitchAllTreesOff;
      procedure SwitchAllTreesOn;
      procedure SwitchTreeOff (t_num:integer);
      procedure SwitchTreeOn (t_num:integer);
      function TreesActive:integer;
      function TreeIsActive (t_num:integer):Boolean;
      function TreesStored:integer;

      function ATree (i:integer):PChar;
      procedure AddTreeString (ts:PChar);
      procedure ShowTrees (var f:text);
      private
      Buffer   : TStrCollection;
      Active   : ACTIVITIES;
      Error    : integer;
      TreeID,
      Cur_Tree,
      Orig_Active,
      Trees_Active: integer;
      procedure StringToTree (A:PChar; var T:TREEOBJ);
      function TreeToString (var T:TREEOBJ):PChar;
      end;

const
  RTreeBufferObj: TStreamRec = (
    ObjType: 101;
    VmtLink: Ofs(TypeOf(TREE_BUFFEROBJ)^);
    Load:    @TREE_BUFFEROBJ.Load;
    Store:   @TREE_BUFFEROBJ.Store);


implementation

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

{ 16 bit bitmasks }
type
   BITLIST = array[0..15] of word;
const
   BITS = 16;
   BITMASK:BITLIST = ($0001,$0002,$0004,$0008,
   		      $0010,$0020,$0040,$0080,
                      $0100,$0200,$0400,$0800,
                      $1000,$2000,$4000,$8000);
   NULL_MASK = $0000;
   FULL_MASK = $FFFF;

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

   constructor TREE_BUFFEROBJ.Init;
   var
      i :  0..ACTIVECELLS;
   begin
      Error             := erOK;
      Buffer.Duplicates := True;      { allow duplicate trees }
      Buffer.Init (MAXTREES, DELTA);  { collection can store 1000 trees }
      for i := 0 to ACTIVECELLS do    { all trees are active }
         Active[i] := FULL_MASK;
      Trees_Active := 0;
      Cur_Tree     := 0;
   end;


   constructor TREE_BUFFEROBJ.Load (var S: TStream);
   var
      i, j: integer;
   begin
      Buffer.Load (S);
      S.Read (Trees_Active, SizeOf(Trees_Active));
      j := Buffer.Count div 16;
      for i := 0 to j do
         S.Read (Active[i], SizeOf (Active[i]));
   end;

   procedure TREE_BUFFEROBJ.Store (var S: TStream);
   var
      i, j: integer;
   begin
      Buffer.Store (S);
      S.Write (Trees_Active, SizeOf (Trees_Active));
      j := Buffer.Count div 16;
      for i := 0 to j do
         S.Write (Active[i], SizeOf (Active[i])); 
   end;

   destructor TREE_BUFFEROBJ.Done;
   begin
      Buffer.Done;
   end;

   function TREE_BUFFEROBJ.ATree (i:integer):PChar;
   begin
      ATree := PChar(Buffer.At(Pred(i)));
   end;

   procedure TREE_BUFFEROBJ.AddTreeString (ts:PChar);
   begin
      Buffer.AtInsert (Buffer.Count, ts);
      Inc (Trees_Active);
   end;

{-----------------------------Clear----------------------------------------}
   procedure TREE_BUFFEROBJ.Clear;
   begin
      Buffer.FreeAll;  { delete and dispose of all items }
   end;
{-----------------------------BufferError----------------------------------}
   function TREE_BUFFEROBJ.BufferError:integer;
   begin
      BufferError := Error;
   end;
{-----------------------------TreesStored----------------------------------}
   function TREE_BUFFEROBJ.TreesStored:integer;
   begin
      TreesStored := Buffer.Count;
   end;
{-----------------------------TreesActive----------------------------------}
   function TREE_BUFFEROBJ.TreesActive:integer;
   begin
      TreesActive := Trees_Active;
   end;
{-----------------------------PutTree--------------------------------------}
   procedure TREE_BUFFEROBJ.PutTree (var T:TREEOBJ);
   begin
      if (Buffer.Count < ABSOLUTEMAXTREES) then begin 
         Buffer.AtInsert (Buffer.Count, TreeToString (T));
         Inc (Trees_Active);
         end
      else Error := erTooManyTrees;
   end;
{-----------------------------GetTree--------------------------------------}
   procedure TREE_BUFFEROBJ.GetTree (ithTree:integer; var T:TREEOBJ);
   begin
      StringToTree (PChar(Buffer.At(Pred(ithTree))), T);
   end;

   procedure TREE_BUFFEROBJ.GetDrawTree (ithTree:integer; T:DRAW_TREEOBJ_PTR);
   var
      A: PChar;
      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
      A := PChar(Buffer.At(Pred(ithTree)));

      { 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;
{-----------------------------TreeIsActive---------------------------------}
   { True if tree t_num is active }
   function TREE_BUFFEROBJ.TreeIsActive (t_num:integer):Boolean;
   var
      t_mod, t_div : integer;
   begin
      t_div := t_num div BITS;
      t_mod := t_num mod BITS;
      { Only switch tree on if it is off... }
      TreeIsActive := (Active[t_div] and BITMASK[t_mod] = BITMASK[t_mod]);
   end;
{-----------------------------SwitchAlltreesOn-----------------------------}
   { Switch all trees ON by filling Active
     flag with FULL_MASK. }
   procedure TREE_BUFFEROBJ.SwitchAllTreesOn;
   var
      i, j: integer;
   begin
      j := Buffer.Count div BITS;
      for i := 0 to j do
         Active[i] := FULL_MASK;
      Trees_Active := Buffer.Count;
   end;
{-----------------------------SwitchAllTreesOff----------------------------}
   { Switch all trees OFF by filling Active
     flag with NULL_MASK. }
   procedure TREE_BUFFEROBJ.SwitchAllTreesOff;
   var
      i, j: integer;
   begin
      j := Buffer.Count div BITS;
      for i := 0 to j do
         Active[i] := NULL_MASK;
      Trees_Active := 0;
   end;
{-----------------------------SwitchTreeOn---------------------------------}
   { Switch on the bit in the Active flag corresponding
     to tree t_num. Increment count of active trees. }
   procedure TREE_BUFFEROBJ.SwitchTreeOn (t_num:integer);