#!/usr/bin/wish
# hanoi.tcl
# experimental implementation of the known puzzle
# by Ralf Sternberg <sternber@informatik.uni-tuebingen.de>
# requires Tcl/Tk 8.0
# Last updated: Januar 22 2001


######################################################################
##  G L O B A L   V A R I A B L E S                                 ##
######################################################################
#
# y0               yposition of floor
# dnr              number of disks
# dth              thickness of disks
# peg(a|b|c,x)     x position of peg a|b|c
# peg(a|b|c,top)   y position of top of tower on peg a|b|c
# peg(a|b|c,list)  list of disks on peg a|b|c in order {bottom .. top}
# curr(id)         canvas id of current disk
# curr(nr)         number of current disk (nr of disk: 1=smallest)
# curr(source)     source peg of current disk
# $disk(nr,id)     canvas id of disk nr (nr of disk: 1=smallest)
# $disk(nr,radius) radius of disk nr (nr of disk: 1=smallest)
# score            text where all moves are being stored
# solution         list of steps to solve the puzzle form: {{a c} {a b} {c b} ...}
# step             step, which has been done by robot
# col(bg)          background color of canvas
# col(pegs)        color of pegs
# col(disks)       color of disks
# col(seldisks)    color of selected disk
# delay            delay between auto moves in ms
# plot             aux array varible for dragging
# lock             aux boolean variable to avoid cleanup when scale is created


######################################################################
##  I N I T I A L I Z A T I O N                                     ##
######################################################################

# colors
set col(bg) Wheat
set col(pegs) Brown
set col(disks) Gold2
set col(seldisks) Gold
# positions
set y0 180
set peg(a,x) 110
set peg(b,x) 210
set peg(c,x) 310
# delay
set delay 150
# number of disks
set dnr 7

# further initializations are done in proc cleanup


######################################################################
##  W I N D O W                                                     ##
######################################################################

wm title . {The Towers of Hanoi}
canvas .c -relief sunken -borderwidth 1 -background $col(bg) -width 420 -height 220 -cursor hand2
frame .menu
  button .menu.clear -width 5 -text clear -command cleanup
  button .menu.auto -width 5 -text auto -command autosolve
  button .menu.score -width 5 -text score -command showscore
  button .menu.quit -width 5 -text quit -command exit
pack .menu.clear .menu.auto .menu.score .menu.quit\
  -fill x -side left -expand yes
pack .c -expand yes -fill both -padx 2 -pady 2
pack .menu -fill x -padx 2 -pady 2

# draw a frame
proc drawFrame {x1 y1 x2 y2} {
  #top
  .c create line [expr $x1 +15] $y1 [expr $x2 -15] $y1
  #bottom
  .c create line [expr $x1 +15] $y2 [expr $x2 -15] $y2
  #left
  .c create line $x1 [expr $y1 +15] $x1 [expr $y2 -15]
  #right
  .c create line $x2 [expr $y1 +15] $x2 [expr $y2 -15]
  #nw
  .c create arc [expr $x1 -15] [expr $y1 -15] [expr $x1 +15] [expr $y1 +15]\
     -start 270 -extent 90 -style arc
  #no
  .c create arc [expr $x2 -15] [expr $y1 -15] [expr $x2 +15] [expr $y1 +15]\
     -start 180 -extent 90 -style arc
  #so
  .c create arc [expr $x2 -15] [expr $y2 -15] [expr $x2 +15] [expr $y2 +15]\
     -start 90 -extent 90 -style arc
  #sw
  .c create arc [expr $x1 -15] [expr $y2 -15] [expr $x1 +15] [expr $y2 +15]\
     -start 0 -extent 90 -style arc

}
# the frame is not centered and does not look good in windows,
# but this can surely be fixed.
# for the time being it is just a superflous eye candy.
if {$tcl_platform(platform) == "unix"} {drawFrame 7 7 416 216}


######################################################################
##  B I N D I N G S                                                 ##
######################################################################

