用VBA解欧拉计划题目（102）--包含原点的三角形

grf1973 · 发表于 2017-12-28 20:35

包含原点的三角形

从笛卡尔平面中随机选择三个不同的点，其坐标均满足-1000 ≤ x, y ≤ 1000，这三个点构成一个三角形。

考虑下面两个三角形：

A(-340,495), B(-153,-910), C(835,-947)X(-175,41), Y(-421,-714), Z(574,-645)

可以验证三角形ABC包含原点，而三角形XYZ不包含原点。

在27K的文本文件triangles.txt中包含了一千个“随机”三角形的坐标，找出其中包含原点在其内部的三角形的数量。

注意：文件中的前两个三角形就是上述样例。

grf1973 · 发表于 2017-12-28 20:36

提示：如果点P在三角形内，那么从A->B->C->A走一圈，点P始终在自己某一侧

香川群子 · 发表于 2017-12-29 22:25

Sub test() 'by kagawa 2017/12/29
'包含原点的三角形=228个
Open ActiveWorkbook.Path & "\p102_triangles.txt" For Input As #1
a = Split(Input(LOF(1), #1), vbLf) '提取全部字符串并按[换行]拆分为数组
Close #1
m = UBound(a) - 1: n = 6
ReDim ar(m, n + 4)
For i = 0 To m
For j = 0 To n - 1
tr = Split(a(i), ",") '按行拆分数组
ar(i, j + 1) = Val(tr(j)) '写入x,y坐标
Next
For j = 0 To 3
ar(i, n + j + 1) = ar(i, j + 1) '重复1,2方便循环计算
Next
Next
For i = 0 To m
For j = 1 To 5 Step 2 '循环计算点1,点2连线的斜率k和截距b 以及过点3斜率k时的截距b1
If ar(i, j) = ar(i, j + 2) Then 'x=b垂直线时
b = ar(i, j) '取点1点2的x值b
b1 = ar(i, j + 4) '取点3的x值b1
Else
k = (ar(i, j + 1) - ar(i, j + 3)) / (ar(i, j) - ar(i, j + 2)) '计算斜率k
b = ar(i, j + 1) - k * ar(i, j) '截距b
b1 = ar(i, j + 5) - k * ar(i, j + 4) '斜率k的直线过点3时的截距b1
End If
If b * b1 > 0 Then Exit For '截距必须符号相反否则点3和坐标轴原点就会在直线两端
Next
If j = 7 Then ar(i, 0) = 1: cnt = cnt + 1
Next
Debug.Print cnt
[a5].Resize(m + 1, n + 1) = ar
MsgBox cnt
End Sub

复制代码

香川群子 · 发表于 2017-12-29 22:54

附件中还有一些提取文本文件的语句。

香川群子 · 发表于 2017-12-30 09:44

索性写成自定义函数了，可以判断任意坐标点，是否包含在3点坐标组成的三角形之内。

Function IsInTriAng(Rng) As Boolean
If Chk(Rng(1), Rng(2), Rng(3), Rng(4), Rng(5), Rng(6), Rng(7), Rng(8)) Then
If Chk(Rng(1), Rng(2), Rng(5), Rng(6), Rng(7), Rng(8), Rng(3), Rng(4)) Then
If Chk(Rng(1), Rng(2), Rng(7), Rng(8), Rng(3), Rng(4), Rng(5), Rng(6)) Then
IsInTriAng = True
End If
End If
End If
End Function
Function IsInTriAngle(x, y, x1, y1, x2, y2, x3, y3) As Boolean
If Chk(x, y, x1, y1, x2, y2, x3, y3) Then
If Chk(x, y, x2, y2, x3, y3, x1, y1) Then
If Chk(x, y, x3, y3, x1, y1, x2, y2) Then
IsInTriAngle = True
End If
End If
End If
End Function
Function Chk(x, y, x1, y1, x2, y2, x3, y3) As Boolean
If x1 = x2 Then
Chk = (x1 - x) * (x3 - x) <= 0
Else
k = (y1 - y2) / (x1 - x2)
b1 = y1 - k * x1: b = y - k * x: b2 = y3 - k * x3
Chk = (b1 - b) * (b2 - b) <= 0
End If
End Function

复制代码

香川群子 · 发表于 2017-12-30 09:48

第一个只用一个参数，把数据按照x, y, x1, y1, x2, y2, x3, y3的格式输入1行8列区域后引用。
或者，按照：
x, y；
x1, y1；
x2, y2；
x3, y3
这样4行2列的格式输入区域后引用。

第2个函数，则需要逐个输入8个坐标参数。
显然第1种方式非常方便，但对格式要求是固定的。

而第二种方式可以任意使用，尤其是在VBA中使用时，可能更方便、准确。

香川群子 · 发表于 2017-12-30 13:17

又找了一种计算点线之间向量关系类型，然后比较是否都为相同类型(含重叠)的快速计算方法。

效率更高啊，且可以扩展为判断点是否包含在任意多边形内。

Function PLineRel(x1, y1, x2, y2, x, y) '点线向量关系类型的计算
r = x1 * (y2 - y) + x2 * (y - y1) + x * (y1 - y2)
If r < 0 Then PLineRel = "<" Else If r > 0 Then PLineRel = ">" Else PLineRel = "=" '重叠
End Function
Sub test2() 'by kagawa 2017/12/30
Open ActiveWorkbook.Path & "\p102_triangles.txt" For Input As #1
a = Split(Input(LOF(1), #1), vbLf) '提取全部字符串并按[回车换行]拆分为数组 Get all
Close #1
m = UBound(a) - 1: n = 6
ReDim ar(m, n + 2)
For i = 0 To m
For j = 0 To n - 1
tr = Split(a(i), ",")
ar(i, j + 1) = Val(tr(j))
Next
ar(i, n + 1) = ar(i, 1): ar(i, n + 2) = ar(i, 2)
Next
For i = 0 To m
r = "" '向量关系初始化
For j = 1 To 5 Step 2
t = PLineRel(ar(i, j), ar(i, j + 1), ar(i, j + 2), ar(i, j + 3), 0, 0)
If r = "" Then If t <> "=" Then r = t '记录非重叠的向量关系类型
If t <> "=" And t <> r Then Exit For '如有类型不同则不符合退出
Next
If j = 7 Then ar(i, 0) = 1: cnt = cnt + 1 '都是相同类型(含重叠)时即为被包含关系
Next
Debug.Print cnt
[a5].Resize(m + 1, n + 1) = ar
MsgBox cnt
End Sub

复制代码

grf1973 · 发表于 2017-12-30 19:15

228，结果正确。

grf1973 · 发表于 2017-12-30 19:19

为什么代码又帖不了，又有关键词过不了关？

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

[VBA] 用VBA解欧拉计划题目（102）--包含原点的三角形

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源