[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.

I really should add a mouse-drag interface but it was too tricky, and
unclear exactly it should work.


----
[HJG] I don't understand what the different colors of the discs are for, 
just decoration? [KPV] Yes
----

======
 ##+##########################################################################
 #
 # 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
 return
======

<<categories>> Application | Games