.c bind disks <Any-Enter> ".c itemconfig current -fill $col(seldisks)"
.c bind disks <Any-Leave> ".c itemconfig current -fill $col(disks)"
.c bind disks <1> "pickupDisk %x %y"
.c bind disks <ButtonRelease-1> {dropDisk}
bind .c <B1-Motion> "dragDisk %x %y"
bind .c <3> "showsettings %x %y"


######################################################################
##  P R O C S                                                       ##
######################################################################

# ======================================================== PICKUP DISK
# This procedure is invoked when the mouse is pressed over one of the disks.
# It sets up state to allow the disk to be dragged.
# Arguments: x, y - The coordinates of the mouse press.
#
proc pickupDisk {x y} {
  global plot peg disk curr dnr
  .c raise current
  # get curr disk's id, nr and source
  set curr(id) [.c find withtag current]
  for {set i 1} {$i <= $dnr} {incr i} {
    if {$disk($i,id) == $curr(id)} {set curr(nr) $i; break}
  }
  foreach p {a b c} {
    if {[lsearch -exact $peg($p,list) $curr(nr)] >= 0} {set curr(source) $p}
  }
  #addtoscore "pickup disk $curr(nr) (id=$curr(id)) from $curr(source)"
  # if we are not allowed
  if {$curr(nr) != [lindex $peg($curr(source),list) end]} {
    unset curr
  } else {
  # ok, we are...
    set plot(lastX) $x
    set plot(lastY) $y
    .c configure -cursor fleur
  }
}


# ========================================================== DRAG DISK
# This procedure is invoked during mouse motion events.
# It drags the current item.
# Arguments: x, y - The coordinates of the mouse.
#
proc dragDisk {x y} {
  global plot curr peg
  # is there a current disk at all? - if not, return
  if {![info exists curr]} {return 1}
  set posX [expr int(([lindex [.c coords $curr(id)] 0] +[lindex [.c coords $curr(id)] 2])/2)]
  set posY [expr int([lindex [.c coords $curr(id)] 3])]
  set moveX [expr $x-$plot(lastX)]
  set moveY [expr $y-$plot(lastY)]
  .c move $curr(id) $moveX $moveY
  set plot(lastX) $x
  set plot(lastY) $y
}


# ========================================================== DROP DISK
# This procedure is invoked when the mouse button is relesaed over a disk.
# It lets the disk fall on the nearest peg.
#
proc dropDisk {} {
  global peg curr y0 disk step dnr
  # is there a current disk at all? - if not, return
  if {![info exists curr]} {return 1}
  # get current disk's xpos and ypos
  set xpos [expr int(([lindex [.c coords $curr(id)] 0] +[lindex [.c coords $curr(id)] 2])/2)]
  set ypos [expr int([lindex [.c coords $curr(id)] 3])]
  # figure out on which peg to drop
  set dest $curr(source); # default
  if {$ypos < [expr $y0 + 15]} {
    foreach p {a b c} {
      if {[expr abs($peg($p,x) -$xpos) -5] < $disk($curr(nr),radius)} {set dest $p}
    }
  }
  moveDisk $curr(source) $dest
  # check if move was illegal
  if {([llength $peg($dest,list)] != 1) &&
      ($curr(nr) > [lindex $peg($dest,list) [expr [llength $peg($dest,list)] -2]])} {
    display "Illegal Move."
    addtoscore "   Illegal Move!\n"
  # check if ready
  } elseif {([llength $peg(b,list)] == $dnr) || ([llength $peg(c,list)] == $dnr)} {
    display "The End."
  } else {
    display "The Towers of Hanoi"
    addtoscore \n
  }
  set step 1
  unset curr
  .c configure -cursor hand2
}


