exp2.frm

典型的势函数编写算法,通过IO输入输出文件实现函数.

VERSION 5.00
Begin VB.Form FrmMain 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0FFFF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "模式识别实验"
   ClientHeight    =   7155
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   8925
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7155
   ScaleMode       =   0  'User
   ScaleWidth      =   8925
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Cmd_exit 
      Caption         =   "退 出"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   6960
      TabIndex        =   4
      Top             =   6000
      Width           =   1695
   End
   Begin VB.CommandButton Cmd_init 
      Caption         =   "初始化"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   6960
      TabIndex        =   3
      Top             =   4920
      Width           =   1695
   End
   Begin VB.CommandButton Cmd_sf 
      Caption         =   "距离算法"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   6960
      TabIndex        =   2
      Top             =   1800
      Width           =   1695
   End
   Begin VB.CommandButton Cmd_yb 
      Caption         =   "显示样本"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   6960
      TabIndex        =   1
      Top             =   720
      Width           =   1695
   End
   Begin VB.PictureBox Piczb 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0FFFF&
      Height          =   5910
      Left            =   240
      ScaleHeight     =   -15
      ScaleLeft       =   -3
      ScaleMode       =   0  'User
      ScaleTop        =   12
      ScaleWidth      =   15
      TabIndex        =   0
      Top             =   720
      Width           =   6400
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      BackColor       =   &H00C0FFFF&
      Caption         =   "最大最小结聚类"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   24
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   1440
      TabIndex        =   5
      Top             =   0
      Width           =   3615
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim yb(0 To 1, 0 To 9) As Double
Const N = 10
Dim D(0 To 19, 0 To N) As Double
Dim cen(0 To 19) As Integer
Dim theshold, theta, D12, tmp, min(0 To N) As Double
Dim minindex(0 To N), clas(0 To N), index, i, k, j, l As Double


Sub zb()
   ' x
    Piczb.Line (-2.5, 0)-(11.5, 0)
    Piczb.Line (11.2, 0.2)-(11.5, 0)
    Piczb.Line (11.2, -0.2)-(11.5, 0)
    For i = -2 To 10 Step 1
        Piczb.Circle (i, 0), 0.02
        Piczb.CurrentX = i - 0.3: Piczb.CurrentY = -0.2
        Piczb.Print i
    Next
     Piczb.CurrentX = 11.3: Piczb.CurrentY = -0.2
        Piczb.Print "x"
    'y
    Piczb.Line (0, -2.5)-(0, 11.5)
    Piczb.Line (0.2, 11.2)-(0, 11.5)
    Piczb.Line (-0.2, 11.2)-(0, 11.5)
    For i = 1 To 10 Step 1
        Piczb.Circle (0, i), 0.03
        Piczb.CurrentX = -0.7: Piczb.CurrentY = i + 0.25
        Piczb.Print i
    Next
    For i = -2 To -1 Step 1
        Piczb.Circle (0, i), 0.03
        Piczb.CurrentX = -0.7: Piczb.CurrentY = i + 0.25
        Piczb.Print i
    Next
     Piczb.CurrentX = -0.7: Piczb.CurrentY = 11.5
        Piczb.Print "y"
