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}Category Games
