hanoi.frm

本人自己做的汉若塔游戏！ 非常有意思 ！

   End
   Begin VB.PictureBox Disk 
      Appearance      =   0  '2D
      BackColor       =   &H0080FFFF&
      ForeColor       =   &H80000008&
      Height          =   165
      Index           =   5
      Left            =   4560
      ScaleHeight     =   135
      ScaleWidth      =   2205
      TabIndex        =   8
      TabStop         =   0   'False
      Top             =   1875
      Visible         =   0   'False
      Width           =   2235
   End
   Begin VB.PictureBox Disk 
      Appearance      =   0  '2D
      BackColor       =   &H00000080&
      ForeColor       =   &H80000008&
      Height          =   165
      Index           =   4
      Left            =   4500
      ScaleHeight     =   135
      ScaleWidth      =   2325
      TabIndex        =   7
      TabStop         =   0   'False
      Top             =   2025
      Visible         =   0   'False
      Width           =   2355
   End
   Begin VB.PictureBox Disk 
      Appearance      =   0  '2D
      BackColor       =   &H000000C0&
      ForeColor       =   &H80000008&
      Height          =   165
      Index           =   3
      Left            =   4440
      ScaleHeight     =   135
      ScaleWidth      =   2445
      TabIndex        =   6
      TabStop         =   0   'False
      Top             =   2175
      Visible         =   0   'False
      Width           =   2475
   End
   Begin VB.PictureBox Disk 
      Appearance      =   0  '2D
      BackColor       =   &H000000FF&
      ForeColor       =   &H80000008&
      Height          =   165
      Index           =   2
      Left            =   4380
      ScaleHeight     =   135
      ScaleWidth      =   2565
      TabIndex        =   5
      TabStop         =   0   'False
      Top             =   2325
      Visible         =   0   'False
      Width           =   2595
   End
   Begin VB.PictureBox Disk 
      Appearance      =   0  '2D
      BackColor       =   &H008080FF&
      ForeColor       =   &H80000008&
      Height          =   165
      Index           =   1
      Left            =   4320
      ScaleHeight     =   135
      ScaleWidth      =   2685
      TabIndex        =   4
      TabStop         =   0   'False
      Top             =   2475
      Visible         =   0   'False
      Width           =   2715
   End
End
Attribute VB_Name = "Hanoi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'This is an old east asian problem and saga has it that the world is doomed when this
'is finished by monks who are transferring 64 golden disks (manually !!) - so
'we can rest assured that the world will live a long time yet.

'The objective is to move all disks from tower A to tower C with the constraint that
'a larger disk can never be placed on a smaller one. To this end tower B may be used
'as an interim station for the disks - but here the same rule prevails.

'This shows recursive programming techniques.

  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

  Const FromTower                          As Long = 1
  Const ViaTower                           As Long = 2
  Const ToTower                            As Long = 3
  
  Const MinDisks                           As Long = 1
  Const MaxDisks                           As Long = 16
  
  Dim NumDisks                             As Long
  Dim TowerHeight(FromTower To ToTower)    As Long
  Dim DiskNumber(FromTower To ToTower, _
                 MinDisks To MaxDisks)     As Long
  Dim XPosn(FromTower To ToTower)          As Long
  Dim YPosn                                As Long
  Dim DiskHeight                           As Long
  Dim NumMoves                             As Long
  Dim CurrentDisk                          As Long
  Dim Busy                                 As Boolean
  Dim StopRequested                        As Boolean

Private Sub Command1_Click()
    
    If Not Busy Then
        Busy = True
        StopRequested = False
        Command2.Caption = "Stop"
        Text1_Change
        
        NumMoves = 0
        
'       the err mechanism will be used to drop out of recursion
'       if the user stops us, in the IDE you will have to set options
'       to stop on unhandled errors only
        On Error Resume Next

'       here we go
        MoveAllDisks NumDisks, FromTower, ViaTower, ToTower
        
        Busy = False
        Command2.Caption = "Exit"
    End If
    
End Sub