End Sub

    
Sub max_min()
    '默认样本数据
    yb(0, 0) = 0: yb(0, 1) = 3: yb(0, 2) = 2: yb(0, 3) = 5: yb(0, 4) = 4: yb(0, 5) = 6: yb(0, 6) = 5: yb(0, 7) = 6: yb(0, 8) = 7: yb(0, 9) = 5
    yb(1, 0) = 0: yb(1, 1) = 8: yb(1, 2) = 2: yb(1, 3) = 1: yb(1, 4) = 1: yb(1, 5) = 3: yb(1, 6) = 8: yb(1, 7) = 3: yb(1, 8) = 4: yb(1, 9) = 4
    
    theta = 0.5: D12 = 0#: tmp = 0
    index = 0: k = 0
    cen(0) = 0
    For j = 0 To N - 1 Step 1
        Piczb.Circle (yb(0, j), yb(1, j)), 0.02, vbBlack
        Piczb.Circle (yb(0, j), yb(1, j)), 0.03, vbBlack
        Piczb.CurrentX = yb(0, j) - 0.5: Piczb.CurrentY = yb(1, j) + 0.6
        Piczb.Print "(" & yb(0, j) & "," & yb(1, j) & ")"
    Next j
    For j = 0 To N - 1 Step 1
        tmp = (yb(0, j) - yb(0, 0)) ^ 2 + (yb(1, j) - yb(1, 0)) ^ 2
        D(0, j) = Sqr(CDbl(tmp))
        If D(0, j) > D12 Then
            D12 = D(0, j): index = j
        End If
    Next j
    
    cen(1) = index
    k = 1
    index = 0
    theshold = D12
    While (theshold > theta * D12)
        For j = 0 To N - 1 Step 1
            tmp = (yb(0, j) - yb(0, cen(k))) ^ 2 + (yb(1, j) - yb(1, cen(k))) ^ 2
            D(k, j) = Sqr(CDbl(tmp))
        Next j
        For j = 0 To N - 1 Step 1
            tmp = D12
            For l = 0 To k Step 1
                If (D(l, j) < tmp) Then
                    tmp = D(l, j): index = l
                End If
            Next l
            min(j) = tmp: minindex(j) = index
        Next j

        Dim max As Double
        max = 0
        index = 0
        For j = 0 To N - 1 Step 1
            If (min(j) > max) Then
                max = min(j): index = j
            End If
        Next j
        If (max > theta * D12) Then
            k = k + 1: cen(k) = index
        End If
        theshold = max
    Wend
    For j = 0 To N - 1 Step 1
        clas(j) = minindex(j)
    Next j
    
    For l = 0 To k Step 1
        Piczb.Circle (yb(0, cen(l)), yb(1, cen(l))), 0.03, vbRed
    Next l

End Sub
Private Sub Cmd_exit_Click()
    End
End Sub

Private Sub Cmd_init_Click()
    Piczb.Picture = LoadPicture()
    Call zb
    Cmd_yb.Enabled = True
End Sub

