Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / puzzle / puzzle.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1999-09-07 | 23.5 KB | 645 lines

VERSION 5.00 Begin VB.Form Puzzle AutoRedraw = -1 'True Caption = "Puzzle" ClientHeight = 7068 ClientLeft = 1272 ClientTop = 1620 ClientWidth = 8268 LinkTopic = "Form1" ScaleHeight = 7068 ScaleWidth = 8268 Begin VB.Frame Frame1 Height = 4092 Left = 1320 TabIndex = 9 Top = 1200 Width = 3972 Begin VB.CommandButton Command1 Caption = "8" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 7 Left = 2640 TabIndex = 17 Top = 2760 Width = 1332 End Begin VB.CommandButton Command1 Caption = "7" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 6 Left = 1320 TabIndex = 16 Top = 2760 Width = 1332 End Begin VB.CommandButton Command1 Caption = "6" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 5 Left = 0 TabIndex = 15 Top = 2760 Width = 1332 End Begin VB.CommandButton Command1 Caption = "5" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 4 Left = 2640 TabIndex = 14 Top = 1440 Width = 1332 End Begin VB.CommandButton Command1 Caption = "4" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 3 Left = 1320 TabIndex = 13 Top = 1440 Width = 1332 End Begin VB.CommandButton Command1 Caption = "3" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 2 Left = 0 TabIndex = 12 Top = 1440 Width = 1332 End Begin VB.CommandButton Command1 Caption = "2" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 1 Left = 2640 TabIndex = 11 Top = 120 Width = 1332 End Begin VB.CommandButton Command1 Caption = "1" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1332 Index = 0 Left = 1320 TabIndex = 10 Top = 120 Width = 1332 End End Begin VB.TextBox numbertext Height = 372 Left = 4920 TabIndex = 5 Top = 6600 Width = 1332 End Begin VB.TextBox depthtext Height = 372 Left = 840 TabIndex = 4 Top = 6600 Width = 1212 End Begin VB.CommandButton Command3 Caption = "&Manhatten" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 612 Left = 5760 TabIndex = 3 ToolTipText = "Use Manhatten heuristics to solve (fast and doesn't consume much memory)" Top = 2400 Width = 1692 End Begin VB.CommandButton Command2 Caption = "&New game" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 612 Left = 5760 TabIndex = 2 ToolTipText = "Reset for new game" Top = 3600 Width = 1692 End Begin VB.CommandButton ButtonExit Caption = "&Exit" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 612 Left = 5760 TabIndex = 1 ToolTipText = "Terminate the program" Top = 4680 Width = 1692 End Begin VB.CommandButton ButtonSolve Caption = "&BFS" BeginProperty Font Name = "MS Sans Serif" Size = 9.6 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 612 Left = 5760 TabIndex = 0 ToolTipText = "Use Breadth First Search to solve (memory hungry)" Top = 1320 Width = 1692 End Begin VB.Label Label3 Alignment = 2 'Center Caption = "Bravo !!!" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 732 Left = 1320 TabIndex = 8 Top = 360 Visible = 0 'False Width = 3972 End Begin VB.Label Label2 Caption = "Number of states in memory" Height = 372 Left = 6240 TabIndex = 7 Top = 6600 Width = 1932 End Begin VB.Label Label1 Caption = "Current depth of search" Height = 372 Left = 2040 TabIndex = 6 Top = 6600 Width = 1812 End Attribute VB_Name = "Puzzle" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim arr() As New Stateposition ' Global array of states Public numberstates As Long ' Keeps track of size of arr() to ' increase it if required Private Globalleft As Integer ' Variables used to allow user moving Private Globaltop As Integer ' tiles while "messing up" the state Private templeft As Integer Private temptop As Integer Private emptyx As Integer Private emptyy As Integer Dim position(3, 3) As Integer ' 2-dimensional array to hold initial ' position Private flag As Boolean ' reset flag for a new game Public finished As Boolean ' indicates that game is finished Private index As Long ' index used in BFS Private redrawindex As Integer ' index used while drawing a solution Private manhatten As Boolean ' indicates what kind of search is used Dim solutionpath() As New Stateposition ' array containing states of ' the solution Dim filled As Long ' number of states in the array '**************************************************************** ' TERMINATING THE GAME '**************************************************************** Private Sub ButtonExit_Click() Unload Me End Sub '**************************************************************** ' SUB THAT TRIGGERS START OF THE SOLUTION. USES GLOBAL "MANHATTEN" ' FLAG TO SOLVE USING CORRESPONDING SOLUTION METHOD '**************************************************************** Private Sub ButtonSolve_Click() Dim i As Integer If Not flag Then ReDim arr(numberstates) ' initializes array of states numberstates = numberstates + 20 flag = True ' indicates that solving in process ' blocking other requests For i = 0 To 7 ' "disables " all tiles Command1(i).Enabled = False Next MousePointer = vbHourglass subEnableButtons False If Not manhatten Then ' triggers BFS startsolving Else manhattensolving ' triggers Manhatten method End If End If End Sub '******************************************************************** ' STANDARD METHOD THAT ALLOWS USER TO MOVE THE TILES. WORKS ' TOGETHER WITH DRAGDROP METHOD. '******************************************************************** Private Sub Command1_MouseDown(index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) templeft = Command1(index).Left temptop = Command1(index).Top Command1(index).Drag vbBeginDrag ' moves corresponding tile End Sub '************************************************************************** ' CHANGES THE STATE OF COMMAND BUTTONS '************************************************************************** Private Sub subEnableButtons(bolValue As Boolean) Command2.Enabled = bolValue Command3.Enabled = bolValue ButtonSolve.Enabled = bolValue End Sub '********************************************************************** ' CLICKING "RESET" BUTTON. FIRST OF ALL CLEANS ALL MEMORY ' LEFT FROM PREVIOUS GAME AND THEN RESETS INITIAL STATE. '********************************************************************** Private Sub Command2_Click() Dim i As Long MsgBox "Please wait, to allow memory deallocation" If Not manhatten Then ' BFS clean up For i = 0 To index ' runs on array of states arr(i).freechild ' deletes references to children and parents Set arr(i) = Nothing Next Else ' Manhatten clean up For i = 0 To filled arr(i).freechild Set arr(i).nextstate = Nothing Set arr(i) = Nothing Next i End If Unload Me ' reloads the form Load Me Me.show End Sub '*********************************************************************** ' TRIGGERS SOLUTION USING MANHATTEN METHOD. '*********************************************************************** Private Sub Command3_Click() manhatten = True ButtonSolve_Click End Sub '*********************************************************************** ' INITIALIZING GLOBAL VARIABLES OF THE FORM. '*********************************************************************** Private Sub Form_Load() Globalleft = 0 Globaltop = 120 numberstates = 20 ' initial length of states array ReDim Preserve arr(numberstates) emptyx = 0 emptyy = 0 flag = False ' game didn't start finished = False ' game not finished index = 0 manhatten = False ' default ReDim solutionpath(1) position(0, 0) = 0 ' initial position position(0, 1) = 1 position(0, 2) = 2 position(1, 0) = 3 position(1, 1) = 4 position(1, 2) = 5 position(2, 0) = 6 position(2, 1) = 7 position(2, 2) = 8 End Sub '********************************************************************** ' SUB THAT ALLOWS MOVING AND DROPPING TILES USING MOUSE. '********************************************************************** Private Sub Frame1_DragDrop(Source As Control, x As Single, y As Single) Dim xcoord As Integer Dim ycoord As Integer Source.Move Globalleft, Globaltop Globalleft = templeft Globaltop = temptop For xcoord = 0 To 2 For ycoord = 0 To 2 If position(xcoord, ycoord) = Source.Caption Then ' button that was moved position(xcoord, ycoord) = 0 position(emptyx, emptyy) = Source.Caption emptyx = xcoord ' update location of emptyy = ycoord ' an empty slot Exit Sub End If Next Next End Sub '*********************************************************************** ' SUB THAT INCREASES THE SIZE OF GLOBAL ARRAY OF STATES. '*********************************************************************** Public Sub createstates() ReDim Preserve arr(numberstates + 20) numberstates = numberstates + 20 DoEvents End Sub '************************************************************************ ' SUB THAT IMPLEMENTS BREADTH FIRST SEARCH. STATES ARE EXPANDED ' LEVEL BY LEVEL. '************************************************************************ Private Sub startsolving() Dim i As Integer Dim temp As Stateposition Dim x As Long i = 0 filled = 1 ' initially one state (current state) is ' in the array Set arr(0) = New Stateposition arr(0).onpath = True arr(0).makearray position ' creating initial position Do While (Not finished) ' until solution state is reached arr(index).evaluate ' evaluate the value of current state depthtext.Text = arr(index).step + 1 ' update textfields with depth depthtext.Refresh ' and number of states in memory numbertext.Text = filled numbertext.Refresh If Not finished Then ' this is not solution state arr(index).expandchildren ' expand it's children ' increase the size of array if necessary If ((filled + arr(index).numberchildren) > numberstates - 30) Then createstates End If arr(index).closed = True ' close current state For i = 0 To arr(index).numberchildren ' add children to array Set arr(filled + i) = arr(index).getchild(i) Next filled = filled + arr(index).numberchildren ' update number of ' states in array Else MousePointer = vbDefault ' game is finished If index = 0 Then Label3.Visible = True ' initial state was the solution one Else Set temp = New Stateposition Set temp = arr(index) ' temp holds a solution state Do While Not temp.parent.onpath ' mark all it's ancestors as temp.onpath = True ' a solution path Set temp = temp.parent Loop temp.onpath = True arr(0).onpath = False For x = 0 To 7 ' enable tile buttons Command1(CInt(x)).Enabled = True Next For redrawindex = 0 To index ' iterate through an array If (arr(redrawindex).onpath) Then ' and if state is on solution path arr(redrawindex).redrawstate ' redraw it End If Next Label3.Visible = True End If End If index = index + 1 ' move to next unevaluated state in the array Loop subEnableButtons True End Sub '*********************************************************************** ' FUNCTION THAT TRANSLATES INDEX INTO CORRESPONDING ' X COORDINATE OF A TILE. '*********************************************************************** Public Function translatex(x As Integer) As Integer Select Case x Case 0 translatex = 0 Case 1 translatex = 1320 Case 2 translatex = 2640 End Select End Function '*********************************************************************** ' FUNCTION THAT TRANSLATES INDEX INTO CORRESPONDING ' Y COORDINATE OF A TILE. '*********************************************************************** Public Function translatey(y As Integer) As Integer Select Case y Case 0 translatey = 120 Case 1 translatey = 1440 Case 2 translatey = 2760 End Select End Function '*********************************************************************** ' FUNCTION THAT FINDS AND RETURNS INDEX OF THE CORRESPONDING ' TILE IN ARRAY OF BUTTONS ACCORDING TO PHYSICAL COORDINATES. '*********************************************************************** Public Function findbutton(x As Integer, y As Integer) Dim i As Integer For i = 0 To 7 If (Command1(i).Left = x And Command1(i).Top = y) Then findbutton = i End If Next End Function '************************************************************************* ' SUB THAT SOLVES PUZZLE USING MANHATTEN TECHNIQUE. NEXT ' STATE TO BE EVALUATED WILL ALWAYS BE THE "BEST" OF ALL ' UNEVALUATED SO FAR STATES. '************************************************************************* Public Sub manhattensolving() Dim i As Integer Dim x As Integer Dim test As Stateposition i = 0 filled = 1 Set arr(0) = New Stateposition arr(0).onpath = True Set test = New Stateposition arr(0).makearray position arr(0).evaluate arr(0).onpath = True arr(0).nextstate.curvalue = 100 Set test = arr(0) ' test holds initial state Do While (Not finished) ' until the game is finished test.expandchildren ' expand children ' update textfields depthtext.Text = test.step + 1 depthtext.Refresh numbertext.Text = filled numbertext.Refresh ' increase size of array if necessary If ((filled + test.numberchildren) > numberstates - 30) Then createstates End If For i = 0 To test.numberchildren - 1 ' iterate through children Set arr(filled + i) = test.getchild(i) ' insert them into the end of array arr(filled + i).evaluate ' evaluate child rearrange test, arr(filled + i) ' update reference to the ' next best state Next filled = filled + test.numberchildren ' update filled variable Set test = test.nextstate ' move to the next best state Loop MousePointer = vbDefault ' game is finished If filled = 1 Then Label3.Visible = True Else i = 1 Do While (Not test.parent.onpath) ' iterate through ancestors of ReDim Preserve solutionpath(i + 1) ' the solution state and create Set solutionpath(i) = test ' array of states lying on the test.onpath = True ' path Set test = test.parent i = i + 1 Loop Set solutionpath(i) = test For x = 0 To 7 ' enable tile buttons Command1(CInt(x)).Enabled = True Next Do While Not solutionpath(i).evaluate ' iterate through solution path solutionpath(i).redrawstate ' redrawing state each time i = i - 1 Loop solutionpath(i).redrawstate Label3.Visible = True End If subEnableButtons True End Sub '************************************************************************ ' SUB THAT CREATES ARRAY OF STATES LYING ON A SOLUTION PATH. '************************************************************************ Public Sub setpath(temp As Stateposition) Set solutionpath(0) = temp End Sub '************************************************************************ ' SUB THAT INSERTS REFERENCE TO A NEW STATE INTO A CHAIN OF ' STATES ACCORDING TO ITS VALUE. '************************************************************************ Private Sub rearrange(test As Stateposition, child As Stateposition) Dim temp As New Stateposition Dim swap As New Stateposition Set temp = test Do While (temp.nextstate.curvalue < child.curvalue) Set temp = temp.nextstate ' go further Loop Set swap = temp.nextstate ' swap 2 references Set temp.nextstate = child Set child.nextstate = swap End Sub