if 0 {Richard Suchenwirth 2003-07-04 - In a brief Wiki visit during vacations, I noticed A simple memory game, "downloaded" and played it a bit - and wanted to do an alternative implementation, with distinctive colors and shapes for easier memorization. Here it is:
(Screenshot in Cheat mode - normally you see at most two cards exposed.) }
set about "Memory2
R.Suchenwirth 2003
Tap on two cards to turn them over.
If they are equal, you win them (10 score).
Else they are turned back again (-1 score).
Click Cheat to see all for a second."
proc main {} {
frame .f
label .f.s -text Score:
label .f.l -textvariable g(score) -width 4 -bg white
button .f.a -text About -command {tk_messageBox -message $about}
button .f.n -text New -command {reset .c}
tk_optionMenu .f.m g(pairs) 8 10 12 15
button .f.c -text Cheat -command {.c lower cover; #after 1000 .c raise cover}
button .f.x -text X -command exit
eval pack [winfo childr .f] -side left -fill y
canvas .c -bg darkgreen -height 250
pack .f .c -fill x
initCards
reset .c
}if 0 {Card images are described in a little language: first the background color, then any number of items in the sequence: type (rect or poly) - fill color - relative coordinates (between 0 and 1):}
proc initCards {} {
global g
array set g {
c.1 {red rect white {.2 .4 .8 .6} rect white {.4 .2 .6 .8}}
c.2 green
c.3 {blue rect yellow {0 .33 1 .66}}
c.4 {yellow poly red {0 0 0 1 1 1}}
c.5 {purple poly white {.5 0 0 .5 .5 1 1 .5} poly yellow {.5 .2 .2 .5 .5 .8 .8 .5}}
c.6 {white rect blue {0 0 .32 1} rect red {.68 0 1 1}}
c.7 {white rect black {0 .5 .5 1} rect black {.5 0 1 .5}}
c.8 {black poly green {.1 .8 .5 .2 .9 .8}}
c.9 {lightblue poly red {.1 .1 .9 .1 .5 .9} poly white {.3 .25 .7 .25 .5 .65}}
c.10 {black rect red {0 .33 1 .67} rect yellow {0 .67 1 1}}
c.11 {yellow rect black {.3 0 1 .7}}
c.12 {blue poly yellow {0 0 0 .8 .8 0} poly yellow {.2 1 1 .2 1 1}}
c.13 {blue rect white {.2 .2 .8 .4} rect white {.2 .6 .8 .8}}
c.14 {black poly red {0 0 1 0 .5 .5} poly red {0 1 1 1 .5 .5}}
c.15 {white rect purple {.1 .1 .9 .3} rect purple {.4 .1 .6 .9}}
}
foreach card [array names g c.*] {
lappend g(cards) $card $card
}
}if 0 {Shuffle and arrange cards on "table":}
proc reset w {
global g
set g(seen) {}
set g(score) 0
$w delete all
set n [expr {2*$g(pairs)-1}]
set ncol [expr {$n<17? 4: 5}]
set cards [lrange $g(cards) 0 $n]
for {set i 0} {$i<6} {incr i} {
for {set j 0} {$j<$ncol} {incr j} {
if ![llength $cards] break
putCard $w $i $j [ldraw cards]
}
}
$w bind cover <1> "uncover $w"
}
proc uncover w {
global g
set id [$w find withtag current]
set which [lindex [$w gettags $id] 1]
$w lower $id ;# show card
lappend g(seen) $which
if {[llength $g(seen)]==2} {
compare $w $g(seen)
set g(seen) {}
}
}if 0 {Two cards are open - see whether they show the same picture:}
proc compare {w seen} {
global g
update
after 1000 ;#wait for player to look
foreach {first second} $seen break
if {$g($first)==$g($second)} {
eval $w delete $seen
incr g(score) 10
} else {
$w raise cover
incr g(score) -1
}
}if 0 {This computes the bounding box for a card, and has it drawn:}
proc putCard {w row col img} {
global g
set s [expr {$g(pairs)<9? 45: $g(pairs)<13? 38: 33}]
set d [expr {$g(pairs)<9? 10: 7}]
set x0 [expr {$col*($s+$d)+$d}]
set x1 [expr {$x0+$s}]
set y0 [expr {$row*($s+$d)+$d}]
set y1 [expr {$y0+$s}]
card $w $x0 $y0 $x1 $y1 $g($img) $col.$row
set g($col.$row) $img
}if 0 {This executes the little "card description language", by scaling and translating relative coordinates to absolute ones:}
proc card {w x0 y0 x1 y1 img tag} {
$w create rect $x0 $y0 $x1 $y1 -fill [lindex $img 0] -tag $tag
set dx [expr {$x1 - $x0 - 2}]
foreach {type color coords} [lrange $img 1 end] {
set final {}
foreach {x y} $coords {
lappend final [expr {$x0+$x*$dx+1}]
lappend final [expr {$y0+$y*$dx+1}]
}
$w create $type $final -fill $color -outline $color -tag $tag
}
$w create rect $x0 $y0 $x1 $y1 -fill grey -tag "cover $tag"
}if 0 {Random arrangement of cards is done by picking and removing an arbitrary element from the list:}
proc ldraw varName {
upvar 1 $varName v
set pos [expr {int(rand()*[llength $v])}]
K [lindex $v $pos] [set v [lreplace $v $pos $pos]]
}
proc K {a b} {set a}#----------------------- Let's go!
main wm geometry . 236x270+0+0 ;# iPaq
Kroc revealed a bug that the default canvas is too small on Linux to show the 6th on row with 15 pairs. Added explicit canvas height - RS
Kroc - 05 Oct 2004 : I've done a Famous Tcl'ers edition of this game: http://www.kroc.tk/tclkit/Memory2.kit
[ Category Games ]