cplabels.pas

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

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, Roderic D. M. Page                                    *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}


{$I CPDIR.INC}


{*

   TO DO
   =====

   1. Could clean up by using PChar type instead
      of Pascal string type.

   2. Use constant declarations for characters like
      underscore. (better programing)

*}


unit cplabels;

{Leaf label operations


 Data structure for storing and accessing leaf labels.

  1. <\i leafcodes> is a hash table for looking up labels. It stores
     the index of each label in the array <\i leaflabels>. In the exmaple below,
     the label 'taxon_1' was the first label encountered and has a hash code of
     3. Hence leafcodes\[3\]=1. 

  2. <\i leaflabels> stores the actual labels in the order encountered by the program. 

  3. <\i translation> maps the tokens in the TRANSLATE command onto the
     leaf labels. The value is the index of the label corresponding to
     the <\i i>th token. Normally this map will be (1,1) (2,2), etc,
     so that the <\i i>th token maps onto the <\i i>th label but if the user doesn't
     order the translation table exactly this structure
     can accomodate this.

  4. <\i transcode> is a hash table for translate tokens.

  5. <\i translabels> stores the translate tokens corresponding to each label.

   <\f3
   i  leafcodes  leaflabels  translation    transcode  translabels
   ---------------------------------------------------------------
   1     3       taxon_1         1              n           t1
   2     2       taxon_2         2              3           t2
   3     1       taxon_3         3              2           t3
   .     .          .            .              .           .
   .     .          .            .              .           .
   .     .          .            .              .           .
   n     2       taxon_n         n              1           t4
   ----------------------------------------------------------------
   >


   <\b Uses>

    [cpvars:cpvars.cpvars] global variables
    [cpmem:cpmem.cpmem] Heap error function

   
   <\b History>

  2/7/91 Written
  3/27/91  Each label is allocated dynamically to save space.


  BM(NH)

   7 Jan 1992 Code added to remove '_' from labels for graphics
              printing.
 
  26 Jan 1993 Load and Store methods added.

	26 July 1993 Bug in LabelToPrintString allowed Hennig86 numeric labels
					to be output as is, not enclosed in quotes.
  }

interface

uses
   {$IFDEF WINDOWS}
   {$IFDEF DEBUG}
   WinCrt,
   {$ENDIF}
   WinTypes,
   WinProcs,
   WObjects,
   Strings,
   {$ENDIF}
   cpvars,      { global variables }
   cpmem;       { heap error function }

const
   MAXLENGTH = 16;  
      {Maximum number of characters in a label }
   HASHTABLESIZE = MAXLEAVES + 1; 
      {Size of hash table = [[MAXLEAVES:cpvars.MAXLEAVES]] + 1 }
   PROBELENGTH = 1; 
      {Length of hash table probe}

