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
}

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

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) {}
    }
}

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

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
}

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"
}

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