Sub MoveAllDisks(ByVal NumDisks, ByVal FromTower, ByVal ViaTower, ByVal ToTower)
'   Move all disks from FromTower to ToTower using ViaTower as intermediate

    Select Case NumDisks
      
      Case 1

'       there is only one disk - just move it from FromTower to ToTower
        MoveOneDisk FromTower, ToTower
'       this was the final stage of recursion
      
      Case Is > 1

'       more than one disk - move all but the bottom disk from FromTower to ViaTower
'       using ToTower as intermediate
        MoveAllDisks NumDisks - 1, FromTower, ToTower, ViaTower

'       the bottom disk is now the only one remainig on FromTower
'       all other disks are on ViaTower, and ToTower is empty

'       move the bottom disk from FromTower to ToTower
        MoveOneDisk FromTower, ToTower
        
'       FromTower is now empty and we use it as interim station for moving
'       all the disks on ViaTower to ToTower
        MoveAllDisks NumDisks - 1, ViaTower, FromTower, ToTower
    
    End Select

End Sub

Sub MoveOneDisk(ByVal TowerA, ByVal TowerB)
'   Move one disk from TowerA to TowerB

    NumMoves = NumMoves + 1
    lbl(1) = NumMoves
    
'   wait a little
    Sleep scrDelay
    
'   determine the disk to move = top disk of TowerA
    CurrentDisk = DiskNumber(TowerA, TowerHeight(TowerA))

'   TowerB grows by 1
    TowerHeight(TowerB) = TowerHeight(TowerB) + 1

'   move current disk on top of TowerB
    Disk(CurrentDisk).Move XPosn(TowerB) - Disk(CurrentDisk).Width \ 2, YPosn - TowerHeight(TowerB) * DiskHeight

'   keep track of where the moved disk is now
    DiskNumber(TowerB, TowerHeight(TowerB)) = CurrentDisk

'   TowerA shrinks by 1
    TowerHeight(TowerA) = TowerHeight(TowerA) - 1

'   give Windows a chance
    DoEvents
    
    If StopRequested Then
'       use Error mechanism to drop out of recursion
        Err.Raise 1
    End If
    
End Sub

Private Sub Command2_Click()
    
    If Busy Then
        StopRequested = True
      Else
        Unload Me
    End If
    
End Sub

Private Sub Form_Load()

'   Coordinates for the Towers
    XPosn(FromTower) = 100
    XPosn(ViaTower) = 350
    XPosn(ToTower) = 600
    YPosn = ScaleHeight - 70
    
    DiskHeight = Disk(MinDisks).Height - 1
    Text1 = MaxDisks
    
End Sub

Private Sub Form_Paint()
'   printing on a form is not permanent - so we have to refresh it when the form is re-painted

 Dim i As Long
 
    FontBold = True
    For i = FromTower To ToTower
        CurrentX = XPosn(i) - 3 '(width of char) / 2  to center it
        CurrentY = YPosn + 1
        Print Mid$("ABC", i, 1);
    Next i
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
'   no unloading while where busy
    
    Cancel = Busy
    
End Sub

Private Sub Text1_Change()
    
    NumDisks = Val(Text1)
    Command1.Enabled = (NumDisks >= MinDisks And NumDisks <= MaxDisks)
    lbl(1) = ""
    lbl(2) = "of " & 2 ^ NumDisks - 1
    
'   how high is each Tower
    TowerHeight(FromTower) = NumDisks
    TowerHeight(ViaTower) = 0
    TowerHeight(ToTower) = 0
    
'   move all disks to FromTower and remember where they are
    For CurrentDisk = MinDisks To MaxDisks
        Disk(CurrentDisk).Move XPosn(FromTower) - Disk(CurrentDisk).Width \ 2, YPosn - CurrentDisk * DiskHeight
        DiskNumber(FromTower, CurrentDisk) = CurrentDisk
'       hide any unused disks
        Disk(CurrentDisk).Visible = (CurrentDisk <= NumDisks)
    Next CurrentDisk
    DoEvents
    
End Sub

Private Sub Text1_GotFocus()

    Text1.SelStart = 0
    Text1.SelLength = 2
    
End Sub