Shifting maze
if 0 {Richard Suchenwirth 2003-11-23 - This game was marketed as "The a-Maze-ing Labyrinth" - here's my Tcl approximation to it.
The maze is a 7*7 grid of cards, 16 of which are fixed on the board, 34 are movable - 33 on the board, and one "off-board" card. You can insert this card at any place where an orange arrow is displayed, and shift the cards in that row or column by one position. Rotate the off-board card by right-clicking.
WARNING: This is still under development - shifting cards works in the good case, but can easily go wrong on other mouse movements. Fixes welcome!
DKF: Hmm. I've not encountered this game before; what's the winning condition(s)?
AK: Each player has a colored token to move. Start locations for the tokens are in the four corners. Each player has a set of cards showing treasures (hide them from other the players). Some pieces of the board (fixed, and moveable) show the same treasures. Each player looks at the topmost treasure card he has, and whenever it is his turn he tries to shift the labyrinth so that his token can move from the current place to the treasure without hitting a wall. He can also move the token (even if the treasure is not hit). When a player was able place his token on a treasure the treasure card is made visible, and the player can work on getting to the next treasure in his set of cards. When a player has visited all treasures on his cards he has to shift the labyrinth so that he can get his token back to his start location. When he reaches the start location again, and is the first to do so, he wins. }
proc main {} {
global g
set g(size) 40
set side [expr $g(size)*9]
pack [canvas .c -width $side -height [expr $g(size)*10] -bg purple]
#------- fixed cards
card .c L 2 1 1
card .c T 0 3 1
card .c T 0 5 1
card .c L 1 7 1
card .c T 1 1 3
card .c T 1 3 3
card .c T 0 5 3
card .c T 3 7 3
card .c T 1 1 5
card .c T 2 3 5
card .c T 3 5 5
card .c T 3 7 5
card .c L 3 1 7
card .c T 2 3 7
card .c T 2 5 7
card .c L 0 7 7
#--- arrows
set y0 [expr $g(size)*0.7]
set y1 [expr $g(size)*8]
set y2 [expr $g(size)*8.3]
foreach x {2.5 4.5 6.5} {
set x0 [expr $x*$g(size)]
foreach line [list [list $x0 $y0 $x0 $g(size)] \
[list $x0 $y2 $x0 $y1] [list $y0 $x0 $g(size) $x0]\
[list $y2 $x0 $y1 $x0]] {
.c create line $line -arrow last -width 5 \
-fill orange -tag arrow
}
}
#--- movable cards
set cards [split [rep I 13][rep L 15][rep T 6] ""]
set y 1
foreach row {
{0 1 0 1 0 1 0}
{1 1 1 1 1 1 1}
{0 1 0 1 0 1 0}
{1 1 1 1 1 1 1}
{0 1 0 1 0 1 0}
{1 1 1 1 1 1 1}
{0 1 0 1 0 1 0}
} {
set x 1
foreach col $row {
if $col {
card .c [ldraw cards] [lpick {0 1 2 3}] $x $y
}
incr x
}
incr y
}
#--- the last card is off-board
card .c $cards 0 4 9 mvcard
movable .c mvcard
}
proc card {w shape rot x y {tag ""}} {
global g
$w create rect [expr {$x*$g(size)}] [expr {$y*$g(size)}] \
[expr {($x+1)*$g(size)}] [expr {($y+1)*$g(size)}] \
-fill brown -tag $tag
switch -- $shape {
I {set coo {0 0.3 1 0.3 1 0.7 0 0.7}}
L {set coo {0.3 1 0.3 0.3 1 0.3 1 0.7 0.7 0.7 0.7 1}}
T {set coo {0 .7 0 .3 .3 .3 .3 0 .7 0 .7 .3 1 .3 1 .7}}
}
set id [$w create poly $coo -fill beige -tag $tag]
rotate $w $id $rot 0.5 0.5
$w scale $id 0 0 $g(size) $g(size)
$w move $id [expr {$x*$g(size)}] [expr {$y*$g(size)}]
}
interp alias {} rep {} string repeat
proc rotate {w tag rot xm ym} {
set coords {}
foreach {x y} [$w coords $tag] {
set r [expr hypot($xm-$x,$ym-$y)]
set a [expr atan2($ym-$y,$xm-$x)-$rot/2.*acos(-1)]
set x2 [expr $xm+cos($a)*$r]
set y2 [expr $ym+sin($a)*$r]
lappend coords $x2 $y2
}
$w coords $tag $coords
}
proc rotate2 {w tag rot} {
foreach id [$w find withtag $tag] {
if {[$w type $id]=="polygon"} {set poly $id; break}
}
foreach {x0 y0 x1 y1} [$w bbox $tag] break
set xm [expr {($x1+$x0)/2.}]
set ym [expr {($y1+$y0)/2.}]
rotate $w $poly $rot $xm $ym
}
proc movable {w tag} {
$w bind $tag <1> {set g(x) %x; set g(y) %y}
$w bind $tag <B1-Motion> [list move %W $tag %x %y]
$w bind $tag <ButtonRelease-1> [list release %W $tag]
set poly {}
$w bind $tag <3> [list rotate2 $w $tag 3]
}
proc move {w tag x y} {
global g
$w move $tag [expr {$x-$g(x)}] [expr {$y-$g(y)}]
array set g [list x $x y $y]
}
proc release {w tag} {
global g
#--- snap card in exact place
foreach {x y - -} [$w bbox $tag] break
set s2 [expr {$g(size)/2.}]
set dx [expr -round($x-$s2)%$g(size)-$s2-1]
set dy [expr -round($y-$s2)%$g(size)-$s2-1]
$w move $tag $dx $dy
#--- on arrow?
foreach {x0 y0 x1 y1} [$w bbox $tag] break
set ok 0
foreach item [$w find overlapping $x0 $y0 $x1 $y1] {
if {[$w type $item] eq "line"} {incr ok; break}
}
if !$ok return
set dir {0 0}
if {$x0==-1} {set x1 [expr $g(size)*8+1]; set dir {1 0}}
if {$x0==$g(size)*8-1} {set x0 -1; set dir {-1 0}}
if {$y0==-1} {set y1 [expr $g(size)*8+1]; set dir {0 1}}
if {$y0==$g(size)*8-1} {set y0 -1; set dir {0 -1}}
if {$dir ne {0 0}} {
foreach {dx dy} $dir break
foreach item [$w find enclosed $x0 $y0 $x1 $y1] {
if {[$w type $item] eq "line"} continue
$w move $item [expr $dx*$g(size)] [expr $dy*$g(size)]
}
$w dtag $tag
}
#--- find out-shifted card
switch -- $dir {
{0 1} {set y0 [expr $g(size)*8-1]}
{0 -1} {set y1 [expr $g(size)-1]}
{1 0} {set x0 [expr $g(size)*8-1]}
{-1 0} {set x1 [expr $g(size)-1]}
}
$w addtag $tag overlapping $x0 $y0 $x1 $y1
$w dtag arrow $tag
movable $w $tag
$w raise $tag
}#--- General utilities:
proc ldraw listVar {
upvar 1 $listVar list
set pos [expr {int(rand()*[llength $list])}]
K [lindex $list $pos] [set list [lreplace $list $pos $pos]]
}
proc K {a b} {set a}
proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
bind . <F1> {console show}
main
bind . <Escape> {exec wish $argv0 &; exit}