[分享与求助]类技术的应用学习实例——数图形中的三角形

Moneky · 发表于 2013-11-14 14:50

近日遇到一个数三角形的题目，如下表左边的图形。按照的方法可以人工数出来，但也想用电脑偷下懒，于是萌生了写个代码的想法。

最先开始想用数组与字典来完成，但那样感觉逻辑性不强且与实际图形不好联系，于是采用了自定义类的方法，也算是学习的一个实例。
于是一步步写下来创建了4个类（点、线、图形、三角形），如下图：

最终经过一路磕磕绊绊还算是完成了。分享一下该文件，如有需要在家辅导孩子的朋友可以直接使用，使用时，只需要从A2开始依次往下输入图形中每条线段的信息——线段上的点，用英文逗号隔开。然后单击按钮即可。

另外，还有问题想求助：类中的集合能否做到指定集合元素类型？
比如代码中的clsShape中的vLines集合，这个集合是clsLine对象的集合，但是在引用其中对象时并不能在输入 . 后自动列出成员，我想如果可以定义其类型为clsLine的话，应该可以自动列出成员。

希望知道的朋友分享一下，谢谢！

该贴已经同步到 Moneky的微博

jsxjd · 发表于 2013-11-14 15:19

图形结构固定的话，可以用公式实现

Moneky · 发表于 2013-11-14 15:48

本帖最后由 Moneky 于 2013-11-14 23:14 编辑

jsxjd 发表于 2013-11-14 15:19
图形结构固定的话，可以用公式实现

这个程序为的是针对任何数三角形的题目。

至于公式嘛，是知道的。

1楼中的问题已经自己解决了——再专门创建一个clsLines类，封装一个集合，提供添加元素接口，Items属性。后面再把代码更新.

后记：
在尝试创建clsLines类时，已经实现了该集合元素返回clsLine对象——VBE中可自动列出成员，但是无法想集合意义调用clsLines实例名称，如：
dim a as new clsLines
a(2) ----------------无法像这样调用，结果导致代码看起来繁杂，因此暂时先放弃这种做法了。

lee1892 · 发表于 2014-9-12 15:42

Moneky 发表于 2013-11-14 15:48
这个程序为的是针对任何数三角形的题目。

至于公式嘛，是知道的。

设置集合类的默认属性为其集合属性

比如 clsLines 里的属性 Lines 是返回 clsLine 的集合，把这个 Lines 属性设置为默认属性。

参考：http://club.excelhome.net/forum. ... &extra=page%3D1

Moneky · 发表于 2014-9-12 16:47

lee1892 发表于 2014-9-12 15:42
设置集合类的默认属性为其集合属性

比如 clsLines 里的属性 Lines 是返回 clsLine 的集合，把这个 Lin ...

谢谢lee1892指点，又掌握了一种新技术。

lee1892 · 发表于 2014-9-12 17:42

另外，我没去看代码，不清楚你的实现算法。

但第一感觉，应该是构建图数据结构，遍历寻找三边回路。应该不需要用到类。

Moneky · 发表于 2014-9-13 09:25

lee1892 发表于 2014-9-12 17:42
另外，我没去看代码，不清楚你的实现算法。

但第一感觉，应该是构建图数据结构，遍历寻找三边回路。应该 ...

我的算法是：
记录图形中的线段（包含线段上的所有点）
依次取每条线段中的两个点预定为三角形的两个顶点，再从其它线段中依次取出每一个点，判断如果现在这个点和之前的两个点都在同一条线段的话，这三个点就可以组成一个三角形。

历遍每条线段就得到了所有三角形了。

很原始的想法

lee1892 · 发表于 2014-9-13 11:57

Moneky 发表于 2014-9-13 09:25
我的算法是：
记录图形中的线段（包含线段上的所有点）
依次取每条线段中的两个点预定为三角形的两个顶 ...

我的算法伪代码如下：

Type 顶点
名称
邻接点集合
与某顶点是否邻接布尔数组
End
读取原始数据，并构造顶点集合
For Each 顶点1 In 顶点集合
For Each 顶点2 In 顶点1.邻接点集合
For Each 顶点3 In 顶点2.邻接点集合
If 顶点3 可连接顶点1
如果 3 点不在一条直线上，且该三角形未记录，则记录入结果

复制代码

创建类总是很费工夫的，构建合适的数据结构会使得算法非常简洁。

lee1892 · 发表于 2014-9-13 12:06

下面这段代码比较啰嗦，主要是数据初始化稍微麻烦点，我估计1万以内的顶点规模的速度是可以接受的，更大规模的会受字典对象影响了。
你这个题目可以锻炼两方面的内容了

