Version 1 of Shifting maze

# TITLE: Labyrinth 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! }

 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}