[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:
[WikiDbImage memory.jpg] (Screenshot in Cheat mode - normally you see at most two cards exposed.)----
[Jeff Smith] 2020-09-02 : Below is an online demo using [CloudTk]. This demo runs "Memory 2" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Memory-2.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
<<inlinehtml>>
<iframe height="290" width="310" src="https://cloudtk-app.tcl-lang.org/cloudtk/VNC?session=new&Tk=Memory-2" allowfullscreen></iframe>
<<inlinehtml>>
----
======
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."
package require Tk
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
}
======
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
}
}
======
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) {}
}
}
======
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
}
}
======
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
}
======
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"
}
======
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]
----
[David Zolli] - 05 Oct 2004 : I've done a '''Famous Tcl'ers edition''' of this game (featuring Donal Fellows, Jeff Hobbs, Richard Suchenwirth, Jean-Claude Wippler, Arjen Markus, Steve Landers, Kevin Kenny, Reinhard Max, John Ousterhout, Andreas Kupries, Miguel Sofer, Don Porter, Brent Welch, Larry Virden and David Welton): http://web.archive.org/web/https://www.zolli.fr/fichiers/Memory2k.zip
[http://web.archive.org/web/https://www.zolli.fr/fichiers/Memory2k.png]
<<categories>> Games