Memory 2

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."
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://www.zolli.fr/fichiers/Memory2k.zip

Category Games