Private Type VERTEX
Name As String * 1
Neibours As New Collection
Linkable() As Boolean
End Type
Private Sub CountTriangles()
Dim aInput, i%, j%, k%, nInd%, sPnt, aPnts, nPnt1, nPnt2
Dim aVerts() As VERTEX, dPnts As Object
Dim dLine As Object
Dim dTris As Object, nCnt%
Dim t#
t = Timer
' 图数据结构初始化
aInput = Cells(2, 1).Resize(Cells(1, 1).End(xlDown).Row - 1, 1)
nInd = 0
Set dPnts = CreateObject("scripting.dictionary")
Set dLine = CreateObject("scripting.dictionary")
ReDim aVerts(1 To UBound(aInput) * 3)
For i = 1 To UBound(aInput)
aPnts = Split(aInput(i, 1), ",")
For Each sPnt In aPnts
If Not dPnts.exists(sPnt) Then
nInd = nInd + 1
dPnts(sPnt) = nInd
If nInd > UBound(aVerts) Then
ReDim Preserve aVerts(1 To nInd * 2)
End If
aVerts(nInd).Name = sPnt
End If
Next
For nPnt1 = 0 To UBound(aPnts) - 2
For nPnt2 = nPnt1 + 1 To UBound(aPnts) - 1
For j = nPnt2 + 1 To UBound(aPnts)
sPnt = Array(aPnts(nPnt1), aPnts(nPnt2), aPnts(j))
dLine(sPnt(0) & sPnt(1) & sPnt(2)) = 1
dLine(sPnt(0) & sPnt(2) & sPnt(1)) = 1
dLine(sPnt(1) & sPnt(0) & sPnt(2)) = 1
dLine(sPnt(1) & sPnt(2) & sPnt(0)) = 1
dLine(sPnt(2) & sPnt(0) & sPnt(1)) = 1
dLine(sPnt(2) & sPnt(1) & sPnt(0)) = 1
Next
Next
Next
Next
ReDim Preserve aVerts(1 To nInd)
For i = 1 To nInd
ReDim aVerts(i).Linkable(1 To nInd)
Next
For i = 1 To UBound(aInput)
aPnts = Split(aInput(i, 1), ",")
For j = 0 To UBound(aPnts) - 1
For k = j + 1 To UBound(aPnts)
With aVerts(dPnts(aPnts(j)))
.Neibours.Add dPnts(aPnts(k)), aPnts(k)
.Linkable(dPnts(aPnts(k))) = True
End With
With aVerts(dPnts(aPnts(k)))
.Neibours.Add dPnts(aPnts(j)), aPnts(j)
.Linkable(dPnts(aPnts(j))) = True
End With
Next
Next
Next
' 遍历查找
Set dTris = CreateObject("scripting.dictionary")
nCnt = 0
For i = 1 To nInd
For Each nPnt1 In aVerts(i).Neibours
For Each nPnt2 In aVerts(nPnt1).Neibours
If aVerts(nPnt2).Linkable(i) Then
aPnts = Array(aVerts(i).Name, aVerts(nPnt1).Name, aVerts(nPnt2).Name)
If Not dLine.exists(Join(aPnts, "")) Then
If Not dTris.exists(aPnts(0) & aPnts(1) & aPnts(2)) And _
Not dTris.exists(aPnts(0) & aPnts(2) & aPnts(1)) And _
Not dTris.exists(aPnts(1) & aPnts(0) & aPnts(2)) And _
Not dTris.exists(aPnts(1) & aPnts(2) & aPnts(0)) And _
Not dTris.exists(aPnts(2) & aPnts(0) & aPnts(1)) And _
Not dTris.exists(aPnts(2) & aPnts(1) & aPnts(0)) Then
nCnt = nCnt + 1
dTris(Join(aPnts, "")) = nCnt
End If
End If
End If
Next
Next
Next
' 输出结果
ReDim aInput(0 To dTris.Count, 0 To 0)
aPnts = dTris.keys
aInput(0, 0) = "共 " & dTris.Count & " 个三角形"
For i = 0 To UBound(aPnts)
aInput(i + 1, 0) = aPnts(i)
Next
Columns(3).ClearContents
Cells(1, 3).Resize(dTris.Count + 1, 1) = aInput
' 清空内存
dPnts.RemoveAll: Set dPnts = Nothing
dLine.RemoveAll: Set dLine = Nothing
dTris.RemoveAll: Set dTris = Nothing
For i = 1 To UBound(aVerts)
Set aVerts(i).Neibours = Nothing
Erase aVerts(i).Linkable
Next
Erase aVerts
Debug.Print Timer - t
End Sub

复制代码

Moneky · 发表于 2014-9-13 12:08

lee1892 发表于 2014-9-13 12:06
下面这段代码比较啰嗦，主要是数据初始化稍微麻烦点，我估计1万以内的顶点规模的速度是可以接受的，更大规模 ...

受教了，代码只有后面再看了，现在上班。谢谢指教！

		自动登录	找回密码
密码			免费注册

[分享] [分享与求助]类技术的应用学习实例——数图形中的三角形