type
   LABEL_STR = string[MAXLENGTH];
      {A leaf label}
   LABEL_PTR = ^LABEL_STR;
      {Pointer to [[LABEL_STR]]}
   LABEL_LIST = array[1..MAXLEAVES] of LABEL_PTR;
      {List of leaf labels, large enough to accomodate [[MAXLEAVES:cpvars.MAXLEAVES]] labels}
   LABEL_CODE = array[1..HASHTABLESIZE] of 0..MAXLEAVES;
      {Hash table for leaf codes}
   LABELOBJ_PTR = ^LABEL_OBJ;
      {Pointer to [LABEL_OBJ]}
   LABEL_OBJ = object (TObject)
      { Encapsulates the labels and the translation table }
      constructor Init;
         {Clear all label lists and hash tables}


      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;virtual;
         {Free memory allocated for label lists}
      function AllAlphaStart:Boolean;
         {True if every label begins with a letter.}
      function LabelToPrintString(j:integer):string;
         {Return a label for writing to a NEXUS file. If label has any 
          punctuation other than _ and . then enclose in single quotes. 
         }
      function AddLabel (s:string; ptr:integer):integer;
         {Add label <\b s> to label list. The value of <\b ptr> is the
          order in which the calling routine encountered the label. If 
          the label does not already occur in list then the value of 
          <\b ptr> is stored in the hash table as a pointer to the actual
          label. 

           <\b Return values>
           <\tab>0<\tab>Successfully added to list
           <\tab>-1<\tab>Hash table overflow
           <\tab>-2<\tab>Insufficient memory for label
           <\tab><\i i><\tab>Index of <\b s> if it already occurs in hash table.
         }

      function AddTransLabel (s:string; ptr:integer):integer;
         {Add token <\b s> to translation table. The value of <\b ptr> is the
          order in which the calling routine encountered the label. If 
          the label does not already occur in list then the value of 
          <\b ptr> is stored in the hash table as a pointer to the actual
          token. 

          <\b See also>
          <\tab>[AddLabel]
         }
      function Encode (s:string; i:integer):integer;
         {Encode the leaf label <\b s>. Used to set up translation table for
          leaf labels. Calls [LocateLabel] to ensure <\b s> is a valid label. If 
          successful sets the private field translation\[<\b i>\] to the result of LocateLabel 
          and returns the same value, otherwise returns 0.}
      function Return_LabelPtr (s:string):integer;
         { Look up string <\b s> and return code if found, otherwise
           return 0. If a translation table is present will automatically
           translate <\b s>.}
      function Labels_Read:Boolean;
         {True if private field <\b LabelsRead> is true}
      procedure LabelsReadTrue;
         {Set the private <\b LabelsRead> field to true}       
      function LabelsStored:integer;
         {Return the number of labels stored.}
      procedure TranslateTrue;
         {Set the private <\b Translate> field to true}
      function LocateLabel (s:string):integer;
         {Looks up <\b s> in list of labels using hash table. Returns index of label if
          found, otherwise 0.}
      function ReturnLabel (i:integer):string;
         {Return a copy of the <\b i>th leaf label.}
      function ReturnNiceLabel (i:integer):string;
         {Return a copy of the <\b i>th leaf label with any
          underscores ("_") stripped.} 
      procedure MakeLabels (n:integer);
         { Make <\b n> labels of the form 1, 2, ...n 

           <\b See also>
           <\tab> [MakeAlphaLabels]
         }
      procedure MakeAlphaLabels (n:integer);
         { Make <\b n> labels of the form a..z,aa..zz,etc.
           Designed to be used by random tree generator to provide some 
           arbitrary labels. 
           
           <\b See also>
           <\tab> [MakeLabels]
         }
      function MaxLabelLength:integer;
         {Return the maximum number of characters in any of the labels.}
      {$IFDEF WINDOWS}
      function MaxLabelWidth (DC: HDC):word;
         {Return in device units the maximum width attained by any
          leaf label stored given the device context <\b DC>. Calls 
          Windows function <\i GetTextExtent>. }
      {$ENDIF}


{$IFDEF debug}
      procedure Dump(var f:text;n:integer);
         {Dump object fields}
{$ENDIF}

      private
      {fields}
      Stored     : integer;
      Translate  : Boolean;     { true if translation table exists }
      LabelsRead : Boolean;
      worklabel  : LABEL_STR;   { current label }
      leaflabels : LABEL_LIST;  { storage for labels }
      leafcodes  : LABEL_CODE;  { hash table for ptrs to labels   }
      translabels: LABEL_LIST;  { storage for tokens }
      transcodes : LABEL_CODE;  { hash table for ptrs to tokens }
      translation: LABEL_CODE;  { ptrs to label corresponding to token }
      {methods}
      procedure GetLabel (Token:string);
      function LabelToString:string;
      function HashCode:integer;
      function LocateName (var L:LABEL_LIST; var H:LABEL_CODE):integer;
      function AddName (var L: LABEL_LIST; var H: LABEL_CODE;
                         ptr : integer):integer;
      function LocateTransLabel (s:string):integer;
      function Decode (s:string):integer;
      end;

