uclustercwrev.pas

clusterfilesrev 最新的分类聚类代码

unit UClusterCWRev;

interface       //  By Yasuharu Okamoto,2002.1
                //                      2004.7

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TFMain = class(TForm)
    ExitButton: TButton;
    OpenDialog1: TOpenDialog;
    PrintDialog1: TPrintDialog;
    CoordButton: TButton;
    Label1: TLabel;
    FontEdit: TEdit;
    procedure ExitButtonClick(Sender: TObject);
 //   procedure FormCreate(Sender: TObject);
    procedure CoordButtonClick(Sender: TObject);
  private
    { Private 愰尵 }
  public
    { Public 愰尵 }
  end;

var
  FMain: TFMain;

var
  ckFSim : integer;    //   屇傃弌偟偨僨乕僞擖椡僼僅乕儉偺Close梡僼儔僢僌
    
const
  MaxN = 1000;          //   崁栚偺嵟戝悢

const
  MaxDim = 200;        //   師尦偺嵟戝悢

type
  TRecD    = record                     // 嫍棧乮椶帡搙乯儕僗僩ListDist偺梫慺宆
                 id1, id2 : integer;    // 僋儔僗僞id1偲id2偺嫍棧傪昞偡
                 d        : extended;   // d : 嫍棧乮椶帡搙乯
             end;

  PntrC    = ^TCluster;                 //   僋儔僗僞傊偺億僀儞僞
  TCluster = record                     //   僋儔僗僞傪昞偡僋儔僗宆
                 id : integer;          //   僋儔僗僞偺捠偟斣崋
                 L, R : PntrC;          //   僋儔僗僞L偲R偺暪崌僋儔僗僞
                 x,                     //   庽忬恾偵偍偗傞僔僼僩検
                 y : extended;          //   僋儔僗僞宍惉婎弨偺嫍棧乮椶帡搙乯
                 CoordV                 //   僋儔僗僞偺廳怱
                        : array[1..MaxDim] of extended;
                 NMem   : Longint;      //   僋儔僗僞偺儊儞僶乕悢
             end;




var
  outf : TextFile;                  // 弌椡梡僼傽僀儖乮擖椡僨乕僞偺僠僃僢僋側偳乯
  LObj : array[1..MaxN] of string;  // 崁栚偺儗儀儖
  Dist,                             // 嫍棧乮旕椶帡搙乯僨乕僞
  Sim                               // 椶帡搙僨乕僞
       : array[1..MaxN,1..MaxN] of extended;
  N : integer;                      // 崁栚悢
  ListDist                          // 嫍棧丒椶帡搙僨乕僞偺儕僗僩
       : array[1..(MaxN*(MaxN+1) div 2)] of TRecD;
  DistEnd,                          // ListDist偺嵟屻偺埵抲
  NC,                               // 尰嵼偺僋儔僗僞悢
  serNC                             // 僋儔僗僞偺捠偟斣崋
       : Longint;
  ListC    : array[1..MaxN+3] of    // 尰嵼偺僋儔僗僞偺儕僗僩
                 record
                   id  : integer;   // 僋儔僗僞偺捠偟斣崋
                   p   : PntrC;     // 僋儔僗僞傊偺億僀儞僞
                 end;
  cpos,                             // 庽忬恾偵偍偗傞僔僼僩検
  dgap : extended;                  // 僔僼僩検偺扨埵
  

var
  DistType : ( DCentroid,   //  廳怱朄
               DWard        //  Ward朄
                         );




implementation

{$R *.DFM}
{$R+}

uses
  UInCoordCW,
  Printers;

procedure TFMain.ExitButtonClick(Sender: TObject);
begin
            close;
end;


//  僋儔僗僞偺捠偟斣崋cid偺傕偺傪媮傔傞
function SeekC( cid : integer ) : PntrC;
  Label QP;
  var   i : integer;
  begin
        i:=1;
        repeat
              if ListC[i].id = cid then goto QP;
              i:=i+1;
        until i > NC;
        raise exception.Create('Range error in SeekC');
    QP : ;
        SeekC:=ListC[i].p;
  end;

//   僋儔僗僞廳怱娫偺嫍棧
function CalcCentroidD( id1, id2 : Longint ) : extended;
  var p1, p2 : PntrC;
      k : Longint;
      v : extended;
  begin
      p1:=SeekC(id1);

      p2:=SeekC(id2);

      v:=0.0;
      for k:=1 to NDim do v:=v+sqr(p1^.CoordV[k]-p2^.CoordV[k]);

      CalcCentroidD:=v;
  end;


