form1.frm

用于求解凸包问题！包围所有的定点！

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "凸包的求法"
   ClientHeight    =   7005
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8805
   LinkTopic       =   "Form1"
   ScaleHeight     =   467
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   587
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command2 
      Caption         =   "计算凸包"
      Height          =   975
      Left            =   8160
      TabIndex        =   2
      Top             =   1800
      Width           =   375
   End
   Begin VB.CommandButton Command1 
      Caption         =   "随机点"
      Height          =   975
      Left            =   8160
      TabIndex        =   1
      Top             =   480
      Width           =   375
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      Height          =   6375
      Left            =   360
      ScaleHeight     =   421
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   501
      TabIndex        =   0
      Top             =   240
      Width           =   7575
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'凸包的求法
Option Explicit

Const numl = 24
Private Type Vector
    X As Single
    Y As Single
    use As Boolean '已加入凸包列表
End Type
Dim ver(numl) As Vector

Private Type line '有向向量
    k As Single
    n As Vector
    d As Single
    Ver1 As Vector
    Ver2 As Vector
End Type

Dim li As line
Dim list(numl) As line '凸包的顶点列表
Dim listn As Long

Dim H As Long
Dim W As Long
Dim i As Long
Dim j As Long


Dim outside As Long
Dim inside As Long
Private Sub Command1_Click()
ini


Picture1_Paint

End Sub


Private Sub Command2_Click()
For i = 0 To numl
ver(i).use = 0
Next
sc
For i = 0 To listn - 1 '绘制凸包
Picture1.Line (list(i).Ver1.X, list(i).Ver1.Y)-(list(i).Ver2.X, list(i).Ver2.Y), QBColor(2)
Next
Picture1.Line (list(0).Ver1.X, list(0).Ver1.Y)-(list(listn - 1).Ver2.X, list(listn - 1).Ver2.Y), QBColor(2)

End Sub

Private Sub Form_Load()
Randomize
H = Picture1.ScaleHeight
W = Picture1.ScaleWidth
ini

End Sub

Private Sub Picture1_Paint()
Picture1.Cls
For i = 0 To numl
Picture1.Circle (ver(i).X, ver(i).Y), 2
Picture1.CurrentX = ver(i).X - 3
Picture1.CurrentY = ver(i).Y
Picture1.Print i
Next

End Sub

Sub ini() '随机
For i = 0 To numl
ver(i).X = Rnd * (W - 200) + 100
ver(i).Y = Rnd * (H - 200) + 100
Next


End Sub

Sub col(v1 As Long, v2 As Long)

li.Ver1 = ver(v1)
li.Ver2 = ver(v2)
If (li.Ver2.X - li.Ver1.X) = 0 Then '垂直
li.n.X = Sgn(li.Ver2.Y - li.Ver1.Y): li.n.Y = 0
ElseIf (li.Ver2.Y - li.Ver1.Y) = 0 Then '水平
li.n.Y = Sgn(li.Ver2.X - li.Ver1.X): li.n.X = 0
Else
li.k = (li.Ver2.Y - li.Ver1.Y) / (li.Ver2.X - li.Ver1.X)
li.n.X = 1 * Cos(Atn(-1 / li.k))
li.n.Y = 1 * Sin(Atn(-1 / li.k))

End If
li.d = VectorDot(li.Ver1, li.n)
End Sub

Function isside(v As Long, t As Long) As Boolean
'左侧,右侧
outside = 0
inside = 0
For j = 0 To numl
If j <> t And j <> v Then
If VectorDot(ver(j), li.n) >= li.d Then inside = inside + 1 Else outside = outside + 1
End If
Next

If outside = 0 Or inside = 0 Then isside = True Else isside = False

End Function

Private Function VectorDot(ByRef a As Vector, ByRef B As Vector) As Single
With a
  VectorDot = (.X * B.X) + (.Y * B.Y)
End With
End Function

Sub sc() '计算凸包

listn = 0

Dim maxx As Long
Dim maxnum As Long
Dim cur As Long
For i = 0 To numl
If ver(i).X > maxx Then maxx = ver(i).X: maxnum = i
Next
ver(maxnum).use = 1
cur = maxnum

Do
For i = 0 To numl
If ver(i).use = True Then
GoTo 2
Else
col cur, i
End If

If isside(cur, i) Then '顶点全部在向量的左侧或右侧，则点为凸包的下一顶点
cur = i
listn = listn + 1
list(listn - 1) = li
ver(i).use = True
GoTo 1
End If

2:
Next
Exit Do
1:
Loop


End Sub