有效边表 VB6.0代码

' 通过声明类来实现链表
Option   Explicit
Public  xValue  As   Single       ' 线与当前x扫描线的交点
Public  yMax  As   Integer        ' 线的y最大值
Public  kSubOne  As   Single      ' k的-1次方
Public  NextNode  As  Node      ' 下一个

Option  Base  1                         ' 让代码中所有数组的上标是从1开始
Dim  X%, Y%, Vid%
Dim  vx  As  Variant, vy  As  Variant     ' 定义存放各个点坐标的数组
Const  Vnumber  =   7                     ' 点的数目
Const  xMax  =   12                       ' 坐标最大值
Const  grid  =   400

Private   Sub Command2_Click() Sub Command2_Click()        '退出
End
End Sub

Private   Sub Command3_Click() Sub Command3_Click()        '生成并输出AET
Dim i As Integer
Form2.Show
For i = 1 To 12
    Call CreatLink(i)               '依次建立12条扫描线的AET
Next
End Sub

Private   Sub CreatLink() Sub CreatLink(xLine As Integer)     '建立AET的过程
Dim xTemp As Single     '当前线与x扫描线的交点的x坐标变量
Dim kTemp As Single     '斜率k变量

Dim n As Node
Dim nI As Node
Dim nI2 As Node
Dim nMax As Node
Dim ListHead As Node    '头
Dim ListTail As Node    '尾

Dim printText As String

For i = 1 To Vnumber    '依次检测各线p1p2 p2p3 p3p4...
    xTemp = (((xLine - Val(vy(i))) * (Val(vx(i + 1)) - Val(vx(i)))) / (Val(vy(i + 1)) - Val(vy(i)))) + Val(vx(i))   '求得当前线与x扫描线的交点的x坐标
    If Val(vx(i + 1)) > Val(vx(i)) Then                             '如果pi+1>pi的情况
        If xTemp >= Val(vx(i)) And xTemp <= Val(vx(i + 1)) Then     '交点位于有效范围内
            Set n = New Node                                        '声明结点
            n.xValue = xTemp                                        '将xTemp存入链结点的第一个位置
            
            If Val(vy(i + 1)) > Val(vy(i)) Then                     '判断y点谁大 将最大值存入链结点的第二个位置
                n.yMax = Val(vy(i + 1))
            Else
                n.yMax = Val(vy(i))
            End If
            
            kTemp = (Val(vy(i + 1)) - Val(vy(i))) / (Val(vx(i + 1)) - Val(vx(i)))   '求k
            n.kSubOne = kTemp                                       '将k存入链结点的第三个位置
            
            If ListHead Is Nothing Then                             '如果链表未空
                Set ListHead = n                                    '通过头 新节点入链
            Else
                Set ListTail.NextNode = n                           '通过尾 新节点入链
            End If
            Set ListTail = n                                        '定义新的尾
            Set ListTail.NextNode = Nothing                         '尾指向空
        Else
        End If
    ElseIf Val(vx(i)) > Val(vx(i + 1)) Then                         '如果pi+1<pi的情况
        If xTemp >= Val(vx(i + 1)) And xTemp <= Val(vx(i)) Then     '交点位于有效范围内
            Set n = New Node
            n.xValue = xTemp
            If Val(vy(i + 1)) > Val(vy(i)) Then
                n.yMax = Val(vy(i + 1))
            Else
                n.yMax = Val(vy(i))
            End If
            kTemp = (Val(vy(i + 1)) - Val(vy(i))) / (Val(vx(i + 1)) - Val(vx(i)))
            n.kSubOne = kTemp
            If ListHead Is Nothing Then
                Set ListHead = n
            Else
                Set ListTail.NextNode = n
            End If
            Set ListTail = n
            Set ListTail.NextNode = Nothing
        Else
        End If
    End If
Next