//  廳怱朄偵傛傞僋儔僗僞偺嶌惉
procedure MakeClustersCentroidD;
  var i, j, c1, c2 : integer;
      td : extended;
  begin
      //   嫍棧偑嵟抁偱偁傞僋儔僗僞偺慻傪媮傔傞
      with ListDist[1] do
        begin  c1:=id1; c2:=id2; td:=d;  end;
      for i:=2 to DistEnd do
        with ListDist[i] do
          if td > d then
            begin
                c1:=id1; c2:=id2; td:=d;
            end;

   //   writeln(outf, 'min_d = ', td:15:5);      

      //  媮傔偨僋儔僗僞偺慻傪侾偮偺僋儔僗僞偵傑偲傔傞
      NC:=NC+1;
      New(ListC[NC].p);
      serNC:=serNC+1;        //  嵟怴偺僋儔僗僞偺捠偟斣崋
      ListC[NC].id:=serNC;
      with ListC[NC].p^ do
        begin
            id:=serNC;
            L :=SeekC(c1);
            R :=SeekC(c2);
            y :=td;
            for i:=1 to NDim do
              CoordV[i]:=(L^.NMem*L^.CoordV[i]+R^.NMem*R^.CoordV[i])
                          /(L^.NMem+R^.NMem);
            NMem:=L^.NMem+R^.NMem;
        end;

      //  嫍棧儕僗僩偺峏怴  
      if NC > 3 then
        begin
          for i:=1 to NC-1 do
            if (ListC[i].id <> c1) and (ListC[i].id <> c2) then
              begin
                  DistEnd:=DistEnd+1;         // 惗惉偝傟偨僋儔僗僞偲偺嫍棧傪
                  with ListDist[DistEnd] do   // 儕僗僩偵晅偗壛偊傞
                    begin
                        id1:=ListC[i].id;
                        id2:=serNC;
                        d:=CalcCentroidD(id1,id2);
                    end;
              end;

          //  惗惉偝傟偨僋儔僗僞偵暪崌偝傟偨僋儔僗偲偺嫍棧僨乕僞偺嶍彍
          i:=1;
          repeat
            if (ListDist[i].id1 = c1) or (ListDist[i].id1 = c2) or
               (ListDist[i].id2 = c1) or (ListDist[i].id2 = c2)
               then
                 begin
                   for j:=i to DistEnd-1 do
                     ListDist[j]:=ListDist[j+1];
                     DistEnd:=DistEnd-1;
                     i:=i-1;
                 end;
            i:=i+1;
          until i >= DistEnd;

          //  惗惉偝傟偨僋儔僗僞偵暪崌偝傟偨僋儔僗僞傪儕僗僩偐傜嶍彍偡傞
          i:=1;
          repeat
              if (ListC[i].id = c1) or (ListC[i].id = c2)
                then begin
                  if i < NC then
                    for j:=i to NC-1 do ListC[j]:=ListC[j+1];
                  NC:=NC-1;
                  i:=i-1;
                end;

              i:=i+1;
          until i > NC;

          MakeClustersCentroidD;   //  僋儔僗僞偺惗惉傪嵞婣揑偵峴偆
        end;

  end;   {   MakeClustersCentroidD   }


//  僋儔僗僞娫偺嫍棧
function SeekD( i1, i2 : Longint ) : extended;
  var pos : Longint;
      ck  : Boolean;
  begin
      pos:=1; ck:=false;
      repeat
          with ListDist[pos] do
          if ((id1 = i1) and (id2 = i2))
            or
             ((id1 = i2) and (id2 = i1))
              then ck:=true
              else pos:=pos+1;
      until ck or (pos >= DistEnd);

      if not(ck) then raise exception.Create('SeekD range error');

      SeekD:=ListDist[pos].d;
  end;

//   僋儔僗僞id偲僋儔僗僞(c1,c2)偺Ward朄偵傛傞婎弨
function CalcWardD( id1, c1, c2 : Longint ) : extended;
  var pid1, pc1, pc2 : PntrC;
      v : extended;
  begin
      pid1:=SeekC(id1);
      pc1 :=SeekC(c1);
      pc2 :=SeekC(c2);

      v:=((pc1^.NMem+pid1^.NMem)*SeekD(id1,c1)
          +(pc2^.NMem+pid1^.NMem)*SeekD(id1,c2)
          -pid1^.NMem*SeekD(c1,c2))/(pid1^.NMem+pc1^.NMem+pc2^.NMem);

      CalcWardD:=v;
  end;


//   Ward朄偵傛傞僋儔僗僞偺嶌惉
procedure MakeClustersWardD;
  var i, j, c1, c2 : integer;
      td : extended;
  begin
      //   嫍棧偑嵟抁偱偁傞僋儔僗僞偺慻傪媮傔傞
      with ListDist[1] do
        begin  c1:=id1; c2:=id2; td:=d;  end;
      for i:=2 to DistEnd do
        with ListDist[i] do
          if td > d then
            begin
                c1:=id1; c2:=id2; td:=d;
            end;


      //  媮傔偨僋儔僗僞偺慻傪侾偮偺僋儔僗僞偵傑偲傔傞
      NC:=NC+1;
      New(ListC[NC].p);
      serNC:=serNC+1;        //  嵟怴偺僋儔僗僞偺捠偟斣崋
      ListC[NC].id:=serNC;
      with ListC[NC].p^ do
        begin
            id:=serNC;
            L :=SeekC(c1);
            R :=SeekC(c2);
            y :=td;

     //       writeln(outf, 'Merge of c1 = ',c1,'  +  c2 = ',c2,
     //                     '   y = ', FloatToStrF(y,ffFixed,9,2));