[Keith Vetter] 2006-05-09 : Here's a version of the Black Box. As wikipedia says [http://en.wikipedia.org/wiki/Black_Box_%28game%29], ''Black Box is a game of''
hide and seek ''which simulates shooting rays into a black box to deduce the
location of balls hidden inside. It game was invented by Eric 
Solomon[http://www.ericsolomon.co.uk/].''

One nice feature of this version is the ability to mark whole regions as
not being possible ball locations. You do this by moving the mouse while
holding down the right button.

I find that for the normal level of difficulty, a score over 20 is good.


----
 ##+##########################################################################
 #
 # blackbox.tcl -- Plays the black box game
 # by Keith Vetter, May 2006
 #
 package require Tk
 
 array set S {title "Black Box" iw 26 ih 26 lvl Normal Easy {6 6 3}
    Normal {8 8 4} Hard {10 10 7} fg yellow bg gray30 clr1 black clr2 gray40}
 foreach {S(w) S(h) S(n)} $S($S(lvl)) break
 image create photo ::img::atom -data {
    R0lGODlhGAAYALMAAPwODPyOjPxSVPw2PAT+BPyqrPxqbPwiJPyanPx+fPxCRAAAd9CgAAfqABYS
    AAAAACH5BAEAAAQALAAAAAAYABgAAwSvkMgpi70I0b3D/UWWcBuIWBkSrGSFhekaJDT5pZlM04ZR
    hjCVbMbrGQQTDyo33BmPAoUL1nT2BFiFYkC4CYnFa3RAHmCYzoR4PDgcAOfVTm2Mbttv+FIexo7d
    eXohOnR1AmVuAIpUYHVHWluJigAJfIVrd3iSYIV+CnaIgQAEl1B2mZqJEoZZqKmBE6ZaZW2vgBug
    oYC7byS0vAC7wS0EmpPHbwfEEpLHx8sbzqMtEQA7}
 image create photo ::img::badAtom -data {
    R0lGODlhGgAaALMAAAD/AISGhERCRMzOzCQiJKymrGRiZOzq7DQ2NFRWVJSWlLS2tNza3HRudPT2
    9CQmJCH5BAEAAAAALAAAAAAaABoAAwTVEMhJn0hJPMq7fM3COOTBLA3hdc1IvqUzNOtUwPh7HEq9
    5IfYbljw3HSw4HDZozRyDmV0yTAdDJOHKyncVa0nFeCJUy6HVYaagQX8kOZzes3oactTuUk9YAwW
    BAJBcHp0awMDCAlJcWlgfIiIF0BnXnR9kQKCJVRej35+iAsId3Foloehfyo3lXOGoJFNDZ5ge5eq
    iAkfC6ewfLGIBWIABp6/sbm7FAG/mMGRAUbAyZiRA00ezcDX3dI1xQWRucLL4AAEBgoLC6ILCgnE
    5xMECJoI8h0RADs=}
 image create photo ::img::xAtom -data {
    R0lGODlhGAAYALMAAPwODAT+BPxSVPyOjPw2PPz+/PxqbPyqrPwiJPx+fPyanPxCRFCgABnqABYS
    AAAAACH5BAEAAAEALAAAAAAYABgAAwSwMIQi67lYqTqpLKA0YOShJV0IrqVyacowrHT9mrA8118N
    a7pEzdOjxXQDYU1QGQ2RSppAsJBghonskLogBEgK7LZLKGc0wyUZgQCcZWnQYt12v45RaZddt5uC
    aQJlBGwAhjgyWnF7fQAJiYpxBYR8hklZeXJDhYYAAQkGBkNzC5uFEqGjgwRDnRVDqwiEm681g3x8
    Q0UrZbhtuTy2lZ2dbborEpzExClERBXLnhwhAREAOw==}
 image create photo ::img::cross -data {
    R0lGODlhGgAaALMAAAQCBFxaXHx+fGxubJSalCQiJIyOjGRiZISGhAwODHR6dISChHRydJyenCQm
    JGRmZCH5BAEAAAAALAAAAAAaABoAAwTX8MhJq73zSf26Pxq2HUBpnigQUtxRpGnxsd0wvHBZDN5K
    1jZczMZ7ACiA3YDBUAhNBQUzeJzolgqFwHFyCLKMWylk1GUFiwUX4Eh/nSYkFL1AGBwBA2IhEDzJ
    KF52BgQGhntrJg8BICkOhgSRhXcpgI6RDQ2RiSeWKAGYmgQBMJ4mCZCShgmVG4F1qYcLTyquc2l2
    eAh7fE9ySU19aiUJfG9ClgVMZ5xeYGJVEkkPS020SVJhYisqRNBDNh3RIDUP1ydKMxkd5ygyHRdl
    Oa0iIz3wPvX6IhEAOw==}
 image create photo ::img::blank -width $S(iw) -height $S(ih)
 
 ##+##########################################################################
 # 
 # DoDisplay -- creates our gui
 # 
 proc DoDisplay {} {
    global S
 
    font create boldFont -family Helvetica -size 10 -weight bold
    option add *highlightThickness 0
 
    wm title . $S(title)
    wm resizable . 0 0
    DoMenus
    frame .l -padx 10 -pady 10 -bg $S(bg)
    frame .c -padx 10 -pady 10 -bg $S(bg)
    #canvas .c -bg $S(bg)
    #. config -padx 10 -pady 10 -bg $S(bg)
    pack .l .c -side left -fill both
 
    label .l.title -text "Black\nBox" -font {Times 24 bold} -fg $S(fg) -bg $S(bg)
    label .l.lscore -text "Score:" -font {Times 12 italic} -fg $S(fg) -bg $S(bg)
    label .l.score -textvariable ::B(score) -font {Helvetica 24 bold italic} \
        -fg $S(fg) -bg $S(bg)
    
    frame .l.atoms -bg $S(bg)
    label .l.reveal -text "Reveal?" -font {Times 12 bold} -fg $S(fg) -bg $S(bg)
    bind .l.reveal <1> Reveal
    label .l.again -text "Again?" -font {Times 12 bold} -fg $S(fg) -bg $S(bg)
    bind .l.again <1> NewGame
    pack .l.title -side top
    pack .l.lscore -side top -pady {20 0}
    pack .l.score -side top
    pack .l.atoms -side bottom -fill both
    DrawBoard
    FillAtoms
    
    bind all <Key-F1> Help
    bind all <Key-F2> NewGame
    bind all <Key-F3> {console show}
 }
 ##+##########################################################################
 #
 # DoMenus -- isn't installing menus really verbose and clunky?
 #
 proc DoMenus {} {
    option add *Menu.tearOff 0
 
    . config -menu [menu .menu]
 
    menu .menu.game
    .menu add cascade -label "Game" -underline 0 -menu .menu.game
    .menu.game add command -label "New Game" -command NewGame -underline 0 \
        -accelerator "F2"
    .menu.game add separator
    .menu.game add cascade -label "Level" -menu .menu.game.lvl -underline 0
    menu .menu.game.lvl
    foreach lev [list "Easy" "Normal" "Hard"] {
        .menu.game.lvl add radio -label "$lev" \
            -variable ::S(lvl) \
            -value $lev \
            -underline 0 \
            -command Resize
    }
    
    .menu.game add separator
    .menu.game add command -label "Exit" -underline 1 -command exit
 
    menu .menu.help
    .menu add cascade -label "Help" -underline 0 -menu .menu.help
    .menu.help add command -label "Help" -underline 0 -command Help \
        -accelerator "F1"
    .menu.help add command -label "About" -underline 0 -command About
 }
 
 proc Resize {} {
    global S
 
    foreach {S(w) S(h) S(n)} $S($S(lvl)) break
    DrawBoard
    FillAtoms
    NewGame
 }
 ##+##########################################################################
 # 
 # FillAtoms -- creates GUI which shows how many atoms are left to place
 # 
 proc FillAtoms {} {
    global S
    
    eval destroy [winfo child .l.atoms]
    set row 0
    set col 0
    for {set i 0} {$i < $S(n)} {incr i} {
        label .l.atoms.$i -image ::img::atom -width $S(iw) -height $S(ih) \
            -bg $S(bg)
        grid .l.atoms.$i -row $row -column $col
        if {[incr col] == 2} {
            incr row
            set col 0
        }
    }
 }
 ##+##########################################################################
 # 
 # UpdateAtoms -- updates GUI to show how many more atoms need placing
 # 
 proc UpdateAtoms {} {
    global S B
 
    set num [llength $B(where)]
    for {set i 0} {$i < $S(n)} {incr i} {
        set img [expr {$i < $num ? "::img::blank" : "::img::atom"}]
        .l.atoms.$i config -image $img
    }
    place forget .l.reveal
    place forget .l.again
    if {$num == $S(n)} {
        place .l.reveal -relx .5 -rely 1 -anchor s
    }
 }
 proc DrawBoard {} {
    global S
    
    eval destroy [winfo child .c]
 
    set S(w1) [expr {$S(w)+1}]
    set S(h1) [expr {$S(h)+1}]
    set S(w2) [expr {$S(w)+2}]
    set S(h2) [expr {$S(h)+2}]
    
    for {set row 0} {$row < $S(h2)} {incr row} {
        grid rowconfigure .c $row -pad 0
        for {set col 0} {$col < $S(w2)} {incr col} {
            grid columnconfigure .c $col -pad 0
            if {$row == 0 || $row > $S(h) || $col == 0 || $col > $S(w)} {
                if {($row == 0 || $row > $S(h)) &&
                    ($col == 0 || $col > $S(w))} continue
                label .c.g$row,$col -image ::img::blank \
                    -width $S(iw) -height $S(ih) \
                    -bg $S(clr2) -relief raised -bd 2 \
                    -compound center -font boldFont
                bind .c.g$row,$col <1> [list Ray $row $col]
                grid .c.g$row,$col -row $row -column $col
            } else {
                label .c.b,$row,$col -image ::img::blank \
                    -width $S(iw) -height $S(ih) \
                    -bg $S(clr1) -relief raised -bd 2
                bind .c.b,$row,$col <1> [list Click $row $col]
                bind .c.b,$row,$col <ButtonPress-3> [list RClick down $row $col]
                bind .c.b,$row,$col <B3-Motion> [list RClick move %X %Y]
 
                grid .c.b,$row,$col -row $row -column $col -sticky news
            }
        }
    }
    grid rowconfigure .c [list 0 $S(h1)] -pad 10
    grid columnconfigure .c [list 0 $S(w1)] -pad 10
 }
 ##+##########################################################################
 # 
 # Reset -- resets all data structures and GUI
 # 
 proc Reset {} {
    global B S
 
    array unset B
    set B(where) {}
    set B(atoms) {}
    set B(rays) 0
    set B(ray,id) 0
    set B(score,base) [expr {2*($S(w)+$S(h))}]
    set B(score) "[expr {$B(score,base)-$B(rays)}]-?"
 
    # Reset board data and board display
    for {set row 1} {$row <= $S(h)} {incr row} {
        for {set col 1} {$col <= $S(w)} {incr col} {
            set B(b,$row,$col) 0
            .c.b,$row,$col config -image ::img::blank -bg $S(clr1)
        }
    }
 
    # Reset arrow buttons
    foreach row [list 0 [expr {$S(h)+1}]] {
        set ch [expr {$row == 0 ? "\u25bc" : "\u25b2"}]
        for {set col 1} {$col <= $S(w)} {incr col} {
            set B(r,$row,$col) 0
            .c.g$row,$col config -text $ch -fg black
        }
    }
    foreach col [list 0 [expr {$S(w)+1}]] {
        set ch [expr {$col == 0 ? "\u25ba" : "\u25c4"}]
        for {set row 1} {$row <= $S(h)} {incr row} {
            set B(r,$row,$col) 0
            .c.g$row,$col config -text $ch -fg black
        }
    }
    UpdateAtoms
 }
 ##+##########################################################################
 # 
 # Click -- handles clicking on the grid to place an atom
 # 
 proc Click {row col} {
    global B S
 
    if {$B(state) ne "play"} return
    set cell "b,$row,$col"
    if {$B($cell) & 2} {                        ;# Already placed an atom
        set B($cell) [expr {$B($cell) & 1}]     ;# Clear 
        .c.$cell config -image ::img::blank
        set n [lsearch $B(where) $cell]
        set B(where) [lreplace $B(where) $n $n]
    } else {                                    ;# Empty location
        if {[llength $B(where)] < $S(n)} {
            set B($cell) [expr {($B($cell) & 1) | 2}] ;# Clear and set
            .c.$cell config -image ::img::atom
            lappend B(where) $cell
        }
    }
    UpdateAtoms
 }
 ##+##########################################################################
 # 
 # _RClick -- handles toggling the X in square row,col
 # 
 proc _RClick {row col} {
    global B S
 
    if {$B(state) ne "play"} return
    set cell "b,$row,$col"
    if {$B($cell) & 4} {                        ;# User cross
        set B($cell) [expr {$B($cell) & 1}]     ;# Clear 
        .c.$cell config -image ::img::blank
    } else {
        if {$B($cell) & 2} {                    ;# Was there an atom there?
            set n [lsearch $B(where) $cell]
            set B(where) [lreplace $B(where) $n $n]
        }
        set B($cell) [expr {($B($cell) & 1) | 4}] ;# Clear and set
        .c.$cell config -image ::img::cross
    }
    UpdateAtoms
 }
 ##+##########################################################################
 # 
 # RClick -- handles right click and possible sweeping motion
 # 
 proc RClick {how r c} {
    global B
    
    if {$B(state) ne "play"} return
    if {$how eq "down"} {
        set cell "b,$r,$c"
        set B(onoff) [expr {! ($B($cell) & 4)}] ;# How we want the cell to be
        _RClick $r $c
    } elseif {$how eq "move"} {
        set w [winfo containing $r $c]
        if {! [winfo exists $w]} {
            puts "move: ?"
            return
        }
        scan $w ".c.b,%d,%d" r c
        set cell "b,$r,$c"
        if {! [info exists B($cell)]} return
        set isX [expr {$B($cell) & 4}]
        if {$B(onoff) && ! $isX} { _RClick $r $c }
        if {! $B(onoff) && $isX} { _RClick $r $c }
    }
 }
 
 ##+##########################################################################
 # 
 # Ray -- Handles firing a ray into the black box
 # 
 proc Ray {row col} {
    global B S
 
    if {$B(state) ne "play"} return
    if {$B(r,$row,$col) != 0} return            ;# Already fired
 
    set drow [expr {$row == 0 ? 1 : $row > $S(h) ? -1 : 0}]
    set dcol [expr {$col == 0 ? 1 : $col > $S(w) ? -1 : 0}]
    set what [ShootRay $row $col $drow $dcol]
 
    if {$what eq "A" || $what eq "R"} {
        .c.g$row,$col config -image ::img::blank -text $what -fg $S(fg)
        set B(r,$row,$col) $what
        incr B(rays)
    } else {
        foreach {r c} $what break
        set B(r,$row,$col) [incr B(ray,id)]
        set B(r,$r,$c) $B(ray,id)
        .c.g$row,$col config -image ::img::blank -text $B(ray,id) -fg $S(fg)
        .c.g$r,$c config -image ::img::blank -text $B(ray,id) -fg $S(fg)
        incr B(rays) 2
    }
    set B(score) "[expr {$B(score,base)-$B(rays)}]-?"
 }
 ##+##########################################################################
 # 
 # ShootRay -- does the actual ray tracing
 # 
 proc ShootRay {row col drow dcol} {
    global B S
 
    set B(path) [list $row $col]
    while {1} {
        set r [expr {$row + $drow}]             ;# Next position
        set c [expr {$col + $dcol}]
        lappend B(path) $r $c
        if {[OffBoard $r $c]} {return [list $r $c]} ;# Did we exit???
 
        if {$B(b,$r,$c) & 1} { return "A" }     ;# Did we hit something
 
        set r1 [expr {$r - abs($dcol)}]         ;# Check for detours
        set r2 [expr {$r + abs($dcol)}]
        set c1 [expr {$c - abs($drow)}]
        set c2 [expr {$c + abs($drow)}]
 
        set corner1 [expr {! [OffBoard $r1 $c1] && ($B(b,$r1,$c1) & 1)}]
        set corner2 [expr {! [OffBoard $r2 $c2] && ($B(b,$r2,$c2) & 1)}]
        
        if {! $corner1 && ! $corner2} {         ;# Missed
            foreach row $r col $c break         ;# Move forward
            continue
        }
        if {$corner1 && $corner2} { return "R" };# Double hit
        if {[OffBoard $row $col]} { return "R" } ;# Edge corner hit
 
        # Turn a corner
        set B(path) [lrange $B(path) 0 end-2]
        set tmp [expr {$corner1 ? abs($dcol) : -abs($dcol)}]
        set dcol [expr {$corner1 ? abs($drow) : -abs($drow)}]
        set drow $tmp
    }
 }
 
 proc Path2XY {} {
    global B S
 
    set xy {}
    foreach {r c} $B(path) {
        set cell .c.b,$r,$c
        if {[OffBoard $r $c]} { set cell .c.g$r,$c}
        set x [expr {[winfo x $cell] + $S(iw)/2}]
        set y [expr {[winfo y $cell] + $S(ih)/2}]
        lappend xy $x $y
    }
    return $xy
 }
 
 proc OffBoard {row col} {
    return [expr {$row == 0 || $row > $::S(h) || $col == 0 || $col > $::S(w)}]
 }
 ##+##########################################################################
 # 
 # PlaceAtoms -- hides cnt atoms in our black box
 # 
 proc PlaceAtoms {cnt} {
    global B
 
    set B(atoms) {}
    set all [array names B b,*]
    while {$cnt} {
        set n [expr {int(rand() * [llength $all])}]
        set cell [lindex $all $n]
        set B($cell) 1
        lappend B(atoms) $cell
        set all [lreplace $all $n $n]
        incr cnt -1
    }
 }
 ##+##########################################################################
 # 
 # Reveal -- show where the atoms are hidden
 # 
 proc Reveal {} {
    global B S
 
    if {$B(state) ne "play"} return
    
    # good guessed => yellow bg
    # bad guess => xAtom image
    # missing guess => badAtom image
 
    set B(state) done
    set misses 0
    foreach cell $B(atoms) {
        if {[lsearch $B(where) $cell] != -1} {  ;# Correctly found
            .c.$cell config -bg $S(fg)
        } else {
            .c.$cell config -image ::img::badAtom
            incr misses 5
        }
    }
 
    foreach cell $B(where) {
        if {[lsearch $B(atoms) $cell] != -1} continue ;# Correctly found
        .c.$cell config -image ::img::xAtom
    }
    place forget .l.reveal
    place .l.again -relx .5 -rely 1 -anchor s
 
    set B(score) [expr {$B(score,base)-$B(rays)-$misses}]
 }
 ##+##########################################################################
 # 
 # NewGame -- starts a new game
 # 
 proc NewGame {} {
    global B S
    
    Reset
    set B(state) "play"
    PlaceAtoms $S(n)
    set B(state) play
 }
 ##+##########################################################################
 #
 # About -- tell something about us
 #
 proc About {} {
    set txt "$::S(title)\n\nby Keith Vetter\nMay, 2006"
    tk_messageBox -icon info -message $txt -title "About $::S(title)"
 }
 ##+##########################################################################
 #
 # Help -- a simple help screen
 #
 proc Help {} {
    catch {destroy .help}
    toplevel .help
    wm title .help "$::S(title) Help"
    #wm geom .help "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
 
    set t .help.t
    text $t -relief raised -wrap word -width 70 -height 31 \
        -padx 10 -pady 10 -cursor {} -yscrollcommand {.help.sb set}
    scrollbar .help.sb -orient vertical -command [list $t yview]
    button .help.dismiss -text Dismiss -command {destroy .help}
    pack .help.dismiss -side bottom -pady 10
    pack .help.sb -side right -fill y
    pack $t -side top -expand 1 -fill both
 
    set bold "[font actual [$t cget -font]] -weight bold"
    set italic "[font actual [$t cget -font]] -slant italic"
    $t tag config title -justify center -foregr red -font "Times 20 bold"
    $t tag configure title2 -justify center -font "Times 12 bold"
    $t tag configure header -font $bold -spacing3 5
    $t tag configure bold -font $bold
    $t tag configure italic -font $italic
    $t tag configure n -lmargin1 10 -lmargin2 10
    $t tag configure bullet -lmargin1 20 -lmargin2 30
 
    $t insert end "$::S(title)\n" title "by Keith Vetter\n\n" title2
 
    set txt "$::S(title) is a game of \"hide and seek\" which simulates "
    append txt "shooting electron rays into a black box to try and deduce "
    append txt "the locations of various atoms hidden inside. It was "
    append txt "invented by Eric Solomon "
    append txt "(http://www.ericsolomon.co.uk/).\n\n"
    $t insert end "Introduction\n" header $txt
    
    set txt "Each ray fired into the black box reveals some "
    append txt "information about the location of the hidden atoms."
    append txt "The rays interact with the atoms in three ways.\n\n"
    $t insert end "Rules\n" header $txt
    
    set txt "A ray which directly hits an atom is absorbed "
    append txt "and doesn't emerge from the box. This is marked by an \"A\"\n"
    $t insert end \u25cf bullet " Absorption: " bold $txt bullet
    set txt "A ray which passes directly to the side "
    append txt "of one atom is deflected by 90 degrees before continuing on. "
    append txt "This is marked by labelling the entry and exit points "
    append txt "with the same id.\n"
    $t insert end \u25cf bullet " Deflection: " bold $txt bullet
    set txt "A reflection can occur in two ways, either by "
    append txt "a ray being deflected twice simultaneously, or "
    append txt "by a ray aimed directly beside an atom located at the edge "
    append txt "of the grid. This is marked by an \"R\".\n\n"
    $t insert end \u25cf bullet " Reflection: " bold $txt bullet
 
    set txt "More complex paths can occur when a ray is deflected one "
    append txt "or more times before being absorbed, reflected or exiting "
    append txt "the grid.\n\n"
    $t insert end $txt
 
    $t insert end "How To Play\n" header
    set txt "\u25cf To fire an electron ray, click on edge square.\n"
    $t insert end $txt bullet
    set txt "\u25cf To place an atom in the box, click on any square "
    append txt "in the box. To remove it, click it again.\n"
    $t insert end $txt bullet
    set txt "\u25cf To X out a square, right-click on the square. "
    append txt "To remove it, right-click it again.\n"
    $t insert end $txt bullet
    set txt "\u25cf To X out multiple square, hold down the right button "
    append txt "and sweep out the area to X out. Repeating will clear it.\n\n"
    $t insert end $txt bullet
 
    set txt "Your score starts off with the number of possible rays. "
    append txt "You lose one point for every "
    append txt "ray entry and exit. You lose five points for every wrong "
    append txt "guess about an atom's location. Thus five rays are equal "
    append txt "to one missed atom."
    $t insert end "Scoring\n" header $txt
    $t config -state disabled
 }
 ################################################################
 
 DoDisplay
 NewGame
 
 return

----
[Category Games]