uclusterrev.pas

clusterfilesrev 最新的分类聚类代码

unit UClusterRev;          //   By Yasuharu Okamoto, 2002.1
                        //                        2004.7

interface

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

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

var
  FMain: TFMain;

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

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;          //   僋儔僗僞宍惉婎弨偺嫍棧乮椶帡搙乯
                 memid                  //   僋儔僗僞偺儊儞僶乕
                       : array[1..MaxN] of integer;
             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;                  // 僔僼僩検偺扨埵


implementation

{$R *.DFM}

uses
  UInDist,               // 嫍棧乮旕椶帡搙乯僨乕僞擖椡梡儐僯僢僩
  UInSim,                // 椶帡搙僨乕僞擖椡梡儐僯僢僩
  UInCoord,
  Printers;

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


var
  DistType : ( DMax,        //  嵟挿嫍棧朄
               DMean,       //  孮娫暯嬒朄
               DMin );      //  嵟抁嫍棧朄


procedure TFMain.FormCreate(Sender: TObject);
begin
    with ComboBoxDist,Items do
      begin
          Add('嵟挿嫍棧朄');
          Add('孮娫暯嬒朄');
          Add('嵟抁嫍棧朄');
          ItemIndex:=0;
      end;
end;

//  僋儔僗僞捠偟斣崋i偲j偺娫偺嫍棧傪媮傔傞
function calcD( i, j : integer ) : extended;
  Label QP;
  var pos : integer;
  begin
      pos:=1;
      repeat
           with ListDist[pos] do
             if ((id1 = i) and (id2 = j))
               or
                ((id1 = j) and (id2 = i))
                then goto QP;
           pos:=pos+1;
      until pos > DistEnd;
      raise Exception.Create('Range Error at ListDist Array');

    QP : ;
      calcD:=ListDist[pos].d;
  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;


//  嵟挿嫍棧朄偵傛傞僋儔僗僞偺嶌惉
procedure MakeClustersMaxD;
  var i, j, c1, c2 : integer;
      td, da, db : 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;
        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;
                        da:=calcD(id1,c1);
                        db:=calcD(id1,c2);
                        if da > db then d:=da else d:=db;  //  嵟挿嫍棧朄
                    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;

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

  end;   {   MakeClustersMaxD   }


 //   孮娫暯嬒朄偵傛傞僋儔僗僞偺惗惉
procedure MakeClustersMeanD;
  var i, j, c1, c2, k, nmem : integer;
      td, sumd : 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;

            //  儊儞僶乕儕僗僩偺嶌惉
            for i:=1 to N do
              if (L^.memid[i])+(R^.memid[i]) > 0 then memid[i]:=1
                                                 else memid[i]:=0;
        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;

                        //   孮娫暯嬒嫍棧偺嶼弌
                        sumd:=0.0;  nmem:=0;
                        for j:=1 to n do
                          for k:=1 to n do
                            if ListC[i].p^.memid[j]
                               * ListC[NC].p^.memid[k] <> 0
                                then
                                  begin
                                    if j > k then sumd:=sumd+Dist[j,k]
                                             else sumd:=sumd+Dist[k,j];
                                    nmem:=nmem+1;
                                  end;
                        d:=sumd/nmem;
                    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;

          MakeClustersMeanD;
        end;

  end;   {   MakeClustersMeanD   }



procedure MakeClustersMinD;
  var i, j, c1, c2 : integer;
      td, da, db : 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;
        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;
                        da:=calcD(id1,c1);
                        db:=calcD(id1,c2);
                        if da < db then d:=da else d:=db; // 嵟抁嫍棧朄
                    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;