module1.vb

苏金明编写的《用VB.NET和VC#.NET开发交互式CAD系统》一书的源代码

Imports System.Math

Module Module1
    Public Function LineLine(ByVal line1 As CLine, ByVal line2 As CLine) As Single()
        Dim reValue(4) As Single
        Dim xx1, yy1, xx2, yy2 As Single
        Dim x1, y1, x2, y2 As Single
        Dim n1, n2, n3, n4 As Single
        Dim k1, k2, c1, c2 As Single

        With line1
            If .LBegin.X > .LEnd.X Then
                xx2 = .LBegin.X
                yy2 = .LBegin.Y
                xx1 = .LEnd.X
                yy1 = .LEnd.Y
            Else
                xx1 = .LBegin.X
                yy1 = .LBegin.Y
                xx2 = .LEnd.X
                yy2 = .LEnd.Y
            End If
        End With

        With line2
            If .LBegin.X > .LEnd.X Then
                x2 = .LBegin.X
                y2 = .LBegin.Y
                x1 = .LEnd.X
                y1 = .LEnd.Y
            Else
                x1 = .LBegin.X
                y1 = .LBegin.Y
                x2 = .LEnd.X
                y2 = .LEnd.Y
            End If
        End With

        Dim kc1 As Single() = LineKX(line1.LBegin, line1.LEnd)
        Dim kc2 As Single() = LineKX(line2.LBegin, line2.LEnd)

        '如果两条直线段的斜率相同
        If kc1(0) = kc2(0) Then
            If kc1(1) <> kc2(1) Then
                reValue(0) = 0
            Else
                n1 = y1 + (-x1) * kc1(0)
                n1 = yy1 + (-xx1) * kc2(0)
                If n1 <> n2 Then
                    'reValue(0) = 0
                Else
                    n3 = Max(xx1, x1)
                    n4 = Min(xx2, x2)
                    reValue(1) = n3
                    reValue(2) = y1 + (n3 - x1) * kc1(0)
                    If (n3 = n4) Then
                        reValue(0) = 1
                    End If
                    reValue(3) = n4
                    reValue(4) = y1 + (n4 - x1) * kc1(0)
                    reValue(0) = 2
                End If
            End If
        Else
            reValue(1) = (kc1(1) - kc2(1)) / (kc2(0) - kc1(0))
            reValue(2) = kc1(1) + reValue(1) * kc1(0)
            '如果交点横坐标在两条直线段的横坐标范围内
            '如果两条直线段垂直相交
            If (kc1(0) = 0 And kc2(0) = 10000 Or kc1(0) = 10000 And kc2(0) = 0) Then
                If reValue(1) >= (x1 - 1) And reValue(1) <= (x2 + 1) And reValue(1) >= (xx1 - 1) And reValue(1) <= (xx2 + 1) Then
                    reValue(0) = 1
                End If
            Else
                If reValue(1) >= x1 And reValue(1) <= x2 And reValue(1) >= xx1 And reValue(1) <= xx2 Then
                    reValue(0) = 1
                Else
                    reValue(0) = 0
                End If
            End If
        End If

        Return reValue
    End Function

    '计算两点之间的距离
    Public Function DistPtoP(ByVal p1 As PointF, ByVal p2 As PointF) As Single
        Return Sqrt((p2.X - p1.X) * (p2.X - p1.X) + (p2.Y - p1.Y) * (p2.Y - p1.Y))
    End Function


    '计算直线段的截距式方程
    Public Function LineKX(ByVal pB As PointF, ByVal pE As PointF) As Single()
        Dim kc(1) As Single
        '若直线段不为竖直线段
        If pB.X <> pE.X Then
            kc(0) = (pE.Y - pB.Y) / (pE.X - pB.X)
            '如果是竖直线段
        Else
            kc(0) = 1000
        End If
        '计算截距
        kc(1) = pB.Y - kc(0) * pB.X
        Return kc
    End Function

    '圆的一般式方程
    Private Function CircleF(ByVal pCenter As PointF, ByVal r As Single) As Single()
        Dim con As Single() = {0, 0, 0}
        con(0) = -2 * pCenter.X
        con(1) = -2 * pCenter.Y
        con(2) = pCenter.X * pCenter.X + pCenter.Y * pCenter.Y - r * r
        Return con
    End Function

    Public Function LineCircle(ByVal line As CLine, ByVal circle As CCircle) As Single()
        Dim kc As Single() = {0, 0}
        Dim con As Single() = {0, 0, 0}
        Dim interxy As Single() = {0, 0, 0, 0, 0}
        Dim LineMinX, LineMaxX, LineMinY, LineMaxY As Single
        Dim X(1) As Single
        Dim Y(1) As Single
        LineMinX = Min(line.LBegin.X, line.LEnd.X)
        LineMaxX = Max(line.LBegin.X, line.LEnd.X)
        LineMinY = Min(line.LBegin.Y, line.LEnd.Y)
        LineMaxY = Max(line.LBegin.Y, line.LEnd.Y)
        kc = LineKX(line.LBegin, line.LEnd)
        con = CircleF(circle.Center, circle.Radius)
        Dim A As Single = 1 + kc(0) * kc(0)
        Dim B As Single = 2 * kc(1) * kc(0) + con(1) * kc(0) + con(0)
        Dim C As Single = kc(1) * kc(1) + con(1) * kc(1) + con(2)
        Dim Root As Single = B * B - 4 * A * C
        If Root < 0 Then
            interxy(0) = 0
        ElseIf Root = 0 Then
            X(0) = -B / 2 / A
            Y(0) = kc(0) * X(1) + kc(1)
            '如果直线不是竖直线
            If line.LBegin.X <> line.LEnd.X Then
                If X(0) < LineMinX Or X(0) > LineMaxX Then
                    interxy(0) = 0
                Else
                    interxy(0) = 1
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                End If
                '如果直线是竖直线
            Else
                If Y(0) < LineMinY Or Y(0) > LineMaxY Then
                    interxy(0) = 0
                Else
                    interxy(0) = 1
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                End If
            End If
        Else
            X(0) = (-B + Sqrt(Root)) / 2 / A
            X(1) = (-B - Sqrt(Root)) / 2 / A
            Y(0) = kc(0) * X(0) + kc(1)
            Y(1) = kc(0) * X(1) + kc(1)
            '如果直线不是竖直线
            If line.LBegin.X <> line.LEnd.X Then
                If (X(0) < LineMinX Or X(0) > LineMaxX) And _
                   (X(1) < LineMinX Or X(1) > LineMaxX) Then
                    interxy(0) = 0
                ElseIf (X(0) < LineMinX Or X(0) > LineMaxX) And _
                       Not (X(1) < LineMinX Or X(1) > LineMaxX) Then
                    interxy(0) = 1
                    interxy(1) = X(1)
                    interxy(2) = Y(1)
                ElseIf Not (X(0) < LineMinX Or X(0) > LineMaxX) And _
                       (X(1) < LineMinX Or X(1) > LineMaxX) Then
                    interxy(0) = 1
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                Else
                    interxy(0) = 2
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                    interxy(3) = X(1)
                    interxy(4) = Y(1)
                End If
                '如果直线是竖直线
            Else
                If (Y(0) < LineMinY Or Y(0) > LineMaxY) And _
                   (Y(1) < LineMinY Or Y(1) > LineMaxY) Then
                    interxy(0) = 0
                ElseIf (Y(0) < LineMinY Or Y(0) > LineMaxY) And _
                       Not (Y(1) < LineMinY Or Y(1) > LineMaxY) Then
                    interxy(0) = 1
                    interxy(1) = X(1)
                    interxy(2) = Y(1)
                ElseIf Not (Y(0) < LineMinY Or Y(0) > LineMaxY) And _
                       (Y(1) < LineMinY Or Y(1) > LineMaxY) Then
                    interxy(0) = 1
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                Else
                    interxy(0) = 2
                    interxy(1) = X(0)
                    interxy(2) = Y(0)
                    interxy(3) = X(1)
                    interxy(4) = Y(1)
                End If
            End If
        End If

        Return interxy
    End Function

End Module