A Hidato solver

Hidato is an interesting puzzle, if not particularly difficult. Basically, you've got a grid (usually not square, possibly with holes in it, but always connected) with some blank squares and some squares filled in with cardinal numbers. What you've got to do is to provide the remaining numbers so that you can trace a path from 1 up to the number of squares (which are both always provided) and where each square is in the Moore Neighborhood of the number before it and after it in the sequence.

Here's a sample solver for these sorts of puzzles.

package require Tcl 8.5

proc init {initialConfiguration} {
    global grid max filled
    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
    }
}

proc findseps {} {
    global max filled
    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]
}

proc makepaths {sep} {
    global grid filled
    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} {
        discover [expr {$x+$dx}] [expr {$y+$dy}] [expr {$from+1}] $to \
            [list [list $from $x $y]] $grid
    }
    return $result
}
proc discover {x y n limit path model} {
    global filled
    # 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} {
        discover [expr {$x+$dx}] [expr {$y+$dy}] $n $limit $path $model
    }
}

proc applypath {path} {
    global grid filled
    puts "Found unique path 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]
    }
}

proc printgrid {} {
    global grid max
    foreach row $grid {
        foreach cell $row {
            puts -nonewline [format " %*s" [string length $max] [expr {
                $cell==-1 ? "." : $cell
            }]]
        }
        puts ""
    }
}

proc solveHidato {initialConfiguration} {
    init $initialConfiguration
    set limit [llength [findseps]]
    while {[llength [set seps [findseps]]] && [incr limit -1]>=0} {
        foreach sep $seps {
            if {[llength [set paths [makepaths $sep]]] == 1} {
                applypath [lindex $paths 0]
                break
            }
        }
    }
    puts ""
    printgrid
}

A quick demonstration:

solveHidato {
     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 
}

It prints this 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

A More Sophisticated Version

This version tackles many much more complex cases

  Requires Tcl 8.6.0 (or later)
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 LegalNeighbours {x y} {
        set result {}
        set columns [llength $grid]
        set rowLen [llength [lindex $grid 0]]
        foreach {dx dy} {0 1 1 1 1 0 1 -1 0 -1 -1 -1 -1 0 -1 1} {
            set xx [expr {$x+$dx}]
            set yy [expr {$y+$dy}]
            if {$xx<0 || $xx>$rowLen || $yy<0 || $yy>$columns} continue
            lappend result $xx $yy
        }
        return $result
    }
    method LegalTerminatingState {} {
        foreach row $grid {
            foreach cell $row {
                if {$cell == 0} {return false}
            }
        }
        return true
    }
    method LegalModelState {model} {
        set r 0
        foreach row $model {
            set c 0
            foreach cell $row {
                if {$cell == 0} {
                    set neighbours [my LegalNeighbours $c $r]
                    set found 0
                    foreach {x y} $neighbours {
                        #my log model($y,$x)=[lindex $model $y $x]
                        if {[lindex $model $y $x] == 0} {
                            set found 1
                            break
                        }
                    }
                    if {!$found} {
                        set probes {}
                        foreach {x y} $neighbours {
                            set p [lindex $model $y $x]
                            if {$p ne ""} {
                                lappend probes $p
                            }
                        }
                        foreach probed $probes {
                            if {
                                ($probed+2) in $probes &&
                                ![dict exists $filled [expr {$probed+1}]]
                            } then {
                                set found 1
                                break
                            }
                        }
                        if {!$found} {
                            return false
                        }
                    }
                }
                incr c
            }
            incr r
        }
        return true
    }

    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
        if {![my LegalModelState $model]} return
        incr n
        foreach {x y} [my LegalNeighbours $x $y] {
            my Discover $x $y $n $limit $path $model
        }
    }

    method log msg {
        puts [string repeat " " [my Indent]]$msg
    }

    method applyPath {path {bit "unique path"}} {
        my log "Found $bit for [lindex $path 0 0] -> [lindex $path end 0]"
        foreach cell $path {
            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 Indent {} {return 0}

    method CommonPrefix paths {
        set prefix [lindex $paths 0]
        foreach path [lrange $paths 1 end] {
            set i -1
            foreach a $prefix b $path {
                if {$a ne $b} {
                    set prefix [lrange $prefix 0 $i]
                    break
                }
                incr i
            }
        }
        return $prefix
    }
    method CommonSuffix paths {
        lreverse [my CommonPrefix [lmap path $paths {lreverse $path}]]
    }

    method ForkSolve {paths} {
        my log "Choice of [llength $paths] possible paths"
        foreach p $paths {
            set subobj [oo::copy [self]]
            oo::objdefine $subobj method Indent {} \
                [list return [expr {[my Indent]+2}]]
            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
                }
                set subpath [my CommonPrefix $paths]
                if {[llength $subpath] > 1} {
                    my applyPath $subpath "common prefix"
                    set pshort {}
                    incr limit
                    break
                }
                set subpath [my CommonSuffix $paths]
                if {[llength $subpath] > 1} {
                    my applyPath $subpath "common suffix"
                    set pshort {}
                    incr limit
                    break
                }
                if {![llength $pshort]} {
                    set pshort $paths
                } elseif {[llength $pshort] > [llength $paths]} {
                    set pshort $paths
                }
            }
            if {[llength $pshort]} {
                my ForkSolve $pshort
                return false
            }
        }
        return [my LegalTerminatingState]
    }
}

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
sample log ""
sample print

Hidato create awkwardcase {
    . 4 .
    0 7 0
    1 0 0
}
awkwardcase log ""
awkwardcase solve
awkwardcase log ""
awkwardcase print

Hidato create tricky {
    40 41  .  . 31  0  .  . 59  0
     0  0  0 37  0 33  0  0 60  0
     0  0  0  0 35  0  0  0 64  0
     .  .  0  0  0  0 54  0  .  .
     .  .  0  0  0 55  0 26  .  .
     .  .  0  7 10  0  0 25  .  .
     0  3  0 13  0 11 17  0  0  0
     1  0  5  0 15  0  0 19 20 21
}
tricky log ""
tricky solve
tricky log ""
tricky print

Hidato create evil {
    1 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 74
    . . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 . 0 .
    . . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 . . 0 0 .
}
evil log ""
evil solve
evil log ""
evil print