cplabels.pas

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

     in single quotes. }
   var
      TempStr: string;
      Firstch, Lastch: string[1];
      i:integer;
   begin
      Firstch := '';
      Lastch  := '';
      TempStr := '';
		worklabel := Copy (leaflabels[j]^, 1, Length(leaflabels[j]^));
		{ 26/7/93 ensure numeric labels from Hennig86 (for example) are treated
		  correctly. }
		if (worklabel[1] in ['0'..'9']) then begin
			Firstch := '''';
			Lastch  := '''';
			end;

		{ check remaining chars }
      for i := 1 to Length (worklabel) do begin
         TempStr := TempStr + worklabel[i];
         { Double quote any single quotes }
         if worklabel[i] = '''' then
            TempStr := TempStr + '''';
         if not (worklabel[i] in ['A'..'Z','a'..'z','0'..'9','_','.']) then
            if (Firstch = '') then begin
               Firstch := '''';
               Lastch  := '''';
					end;
         end;
      LabelToPrintString := Firstch + TempStr + LastCh;
   end;


   function LABEL_OBJ.HashCode:integer;
   { Return hash code of worklabel }
   var
      j, StrLen, hcode: integer;
   begin
      StrLen := Length (worklabel);
      j     := 1;
      hcode := 0;
      while (j <= StrLen) do begin
         hcode := hcode + (j * ord(worklabel[j]));
         Inc (j);
         end;
      HashCode := Succ (hcode mod HASHTABLESIZE);
   end;



   function LABEL_OBJ.LocateName (var L: LABEL_LIST;
                                  var H: LABEL_CODE):integer;
   { Look up worklabel in hash table H.
     Return ptr to worklabel in L if found, otherwise 0. }
   var
      original_hcode, hcode : integer;
      finished : boolean;
   begin
      hcode := HashCode;
      original_hcode := hcode;
      finished := false;
      while not finished do begin
         if (H[hcode] = 0) then begin
            { Bucket is vacant }
            LocateName := 0;
            finished := true;
            end
         else begin
            { Cell is occupied }
            if (L[H[hcode]]^ = worklabel) then begin
               { We've found the name }
               LocateName := H[hcode];
               finished := true;
               end
            else begin
               { Bucket is different, resolve collision by linear probing }
               hcode := hcode + PROBELENGTH;
               if (hcode > HASHTABLESIZE) then
                  hcode := 1;
               if (hcode = original_hcode) then begin
                  { We've looked at the whole table without success }
                  LocateName := 0;
                  finished := true;
                  end
               end;
            end;
         end;
   end;

{ Hooks for locate name }

   function LABEL_OBJ.LocateLabel (s:string):integer;
   { look up s in leaf labels.
     Return ptr to worklabel in leaflabels if found, otherwise 0. }
   begin
      GetLabel (s);
      LocateLabel := LocateName (leaflabels, leafcodes);
   end;

   function LABEL_OBJ.LocateTransLabel (s:string):integer;
   { look up s in translate labels
     Return ptr to worklabel in translabels if found, otherwise 0. }
   begin
      GetLabel (s);
      LocateTransLabel := LocateName (translabels, transcodes);
   end;


{ Add a label }

   function LABEL_OBJ.AddName (var L: LABEL_LIST;
                      var H: LABEL_CODE;
                      ptr : integer):integer;
   { Add worklabel to label list and hash table. The hash table
     stores an integer "ptr" that points to the worklabel in L.
     Returns:
         0: OK
        -1: Hash table overflow
        -2: Insufficient memory for label
         i: Index of S if it already occurs in hash table.
   }

   var
      original_hcode, hcode : integer;
      finished : boolean;

   begin
      hcode := HashCode;
      original_hcode := hcode;
      finished := false;
      while not finished do begin
         if (H[hcode] = 0) then begin
            { Bucket is vacant }
            GetMem (L[ptr], SizeOf(LABEL_STR));
            if (L[ptr] = NIL) then begin
               AddName := -2;
               finished := true;
               end
            else begin
               L[ptr]^  := worklabel;
               H[hcode] := ptr;
               AddName := 0;
               finished     := true;
               end;
            end
         else begin
            { Bucket is occupied }
            if (L[H[hcode]]^ = worklabel) then begin
               { Bucket is the same, so we've a duplicate label }
               AddName := H[hcode];
               finished     := true;
               end
            else begin
               { Bucket is different, resolve collision by linear probing }
               hcode := hcode + PROBELENGTH;
               if (hcode > HASHTABLESIZE) then
                  hcode := 1;
               if (hcode = original_hcode) then begin
                  { We've looked at the whole table, so we've got overflow }
                  AddName := -1;
                  finished     := true;
                  end
               end;
            end;
         end;
   end;

{ Hooks for AddName }

   function LABEL_OBJ.AddLabel (s:string; ptr:integer):integer;
   var
      Result: integer;
   begin
      GetLabel (s);
      Result := AddName (leaflabels, leafcodes,ptr);
      if (Result = 0) then
         Inc (Stored);
      AddLabel := Result;
   end;

   function LABEL_OBJ.AddTransLabel (s:string; ptr:integer):integer;
   begin
      GetLabel (s);
      AddTransLabel := AddName (translabels, transcodes,ptr);
   end;

   function LABEL_OBJ.Decode (s:string):integer;
   { Return ptr to leaf label corresponding to translation of
     token s if s exists in translabels, otherwise 0. }
   var
      Result: integer;
   begin
      { Locate token }
      Result := LocateTransLabel (s);
      if (Result <> 0) then
         { return ptr to leaf label }
         Decode := Translation[Result]
      else Decode := Result;
   end;

   function LABEL_OBJ.Encode (s:string; i:integer):integer;
   { Encode leaf label s by making ith cell in
     translation point to leaf label in leaflabel.
     Return ptr to s in leaflabels if label exists,
     otherwise 0. }
   var
      Result: integer;
   begin
      { Locate token }
      Result := LocateLabel (s);
      if (Result <> 0) then
         { Encode the label }
         Translation[i] := Result;
      Encode := Result;
   end;


{$IFDEF debug}
   procedure LABEL_OBJ.dump (var f:text; n:integer);

   var
      i: integer;

      procedure PrintString (s:string);
      var
         i: integer;
      begin
         for i := 1 to MAXLENGTH do
            if (i <= Length (s)) then
               write (f,s[i])
            else write (f,' ');
      end;

   begin
      for i := 1 to n do begin
         write (f,i:3,' ');
         write (f, LeafLabels[i]^);
         write (f,Translation[i]:3);
{         if Translate then
            write (f,' ',Translabels[i]^);}
         writeln (f);
         end;
   end;
{$ENDIF}

   procedure LABEL_OBJ.TranslateTrue;
   begin
      Translate := TRUE;
   end;

   procedure LABEL_OBJ.LabelsReadTrue;
   begin
      LabelsRead := TRUE;
   end;

   function LABEL_OBJ.Labels_Read:Boolean;
   begin
      Labels_Read := LabelsRead;
   end;

   function LABEL_OBJ.Return_LabelPtr (s:string):integer;
   { Given s, return name ptr if found, 0 otherwise.
     Perform any translation needed. }
   begin
      if Translate then
         Return_LabelPtr := Decode (s)
      else Return_LabelPtr := LocateLabel (s);
   end;

   procedure LABEL_OBJ.MakeLabels (n:integer);
   { Make n labels <1,...,n>, useful for
     experimenting with trees. }
   var
      i, Result: integer;
      TmpStr: string;
   begin
      for i := 1 to n do begin
         Str (i, TmpStr);
         Result := AddLabel (TmpStr, i);
         end;
   end;

   { True if all labels start with A..Z or a..z.
     Used to check whether tree formats needing
     labels starting with letters can be written. }
   function LABEL_OBJ.AllAlphaStart:Boolean;
   var
      i:integer;
      OK: Boolean;
   begin
      i  := 0;
      OK := true;
      while (i<Stored) and OK do begin
         Inc (i);
         if (LeafLabels[i] <> NIL) then
            OK := (LeafLabels[i]^[1] in ['A'..'Z','a'..'z']);
         end;
      AllAlphaStart := OK;
   end;


   procedure LABEL_OBJ.MakeAlphaLabels (n:integer);
   { Make n labels of the form a..z,aa..zz,etc.
     Designed to be used by random tree generator
     to provide some arbitrary labels. }
   const
      ALPHABET=26; { letters in alphabet }
      ASCIIa  =96; { ASCII code of character before 'a' }
   var
      i,j,k,Result: integer;
      TmpStr: string;
      ch:char;
   begin
      i := 0;
      j := 1;
      while (i < n) do begin
         if ((i div ALPHABET) <> 0) and ((i mod ALPHABET) = 0) then
            Inc (j);
         Inc (i);
         k := i mod ALPHABET;
         if (k=0) then
            k := ALPHABET;
         ch := chr(ASCIIa + k);
         for k := 1 to j do
            TmpStr[k] := ch;
         TmpStr[0] := chr(j);
         Result := AddLabel (TmpStr, i);
         end;
   end;


   { Return maximum number of characters in any of the labels }
   function LABEL_OBJ.MaxLabelLength:integer;
   var
      i, j: integer;
      Longest : integer;
   begin
      Longest := 0;
      for i := 1 to Stored do begin
         j := Length(LeafLabels[i]^);
         if (j > Longest) then
            Longest := j;
         end;
      MaxLabelLength := Longest;
   end;

{$IFDEF WINDOWS}
   { Return the maximum width of any stored label
     if output using the device context DC. }
   function LABEL_OBJ.MaxLabelWidth (DC: HDC):word;
   var
      i, j:integer;
      s:string;
      MaxL, ThisL : word;
      Buf : array[0..20] of char;
   begin
      MaxL := 0;
      for i := 1 to Stored do begin
          s := 'X' + ReturnLabel (i);
          StrPCopy (Buf, s);
          ThisL := LoWord (GetTextExtent (DC, Buf, StrLen(Buf)));
          if (ThisL > MaxL) then
             MaxL := ThisL;
         end;
      MaxLabelWidth := MaxL;
   end;
{$ENDIF}

   function LABEL_OBJ.LabelsStored:integer;
   begin
      LabelsStored := Stored;
   end;


begin
   RegisterType (RLabelObj);
end.