Solve a Numbrix puzzle: Difference between revisions
Content added Content deleted
(+ D entry) |
(Tcl implementation added) |
||
| Line 1,057: | Line 1,057: | ||
</pre> |
</pre> |
||
[[Category:Puzzles]] |
[[Category:Puzzles]] |
||
=={{header|Tcl}}== |
|||
Following loosely the structure of [[Solve_a_Hidato_puzzle#Tcl]]. |
|||
<lang Tcl># Loop over adjacent pairs in a list. |
|||
# Example: |
|||
# % eachpair {a b} {1 2 3} {puts $a $b} |
|||
# 1 2 |
|||
# 2 3 |
|||
proc eachpair {varNames ls script} { |
|||
if {[lassign $varNames _i _j] ne ""} { |
|||
return -code error "Must supply exactly two arguments" |
|||
} |
|||
tailcall foreach $_i [lrange $ls 0 end-1] $_j [lrange $ls 1 end] $script |
|||
} |
|||
namespace eval numbrix { |
|||
namespace path {::tcl::mathop ::tcl::mathfunc} |
|||
proc parse {txt} { |
|||
set map [split [string trim $txt] \n] |
|||
} |
|||
proc print {map} { |
|||
join [lmap row $map { |
|||
join [lmap val $row { |
|||
format %2d $val |
|||
}] " " |
|||
}] \n |
|||
} |
|||
proc mark {map x y i} { |
|||
lset map $x $y $i |
|||
} |
|||
proc moves {x y} { |
|||
foreach {dx dy} { |
|||
0 1 |
|||
-1 0 1 0 |
|||
0 -1 |
|||
} { |
|||
lappend r [+ $dx $x] [+ $dy $y] |
|||
} |
|||
return $r |
|||
} |
|||
proc rmap {map} { ;# generate a reverse map in a dict {val {x y} ..} |
|||
set rmap {} |
|||
set h [llength $map] |
|||
set w [llength [lindex $map 0]] |
|||
set x $w |
|||
while {[incr x -1]>=0} { |
|||
set y $h |
|||
while {[incr y -1]>=0} { |
|||
set i [lindex $map $x $y] |
|||
if {$i} { |
|||
dict set rmap [lindex $map $x $y] [list $x $y] |
|||
} |
|||
} |
|||
} |
|||
return $rmap |
|||
} |
|||
proc gaps {rmap} { ;# list all the gaps to be filled |
|||
set known [lsort -integer [dict keys $rmap]] |
|||
set gaps {} |
|||
eachpair {i j} $known { |
|||
if {$j > $i+1} { |
|||
lappend gaps $i $j |
|||
} |
|||
} |
|||
return $gaps |
|||
} |
|||
proc fixgaps {map rmap gaps} { ;# add a "tail" gap if needed |
|||
set w [llength $map] |
|||
set h [llength [lindex $map 0]] |
|||
set size [* $h $w] |
|||
set max [max {*}[dict keys $rmap]] |
|||
if {$max ne $size} { |
|||
lappend gaps $max Inf |
|||
} |
|||
return $gaps |
|||
} |
|||
proc paths {map x0 y0 n} { ;# generate all the maps with a single path filled legally |
|||
if {$n == 0} {return [list $map]} |
|||
set i [lindex $map $x0 $y0] |
|||
set paths {} |
|||
foreach {x y} [moves $x0 $y0] { |
|||
set j [lindex $map $x $y] |
|||
if {$j eq ""} { |
|||
continue |
|||
} elseif {$j == 0 && $n == $n+1} { |
|||
return [list [mark $map $x $y [+ $i 1]]] |
|||
} elseif {$j == $i+1} { |
|||
lappend paths $map |
|||
continue |
|||
} elseif {$j || ($n == 1)} { |
|||
continue |
|||
} else { |
|||
lappend paths {*}[ |
|||
paths [ |
|||
mark $map $x $y [+ $i 1] |
|||
] $x $y [- $n 1] |
|||
] |
|||
} |
|||
} |
|||
return $paths |
|||
} |
|||
proc solve {map} { |
|||
# fixpoint map |
|||
while 1 { ;# first we iteratively fill in paths with distinct solutions |
|||
set rmap [rmap $map] |
|||
set gaps [gaps $rmap] |
|||
set gaps [fixgaps $map $rmap $gaps] |
|||
if {$gaps eq ""} { |
|||
return $map |
|||
} |
|||
set oldmap $map |
|||
foreach {i j} $gaps { |
|||
lassign [dict get $rmap $i] x0 y0 |
|||
set n [- $j $i] |
|||
set paths [paths $map $x0 $y0 $n] |
|||
if {$paths eq ""} { |
|||
return "" |
|||
} elseif {[llength $paths] == 1} { |
|||
#puts "solved $i..$j" |
|||
#puts [print $map] |
|||
set map [lindex $paths 0] |
|||
} |
|||
;# we could intersect the paths to maybe get some tiles |
|||
} |
|||
if {$map eq $oldmap} { |
|||
break |
|||
} |
|||
} |
|||
#puts "unique paths exhausted - going DFS" |
|||
try { ;# for any left over paths, go DFS |
|||
;# we might want to sort the gaps first |
|||
foreach {i j} $gaps { |
|||
lassign [dict get $rmap $i] x0 y0 |
|||
set n [- $j $i] |
|||
set paths [paths $map $x0 $y0 $n] |
|||
foreach path $paths { |
|||
#puts "recursing on $i..$j" |
|||
set sol [solve $path] |
|||
if {$sol ne ""} { |
|||
return $sol |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
namespace export {[a-z]*} |
|||
namespace ensemble create |
|||
} |
|||
set puzzles { |
|||
{ |
|||
0 0 0 0 0 0 0 0 0 |
|||
0 0 46 45 0 55 74 0 0 |
|||
0 38 0 0 43 0 0 78 0 |
|||
0 35 0 0 0 0 0 71 0 |
|||
0 0 33 0 0 0 59 0 0 |
|||
0 17 0 0 0 0 0 67 0 |
|||
0 18 0 0 11 0 0 64 0 |
|||
0 0 24 21 0 1 2 0 0 |
|||
0 0 0 0 0 0 0 0 0 |
|||
} |
|||
{ |
|||
0 0 0 0 0 0 0 0 0 |
|||
0 11 12 15 18 21 62 61 0 |
|||
0 6 0 0 0 0 0 60 0 |
|||
0 33 0 0 0 0 0 57 0 |
|||
0 32 0 0 0 0 0 56 0 |
|||
0 37 0 1 0 0 0 73 0 |
|||
0 38 0 0 0 0 0 72 0 |
|||
0 43 44 47 48 51 76 77 0 |
|||
0 0 0 0 0 0 0 0 0 |
|||
} |
|||
} |
|||
foreach puzzle $puzzles { |
|||
set map [numbrix parse $puzzle] |
|||
puts "\n== Puzzle [incr i] ==" |
|||
puts [numbrix print $map] |
|||
set sol [numbrix solve $map] |
|||
if {$sol ne ""} { |
|||
puts "\n== Solution $i ==" |
|||
puts [numbrix print $sol] |
|||
} else { |
|||
puts "\n== No Solution for Puzzle $i ==" |
|||
} |
|||
}</lang> |
|||
{{Out}} |
|||
<pre> |
|||
== Puzzle 1 == |
|||
0 0 0 0 0 0 0 0 0 |
|||
0 0 46 45 0 55 74 0 0 |
|||
0 38 0 0 43 0 0 78 0 |
|||
0 35 0 0 0 0 0 71 0 |
|||
0 0 33 0 0 0 59 0 0 |
|||
0 17 0 0 0 0 0 67 0 |
|||
0 18 0 0 11 0 0 64 0 |
|||
0 0 24 21 0 1 2 0 0 |
|||
0 0 0 0 0 0 0 0 0 |
|||
== Solution 1 == |
|||
49 50 51 52 53 54 75 76 81 |
|||
48 47 46 45 44 55 74 77 80 |
|||
37 38 39 40 43 56 73 78 79 |
|||
36 35 34 41 42 57 72 71 70 |
|||
31 32 33 14 13 58 59 68 69 |
|||
30 17 16 15 12 61 60 67 66 |
|||
29 18 19 20 11 62 63 64 65 |
|||
28 25 24 21 10 1 2 3 4 |
|||
27 26 23 22 9 8 7 6 5 |
|||
== Puzzle 2 == |
|||
0 0 0 0 0 0 0 0 0 |
|||
0 11 12 15 18 21 62 61 0 |
|||
0 6 0 0 0 0 0 60 0 |
|||
0 33 0 0 0 0 0 57 0 |
|||
0 32 0 0 0 0 0 56 0 |
|||
0 37 0 1 0 0 0 73 0 |
|||
0 38 0 0 0 0 0 72 0 |
|||
0 43 44 47 48 51 76 77 0 |
|||
0 0 0 0 0 0 0 0 0 |
|||
== Solution 2 == |
|||
9 10 13 14 19 20 63 64 65 |
|||
8 11 12 15 18 21 62 61 66 |
|||
7 6 5 16 17 22 59 60 67 |
|||
34 33 4 3 24 23 58 57 68 |
|||
35 32 31 2 25 54 55 56 69 |
|||
36 37 30 1 26 53 74 73 70 |
|||
39 38 29 28 27 52 75 72 71 |
|||
40 43 44 47 48 51 76 77 78 |
|||
41 42 45 46 49 50 81 80 79 |
|||
</pre> |
|||