[Sarnold] A classical recursivity example as a small game.

The goal is to move entierly a tower from one pit to another. The tower is formed by 3 to 5 discs, which reside on a pit. There are three pits, and you can move only one disc at a time, but not over a smaller disc.

-----

 #! /usr/bin/wish
 
 # We work in GUI mode
 package require Tk
 
 proc stackMove {numberOfDiscs from to temporary {level 0}} {
     if {$numberOfDiscs==1} {
         oneMove $from $to
         return
     }
     stackMove [expr {$numberOfDiscs-1}] $from $temporary $to [expr {$level+1}]
     oneMove $from $to
     stackMove [expr {$numberOfDiscs-1}] $temporary $to $from $level
 }
 
 proc drawStacks {{flashed 0}} {
     foreach i {1 2 3} {
         if {$i==$flashed} {
             DrawStack $i 1
         } else {
             DrawStack $i
         }
     }
     update
     after 350
 }
 
 proc DrawStack {stackIndex {flashed 0}} {
     # remove all existing discs
     .stacks.tower$stackIndex delete all
     .stacks.tower$stackIndex create rectangle 120 30 130 400 -tags tower -fill #777
     .stacks.tower$stackIndex create rectangle 0 380 250 400 -tags base -fill #777
     
     set Discs $::discs($stackIndex)
     if {[llength $Discs]==1} {
         return
     }
     set Discs [lrange $Discs 1 end]
     set discIndex 0
     foreach n $Discs {
         # n is the size of the disc
         # discIndex is the position (the highest to the top)
         if {$flashed && $n==[lindex $Discs end]} {
             .stacks.tower$stackIndex create rectangle [expr {125-$n*110/$::nbDiscs}] \
                     [expr {-$discIndex*25+375}] [expr {125+$n*110/$::nbDiscs}] \
                     [expr {-$discIndex*25+365}] -fill #F55
         } else  {
             .stacks.tower$stackIndex create rectangle [expr {125-$n*110/$::nbDiscs}] \
                     [expr {-$discIndex*25+375}] [expr {125+$n*110/$::nbDiscs}] \
                     [expr {-$discIndex*25+365}] -fill #55C
         }
         incr discIndex
     }
 }
 
 proc init {} {
     wm title . "Hanoi Towers"
     frame .stacks -width 750 -height 500
     pack .stacks -side top
     foreach i {1 2 3} {
         set tower .stacks.tower
         canvas $tower$i -width 250 -height 400
         pack $tower$i -in .stacks -side left
         $tower$i create rectangle 120 30 130 400 -tags tower -fill #777
         $tower$i create rectangle 0 380 250 400 -tags base -fill #777
     }
     frame .command -width 750 -height 60
     pack .command -side bottom
     set ::nbDiscs 3
     label .command.labelNbDiscs -text "Nb Discs :"
     pack .command.labelNbDiscs -side left
     spinbox .command.nbDiscs -textvariable ::nbDiscs\
             -values {3 4 5} -state normal
     pack .command.nbDiscs -side left
     checkbutton .command.computer -variable ::computer
     pack .command.computer -side left
     label .command.automatic -text "automatic"
     pack .command.automatic -side left
     button .command.exit -text Exit -command {update;exit}
     pack .command.exit -side right -padx 20
     button .command.go -text "Go!" -command {Begin}
     pack .command.go -side right -padx 20
     
 }
 
 proc discInit {} {
     set n $::nbDiscs
     incr n
     foreach stack {1 2 3} {
         set ::discs($stack) [list $n]
     }
     incr n -1
     for {set width $n} {$width>0} {incr width -1} {
         lappend ::discs(1) $width
     }
     drawStacks
 }
 
 proc Begin {} {
     # beginning of the game : no move yet
     set ::moveNumber 0
     # disable interrupt game
     .command.go configure -state disabled
     discInit
     drawStacks
     if {$::computer} {
         stackMove $::nbDiscs 1 2 3
         .command.go configure -state normal
         tk_messageBox -message "End of automatic game !"
     } else  {
         ReadyToMove
     }
     # Destroy .command
     # Destroy .stacks
     # init
 }
 
 ################################################################################
 # returns 1 if the player have won the game, 0 if the game is still unfinished
 ################################################################################
 proc HaveWonGame {} {
     if {[llength $::discs(1)]==1} {
         if {[llength $::discs(2)]==1 ||
             [llength $::discs(3)]==1} {
             return 1
         }
     }
     return 0
 }
 
 ################################################################################
 # set the stacks to be ready for interactive playing
 ################################################################################
 proc ReadyToMove {} {
     if {[HaveWonGame]} {
         tk_messageBox -message "Game won in $::moveNumber moves !\nCongratulations !"
         .command.go configure -state normal
         foreach i {1 2 3} {
             .stacks.tower$i configure -background #fff
         }
         return
     }
     foreach i {1 2 3} {
         if {[llength $::discs($i)]!=1} {
             .stacks.tower$i bind all <ButtonPress-1> {SelectSource [string index %W end]}
         } else  {
             .stacks.tower$i bind all <ButtonPress-1> {}
         }
         .stacks.tower$i configure -background #fff
     }
 }
 
 ################################################################################
 # select the tower as source
 # towerIndex : integer 1..3
 ################################################################################
 proc SelectSource {towerIndex} {
     set ::source $towerIndex
     .stacks.tower$towerIndex bind all <ButtonPress-1> {ReadyToMove}
     .stacks.tower$towerIndex configure -background #df7
     foreach i {1 2 3} {
         if {$i!=$towerIndex && [lindex $::discs($i) end]>[lindex $::discs($towerIndex) end]} {
             .stacks.tower$i bind all <ButtonPress-1> {oneMoveInteractive %W; ReadyToMove}
         }
     }
     update
 }
 
 ################################################################################
 # perform one move with interactive game
 ################################################################################
 proc oneMoveInteractive {widget} {
     set to [string index $widget end]
     set from $::source
     oneMove $from $to
 }
 
 
 ################################################################################
 # perform one move graphically and internally
 ################################################################################
 proc oneMove {from to} {
     if {[llength $::discs($from)]==1} {
         error "stack no. $from is void"
     }
     
     set discWidth [lindex $::discs($from) end]
     if {$discWidth>[lindex $::discs($to) end]} {
         error "disc width overflow in destination"
     }
     # flash the top of the source stack
     drawStacks $from
     # perform the move in the global array
     lappend ::discs($to) $discWidth
     set ::discs($from) [lrange $::discs($from) 0 end-1]
     incr ::moveNumber
     # flash the top of the destination stack
     drawStacks $to
     drawStacks
 }
 array set discs {}
 init
 
-----
[Category Games]
[Category Application]