The Gallows game

Richard Suchenwirth 2003-07-01 - Yet another Tcltoy, runnable on PocketPC and elsewhere: a word-guessing game (also known as Hangman), where you propose letters and have to succeed before you're fully on the gallows. Adjust the word list words0 to your likings.

WikiDbImage 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."

 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
 }
 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 ;-)