const
  RLabelObj: TStreamRec = (
    ObjType: 100;
    VmtLink: Ofs(TypeOf(LABEL_OBJ)^);
    Load:    @LABEL_OBJ.Load;
    Store:   @LABEL_OBJ.Store);
    {Registration record for LABEL_OBJ}


implementation

   procedure ClearList (var L:LABEL_LIST);
   var
      i:1..MAXLEAVES;
   begin
      for i := 1 to MAXLEAVES do
         L[i] := NIL;
   end;

   procedure ClearTable (var T:LABEL_CODE);
   var
      i:1..HASHTABLESIZE;
   begin
      for i := 1 to HASHTABLESIZE do
         T[i] := 0;
   end;


   constructor LABEL_OBJ.Init;
   begin
      Stored     := 0;
      Translate  := FALSE;
      LabelsRead := FALSE;
      worklabel  := '';
      ClearTable (leafcodes);
      ClearTable (transcodes);
      ClearTable (translation);
      ClearList (leaflabels);
      ClearList (translabels);
   end;

   constructor LABEL_OBJ.Load (var S: TStream);
   var
      i:integer;
   begin
      S.Read (Stored, sizeof(Stored));
      S.Read (Translate, sizeof(Translate));
      S.Read (LeafCodes, sizeof(LeafCodes));
      S.Read (TransCodes, sizeof(TransCodes));
      S.Read (Translation, sizeof (Translation));
      for i := 1 to Stored do
         LeafLabels[i] := LABEL_PTR (S.readStr);
      if Translate then
         for i := 1 to Stored do
            TransLabels[i] := LABEL_PTR (S.ReadStr); 
   end;

   procedure LABEL_OBJ.Store (var S: TStream);
   var
      i : integer;
   begin
      S.Write (Stored, sizeof(Stored));
      S.Write (Translate, sizeof(Translate));
      S.Write (LeafCodes, sizeof(LeafCodes));
      S.Write (TransCodes, sizeof(TransCodes));
      S.Write (Translation, sizeof (Translation));
      for i := 1 to Stored do
         S.WriteStr (PString (LeafLabels[i]));
      if Translate then
         for i := 1 to Stored do
            S.WriteStr (PString (TransLabels[i]));
   end;


   destructor LABEL_OBJ.Done;
   var
      i: integer;
   begin
      i := 0;
      while (i < Stored) do begin
         Inc (i);
         FreeMem (LeafLabels[i], SizeOf (LABEL_STR));
         if Translate then
            FreeMem (TransLabels[i], SizeOf (LABEL_STR));
         end;
   end;


   procedure LABEL_OBJ.GetLabel (Token:string);
   { Convert string to label, truncating if
     necessary. }
   var
      i: integer;
   begin
      worklabel := '';
      for i := 1 to MAXLENGTH do
         if (i <= Length (Token)) then
            worklabel := worklabel + Token[i];
   end;

   function LABEL_OBJ.LabelToString:string;
   { Return label as a string. }
   begin
      LabelToString := Copy (worklabel, 1, Length (worklabel));
   end;

   function LABEL_OBJ.ReturnLabel (i:integer):string;
   begin
      ReturnLabel := Copy (leaflabels[i]^, 1, Length(leaflabels[i]^));
   end;

   { Return a label with underscores replaced by spaces.
     Used when doing nice graphics of trees. }
   function LABEL_OBJ.ReturnNiceLabel (i:integer):string;
   var
      TempStr:string;
      j : byte;
   begin
      TempStr := Copy (leaflabels[i]^, 1, Length(leaflabels[i]^));
      j := Pos('_', TempStr);
      while (j <> 0) do begin
         TempStr[j] := ' ';
         j := Pos ('_', TempStr);
         end;
      ReturnNiceLabel := TempStr;
   end;


   function LABEL_OBJ.LabelToPrintString(j:integer):string;
   { Return a label for writing to a file.
     If label has any punctuation other than _ and . then enclose