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 add variable ::wordview write {.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