Solve a Hidato puzzle/Extended Tcl solution
This version handles even tricky cases where there are many possible choices of each path but only one leads to a solution (as in awkwardcase below). The core of this is the ForkSolve method, which clones the current object and speculatively searches forward from there. (Note, you need a very recent build of Tcl 8.6 to make this work, as it depends on a feature change from 2012-03-27.)
<lang tcl>package require Tcl 8.6
oo::class create Hidato {
variable grid max filled
constructor {initialConfiguration} {
set max 1 set y 0 foreach row [split [string trim $initialConfiguration "\n"] "\n"] { set x 0 set rowcontents {} foreach cell $row { if {![string is integer -strict $cell]} {set cell -1} lappend rowcontents $cell set max [expr {max($max, $cell)}] if {$cell > 0} { dict set filled $cell [list $y $x] } incr x } lappend grid $rowcontents incr y }
}
method FindSeps {} {
set result {} for {set i 1} {$i < $max-1} {incr i} { if {[dict exists $filled $i]} { for {set j [expr {$i+1}]} {$j <= $max} {incr j} { if {[dict exists $filled $j]} { if {$j-$i > 1} { lappend result [list $i $j [expr {$j-$i}]] } break } } } } return [lsort -integer -index 2 $result]
}
method MakePaths {sep} {
lassign $sep from to len lassign [dict get $filled $from] y x set result {} foreach {dx dy} {-1 -1 -1 0 -1 1 0 -1 0 1 1 -1 1 0 1 1} { my Discover [expr {$x+$dx}] [expr {$y+$dy}] [expr {$from+1}] $to \ [list [list $from $x $y]] $grid } return $result
}
method Discover {x y n limit path model} {
# Check for illegal if {[lindex $model $y $x] != 0} return upvar 1 result result lassign [dict get $filled $limit] ly lx # Special case if {$n == $limit-1} { if {abs($x-$lx)<=1 && abs($y-$ly)<=1 && !($lx==$x && $ly==$y)} { lappend result \ [lappend path [list $n $x $y] [list $limit $lx $ly]] } return } # Check for impossible if {abs($x-$lx) > $limit-$n || abs($y-$ly) > $limit-$n} return # Recursive search lappend path [list $n $x $y] lset model $y $x $n incr n foreach {dx dy} {-1 -1 -1 0 -1 1 0 -1 0 1 1 -1 1 0 1 1} { my Discover [expr {$x+$dx}] [expr {$y+$dy}] $n $limit $path $model }
}
forward log puts
method applyPath {path {bit "unique path"}} {
my log "Found $bit for [lindex $path 0 0] -> [lindex $path end 0]" foreach cell [lrange $path 1 end-1] { lassign $cell n x y lset grid $y $x $n dict set filled $n [list $y $x] }
}
method print {} {
foreach row $grid { foreach cell $row { puts -nonewline [format " %*s" [string length $max] [expr { $cell==-1 ? "." : $cell }]] } puts "" }
}
method state {} {list $grid $max $filled}
method ForkSolve {paths} {
my log "Choice of [llength $paths] possible paths" foreach p $paths { set subobj [oo::copy [self]] try { $subobj applyPath $p "path #[incr count]" if {[$subobj solve]} { my log "Leads to solution!" lassign [$subobj state] grid max filled return -code break } else { my log "No solution?" } } finally { $subobj destroy } }
}
method solve {} {
set limit [llength [my FindSeps]] while {[llength [set seps [my FindSeps]]] && [incr limit -1]>=0} { set pshort {} foreach sep $seps { set paths [my MakePaths $sep] if {[llength $paths] == 1} { my applyPath [lindex $paths 0] set pshort {} break } elseif {![llength $pshort]} { set pshort $paths } elseif {[llength $pshort] > [llength $paths]} { set pshort $paths } } if {[llength $pshort]} { my ForkSolve $pshort return false } } return true
}
}
Hidato create sample {
0 33 35 0 0 . . .
0 0 24 22 0 . . .
0 0 0 21 0 0 . .
0 26 0 13 40 11 . .
27 0 0 0 9 0 1 .
. . 0 0 18 0 0 .
. . . . 0 7 0 0
. . . . . . 5 0
} sample solve puts "" ;# Blank line for clarity in output sample print puts ""
Hidato create awkwardcase {
. 4 . 0 7 0 1 0 0
} awkwardcase solve puts "" awkwardcase print</lang>
- Output:
Found unique path for 5 -> 7 Found unique path for 7 -> 9 Found unique path for 9 -> 11 Found unique path for 11 -> 13 Found unique path for 33 -> 35 Found unique path for 18 -> 21 Found unique path for 1 -> 5 Found unique path for 35 -> 40 Found unique path for 22 -> 24 Found unique path for 24 -> 26 Found unique path for 27 -> 33 Found unique path for 13 -> 18 32 33 35 36 37 . . . 31 34 24 22 38 . . . 30 25 23 21 12 39 . . 29 26 20 13 40 11 . . 27 28 14 19 9 10 1 . . . 15 16 18 8 2 . . . . . 17 7 6 3 . . . . . . 5 4 Choice of 2 possible paths Found path #1 for 1 -> 4 Found unique path for 4 -> 7 Leads to solution! . 4 . 3 7 5 1 2 6