MasterMind 2

Richard Suchenwirth 2003-07-05 - I found this (physical) game in my cupboard and remembered how it thrilled me years ago. Guess what my next thought was... And here it is, runnable on PocketPC and hopefully elsewhere;)
For single players, a random color combination is generated on every Reset. A second player can also manually put a combination under the green cover at top right.
The Mastermind page has an earlier implementation I wasn't aware of.
set about "MasterMind - (c) 1993 Invicta Toys and Games Ltd.
  simulated in Tcl/Tk by R.Suchenwirth 2003

  Guess colors of 4 pegs.
  multicolor: maybe >1 of a color.
  holecolor: black possible.
  Tap on color at right, then on hole to place peg.
  Double-tap to clear hole.
  Judgement (small pins):
  red: color & place ok
  white: color ok, wrong place"

package require Tk
proc main {} {
    global g
    pack [canvas .c -bg grey30]
    set y0 5 ; set y1 10
    for {set i 0} {$i<12} {incr i} {
        .c create rect 10 $y0 15 $y1 -tag "pin $i,0"
        .c create rect 20 $y0 25 $y1 -tag "pin $i,1"
        incr y0 10; incr y1 10
        .c create rect 10 $y0 15 $y1 -tag "pin $i,2"
        .c create rect 20 $y0 25 $y1 -tag "pin $i,3"
       set h0 [expr {$y0-9}]
       set h1 [expr {$h0+14}]
       foreach j {1 2 3 4} {
           set x [expr {20*$j+20}]
           set x1 [expr {$x+14}]
           oval .c $x $h0 $x1 $h1 -tag "hole $i:$j"
       }
       incr y0 8
       .c create line 5 $y0 120 $y0
       incr y0 4; incr y1 12
    }
    #-- choosers
    set g(colors) {white yellow orange red magenta purple blue green}
    set y0 15 ; set y1 [expr $y0+14]
    foreach color $g(colors) {
        oval .c 125 $y0 139 $y1 -tag chooser -fill $color
        incr y0 20 ; incr y1 20
    }
    .c bind chooser <1> {set g(color) [%W itemcget current -fill]}
    .c bind hole <1> {%W itemconfig current -fill $g(color)}
    .c bind hole <Double-1> {%W itemconfig current -fill black}
    set x0 150 ; set x1 164
    foreach i {1 2 3 4} {
        oval .c $x0 20 $x1 34 -tag "hole t$i"
        incr x0 20 ; incr x1 20
    }
    .c create rect 145 10 230 40 -fill darkgreen -tag cover
    .c bind cover <1> {toggleCover %W}
    cbutton .c.j 190 90 Judge {judge .c}
    ccbutton .c.mc 190 150 multicolor g(multicolor)
    ccbutton .c.ec 190 175 holecolor g(holecolor)
    cbutton .c.r 190 200 New {reset .c}  
    cbutton .c.a 190 225 About {tk_messageBox -message $about}
    cbutton .c.q 190 250 Quit exit
    reset .c
}

proc toggleCover w {
    if {[$w find below cover]==""} {
        $w raise cover
    } else {
        $w lower cover
    }
}

proc cbutton {w x y text cmd} {
    button $w -text $text -command $cmd -width 8 -bg gray30 -fg green
    [winfo parent $w] create window $x $y -window $w
}

proc ccbutton {w x y text var } {
    checkbutton $w -text $text -variable $var -bg gray30 -fg green
    [winfo parent $w] create window $x $y -window $w
}

proc reset w {
    global g
    set g(row) 0
    set colors $g(colors)
    if $g(holecolor) {lappend colors black}
    $w itemconfig pin -fill black
    $w itemconfig hole -fill black
    foreach i {1 2 3 4} {
        set color [? $colors]
        if !$g(multicolor) {lremove colors $color}
        $w itemconfig t$i -fill $color
    }
    $w raise cover
}
proc ? L {
    lindex $L [expr {int(rand()*[llength $L])}]
}
proc judge w {
    global g
    set target {}
    foreach i {1 2 3 4} {
        lappend target [$w itemcget t$i -fill]
    }
    set guess {}
    foreach i {1 2 3 4} {
        lappend guess [$w itemcget $g(row):$i -fill]
    }
    set res {}
    foreach gs $guess t $target {
        if {$gs == $t} {
            lappend res red
            lremove guess $gs
            lremove target $t
        }
    }
    foreach gs $guess {
        if {[lsearch $target $gs]>=0} {
            lappend res white
            lremove target $gs
        }
    }
    foreach i {0 1 2 3} pin $res {
        $w itemconfig $g(row),$i -fill $pin
    }
    incr g(row)
    if {$g(row)>12 || $res=="red red red red"} {
        $w lower cover
    }
}
proc lremove {listName elem} {
    upvar 1 $listName list
    set pos [lsearch $list $elem]
    set list [lreplace $list $pos $pos]
}
# Workaround for circles
proc rp {x0 y0 x1 y1 {n 0} } {
    set xm [expr {($x0+$x1)/2.}]
    set ym [expr {($y0+$y1)/2.}]
    set rx [expr {$xm-$x0}]
    set ry [expr {$ym-$y0}]
    if {$n==0} {
        set n [expr {round(($rx+$ry))}]
    }
    set step [expr {atan(1)*8/$n}]
    set res ""
    set th [expr {atan(1)*6}]
    for {set i 0} {$i<$n} {incr i} {
        lappend res \
            [expr {$xm+$rx*cos($th)}] \
            [expr {$ym+$ry*sin($th)}]
        set th [expr {$th+$step}]
    }
    set res
}
proc oval {w x0 y0 x1 y1 args} {
    eval $w create poly [rp $x0 $y0 $x1 $y1] $args
}
#--------------
main
wm geometry . 236x268+0+0
Category Games