lexfiend - Thanks, Keith! Brings back a lot of childhood memories. 8-)
LV (I hope firefox doesn't mangle the code on this page...) When I download this page, I'm not getting the left and right arrows displaying - instead, the unicode ascii representation is appearing. I wonder what font I need for those? The up and down arrows are appearing correctly.KPV I'm using the unicode characters \u25bc, \u25b2, \u25ba and \u25c4 for the arrows. Perhaps your default font don't have these characters. On my Windows system, the font is Arial.
##+##########################################################################
#
# 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