# ========================================================== MOVE DISK
# This procedure moves one disk from peg source to peg dest.
#
proc moveDisk {source dest} {
  global disk peg moves dth
  # get nr, xpos and ypos of disk
  set nr [lindex $peg($source,list) end]
  set posX [expr int(([lindex [.c coords $disk($nr,id)] 0]\
             +[lindex [.c coords $disk($nr,id)] 2])/2)]
  set posY [expr int([lindex [.c coords $disk($nr,id)] 3])]
  # de-register
  incr peg($source,top) $dth
  set peg($source,list) [lreplace $peg($source,list) end end]
  #get desired position
  set desX $peg($dest,x)
  set desY $peg($dest,top)
  # if not on the dest peg already, first raise
  if {[expr abs($posX -$desX) -5] >= $disk($nr,radius)} {
    while {$posY > 60} {
      .c move $disk($nr,id) 0 -1
      incr posY -1; update idletasks
    }
    after 50
  }
  # adjust to peg
  while {$posX < $desX} {
    .c move $disk($nr,id) 1 0
    incr posX; update idletasks
  }
  while {$posX > $desX} {
    .c move $disk($nr,id) -1 0
    incr posX -1; update idletasks
  }
  after 50
  # drop
  while {$posY < $desY} {
    .c move $disk($nr,id) 0 1
    incr posY; update idletasks
  }
  # raise
  while {$posY > $desY} {
    .c move $disk($nr,id) 0 -1
    incr posY -1; update idletasks
  }
  # output
  if {$source != $dest} {
    incr moves
    addtoscore [format " %4d:   %s -> %s    disk %d" $moves $source $dest $nr]
  }
  # register
  incr peg($dest,top) -$dth
  lappend peg($dest,list) $nr
  update
}


# ====================================================== SHOW SETTINGS
# This procedure is invoked when right mouse button is pressed on canvas
#
proc showsettings {x y} {
  global dnr delay lock tcl_platform
  if [winfo exists .settings] {raise .settings .; return}
  set lock 1
  toplevel .settings
  wm title .settings Settings
  scale .settings.dnr -label "number of disks:" -orient horizontal -length 200\
    -from 1 -to 10 -tickinterval 1 -command chdnr
  pack .settings.dnr -side top -fill x -padx 15 -pady 10
  scale .settings.delay -label "delay (ms):" -orient horizontal -length 200\
    -from 0 -to 1000 -tickinterval 250 -resolution 50 -variable delay
  pack .settings.delay -side top -fill x -padx 15 -pady 10
  frame .settings.buttons
  button .settings.buttons.close -text close -command {destroy .settings}
  pack .settings.buttons.close
  pack .settings.buttons -side top -fill x -padx 15 -pady 10
  .settings.dnr set $dnr
  set lock 0
  wm geometry .settings +[expr [winfo rootx .] +$x]+[expr [winfo rooty .] +$y]
}

# This aux proc is invoked when the scale for dnr changes
proc chdnr {n} {
  global dnr lock
  if $lock return
  if {$n != $dnr} {set dnr $n; cleanup}
}


# =========================================================== CLEAN UP
# This procedure moves all disks in start position.
#
proc cleanup {} {
  global peg disk y0 col moves score solution dnr dth step
  .menu.auto configure -text "auto"
  set solution {}
  hanoi $dnr a c b
  set moves 0
  set step 0
  catch {.score.text delete 1.0 end}
  set score ""
  addtoscore " move:  from to    disk\n ------------------------\n"
  display "The Towers of Hanoi"
  catch {.c delete disks pegs}
  # thickness of disks
  if {$dnr <=7} {set dth 13}\
  elseif {$dnr ==8} {set dth 12}\
  elseif {$dnr ==9} {set dth 11}\
  elseif {$dnr ==10} {set dth 10}
  # build up the three pegs:
  .c create rectangle  40 $y0 380 [expr $y0 +15] -fill $col(pegs) -tags pegs
  .c create rectangle [expr $peg(a,x) -5] 70 [expr $peg(a,x) +5] $y0 -fill $col(pegs) -tags pegs
  .c create rectangle [expr $peg(b,x) -5] 70 [expr $peg(b,x) +5] $y0 -fill $col(pegs) -tags pegs
  .c create rectangle [expr $peg(c,x) -5] 70 [expr $peg(c,x) +5] $y0 -fill $col(pegs) -tags pegs
  # make the golden disks:
  set radius 16
  for {set i 1} {$i <= $dnr} {incr i} {
    set disk($i,id) [.c create rectangle 0 0 [expr $radius*2] $dth\
                       -fill $col(disks) -tags disks]
    set disk($i,radius) $radius
    incr radius 4
  }
  foreach abc {a b c} {
    set peg($abc,top) $y0
    set peg($abc,list) {}
  }
  set ground $y0
  for {set i $dnr} {$i >= 1} {incr i -1} {
    .c coords $disk($i,id) [expr $peg(a,x) -$disk($i,radius)] [expr $ground -$dth]\
                           [expr $peg(a,x) +$disk($i,radius)] $ground
    incr ground -$dth
    incr peg(a,top) -$dth
    lappend peg(a,list) $i
  }
}