'按照xValue排序
    Set nI2 = ListHead
    While Not nI2 Is Nothing
        Set nI = nI2
        Set nMax = nI2
        While (Not nI Is Nothing And Not nI.NextNode Is Nothing)
    
        If nI.xValue < nI.NextNode.xValue Then
            Set nMax = nI.NextNode
        End If
        Set nI = nI.NextNode
        Wend
        
            Dim tempV As Single

            tempV = nMax.xValue
            nMax.xValue = nI2.xValue
            nI2.xValue = tempV

            tempV = nMax.yMax
            nMax.yMax = nI2.yMax
            nI2.yMax = tempV

            tempV = nMax.kSubOne
            nMax.kSubOne = nI2.kSubOne
            nI2.kSubOne = tempV
        
        
        Set nI2 = nI2.NextNode
    Wend
'---
'输出当前链表到form2
While Not ListHead Is Nothing
    Set n = ListHead
    Set ListHead = ListHead.NextNode
    printText = Format(n.xValue, "###0.00") & ", " & n.yMax & ", " & Format(n.kSubOne, "###0.00") + "    " + printText
    Set n = Nothing
Wend
    Form2.Print Str(xLine) + "   " + printText
End Sub

Private   Sub Form_Activate() Sub Form_Activate()
Set n = New Node
X = 0
Y = 0
For i = 1 To xMax + 1              '画方格
    Line (0, Y)-(xMax * grid, Y)
    Line (X, 0)-(X, xMax * grid)
    X = X + grid
    Y = Y + grid
Next
For i = 1 To Vnumber
    Line (vx(i) * grid, vy(i) * grid)-(vx(i + 1) * grid, vy(i + 1) * grid), QBColor(12)
    Print "p" & IIf((i + 1) = 8, 1, i + 1)
Next i
Vid = Text2
Label1(Vid - 1).ForeColor = QBColor(9)
Text1(2 * Vid - 1).ForeColor = QBColor(9)
Text1(2 * Vid - 2).ForeColor = QBColor(9)
End Sub

Private   Sub Form_Load() Sub Form_Load()
Scale (-ScaleWidth / 4, ScaleHeight - 200)-(ScaleWidth * 3 / 4 - 200, -200)
vx = Array(Text1(0), Text1(2), Text1(4), Text1(6), Text1(8), Text1(10), Text1(12), Text1(0))
vy = Array(Text1(1), Text1(3), Text1(5), Text1(7), Text1(9), Text1(11), Text1(13), Text1(1))
End Sub

Private   Sub Form_MouseDown() Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Text1(Vid * 2 - 2) = Round(X / grid): Text1(Vid * 2 - 1) = Round(Y / grid)
End Sub

Private   Sub Text1_Change() Sub Text1_Change(Index As Integer)
Form1.Cls
DrawWidth = 1: X = 0: Y = 0
Text2 = Int((Index + 1) / 2 + 0.5)
Vid = Text2
For i = 1 To xMax + 1 '画方格
    Line (0, Y)-(xMax * grid, Y)
    Line (X, 0)-(X, xMax * grid)
    X = X + grid
    Y = Y + grid
Next
vx = Array(Text1(0), Text1(2), Text1(4), Text1(6), Text1(8), Text1(10), Text1(12), Text1(0))
vy = Array(Text1(1), Text1(3), Text1(5), Text1(7), Text1(9), Text1(11), Text1(13), Text1(1))
For i = 1 To Vnumber
    Line (vx(i) * grid, vy(i) * grid)-(vx(i + 1) * grid, vy(i + 1) * grid), QBColor(12)
    Print "p" & IIf((i + 1) = 8, 1, i + 1)
Next i
End Sub

Private   Sub Text2_Change() Sub Text2_Change()
If Text2 < 1 Then Text2 = 1
If Text2 > Vnumber Then Text2 = Vnumber
For tt = 1 To Vnumber
Label1(tt - 1).ForeColor = QBColor(0)
Text1(2 * tt - 1).ForeColor = QBColor(0)
Text1(2 * tt - 2).ForeColor = QBColor(0)
Next
Vid = Text2
Label1(Vid - 1).ForeColor = QBColor(9)
Text1(2 * Vid - 1).ForeColor = QBColor(9)
Text1(2 * Vid - 2).ForeColor = QBColor(9)
End Sub

Private   Sub Command1_Click() Sub Command1_Click()
'For i = 1 To 12
'    Call CreatLink(i)               '依次建立12条扫描线的AET
'Next
End Sub