ai.frm

人工智能编程示例

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "An example of Artificial Intelligence (by Sangaletti Federico [e-mail]-)"
   ClientHeight    =   6420
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9780
   Icon            =   "AI.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6420
   ScaleWidth      =   9780
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton Command4 
      Caption         =   "&Send me a comment"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   8520
      Picture         =   "AI.frx":030A
      Style           =   1  'Graphical
      TabIndex        =   3
      Top             =   5400
      Width           =   1215
   End
   Begin VB.CommandButton Command3 
      Caption         =   "&Clear"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   4560
      Picture         =   "AI.frx":0614
      Style           =   1  'Graphical
      TabIndex        =   2
      Top             =   5400
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "&Draw obstacles"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   5880
      Picture         =   "AI.frx":0EDE
      Style           =   1  'Graphical
      TabIndex        =   1
      Top             =   5400
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "&Go!"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   7200
      Picture         =   "AI.frx":11E8
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   5400
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************
'* This code demostrate how to create an     *
'* AI algorithm for going from a start point *
'* to a stop point turning some obstacles    *
'*                                           *
'* This code isn't optimized for the speed   *
'* and to chose the shortest way!!           *
'*********************************************

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Dim coordX, coordY As Long
Dim destX, destY As Long
Dim startX, startY As Long

Const nObstacles = 64
Dim XArray(nObstacles) As Variant
Dim YArray(nObstacles) As Variant
Dim Again, a As Boolean
Dim startT, stopT As Long
Dim tmpX, tmpY As Long

Private Sub Command1_Click()
   If destX = 0 Then
      MsgBox "You must specify the stop point coordinates!" & vbCrLf & "Click on the form", vbExclamation
      Exit Sub
   End If
   
   startT = Timer
   Do
      Me.PSet (startX, startY), RGB(255, 0, 0)
      If startX <> destX Then
         If (destX - startX) < 0 Then
            For i = 1 To nObstacles
               If (startX - 1 >= XArray(i) And startX - 1 <= XArray(i) + 500) And (startY >= YArray(i) And startY <= YArray(i) + 500) Then
                  Again = True
                  Do
                     If (destX - startX) < 0 Then
                        startY = startY - 1
                     Else
                        startY = startY + 1
                     End If
                     Me.PSet (startX, startY), RGB(255, 0, 0)
                     If (startX - 1 >= XArray(i) And startX - 1 <= XArray(i) + 500) And (startY >= YArray(i) And startY <= YArray(i) + 500) Then
                        Again = True
                     Else
                        Again = False
                     End If
                  Loop Until Again = False
               End If
            Next i
            startX = startX - 1
         Else
            For i = 1 To nObstacles
               If (startX + 1 >= XArray(i) And startX + 1 <= XArray(i) + 500) And (startY >= YArray(i) And startY <= YArray(i) + 500) Then
                  Again = True
                  Do
                     If (destX - startX) < 0 Then
                        startY = startY - 1
                     Else
                        startY = startY + 1
                     End If
                     Me.PSet (startX, startY), RGB(255, 0, 0)
                     If (startX + 1 >= XArray(i) And startX + 1 <= XArray(i) + 500) And (startY >= YArray(i) And startY <= YArray(i) + 500) Then
                        Again = True
                     Else
                        Again = False
                     End If
                  Loop Until Again = False
               End If
            Next i
            startX = startX + 1
         End If
      End If
      If startY <> destY Then
         If (destY - startY) < 0 Then
            For i = 1 To nObstacles
               If (startY - 1 >= YArray(i) And startY - 1 <= YArray(i) + 500) And (startX >= XArray(i) And startX <= XArray(i) + 500) Then
                  Again = True
                  Do
                     If (startY - destY) < 0 Then
                        startX = startX - 1
                     Else
                        startX = startX + 1
                     End If
                     Me.PSet (startX, startY), RGB(255, 0, 0)
                     If (startY - 1 >= YArray(i) And startY - 1 <= YArray(i) + 500) And (startX >= XArray(i) And startX <= XArray(i) + 500) Then
                        Again = True
                     Else
                        Again = False
                     End If
                  Loop Until Again = False
               End If
            Next i
            startY = startY - 1
         Else
            For i = 1 To nObstacles
               If (startY + 1 >= YArray(i) And startY + 1 <= YArray(i) + 500) And (startX >= XArray(i) And startX <= XArray(i) + 500) Then
                  Again = True
                  Do
                     If (startY - destY) < 0 Then
                        startX = startX - 1
                     Else
                        startX = startX + 1
                     End If
                     Me.PSet (startX, startY), RGB(255, 0, 0)
                     If (startY + 1 >= YArray(i) And startY + 1 <= YArray(i) + 500) And (startX >= XArray(i) And startX <= XArray(i) + 500) Then
                        Again = True
                     Else
                        Again = False
                     End If
                  Loop Until Again = False
               End If
            Next i
            startY = startY + 1
         End If
      End If
      DoEvents
   Loop Until startX = destX And startY = destY
   stopT = Timer
   MsgBox "Done!!" & vbCrLf & "Time elapsed " & stopT - startT & " sec.", vbExclamation
End Sub

Private Sub Command2_Click()
   Call Command3_Click
   tmpX = 1500
   tmpY = 300
   
   a = True
   For i = 1 To nObstacles
      tmpX = tmpX + 80
      tmpY = tmpY + 560
      XArray(i) = tmpX
      YArray(i) = tmpY
      Me.Line (tmpX, tmpY)-(tmpX + 500, tmpY + 500), RGB(0, 0, 255), BF
      If i >= 8 Then
         If (i / 8) / Int(i / 8) = 1 Then
            If a = False Then
               tmpY = 300
               a = True
            Else
               tmpY = 0
               a = False
            End If
         End If
      End If
   Next i
End Sub

Private Sub Command3_Click()
   Me.Cls
   Erase XArray
   Erase YArray
   Call Form_Activate
End Sub

Private Sub Command4_Click()
   ShellExecute 0, vbNullString, "mailto:[e-mail]?subject=-AI example-", vbNullString, "", 1
End Sub

Private Sub Form_Click()
   Me.Circle (coordX, coordY), 30, 255
   Me.Print "   Stop"
   destX = coordX
   destY = coordY
End Sub

Private Sub Form_Activate()
   Randomize
   startX = Int((Rnd * 2000) + 1)
   startY = Int((Rnd * 2000) + 1)
   Me.Circle (startX, startY), 30, RGB(0, 255, 0)
   Me.Print "   Start"
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   coordX = X
   coordY = Y
End Sub