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

{$I CPDIR.INC}

unit cpset;
{Set operations


<\b Uses>
 [cpvars:cpvars] global variables
 cpwbuf line buffer

<\b History>
    2/6/91 Written
   2/13/91 Hash function added

   12 Dec 1991 Code cleaned up
   30 Oct 1992 WriteSet added.
   15 Jan 1993 Formatted for WSHELP
   26 Jan 1993 Load and Store methods added.
}

interface

uses
   cpvars,   { global variables }
   cpwbuf,   { line buffer }
   WObjects;

type
   SET_RELATIONS = (IDENTITY, SUBSET, DISJOINT, SUPERSET, OVERLAPPING);
      {Kinds of set relationships }
     
   CLUSTER = set of 1..MAXLEAVES;
      {Set with range 1..[[MAXLEAVES:cpvars.MAXLEAVES]]}

   CLUSTEROBJ = object (TObject)
      {A set object}
      constructor Load (var Stream: TStream);
         {Calls <\i Stream.Load> to read the set from <\b Stream>}
      procedure Store (var Stream: TStream);
         {Calls <\i Stream.Write> to write the set to <\b Stream>}
      function Empty:Boolean;
         {True if set if empty }
      function IsFullSet:Boolean;
			{True if set = }

		procedure Complement (var Result:CLUSTEROBJ; n : integer);

      procedure NullSet;
         {Set = \[ \]}
      procedure FullSet (Range:integer);
         {Set = 1..<\b Range>}
      procedure MakeSet (t:CLUSTER);
         {Set = <\b t>}
      procedure AddToSet (i:integer);
         {Add <\b i> to set }
      procedure DeleteFromSet (i:integer);
         {Delete element <\b i> from set }
      procedure GetSet (var CopyOfSet: CLUSTER);
         {Return the set in <\b CopyOfSet>}
      procedure AddSetToSet (T:CLUSTEROBJ);
			{Add <\b T> to set}
		procedure DeleteSetFromSet (var T:CLUSTEROBJ);
      	{Delete <\b T> from set}
      procedure WriteSet (var f:text);
         {Write a list of the elements of the set to the file <\b f>}
      function IsElement (i:integer):Boolean;
         {True if <\b i> is an element of the set }
      function First_Element:integer;
         {Return the first element of the set }
      function Next_Element:integer;
         {Return the next element of the set }
      function MoreMembers:Boolean;
         {True if the members of the set have not been exhausted }
      function LastElement:integer;
         {Last element in set }
      function Cardinality:integer;
         {Number of elements in set}
      function MaskedCardinality (var Mask:CLUSTEROBJ):integer;
         { Return the number of elements in the set that are not also
           members of <\b Mask>}
      procedure DisplaySet (Range:integer);
         { Display elements in the set upt <\b Range> set in the form:

           <\f2 ****.....* ***...*...>
         }
      procedure ShowSet (title:string);
         {Write the set to the file [NewLog:cpwbuf.NewLog.NewLog] in the form <\b title>: \[1 2..4 6\] }
      function Relationship (var T:CLUSTEROBJ):SET_RELATIONS;
         {Return the relationship between the set and <\b T>}
      function Compatible (var T:CLUSTEROBJ):Boolean;
         {True if set <\b T> is compatible with set }
      procedure InCommon (var T:CLUSTEROBJ);
         {Return number of elements in intersection of <\b T> and set }
      procedure Unique (var T:CLUSTEROBJ);
         {Delete all members of set that are also members of <\b T>}
      procedure InterSection (var T, Result:CLUSTEROBJ);
         {Return in <\b Result> the intersection of the set with <\b T>}
      procedure SetDifference(var T, Result:CLUSTEROBJ);
         {Return in <\b Result> the elements in s that are not also in <\b T>}
      function hcode (HashSize:integer):integer;
         {Return a hash codse for the set }
      function IsSubSet (var T:CLUSTEROBJ):Boolean;
         {True if <\b T> is a subset of the set }
      procedure DumpSet (var f:text; title:string);
         {Write the set to the file <\b f> in the form <\b title>: \[1 2..4 6\] }        
      private
      S: CLUSTER;
      Cur_Element: 0..MAXLEAVES;
      function SetToNumber:Real;
      end;

   CLUSTEROBJ_PTR = ^CLUSTEROBJ;

