##+##########################################################################
 #
 # 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