if 0 {[Richard Suchenwirth] 2003-07-01 - Yet another Tcltoy, runnable on [PocketPC] and elsewhere: a word-guessing game, where you propose letters and have to succeed before you're fully on the gallows. Adjust the word list ''words0'' to your likings. [http://mini.net/files/gallows.jpg] } 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." 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 } main ---- [TV] 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 ;-)