const
  RClusterObj: TStreamRec = (
    ObjType: 105;
    VmtLink: Ofs(TypeOf(CLUSTEROBJ)^);
    Load:    @CLUSTEROBJ.Load;
    Store:   @CLUSTEROBJ.Store); {Stream registration for [CLUSTEROBJ]}


procedure Label_Cols (indent, col, limit:integer);
{ Label a series of columns in the format

                1 1111111112
       1234567890 1234567890
       ---------- ----------
}


implementation


{ Label a series of columns in the format

                1 1111111112
       1234567890 1234567890
       ---------- ----------

  Used by other units when displaying sets...

}
procedure Label_Cols (indent, col, limit:integer);
var
   i,j,k,m:integer;
begin
   {$IFDEF DEVICE}
   k := 100;
   repeat
      if (Limit div k) > 0 then begin
         for i := 1 to indent do
            write (NEWLOG, ' ');
         for i := 1 to Limit do begin
            if (k = 1) then
               write (NEWLOG, i mod 10)
            else begin
               m := i div k;
               if (m > 0) then
                  write (NEWLOG, m)
               else write (NEWLOG, ' ');
               end;
            if (i mod col) = 0 then
               write (NEWLOG, ' ');
            end;
         writeln (NEWLOG);
         end;
      k := k div 10;
   until (k = 0);

   { underline }
   for i := 1 to indent do
      write (NEWLOG, ' ');
   for i := 1 to Limit do begin
      write (NEWLOG, '-');
      if (i mod 10) = 0 then
         write (NEWLOG, ' ');
      end;
   writeln (NEWLOG);

   {$ELSE}
   k := 100;
   Buffer.Clear;
   repeat
      if (Limit div k) > 0 then begin
         for i := 1 to indent do
            Buffer.AppendChar ( ' ');
         for i := 1 to Limit do begin
            if (k = 1) then
               Buffer.AppendInteger (i mod 10)
            else begin
               m := i div k;
               if (m > 0) then
                  Buffer.AppendInteger (m)
               else Buffer.AppendChar(' ');
               end;
            if (i mod col) = 0 then
               Buffer.AppendChar (' ');
            end;

         DisplayBuffer.InsertLineBuffer (Buffer);
         Buffer.Clear;
         end;
      k := k div 10;
   until (k = 0);

   Buffer.Clear;
   for i := 1 to indent do
      Buffer.AppendChar(' ');
   for i := 1 to Limit do begin
      Buffer.AppendChar ('-');
      if (i mod 10) = 0 then
         Buffer.AppendChar (' ');
      end;
   DisplayBuffer.InsertLineBuffer (Buffer);
   {$ENDIF}
end;


constructor CLUSTEROBJ.Load (var Stream: TStream);
begin
   Stream.Read (S, SizeOf(S));
end;

procedure CLUSTEROBJ.Store (var Stream: TStream);
begin
   Stream.Write (S, SizeOf(S));
end;


{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.NullSet;
   begin
      S := [];
   end;

{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.FullSet (Range:integer);
   begin
      S := [1..Range];
   end;

{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.MakeSet (t:CLUSTER);
   var
      i: integer;
   begin
      S := [];
      i := 0;
      while (t <> []) do begin
         repeat
            inc (i);
         until (i in t);
         S := S + [i];
         t := t - [i];
         end;    
   end;

{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.AddToSet (i:integer);
   begin
      S := S + [i];
	end;


{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.DeleteFromSet (i:integer);
   begin
      S := S - [i];
   end;

{-----------------------------TITLE----------------------------------------}

   procedure CLUSTEROBJ.GetSet (var CopyOfSet: CLUSTER);
   var
      TempSet: CLUSTER;
      i : integer;
   begin
      CopyOfSet := [];
      TempSet := S;
      i       := 1;
      while (TempSet <> []) do begin
         if (i in TempSet) then begin
            TempSet := TempSet - [i];
            CopyOfSet := CopyOfSet + [i];
            end;
         Inc (i);
         end;
   end;


   procedure CLUSTEROBJ.AddSetToSet (T:CLUSTEROBJ);
   begin
      S := S + T.S;
	end;

	procedure CLUSTEROBJ.DeleteSetFromSet (var T: CLUSTEROBJ);
	begin
		S := S - T.S;
   end;

   procedure CLUSTEROBJ.InterSection (var T, Result:CLUSTEROBJ);
   begin
      Result.S := S * T.S;
	end;