回 帖 发 新 帖 刷新版面

主题:已知三角形A、B两点坐标、BC边长、∠BAC角度,求C点坐标

在QQ群里闲聊时看到的一个问题:已知三角形A、B两点坐标、BC边长、∠BAC角度,求C点坐标。
注:不一定是三角形,也就是说,角度可能是180、0 等等任何可能的值。
无聊自己试着写了下。才发现原来初中、高中的数学知识还是有用的[em1]
主要代码如下。还有一些小错误,
[code=vb]
Option Explicit
Private Type POINT
    x As Single
    y As Single
End Type

Private Function CalcAC(ByRef pA As POINT, ByRef pB As POINT, ByVal bc As Single, ByVal bac As Single) As Single
'//! 已知一个三角形的A、B两点坐标、BC边长、∠BAC,求另一边AC的长度
Dim ab As Single
Dim ac As Single
Const PI As Single = 3.1415926
ab = CalcDistance(pA, pB)

ac = Sqr(ab ^ 2 + bc ^ 2 - 2 * ab * bc * Cos(bac / 180 * PI))

CalcAC = ac
End Function
Private Sub DrawAxes()
    pic1.Cls
    
    pic1.Height = pic1.Width
    pic1.BackColor = vbBlack
    pic1.AutoRedraw = True
    pic1.Scale (-200, 200)-(200, -200)
    pic1.ForeColor = vbGreen
    pic1.DrawWidth = 1
    pic1.Line (-200, 0)-(200, 0)
    pic1.Line (190, 10)-(200, 0)
    pic1.Line (190, -10)-(200, 0)
    
    pic1.Line (0, -200)-(0, 200)
    pic1.Line (10, 190)-(0, 200)
    pic1.Line (-10, 190)-(0, 200)
End Sub

Private Sub Command1_Click()

Dim pA As POINT
Dim pB As POINT
Dim bc As Single
Dim bac As Single
Dim pt() As POINT

Dim r As Single
Dim n As Integer
Dim i As Integer

Dim result() As Single

Call DrawAxes

'//:测试
pA.x = 0
pA.y = 0
pB.x = 2
pB.y = 0
Debug.Print GetPoint(pA, 2, pB, 2, pt())
Debug.Print pt(0).x, pt(0).y
Debug.Print pt(1).x, pt(1).y
'Exit Sub

pA.x = txtAx.Text
pA.y = txtAy.Text

pB.x = txtBx.Text
pB.y = txtBy.Text

bc = txtBC.Text
bac = txtBAC.Text

    pic1.ForeColor = vbRed
    pic1.DrawWidth = 1
    pic1.POINT pA.x, pA.y
    pic1.POINT pB.x, pB.y
    pic1.Line (pA.x, pA.y)-(pB.x, pB.y)
    
    r = CalcAC(pA, pB, bc, bac)
    
    'Label5.Caption = r
    pic1.ForeColor = vbYellow
    pic1.Circle (pA.x, pA.y), r
    
    pic1.Circle (pB.x, pB.y), bc
    n = GetPoint(pA, r, pB, bc, pt())
    'Label5.Caption = Label5.Caption & "," & n
    
    pic1.ForeColor = vbMagenta
    For i = 0 To n - 1
        pic1.POINT pt(i).x, pt(i).y
        Debug.Print pt(i).x, pt(i).y
        If (CalcDistance(pt(i), pB) - bc) < 0.0000001 Then
            pic1.Line (pt(i).x, pt(i).y)-(pB.x, pB.y)
            pic1.Line (pt(i).x, pt(i).y)-(pA.x, pA.y)
            Label5.Caption = pt(i).x & "," & pt(i).y
            'Exit For
        Else
            Debug.Print "--------", bc, CalcDistance(pt(i), pB)
        End If
        
    Next
    
    pic1.ForeColor = vbGreen
    If n = 2 Then
        pic1.Line (pt(0).x, pt(0).y)-(pt(1).x, pt(1).y)
    End If
    
End Sub

Private Sub Form_Load()
Call DrawAxes
End Sub

Private Function GetPoint(ByRef pA As POINT, ByVal ra As Single, ByRef pB As POINT, ByVal rb As Single, ByRef pt() As POINT) As Long
'//! 获取两个圆的交点
'//! 返回值:交点的个数;交点的坐标通过pt()数组引用返回
'//! 参数:pa,pb两个圆的圆心坐标,ra,rb两个圆的半径
Dim ab As Single
Dim n As Integer
Dim r As Integer
Dim result() As Single
Dim a As Single
Dim b As Single
Dim c As Single
Dim i As Integer

ab = CalcDistance(pA, pB)
If ab > (ra + rb) Or ab < Abs(ra - rb) Then
    n = 0
ElseIf (ab < (ra + rb) And ab > Abs(ra - rb)) Then
    n = 2
ElseIf (ab = Abs(ra - rb) Or ab = (ra + rb)) Then
    n = 1
End If

Dim t As Single
t = ra ^ 2 - rb ^ 2 + pB.x ^ 2 - pA.x ^ 2 + pB.y ^ 2 - pA.y ^ 2
a = 1 + ((pB.y - pA.y) / (pB.x - pA.x)) ^ 2
b = -1 * (2 * ((pB.y - pA.y) / (pB.x - pA.x)) * ((t - (2 * pB.x - 2 * pA.x) * pA.x) / (2 * pB.x - 2 * pA.x)) + 2 * pA.y)
c = ((t - (2 * pB.x - 2 * pA.x) * pA.x) / (2 * pB.x - 2 * pA.x)) ^ 2 + pA.y ^ 2 - ra ^ 2

r = CalcFangCheng(a, b, c, result())
Debug.Assert r = n
If r > 0 Then
    ReDim pt(r - 1) As POINT
    For i = 0 To r - 1
        pt(i).y = result(i)
        pt(i).x = ((ra ^ 2 - rb ^ 2 + pB.x ^ 2 - pA.x ^ 2 + pB.y ^ 2 - pA.x ^ 2) - (2 * pB.y - 2 * pA.y) * pt(i).y) / (2 * pB.x - 2 * pA.x)
    Next
End If

GetPoint = n
End Function

Private Function CalcDistance(ByRef pA As POINT, ByRef pB As POINT) As Single
'//! 计算平面内两点的距离
    CalcDistance = Sqr((pB.x - pA.x) ^ 2 + (pB.y - pA.y) ^ 2)
End Function

Private Function CalcFangCheng(ByVal a As Single, ByVal b As Single, ByVal c As Single, ByRef result() As Single) As Long
'//! 解方程ax^2 + bx + c = 0
Dim n As Integer
Dim delta As Single

delta = b ^ 2 - 4 * a * c
If delta < 0 Then
    n = 0
ElseIf delta > 0 Then
    n = 2
    ReDim result(1) As Single
    result(0) = (b * (-1) + Sqr(delta)) / (2 * a)
    result(1) = (b * (-1) - Sqr(delta)) / (2 * a)
Else
    n = 1
    ReDim result(0) As Single
    result(0) = b * (-1) / (2 * a)
End If

CalcFangCheng = n
End Function
[/code]
[em1][em1][em1][em1]

回复列表 (共11个回复)

11 楼

[quote]好文章。总是支持一下的[/quote]
警告,准备封号

我来回复

您尚未登录,请登录后再回复。点此登录或注册