Private Sub Cmd_sf_Click()
    Call max_min
    Dim a, b, c, aa, bb, ccc As Integer
    Dim max_x, min_x, max_y, min_y As Double
    a = b = c = 0
    aa = bb = ccc = 0
    For j = 0 To N - 1
        If clas(j) = 0 Then
            a = a + 1
        End If
        If clas(j) = 1 Then
            b = b + 1
        End If
        If clas(j) = 2 Then
            c = c + 1
        End If
    Next j
    ReDim ca(0 To 1, 0 To a) As Double
    ReDim cb(0 To 1, 0 To b) As Double
    ReDim cc(0 To 1, 0 To c) As Double

    For j = 0 To N - 1
        If clas(j) = 0 Then
            ca(0, aa) = yb(0, j)
            ca(1, aa) = yb(1, j)
            aa = aa + 1
        End If
        If clas(j) = 1 Then
            cb(0, bb) = yb(0, j)
            cb(1, bb) = yb(1, j)
            bb = bb + 1
        End If
        If clas(j) = 2 Then
            cc(0, ccc) = yb(0, j)
            cc(1, ccc) = yb(1, j)
            ccc = ccc + 1
        End If
    Next j
    'c1
    max_x = ca(0, 0)
    min_x = ca(0, 0)
    max_y = ca(1, 0)
    min_y = ca(1, 0)
    For i = 0 To a - 1 Step 1
        'max_x
        If max_x < ca(0, i) Then
            max_x = ca(0, i)
        End If
        'min_x
        If min_x > ca(0, i) Then
            min_x = ca(0, i)
        End If
        'max_y
        If max_y < ca(1, i) Then
            max_y = ca(0, i)
        End If
        'min_y
        If min_y > ca(1, i) Then
            min_y = ca(0, i)
        End If
    Next
    Piczb.Line (min_x - 0.3, min_y - 0.3)-(max_x + 0.3, min_y - 0.3), vbBlack
    Piczb.Line (max_x + 0.3, min_y - 0.3)-(max_x + 0.3, max_y + 0.3), vbBlack
    Piczb.Line (max_x + 0.3, max_y + 0.3)-(min_x - 0.3, max_y + 0.3), vbBlack
    Piczb.Line (min_x - 0.3, max_y + 0.3)-(min_x - 0.3, min_y - 0.3), vbBlack
    'c2
    max_x = cb(0, 0)
    min_x = cb(0, 0)
    max_y = cb(1, 0)
    min_y = cb(1, 0)
    For i = 1 To b - 1 Step 1
        'max_x
        If max_x < cb(0, i) Then
            max_x = cb(0, i)
        End If
        'min_x
        If min_x > cb(0, i) Then
            min_x = cb(0, i)
        End If
        'max_y
        If max_y < cb(1, i) Then
            max_y = cb(1, i)
        End If
        'min_y
        If min_y > cb(1, i) Then
            min_y = cb(1, i)
        End If
    Next
   
    Piczb.Line (min_x - 0.3, min_y - 0.3)-(max_x + 0.3, min_y - 0.3), vbBlack
    Piczb.Line (max_x + 0.3, min_y - 0.3)-(max_x + 0.3, max_y + 0.3), vbBlack
    Piczb.Line (max_x + 0.3, max_y + 0.3)-(min_x - 0.3, max_y + 0.3), vbBlack
    Piczb.Line (min_x - 0.3, max_y + 0.3)-(min_x - 0.3, min_y - 0.3), vbBlack
    'c3
    max_x = cc(0, 0)
    min_x = cc(0, 0)
    max_y = cc(1, 0)
    min_y = cc(1, 0)
    For i = 0 To c - 1 Step 1
           ' lbl1(i).Caption = ca(0, i) & " " & ca(1, i)
        'max_x
        If max_x < cc(0, i) Then
            max_x = cc(0, i)
        End If
        'min_x
        If min_x > cc(0, i) Then
            min_x = cc(0, i)
        End If
        'max_y
        If max_y < cc(1, i) Then
            max_y = cc(1, i)
        End If
        'min_y
        If min_y > cc(1, i) Then
            min_y = cc(1, i)
        End If
    Next
    Piczb.Line (min_x - 0.3, min_y - 0.3)-(max_x + 0.3, min_y - 0.3), vbBlack
    Piczb.Line (max_x + 0.3, min_y - 0.3)-(max_x + 0.3, max_y + 0.3), vbBlack
    Piczb.Line (max_x + 0.3, max_y + 0.3)-(min_x - 0.3, max_y + 0.3), vbBlack
    Piczb.Line (min_x - 0.3, max_y + 0.3)-(min_x - 0.3, min_y - 0.3), vbBlack
End Sub

Private Sub Cmd_yb_Click()
    'Call max_min
    Cmd_sf.Enabled = True
    Cmd_yb.Enabled = False
    yb(0, 0) = 0: yb(0, 1) = 3: yb(0, 2) = 2: yb(0, 3) = 5: yb(0, 4) = 4: yb(0, 5) = 6: yb(0, 6) = 5: yb(0, 7) = 6: yb(0, 8) = 7: yb(0, 9) = 5
    yb(1, 0) = 0: yb(1, 1) = 8: yb(1, 2) = 2: yb(1, 3) = 1: yb(1, 4) = 1: yb(1, 5) = 3: yb(1, 6) = 8: yb(1, 7) = 3: yb(1, 8) = 4: yb(1, 9) = 4
    For j = 0 To N - 1 Step 1
        Piczb.Circle (yb(0, j), yb(1, j)), 0.03, vbRed
        Piczb.Circle (yb(0, j), yb(1, j)), 0.02, vbRed
        Piczb.CurrentX = yb(0, j) - 0.5: Piczb.CurrentY = yb(1, j) + 0.6
        Piczb.Print "(" & yb(0, j) & "," & yb(1, j) & ")"
    Next j
End Sub

Private Sub Form_Load()
    'Piczb.Picture = LoadPicture("bg.jpg")
    Cmd_yb.Enabled = False
    Cmd_sf.Enabled = False
End Sub


Private Sub Label2_Click()

End Sub