Updated 2012-11-21 19:07:58 by pooryorick

During a hard disk cleanup I found an old (Tcl 7.6 / Tk 4.2) weekend fun program, MasterMind. I massaged it a bit to work with Tcl/Tk 8.4. A starkit (along with other starkits) can be found on my sons download page [1]. It's a german version, but I plan to internationalize it eventually (and remove the verbose random number generation). Have fun.

See also MasterMind 2 (I didn't know this page when I wrote that- RS).
#!/usr/local/bin/wish8.4

package require Tk

set color_tab(0) chocolate3
set color_tab(1) white
set color_tab(2) yellow
set color_tab(3) orange
set color_tab(4) red
set color_tab(5) green
set color_tab(6) blue
set color_tab(7) tan4
set color_tab(8) black

set act_color 1
set act_row 0

set spiel 1
set pkt 0
set total_pkt 0

set helptxt "
Mastermind ( Superhirn ):

   Setzen und Löschen von Farbpins:

    Mit der linken Maustaste auf das Feld klicken, auf
    das der Farbpin gesetzt werden soll.

    Mit der rechten Maustaste wird der Farbpin wieder
    entfernt.

    Beides funktioniert nur in Zeilen, die noch nicht
    bewertet wurden.

   Farbauswahl:

    Mit der linken Maustaste im Feld \"Farbauswahl\" auf
    die gewünschte Farbe klicken. Das angewählte Feld
    erscheint eingesunken.

   Bewertung:

    Mit der linken Maustaste auf den Knopf mit der
    Zeilennummer klicken. Der Knopf bleibt eingesunken.

    Rechts erscheint die Bewertung, erst die schwarzen,
    dann die weißen Bewertungspins.

    Weiß bedeutet, daß die Farbe eines Pins des Geheim-
    codes richtig erraten wurde.

    Schwarz bedeutet, daß Farbe und Position eines Pins
    des Geheimcodes richtig erraten wurde.

   Spielende:

    Wenn alle Pins richtig gesetzt wurden (fünf schwarze
    Bewertungspins) oder in der zwölften Reihe der
    Geheimcode nicht erraten wurde, ist das Spiel zu Ende.

    Im oberen Anzeigefeld wird der Geheimcode aufgedeckt
    und die neue Gesamtpunktzahl angezeigt.

    Die Punktzahl ist die Anzahl Reihen, die benötigt
    wurden, um den Geheimcode zu entschlüsseln. Wurde
    der Geheimcode nicht erraten, werden 15 Punkte
    gezählt.

   Hilfe/Weiter/Ende:

    Beim Anklicken des grauen Hilfe-Knopfes erscheint
    diese Hilfe.

    Beim Anklicken des grünen Weiter-Knopfes wird das
    Spielfeld in den Anfangszustand versetzt, die Spiel-
    nummer um 1 erhöht und die Punktzahl auf 0 gesetzt.

    Beim Anklicken des roten Ende-Knopfes wird das Spiel
    abgebrochen.
"

frame .dsp -bg $color_tab(0) -bd 3 -relief groove
frame .field -bg $color_tab(0) -bd 3 -relief groove
frame .panel -bg $color_tab(0) -bd 3 -relief groove

pack .dsp .field .panel -fill x -padx 1m -pady 1m

frame .dsp.ft -bg $color_tab(0)
frame .dsp.fc -bg $color_tab(0)

pack .dsp.ft .dsp.fc -pady 1m -fill x

label .dsp.ft.spl -text "Spiel:" -bg $color_tab(0)
label .dsp.ft.spn -textvariable spiel -bg $color_tab(0) -width 2
label .dsp.ft.pktl -text "Punkte:" -bg $color_tab(0)
label .dsp.ft.pktn -textvariable pkt -bg $color_tab(0) -width 3
label .dsp.ft.tpl -text "Gesamt:" -bg $color_tab(0)
label .dsp.ft.tpn -textvariable total_pkt -bg $color_tab(0) -width 4

pack .dsp.ft.spl .dsp.ft.spn .dsp.ft.pktl .dsp.ft.pktn .dsp.ft.tpl .dsp.ft.tpn  -side left -padx 1m -fill x

label .dsp.fc.lbl -relief flat -width 2 -bg $color_tab(0)

pack .dsp.fc.lbl -side left -padx 2m

for {set n 0} {$n < 5} {incr n} {
     frame .dsp.fc.n$n -bg $color_tab(0)  -relief sunken -bd 3 -width 6m -height 6m
     pack .dsp.fc.n$n -side left -padx 1m
}

. configure -bg $color_tab(0)

wm title . "Superhirn"
wm resizable . 0 0

proc init_array {} {
    global pin_array aim_array
    for {set col 0} {$col < 5} {incr col} {
        set aim_arry($col) 0
        for {set row 1} {$row < 13} {incr row} {
            set pin_array($row,$col) 0
        }
    }
}

proc choose_combination {} {
    global aim_array
    for {set n 0} {$n < 5} {incr n} {
        set aim_array($n) 0
        }
    set seed [expr [clock clicks] % 107520]
    set ptr 0
    while {$ptr < 5} {
       set seed [expr (24298 * $seed + 99991) % 199017]
       set rand [expr int($seed * 8 / 199017) + 1]
       set coll 0
       for {set n 0} {$n < $ptr} {incr n} {
         if {$rand == $aim_array($n)} {
            set coll 1
            break
            }
         }
       if {$coll} {continue}
       set aim_array($ptr) $rand
       #set_color_pin 12 $ptr $aim_array($ptr)
       incr ptr
       }
}

proc next_game {} {
    global color_tab act_row spiel pkt
    for {set n 0} {$n < 5} {incr n} {
        .dsp.fc.n$n configure -bg $color_tab(0) -relief sunken
    }
    for {set row 1} {$row < 13} {incr row} {
        .field.fr$row.nr$row configure -relief raised
        for {set col 0} {$col < 5} {incr col} {
            .field.fr$row.fc$row.colbut${row}x$col configure  -bg $color_tab(0) -relief sunken
            .field.fr$row.fa$row.colans${row}x$col configure  -bg $color_tab(0) -relief sunken
        }
    }
    set act_row 0
    incr spiel
    set pkt 0
    choose_combination
}

proc calc_result {row} {
    global pkt total_pkt aim_array color_tab
    incr pkt $row
    incr total_pkt $row
    for {set n 0} {$n < 5} {incr n} {
        .dsp.fc.n$n configure -bg $color_tab($aim_array($n)) -relief raised
    }
}

proc set_color_pin {row col clr} {
    global color_tab act_row pin_array
    if {$row > $act_row} {
        .field.fr$row.fc$row.colbut${row}x$col configure -relief raised  -bg $color_tab($clr)
        set pin_array($row,$col) $clr
    }
}

proc reset_color_pin {row col} {
    global color_tab act_row pin_array
    if {$row > $act_row} {
        .field.fr$row.fc$row.colbut${row}x$col configure -relief sunken  -bg $color_tab(0)
        set pin_array($row,$col) 0
    }
}

proc set_answer_pin {row col clr} {
    if {$clr == 1} {
        .field.fr$row.fa$row.colans${row}x$col configure -relief raised  -bg white
    } else {
       .field.fr$row.fa$row.colans${row}x$col configure -relief raised  -bg black
    }
}

proc answer {row} {
    global act_row pin_array aim_array
    if {[expr $row - $act_row] == 1} {
        .field.fr$row.nr$row configure -relief sunken
        incr act_row
    }
    set whities 0
    set blackies 0
    for {set n 0} {$n < 5} {incr n} {
        set hit 0
        for {set i 0} {$i < 5} {incr i} {
            if {$pin_array($row,$i) == $aim_array($n)} {
                set hit 1
                if {$n == $i} {
                    set hit 2
                    break
                }
            }
        }
        if {$hit == 1} {
            incr whities
        } elseif {$hit == 2} {
            incr blackies
        }
    }
    set col 0
    for {set n 0} {$n < $blackies} {incr n} {
        set_answer_pin $row $col 2
        incr col
    }
    for {set n 0} {$n < $whities} {incr n} {
        set_answer_pin $row $col 1
        incr col
    }
    if {$blackies == 5} {
        calc_result $act_row
        set act_row 15
    } elseif {$act_row == 12} {
        set act_row 15
        calc_result $act_row
    }
}

proc create_colors_row {row} {
    global color_tab
    frame .field.fr$row.fc$row -bg $color_tab(0)
    pack .field.fr$row.fc$row -side left -padx 1m
    for {set n 0} {$n < 5} {incr n} {
        frame .field.fr$row.fc$row.colbut${row}x$n -bg $color_tab(0)  -relief sunken -bd 3 -width 6m -height 6m
        pack .field.fr$row.fc$row.colbut${row}x$n -side left -padx 1m
        bind .field.fr$row.fc$row.colbut${row}x$n <Button-1> "
           set_color_pin $row $n \$act_color"
        bind .field.fr$row.fc$row.colbut${row}x$n <Button-3> "
           reset_color_pin $row $n"
    }
}

proc create_answer_row {row} {
    global color_tab
    frame .field.fr$row.fa$row -bg $color_tab(0)
    pack .field.fr$row.fa$row -side left -padx 1m
    for {set n 0} {$n < 5} {incr n} {
        frame .field.fr$row.fa$row.colans${row}x$n -bg $color_tab(0)  -relief sunken -bd 3 -width 4m -height 4m
        pack .field.fr$row.fa$row.colans${row}x$n -side left -padx 1m -pady 1m
    }
}

proc create_row {row} {
    global color_tab
    frame .field.fr$row -bg $color_tab(0)
    pack .field.fr$row -side bottom -fill x -padx 1m -pady 1m
    label .field.fr$row.nr$row -bg $color_tab(0) -text $row   -relief raised -width 2 -bd 2
    pack .field.fr$row.nr$row -side left -padx 1m
    bind .field.fr$row.nr$row <Button-1> "answer $row"
    create_colors_row $row
    create_answer_row $row
}

#
# read help text
#
proc readhelp {} {
    global helptxt
    # set ht [open [file join $::starkit::topdir help help.txt] r]
    # while { ! [eof $ht] } {
    #       .help.f.help insert end [gets $ht]
    #       .help.f.help insert end "\n"
    #       }
    .help.f.help insert end $helptxt
}

#
# show help window
#
proc help {} {
    toplevel .help
    wm title .help "Mastermind Hilfe"
    frame .help.f
    text .help.f.help -width 62 -setgrid 1 -wrap word  -yscrollcommand {.help.f.scr set}  -highlightthickness 0
    scrollbar .help.f.scr -command {.help.f.help yview}  -highlightthickness 0
    button .help.dis -text "Hilfe beenden" -command {destroy .help}  -highlightthickness 0
    pack .help.f
    pack .help.dis -fill x
    pack .help.f.help -side left
    pack .help.f.scr -side left -fill y
    readhelp
    .help.f.help configure -state disabled
}

proc create_color_choice {} {
    global color_tab act_color
    label .panel.lbl -text "Farbauswahl:" -bg $color_tab(0) -anchor w
    frame .panel.colors -bg $color_tab(0)
    pack .panel.lbl .panel.colors -padx 2m -pady 1m
    for {set n 1} {$n < 9} {incr n} {
        frame .panel.colors.c$n -bg $color_tab($n) -bd 3  -width 8m -height 8m
        bind .panel.colors.c$n <Button-1> "
           .panel.colors.c\$act_color configure -relief flat
           .panel.colors.c$n configure -relief sunken
           set act_color $n"
        pack .panel.colors.c$n -side left -padx 1m
    }
    frame .panel.but -bg $color_tab(0) -bd 3 -relief groove
    pack .panel.but -fill x -expand 1 -padx 1m -pady 1m
    button .panel.but.help -text "Hilfe" -command help  -bg gray80 -activebackground gray85 -bd 2  -highlightthickness 0
    button .panel.but.next -text "Weiter" -command next_game  -bg green2 -activebackground green -bd 2  -highlightthickness 0
    button .panel.but.exit -text "Ende" -command {destroy .}  -bg red2 -activebackground red -bd 2  -highlightthickness 0
    pack .panel.but.help .panel.but.next .panel.but.exit  -side left -padx 1m -pady 1m -fill x -expand 1
}

for {set n 1} {$n <= 12} {incr n} {
    create_row $n
}

create_color_choice
.panel.colors.c1 configure -relief sunken
init_array
choose_combination