# ========================================================= AUTO SOLVE
# This procedure is invoked when the 'auto' button is pressed.
#
proc autosolve {} {
  global solution step
  if {[.menu.auto cget -text] == "stop"} {
    .menu.auto configure -text "auto"
  } else {
    if {$step <= 1} {
      cleanup
      if {[llength $solution] == 1} {display "1 Step"} \
        {display "[llength $solution] Steps"}
      update; after 1000
    }
    .menu.auto configure -text "stop"
    robot
  }
}


# ============================================================== ROBOT
# This procedure moves the disks automatically according to the
# list 'solution', beginning with 'step'.
# Arguments:
# step:   pos of list, where to begin
#
proc robot {} {
  global solution delay step
  if {[.menu.auto cget -text] != "stop"} {return 1}
  incr step
  if {$step > [llength $solution]} {
    .menu.auto configure -text "auto"
    return 1
  }
  display "Step $step"
  set mov [lindex $solution [expr $step -1]]
  moveDisk [lindex $mov 0] [lindex $mov 1]
  addtoscore "   robot\n"
  after $delay robot
}


# ============================================================== HANOI
# This procedure writes a list of the necessary steps to solve the puzzle
# into the variable solution.
# Arguments:
# disks:  number of disks
# source: sourcepeg
# dest:   destination peg
# aux:    auxiliary peg
#
proc hanoi {disks source dest aux} {
  global solution
  if {$disks == 1} {
    # only one disk: just move it
    lappend solution "$source $dest"
  } else {
    # "something" on a disk:
    # 1. bring "something" to aux
    hanoi [expr $disks -1] $source $aux $dest
    # 2. move disk to dest
    lappend solution "$source $dest"
    # 3. bring "something" to dest
    hanoi [expr $disks -1] $aux $dest $source
  }
}


# ============================================================ DISPLAY
# This procedure displays an information message.
# Arguments: text - the message to display
#
proc display {text} {
  global infotext peg
  catch [.c delete $infotext]
  set infotext [.c create text $peg(b,x) 20 -text $text\
    -font {Helvetica 14 bold} -anchor n -justify center]
}


# ========================================================= SHOW SCORE
# This procedure is invoked when button 'score' is pressed.
#
proc showscore {} {
  global score col tcl_platform
  if [winfo exists .score] {raise .score .; return}
  toplevel .score
  wm title .score "The Score"
  text .score.text -height 12 -width 48 -background $col(bg)\
    -font {Courier 12} -yscrollcommand ".score.scroll set"
  scrollbar .score.scroll -command ".score.text yview" -width 12
  pack .score.text -side left -expand yes -fill both
  pack .score.scroll -side right -fill y
  .score.text insert end $score
}


# ======================================================= ADD TO SCORE
# This procedure appends text to score and tries to update score window
#
proc addtoscore {text} {
  global score
  append score $text
  catch {.score.text insert end $text; .score.text see end}
}


######################################################################
##  M A I N                                                         ##
######################################################################

cleanup

# end of hanoi.tcl