Keith Vetter 2006-02-11 : Here's a very tough puzzle where you have to rotate numbers on three interlocking rings to get the numbers back in order.
I haven't solved a non-trivial puzzle yet. I wrote a brute-force solver but it blew out of available memory at a depth of about 8. Using better data structures and retrograde analysis I could probably get that up to about 15. But seeing how there are on the order of 12! different positions, the brute force solution is not very effective.
##+##########################################################################
#
# Rings.tcl -- rotate numbers on three rings until back in order
# by Keith Vetter -- February, 2006
#
package require Tk
array set S {title "Ring Master" sz 75 steps 30 state "play"}
set S(sz) 75
array set COLORS {r0 yellow r1 green r2 cyan}
array set ROT {r0,l {3 7 8 5 2 1} r0,r {1 2 5 8 7 3}
r1,l {6 10 11 8 4 3} r1,r {3 4 8 11 10 6}
r2,l {7 11 12 9 5 4} r2,r {4 5 9 12 11 7}}
proc DoDisplay {} {
wm title . $::S(title)
DoMenus
canvas .c -bg black -highlightthickness 0 ;# Size set by minsize
pack .c -side top -fill both -expand 1
bind .c <Configure> {ReCenter %W %h %w} ;# Force 0,0 to be in center
DrawRings
bind all <Key-Up> [list DoRotate r0 r]
bind all <Shift-Key-Up> [list DoRotate r0 l]
bind all <Key-Left> [list DoRotate r1 r]
bind all <Shift-Key-Left> [list DoRotate r1 l]
bind all <Key-Right> [list DoRotate r2 r]
bind all <Shift-Key-Right> [list DoRotate r2 l]
bind all <Key-F2> {console show}
focus .c
foreach {l t r b} [.c bbox all] break
wm minsize . [expr {$r - $l + 50}] [expr {$b - $t + 50}]
set txt "Up - top ring\n"
append txt "Left - left ring\n"
append txt "Right - right ring\n"
append txt "Shift reverses"
.c create text 0 0 -tag help -fill white -font {Tahoma 8 bold} \
-text $txt -anchor ne
}
proc NewGame {{shuffle 1}} {
MakeBoard
if {$shuffle} ShuffleBoard
DrawBoard
set ::S(state) play
}
proc DoMenus {} {
menu .m -tearoff 0
. configure -menu .m ;# Attach menu to main window
.m add cascade -menu .m.game -label "Game" -underline 0
.m add cascade -menu .m.help -label "Help" -underline 0
menu .m.game -tearoff 0
.m.game add command -label "New Game" -under 0 -command NewGame -acc "F2"
.m.game add separator
.m.game add command -label "Reset" -under 0 -command {NewGame 0}
.m.game add command -label "Shuffle" -under 0 -command {ShuffleBoard 20 1}
.m.game add separator
.m.game add command -label "Exit" -under 1 -command exit
menu .m.help -tearoff 0
.m.help add command -label "About" -under 0 -command About
}
proc About {} {
set txt "$::S(title)\nby Keith Vetter, February 2006\n\n"
append txt "Rotate the rings to rearrange the\n"
append txt "numbers so that are ordered correctly.\n\n"
append txt "Use the up, left and right arrow keys to\n"
append txt "rotate the rings clockwise; hold the shift\n"
append txt "key down while pressing an arrow key to\n"
append txt "rotate counter-clockwise.\n\n"
append txt "Alternatively, clicking with the right or left\n"
append txt "mouse button on an unambiguous disk will\n"
append txt "also rotate the ring."
tk_messageBox -message $txt -title About
}
##+##########################################################################
#
# Recenter -- keeps 0,0 at the center of the canvas during resizing
#
proc ReCenter {W h w} { ;# Called by configure event
set h2 [expr {$h / 2}]
set w2 [expr {$w / 2}]
$W config -scrollregion [list -$w2 -$h2 $w2 $h2]
.c coords help [expr {$w2 - 10}] [expr {-($h2 - 10)}]
}
proc MakeBoard {} {
for {set i 1} {$i <= 12} {incr i} {
set ::B($i) $i
set ::IMG($i) "::img::[expr {int(rand() * 3)}]"
}
}
proc ShuffleBoard {{n 50} {animate 0}} {
set lwhich -1
set ldir -1
for {set i 0} {$i < $n} {incr i} {
while {1} {
set which "r[expr {int(rand()*3)}]"
set dir [expr {rand() < .5 ? "r" : "l"}]
if {$lwhich != $which || $ldir == $dir} break
}
set lwhich $which
set ldir $dir
if {$animate} {
DoRotate $which $dir
} else {
RotateRing ::B $which $dir
}
}
}
proc DrawDisk {who where} {
.c delete d$who
set x $::P($where,x)
set y $::P($where,y)
.c create image $x $y -tag d$who -image $::IMG($who)
.c create text $x [expr {$y-1}] -tag d$who -text $who -font {Times 18 bold} -fill white
.c create text $x [expr {$y-2}] -tag d$who -text $who -font {Times 18 bold}
.c bind d$who <1> [list Click $who l]
.c bind d$who <3> [list Click $who r]
}
proc DrawRings {} {
foreach which {r0 r1 r2} {
set center [expr {$which eq "r0" ? 4 : $which eq "r1" ? 7 : 8}]
.c delete r$which
set steps 5
set colors [GradientColors [.c cget -bg] $::COLORS($which) $steps]
set xy [Expand $::P($center,x) $::P($center,y) $::S(sz)]
for {set i 1} {$i < $steps} {incr i} {
set color [lindex $colors $i]
set w [expr {2*($steps-$i) - 1}]
.c create oval $xy -tag r$which -outline $color -width $w
}
.c lower r$which
}
}
proc Victory {} {
if {$::S(state) ne "play"} return
set ::S(state) solved
Flash
}
proc Flash {{cnt 3} {delay 200}} {
for {set i 0} {$i < $cnt} {incr i} {
.c config -bg red
update
after $delay
.c config -bg black
update
after $delay
}
}
proc Expand {x y d} {
return [list [expr {$x-$d}] [expr {$y-$d}] [expr {$x+$d}] [expr {$y+$d}]]
}
proc Dist {a b} {
global P
set dx [expr {$P($a,x)-$P($b,x)}]
set dy [expr {$P($a,y)-$P($b,y)}]
return [expr {hypot($dx,$dy)}]
}
proc Init {} {
global P S
set S(B) [expr {$S(sz)/2.0}]
set S(A) [expr {$S(B) / sqrt(3)}]
set S(C) [expr {2*$S(A)}]
# Figure out position of each node based on S(sz)
set P(4,x) 0 ; set P(4,y) -$S(C)
set P(8,x) $S(B) ; set P(8,y) $S(A)
set P(7,x) -$S(B) ; set P(7,y) $S(A)
set P(2,x) $S(B) ; set P(2,y) [expr {$P(4,y) - $S(A) - $S(C)}]
set P(1,x) -$S(B) ; set P(1,y) $P(2,y)
set P(5,x) $S(sz) ; set P(5,y) $P(4,y)
set P(3,x) -$P(5,x) ; set P(3,y) $P(4,y)
set P(9,x) [expr {$P(8,x) + $S(sz)}] ; set P(9,y) $P(8,y)
set P(6,x) -$P(9,x) ; set P(6,y) $P(8,y)
set P(11,x) 0 ; set P(11,y) [expr {$P(7,y) + $S(A) + $S(C)}]
set P(10,x) $P(3,x) ; set P(10,y) $P(11,y)
set P(12,x) $P(5,x) ; set P(12,y) $P(11,y)
}
proc GradientColors {c1 c2 n} {
foreach {r1 g1 b1} [winfo rgb . $c1] break
foreach {r2 g2 b2} [winfo rgb . $c2] break
foreach el {r1 g1 b1 r2 g2 b2} { ;# Normalize to 0-255 range
set $el [expr {[set $el] * 255 / 65535}].0
}
set r_step 0.0 ; set g_step 0.0 ; set b_step 0.0
if {$n > 1} {
set r_step [expr {($r2-$r1) / ($n-1)}]
set g_step [expr {($g2-$g1) / ($n-1)}]
set b_step [expr {($b2-$b1) / ($n-1)}]
}
set steps {}
for {set i 0} {$i < $n} {incr i} {
set r [expr {int($r_step * $i + $r1)}]
set g [expr {int($g_step * $i + $g1)}]
set b [expr {int($b_step * $i + $b1)}]
lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
}
return $steps
}
proc DrawBoard {} {
global B
for {set i 1} {$i <= 12} {incr i} {
DrawDisk $B($i) $i
}
}
proc RotateRing {brd which dir} {
upvar $brd BB
set rot $::ROT($which,$dir)
set last $BB([lindex $rot end])
foreach pos $rot {
set this $BB($pos)
set BB($pos) $last
set last $this
}
}
proc DoRotate {which dir} {
array set d {r0 {5 8 7 3 1 2} r1 {8 11 10 6 3 4} r2 {9 12 11 7 4 5}}
array set c {r0 4 r1 7 r2 8}
if {$::S(state) == "anim"} return
AnimateRotate $c($which) $d($which) $dir
RotateRing ::B $which $dir
DrawBoard
if {$::S(state) != "play"} return
for {set i 1} {$i <= 12} {incr i} { ;# Is it solved???
if {$::B($i) != $i} return
}
Victory
}
proc Click {who dir} {
global B
if {$B(1) == $who || $B(2) == $who} {
DoRotate r0 $dir
} elseif {$B(6) == $who || $B(10) == $who} {
DoRotate r1 $dir
} elseif {$B(9) == $who || $B(12) == $who} {
DoRotate r2 $dir
}
}
proc AnimateRotate {center whom dir} {
global S P B
set tmp $S(state)
set S(state) "anim"
set dir [expr {$dir eq "r" ? 1 : -1}]
unset -nocomplain pos
for {set i 0} {$i <= $S(steps)} {incr i} {
set da [expr {$i * 60 / $S(steps)}]
for {set idx 0} {$idx < 6} {incr idx} {
set a [expr {($idx*60 + $dir*$da) * acos(-1) /180}]
set x [expr {$P($center,x) + $S(sz)*cos($a)}]
set y [expr {$P($center,y) + $S(sz)*sin($a)}]
if {$i > 0} {
set dx [expr {$x - $pos($idx,x)}]
set dy [expr {$y - $pos($idx,y)}]
set who $B([lindex $whom $idx])
.c move d$who $dx $dy
}
set pos($idx,x) $x
set pos($idx,y) $y
}
update
after 10
}
set S(state) $tmp
}
image create photo ::img::0 -data {
R0lGODlhLQAtALMAAHxuHIyGJOzmpNLASuPWc/z83bCmNPz2xNTIXwQC/OrkjPT29PzypLyyPJyS
LIR6HCH5BAEAAAkALAAAAAAtAC0AAwT/MMlJq1w462W7/8kmimBZjUWqFqMJbuohz7O6uZaWykzv
/wyZDYObZAo8oBJ4SGVwrMVuSVU2owUTZlrt+q7ElzTpLQvDHRbyUG73zlmLGumug+OUWH0Pruj3
ewsHUnlrgIcyHAl/h4BNElyNiJBkkoAJNJaSM5qNCpydjpWhbaOkp6hLCgqpbasCAqytVQqwr7NV
sau7uEq7qwS1vUCxwQkEwcM/CsgSyKvKDMAEzgjJyszWEwjWyrHcFAgDBNgEAwgV4si4zAMDFuLj
5KkCBAgN7xYG7uOo9Qj7PuzrR+pfAwMlAuybp6mdAYQmHAR4JgsQsAEOHOSL6KCBNWhuR4Ddy1hE
gkSNH2PRKibuZMkJBgIE6Cjvl65pAxpIVPiygoMHD2YOPMeNnwGJQB309PATgNOgMmU+cArggdKl
JZBOfRr0apEIADs=}
image create photo ::img::1 -data {
R0lGODlhLQAtALMAAHwcbowkhuyk5tJKwONz1vzd/LA0pvzE9tRfyAT8AuqM5PT09vyk8rw8spws
koQceiH5BAEAAAkALAAAAAAtAC0AAwT/MMlJq1w462W7/8kmimBZjUWqFqMJbuohz7O6uZaWykzv
/wyZDYObZAo8oBJ4SGVwrMVuSVU2owUTZlrt+q7ElzTpLQvDHRbyUG73zlmLGumug+OUWH0Pruj3
ewsHUnlrgIcyHAl/h4BNElyNiJBkkoAJNJaSM5qNCpydjpWhbaOkp6hLCgqpbasCAqytVQqwr7NV
sau7uEq7qwS1vUCxwQkEwcM/CsgSyKvKDMAEzgjJyszWEwjWyrHcFAgDBNgEAwgV4si4zAMDFuLj
5KkCBAgN7xYG7uOo9Qj7PuzrR+pfAwMlAuybp6mdAYQmHAR4JgsQsAEOHOSL6KCBNWhuR4Ddy1hE
gkSNH2PRKibuZMkJBgIE6Cjvl65pAxpIVPiygoMHD2YOPMeNnwGJQB309PATgNOgMmU+cArggdKl
JZBOfRr0apEIADs=}
image create photo ::img::2 -data {
R0lGODlhLQAtALMAABxufCSGjKTm7ErA0nPW4938/DSmsMT2/F/I1PwCBIzk6vT29KTy/DyyvCyS
nBx6hCH5BAEAAAkALAAAAAAtAC0AAwT/MMlJq1w462W7/8kmimBZjUWqFqMJbuohz7O6uZaWykzv
/wyZDYObZAo8oBJ4SGVwrMVuSVU2owUTZlrt+q7ElzTpLQvDHRbyUG73zlmLGumug+OUWH0Pruj3
ewsHUnlrgIcyHAl/h4BNElyNiJBkkoAJNJaSM5qNCpydjpWhbaOkp6hLCgqpbasCAqytVQqwr7NV
sau7uEq7qwS1vUCxwQkEwcM/CsgSyKvKDMAEzgjJyszWEwjWyrHcFAgDBNgEAwgV4si4zAMDFuLj
5KkCBAgN7xYG7uOo9Qj7PuzrR+pfAwMlAuybp6mdAYQmHAR4JgsQsAEOHOSL6KCBNWhuR4Ddy1hE
gkSNH2PRKibuZMkJBgIE6Cjvl65pAxpIVPiygoMHD2YOPMeNnwGJQB309PATgNOgMmU+cArggdKl
JZBOfRr0apEIADs=
}
################################################################
Init
DoDisplay
NewGame
returnHJG I don't understand what the different colors of the discs are for, just decoration? KPV Yes