set about "Gallows.tcl
R. Suchenwirth 2003
Powered by Tcl/Tk!
Click on a black letter to see if it occurs in the word to be guessed.
If not, the gallows grow by one part, and you lose 1 score.
Win 1 score per guessed letter, and 10 per guessed word."
package require Tk
set words0 {
computer mouse keyboard printer
school teacher book pencil
elephant crocodile giraffe rhinoceros
telephone toaster bathtub
hospital "city hall" "gas station"
}
proc main {} {
frame .f
label .f.score -width 20 -textvar score
button .f.about -text About -command {tk_messageBox -message $about}
button .f.reset -text Reset -command {reset .c all}
button .f.x -text X -command exit
eval pack [winfo children .f] -side left
canvas .c
drawGallows .c
set font {Tahoma 11 bold}
.c create text 110 150 -tag word -font $font
trace var ::wordview w {.c itemconfig word -text $::wordview ;#}
drawKeyboard .c $font
pack .f .c -fill x
wm geometry . 232x268+0+0
reset .c all
}
proc drawGallows w {
set n 0
foreach line {
{50 120 50 20} {50 20 110 20}
{50 50 80 20} {110 20 110 50}
{105 50 110 45 115 50 110 60 105 50}
{110 60 110 90}
{90 80 110 60} {110 60 130 80}
{90 110 110 90} {110 90 130 110}
} {
$w create line $line -tag "gallows g[incr n]"
}
}
proc drawKeyboard {w font} {
set x 16; set y 200
foreach letter {
A B C D E F G H I J K L M
N O P Q R S T U V W X Y Z} {
$w create text $x $y -text $letter -tag ltr -font $font
if {[incr x 16] > 220} {
set x 16; incr y 24
}
}
$w bind ltr <1> {selected %W}
}
proc selected w {
set id [$w find withtag current]
if {[$w itemcget $id -fill] != "black"} return
lappend ::selected [$w itemcget $id -text]
set howmany [viewWord $w]
if {$howmany==0} {
missed $w
$w itemconfig $id -fill red
incr ::score -1
} else {
$w itemconfig $id -fill white
incr ::score $howmany
}
}
proc missed w {
global nmissed word wordview
incr nmissed
$w itemconfig g$nmissed -fill red
if {$nmissed>=10} {
set wordview [split $word ""]
after 2000 "reset $w"
}
}
proc reset {w {all ""}} {
$w itemconfig ltr -fill black
$w itemconfig gallows -fill white
set ::selected ""
set ::wordview ""
set ::nmissed 0
if {$all != ""} {
set ::words [string toupper $::words0]
set ::score 0
set ::t0 [clock seconds]
}
pickWord $w
}
proc pickWord w {
global word words t0
set lwords [llength $words]
if {$lwords==0} {
set sec [expr [clock sec]-$t0]
set n [llength $::words0]
tk_messageBox -title Congratulations \
-message "You made it!
$n words in $sec seconds
Average: [format %.2f [expr $sec/$n.]]"
return
}
set pos [expr int(rand()*$lwords)]
set word [lindex $words $pos]
set words [lreplace $words $pos $pos]
viewWord $w
}
proc viewWord w {
global word selected wordview
set before [count _ $wordview]
set wordview ""
set hit 0
foreach char [split $word ""] {
if {$char!=" " && [lsearch $selected $char]<0} {
set char _
}
append wordview "$char "
}
set todo [count _ $wordview]
if {$todo==0} {celebrate $w}
expr $before-$todo
}
proc count {what list} {
set n 0
foreach i $list {incr n [expr {$i==$what}]}
set n
}
proc celebrate w {
incr ::score 10
$w itemconfig word -fill green
after 1000 $w itemconfig word -fill black
after 1500 reset $w
}
mainTV Nice. Good interaction. - RS: Yes - my 13-yo daughter snatched it out of my hand when she saw it, and played right away without needing explanations ;-)
