cphset.pas

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

{$I CPDIR.INC}

{*

   Hash table for clusters

   2/13/91  First version

   3/19/91  Memory error checking added.


   BM(NH)

   6 Feb 1992  Uses NEWLOG text file device driver
  28 Jan 1993  []

*}

{*
   Objects
   -------

   HASH_TABLEOBJ
*}


unit cphset;

interface

uses
   cpmem,    { heap error handling }
   cpwbuf,   { display buffer }
   cpset;    { cluster }

const
   HASHTABLESIZE = 1991;
   HASH_M1       = HASHTABLESIZE - 1;

type
   HASH_BUCKET = record
      count    : integer;
      contents : CLUSTEROBJ;
      end;
   HASH_BUCKET_PTR = ^HASH_BUCKET;

   HASHTABLEPTR = ^HASH_TABLEOBJ;
   HASH_TABLEOBJ = object
      constructor Init;
      destructor Done;
      function IsEmpty(i:integer):Boolean;
      function ReturnCount(i:integer):integer;
      function ReturnClusterPtr(i:integer):CLUSTEROBJ_PTR;
      procedure Show (Range:integer);
      function Insert (var S:CLUSTEROBJ):integer;
      procedure FirstBucket (var C:CLUSTEROBJ; var F:integer);
      procedure NextBucket (var C:CLUSTEROBJ; var F:integer);
      function MoreBuckets:Boolean;

      private
      H: array[0..HASH_M1] of HASH_BUCKET_PTR;
      Buckets    : 0..HASH_M1;  { no. of occupied buckets }
      Count      : 0..HASH_M1;  { local counter }
      LastBucket : 0..HASH_M1;
      function NonEmptyBucket:integer;
      end;

implementation

   constructor HASH_TABLEOBJ.Init;
   var
      i: 0..HASH_M1;
   begin
      Buckets := 0;
      Count   := 0;
      for i := 0 to HASH_M1 do
         H[i] := NIL;
   end;

   destructor HASH_TABLEOBJ.Done;
   var
      i: 0..HASH_M1;
   begin
      for i := 0 to HASH_M1 do
         if (H[i] <> NIL) then
            Dispose (H[i]);
   end;

{---HASH_TABLEOBJ Queries---}

   function HASH_TABLEOBJ.IsEmpty(i:integer):Boolean;
   { TRUE if ith cell is empty }
   begin
      IsEmpty := (H[i] = NIL);
   end;

   function HASH_TABLEOBJ.ReturnCount(i:integer):integer;
   begin
      ReturnCount := H[i]^.Count;
   end;

   function HASH_TABLEOBJ.ReturnClusterPtr(i:integer):CLUSTEROBJ_PTR;
   begin
      ReturnClusterPtr := @H[i]^.Contents;
   end;

   procedure HASH_TABLEOBJ.Show (Range:integer);
   var
      {$IFDEF DEVICE}
      s: string;
      {$ENDIF}
      i, j: integer;
   begin
      {$IFDEF DEVICE}
      writeln (NEWLOG);
      writeln (NEWLOG, 'Cluster table');
      writeln (NEWLOG);
      Label_Cols (4,10,Range);
      j := 0;
      for i := 0 to HASH_M1 do
         if (H[i] <> NIL) then begin
            Inc (j);
            write (NEWLOG, j:3, ' ');
            H[i]^.Contents.DisplaySet (Range);
            writeln (NEWLOG, H[i]^.Count:5);
            end;
      writeln (NEWLOG);
      {$ELSE}
      DisplayBuffer.InsertNewLine;
      DisplayBuffer.InsertATitle ('Cluster table');
      Label_Cols (4,10,Range);
      Buffer.Clear;
      j := 0;
      for i := 0 to HASH_M1 do
         if (H[i] <> NIL) then begin
            Inc (j);
            Str (j:3, s);
            Buffer.AppendString (s + ' ');
            H[i]^.Contents.DisplaySet (Range);
            Str (H[i]^.Count:5, s);
            Buffer.AppendString (s);
            DisplayBuffer.InsertLineBuffer (Buffer);
            Buffer.Clear;
            end;
      DisplayBuffer.InsertNewLine;
      {$ENDIF}
   end;

   function HASH_TABLEOBJ.Insert (var S:CLUSTEROBJ):integer;
   { Insert cluster S into hash table, return codes:
      -2: No memory
      -1: Hash table overflow
       0: Successful
   }
   const
      PROBELENGTH = 1;
   var
      ocode,
      hcode : integer;
      Finished  : Boolean;
   begin
      Insert := 0;
      hcode := S.HCode (HASHTABLESIZE);
      ocode := hcode;
      Finished  := FALSE;
      while not Finished do begin
         if (H[hcode] = NIL) then begin
            { Cell is vacant }
            GetMem (H[hcode], SizeOf (HASH_BUCKET));
            if (H[hcode] = NIL) then begin
               Insert := -2;
               Exit;
               end
            else Inc (Buckets);
            H[hcode]^.count   := 1;
            H[hcode]^.contents.NullSet;
            H[hcode]^.contents.AddSetToSet (S);
            Finished          := TRUE;
            end
      else begin
         { Cell is occupied }
         if (S.Relationship (H[hcode]^.contents) = IDENTITY) then begin
            { Cell is the same }
            Inc (H[hcode]^.Count);
            Finished := TRUE;
            end
         else begin
            { Cell is different, resolve collision by linear probing }
            hcode := hcode + PROBELENGTH;
            if (hcode > HASH_M1) then
               hcode := 0;
            if (hcode = ocode) then begin
               Insert := -1;
               Exit;
               end;
            end;
         end;
      end;
   end;

{----------------------------------------------------------------------------}

   function HASH_TABLEOBJ.NonEmptyBucket:integer;
   var
      i: integer;
   begin
      i := Succ (LastBucket);
      while (H[i] = NIL) do
         Inc (i);
      LastBucket := i;
      NonEmptyBucket := i;
   end;


   procedure HASH_TABLEOBJ.FirstBucket (var C:CLUSTEROBJ; var F:integer);
   var
      i: integer;
   begin
      LastBucket := 0;
      Count      := 1;
      i := NonEmptyBucket;
      C.NullSet;
      C.AddSetToSet (H[i]^.contents);
      F := H[i]^.count;
   end;

   procedure HASH_TABLEOBJ.NextBucket (var C:CLUSTEROBJ; var F:integer);
   var
      i: integer;
   begin
      i := NonEmptyBucket;
      Inc (Count);
      C.NullSet;
      C.AddSetToSet (H[i]^.contents);
      F := H[i]^.count;
   end;

   function HASH_TABLEOBJ.MoreBuckets:Boolean;
   begin
      MoreBuckets := (Count < Buckets);
   end;





end.