[Keith Vetter] 2007-02-09 : Artificial intelligence in Tcl? 
Here's a program that 
while I wouldn't call intelligent it clearly does a 
task which for humans requires intelligence--solving
logic problems. I guess that qualifies as weak AI
[http://en.wikipedia.org/wiki/Weak_AI].

Anyway, recently I received the fun book ''Challenging Logic Puzzles'' by
Barry R. Clarke
[http://www.amazon.com/Challenging-Logic-Puzzles-Mensa-Clarke/dp/1402705417/sr=1-1/qid=1170993886/ref=sr_1_1/104-4625890-2573534].

Many of the puzzles in the book are of the following format: several
rows of information organized into several columns categories such as name,
occupation, favorite food, etc. But for various (amusing) reasons, the
lists are scrambled such that one and only one item in each column is
in its correct position. Finally we're given a list of constraints
such as ''the person who eats ice cream is two place above the man in
the red shirt''. The goal is to unscramble the list.

Here's an example from the book: 
          Beating at Eating
     Name     Surname   Dessert
      Agatha   Greed     cream puffs
      Bugsy    Forager   trifle
      Delilah  Eatalot   cheesecake
      Chuck    Hunk      ice cream

   (short spiel about an eating contest and how the lists
    got messed up so that one and only one item in each column
    is correctly positioned)

   1) Chuck is one place above ice cream
   2) Trifle is not above Delilah
   3) Greed is two places below Delilah
   4) Trifle is one place above Forager.

Fun little puzzle, give it a try.

After solving a bunch of these, I decided to see if I could program
the computer to solve these types of problems. The approach I took is
to enumerate all possible solutions and test each one to see if it
matches all the conditions. There were two challenges. First is
to enumerate and test all possible combinations. [Permutations] 
helped with the enumeration and some fun coding help with the testing.

The bigger challenge was to make the process efficient. The number of 
possible solutions grows really fast: N rows of M columns yields
N!**M possibilities. A simple 4x3 puzzle has 13,824 possible
solutions, one 6x4 has 268,738,560,000. I found 3 ways to reduce
this number. First, throw out all possibilities not having exactly
one item correctly placed. Second, you can prune whole chunks of 
possibilities by noting that if a certain ordering of column A
fails some constraint then you don't need to test that ordering of A
with all the possible orderings of the other columns. Third, an
optimal reordering of the constraints can increase the likelihood of
big chunks being pruned.

How good were these optimations? Well a 5x4 puzzle originally took 
over thirteen minutes to solve now completes in three seconds 
(207,360,000 possible solutions reduced to 5,765).


The purpose of this program is to let you enter in puzzles of
this type and have the computer solve them. I've included a dozen 
samples from the book of varying complexity. Give a try at solving
them by hand then check out how well the program does.

----
 ##+##########################################################################
 #
 # LogicPuzzleSolver.tcl -- Solves one type of logic problems
 # by Keith Vetter, February 2007
 #
 
 package require Tk
 package require tile
 
 set S(title) "TCL Logic Puzzle Solver"
 array set PERMCNT {0 0 1 1 2 0 3 3 4 8 5 45 6 264 7 1855 8 14832 9 133497}
 set PLACES {xx first second third fourth fifth sixth seventh eighth
   ninth tenth eleventh twelfth thirteenth fourteenth fifteenth}
 
 proc DoDisplay {} {
   global S
 
   wm title . $S(title)
   label .tmp
   eval font create boldFont [font actual "[.tmp cget -font] bold"]
   font create bigBold -family Helvetica -size 18 -weight bold
   destroy .tmp
 
   frame .master -bd 0 -relief ridge -padx 10
   frame .const -bd 0 -relief ridge
   button .solve -text "Solve" -font boldFont -bd 5 -command Solve
   pack .master .const -side top -fill x -pady {0 30}
   pack .solve -side top -expand 1 -pady 15
   DoMenus
   DrawMaster
   DrawConstraints
 
   bind all <Key-Return> [bind all <Key-Tab>]
   bind all <Key-F2> {console show}
 }
 proc DoMenus {} {
   . configure -menu [menu .m -tearoff 0]
   .m add cascade -menu [menu .m.game  -tearoff 0] -label "Game" -underline 0
   .m add cascade -menu [menu .m.puzzle  -tearoff 0] -label "Puzzles" -underline 0
   .m add cascade -menu [menu .m.help  -tearoff 0] -label "Help" -underline 0
 
   .m.game add command -label "Load Puzzle" -under 0 -command LoadPuzzle
   .m.game add command -label "Save Puzzle" -under 0 -command SavePuzzle
   .m.game add separator
   .m.game add command -label "Blank Puzzle" -under 0 -command BlankDlg
   .m.game add separator
   .m.game add command -label "Exit" -under 1 -command exit
 
   set cnt -1
   foreach title [GetTitles] {
       incr cnt
       #.m.puzzle add command -label $title -command [list NewPuzzle $cnt]
       .m.puzzle add radiobutton -label $title -variable S(who) -value $cnt \
           -command [list NewPuzzle $cnt]
   }
   .m.help add command -label About -under 0 -command About
 }
 proc About {} {
   set txt "$::S(title)\nby Keith Vetter, February 2007\n\n"
   append txt "There's a class of logic puzzle in which\n"
   append txt "there is a grid of people and attributes.\n"
   append txt "We know that EXACTLY one attribute in\n"
   append txt "each column is positioned correctly.\n\n"
   append txt "Also in the puzzle are a set of constraints\n"
   append txt "on the items. For example, a typical one\n"
   append txt "might be \"Sally is 2 places below the\n"
   append txt "doctor\" or \"Bob is not the butcher.\"\n\n"
   append txt "This program lets you enter and solve\n"
   append txt "such logic puzzles."
   tk_messageBox -icon info -message $txt -title "About $::S(title)"
 }
 
 proc DrawMaster {} {
   global S MASTER
 
   set S(total) [expr {wide(pow($::PERMCNT($S(numElem)), $S(numCol)))}]
   set S(total,disp) "[Comma $S(total)] configurations"
 
   set W .master
   eval destroy [winfo child $W]
   entry $W.title -textvariable ::MASTER(title) -font bigBold -justify c
   frame $W.grid
   label $W.total -textvariable S(total,disp)
   label $W.help -fg red -font boldFont \
       -text "EXACTLY one item in each column is correctly positioned"
 
   pack $W.title $W.grid $W.help $W.total  -side top -fill both
 
   for {set col 0} {$col < $S(numCol)} {incr col} {
       entry $W.title,$col -textvariable ::MASTER(t,$col) \
           -justify c -font boldFont -relief solid
       grid $W.title,$col -row 0 -column $col -sticky ew -in $W.grid
   }
   for {set row 0} {$row < $S(numElem)} {incr row} {
       for {set col 0} {$col < $S(numCol)} {incr col} {
           entry $W.$row,$col -textvariable ::MASTER($row,$col) \
               -justify c -bd 1 -relief solid
           grid $W.$row,$col -row [expr {$row+1}] -column $col \
               -sticky news -in $W.grid
       }
   }
   trace remove variable MASTER write Tracer
   trace variable MASTER w Tracer
   Tracer MASTER {} w
 }
 
 proc DrawConstraints {} {
   global S C
 
   set names [GetMasterNames]
   set ops [GetOperations]
 
   set W .const
   eval destroy [winfo child $W]
   label $W.title -text Constraints -font bigBold -justify c
   frame $W.grid
   pack $W.title $W.grid -side top -fill both
 
   label $W.t,0 -text "Who" -font boldFont -justify c
   label $W.t,1 -text "Operation" -font boldFont -justify c
   label $W.t,2 -text "Whom" -font boldFont -justify c
   grid $W.t,0 $W.t,1 $W.t,2 -row 0 -sticky ew -in $W.grid
 
   for {set row 0} {$row < 10} {incr row} {
       set w1 $W.grid.$row,who
       set w2 $W.grid.$row,op
       set w3 $W.grid.$row,whom
 
       ::ttk::combobox $w1 -textvariable C($row,who) \
           -values $names -state readonly -justify c
       ::ttk::combobox $w2 -textvariable C($row,op) \
           -values $ops -state readonly -justify c
       ::ttk::combobox $w3 -textvariable C($row,whom) \
           -values $names -state readonly -justify c
       grid $w1 $w2 $w3 -row [expr {$row+1}]
   }
   trace remove variable C write Tracer
   trace variable C w Tracer
   Tracer C {} w
 }
 proc Tracer {var1 var2 op} {
   global C S MASTER
 
   set valid 1
 
   # MASTER tests
   for {set row 0} {$row < $S(numElem)} {incr row} {
       for {set col 0} {$col < $S(numCol)} {incr col} {
           if {! [info exists MASTER($row,$col)]} { set MASTER($row,$col) ""}
           if {$MASTER($row,$col) eq ""} { set valid 0 ; break }
       }
       if {! $valid} break
   }
 
   # Constraint tests
   set W .const
   if {[winfo exists $W.grid]} {
       set names [GetMasterNames]
       set ops [GetOperations]
 
       for {set row 0} {$row < 10} {incr row} {
           foreach a {who op whom} {
               if {! [info exists C($row,$a)]} { set C($row,$a) "" }
               if {$C($row,$a) eq "<none>"} {set C($row,$a) ""}
           }
 
           set newState readonly
           set r [expr {$row - 1}]
           if {$row > 0 &&
               ($C($r,who) eq "" || $C($r,op) eq "" || $C($r,whom) eq "")} {
               set newState disabled
               if {$C($r,who) ne "" || $C($r,op) ne "" || $C($r,whom) ne ""} {
                   set valid 0
               }
           }
           set w1 $W.grid.$row,who
           set w2 $W.grid.$row,op
           set w3 $W.grid.$row,whom
           $w1 config -state $newState -value $names
           $w2 config -state $newState -values $ops
           $w3 config -state $newState -value $names
       }
   }
   .solve config -state [expr {$valid ? "normal" : "disabled"}]
 }
 proc GetOperations {} {
   global S
 
   set all {<none>}
   lappend all "above" "not above"
   for {set i 1} {$i < $S(numElem)} {incr i} {
       lappend all "$i above"
   }
   lappend all "is" "is not" "below" "not below"
   for {set i 1} {$i < $S(numElem)} {incr i} {
       lappend all "$i below"
   }
   lappend all "next to" "not next to"
   return $all
 }
 proc GetMasterNames {} {
   global S MASTER
 
   set all {<none>}
   for {set col 0} {$col < $S(numCol)} {incr col} {
       for {set row 0} {$row < $S(numElem)} {incr row} {
           lappend all $MASTER($row,$col)
       }
   }
   set all [concat $all [lrange $::PLACES 1 $S(numElem)]]
   return $all
 }
 proc GetColumnNames {col} {
   set all {""}
   for {set row 0} {$row < $::S(numElem)} {incr row} {
       lappend all $::MASTER($row,$col)
   }
   return $all
 }
 proc Solve {} {
   global S PERMCNT cnt
 
   Init
   set S(result) {}
   set S(stat) ""
   set S(cnt,disp) 0
   set S(where) {}
   set S(C) [SortConstraints]
 
   SolveDialog
   set start [clock seconds]
   set cnt 0
   set mod 100
   while {1} {
       if {($cnt % $mod) == 0} {
           set S(cnt,disp) [Comma $cnt];
           if {$cnt >= 1000} {set mod 1000}
           if {$cnt >= 5000} {set mod 5000}
           update
       }
       incr cnt
       if {! [winfo exists .sdlg]} break
 
       if {[TestTrialSolution]} {
           lappend S(result) [array get ::TRIAL]
           lappend S(where) $cnt
           set S(stat) [llength $S(result)]
       }
       if {[StepTrialSolution]} break
   }
   set S(cnt) $cnt
   set S(ttime) [expr {[clock seconds] - $start}]
   if {[winfo exists .sdlg] || $S(result) ne {}} {
       SolutionDialog
   }
   return [llength $S(result)]
 }
 proc SolutionDialog {} {
   global S MASTER TRIAL
 
   set W .sdlg
   set WB .sdlg.body
   if {! [winfo exists $W]} SolveDialog
 
   set S(cancel) "Dismiss"
   eval destroy [winfo child $WB]
 
   set len [llength $S(result)]
   if {$len == 0} {
       set S(title) "ERROR: no solution"
       return
   }
   if {$len > 1} {
       set S(title) "ERROR: $len solutions"
       return
   }
   wm title $W "Solution"
   set S(title) $MASTER(title)
   $WB config -padx 20 -pady 10
   set S(stat) [clock format $S(ttime) -gmt 1 -format %M:%S]
   append S(stat) "\t[Comma $S(cnt)]/[Comma $S(total)]"
 
   array set TRIAL [lindex $S(result) 0]
 
   for {set col 0} {$col < $S(numCol)} {incr col} {
       label $WB.title,$col -textvariable MASTER(t,$col) \
           -justify c -font boldFont -relief solid -bg white
       grid $WB.title,$col -row 0 -column $col -sticky ew
       grid columnconfigure $WB $col -weight 1 -uniform a
   }
   for {set row 0} {$row < $S(numElem)} {incr row} {
       for {set col 0} {$col < $S(numCol)} {incr col} {
           set bg white
           if {$TRIAL($row,$col) eq $MASTER($row,$col)} { set bg cyan }
 
           label $WB.$row,$col -textvariable TRIAL($row,$col) \
               -justify c -bd 1 -relief solid -bg $bg
           grid $WB.$row,$col -row [expr {$row+1}] -column $col \
               -sticky news
       }
   }
 
   CenterWindow $W
   bind $W <Escape> [list destroy $W]
   bind $W <space> [list destroy $W]
 }
 proc SolveDialog {} {
   global S PERMCNT
 
   set S(cancel) "Stop"
   set S(title) "Solving..."
 
   set W .sdlg
   destroy $W
   toplevel $W
   wm withdraw $W
   wm title $W ""
   wm transient $W .
 
   label $W.title -textvariable S(title) -font bigBold
   frame $W.body
   label $W.body.cnt -textvariable S(cnt,disp) -anchor e
   label $W.body.ttl -text " out of [Comma $S(total)]" -anchor w
   label $W.stat -textvariable S(stat)
   frame $W.buttons -bd 2 -relief ridge
   ::ttk::button $W.buttons.cancel -textvariable S(cancel) \
       -command [list destroy $W]
 
   grid $W.title  -padx 30 -sticky ew
   grid $W.body -sticky ew
   grid $W.body.cnt $W.body.ttl -sticky ew
   grid $W.stat
   grid $W.buttons -sticky ew
   pack $W.buttons.cancel -side bottom -pady 10
 
   CenterWindow $W .
   wm deiconify $W
   grab $W
 }
 proc CenterWindow {w {W .}} {
   update idletasks                            ;# Need to get geometry correct
   set wh [winfo reqheight $w]        ; set ww [winfo reqwidth $w]
   set sw [winfo width $W]            ; set sh [winfo height $W]
   set sy [winfo y $W]                ; set sx [winfo x $W]
   set x [expr {$sx + ($sw - $ww)/2}] ; set y [expr {$sy + ($sh - $wh)/2}]
 
   incr y -130
   if {$x < 0} { set x 0 }            ; if {$y < 0} {set y 0}
 
   wm geometry $w +$x+$y
 }
 proc TestTrialSolution {} {
   global C COL S
 
   if {! [TestColumns]} { return 0 }           ;# Shouldn't happen
 
   foreach which $S(C) {
       foreach {ok badCol} [Test1Constraint $which] break
       if {! $ok} {
           for {set i 0} {$i < $badCol} {incr i} {
               set COL($i) {}
           }
           return 0
       }
   }
   return 1
 }
 proc TestColumns {} {
   global S MASTER TRIAL
 
   # One correct per column
   for {set col 0} {$col < $S(numCol)} {incr col} {
       set numOK 0
       for {set row 0} {$row < $S(numElem)} {incr row} {
           incr numOK [string equal $MASTER($row,$col) $TRIAL($row,$col)]
       }
       if {$numOK != 1} { return 0 }
   }
   return 1
 }
 proc Test1Column {col} {
   global S COL
 
   set numOK 0
   for {set row 0} {$row < $S(numElem)} {incr row} {
       incr numOK [expr {$row == [lindex $COL($col) $row]}]
   }
   if {$numOK != 1} { return 0 }
   return 1
 }
 proc Dump {} {
   global S TRIAL
 
   for {set row 0} {$row < $S(numElem)} {incr row} {
       set line ""
       for {set col 0} {$col < $S(numCol)} {incr col} {
           append line "$TRIAL($row,$col)\t"
       }
       puts $line
   }
 }
 proc StepTrialSolution {} {
   global S COL
 
   for {set i 0} {$i < $S(numCol)} {incr i} {
       set done 1
 
       while {1} {
           set COL($i) [NextPerm $COL($i)]
           if {$COL($i) eq {}} {
               set done 0
               set COL($i) [FirstPerm]
           }
           if {[Test1Column $i]} break
       }
       FillColumn $i
       if {$done} { return 0}
   }
   return 1
 }
 proc FillColumn {col} {
   global MASTER TRIAL COL S
 
   if {$COL($col) eq {}} return
   for {set row 0} {$row < $S(numElem)} {incr row} {
       set from [lindex $COL($col) $row]
       set TRIAL($row,$col) $MASTER($from,$col)
   }
 }
 proc SortConstraints {} {
   global C
 
   set all {}
   foreach arr [array names C *,who] {
       if {$C($arr) eq ""} continue
       set which [lindex [split $arr ","] 0]
 
       foreach {. col0} [FindWho $C($which,who) $which] break
       foreach {. col1} [FindWho $C($which,whom) $which] break
       set minCol [expr {$col0 < $col1 ? $col0 : $col1}]
       lappend all [list $which $minCol]
   }
   set result {}
   foreach arr [lsort -index 1 -decreasing -integer $all] {
       lappend result [lindex $arr 0]
   }
   return $result
 }
 
 
 proc Init {} {
   global COL
 
   for {set i 0} {$i < $::S(numCol)} {incr i} {
       set COL($i) [FirstPerm]
       FillColumn $i
 
       while {1} {
           if {[Test1Column $i]} break
           set COL($i) [NextPerm $COL($i)]
           FillColumn $i
       }
   }
 }
 proc FirstPerm {} {
   set result {}
   for {set i 0} {$i < $::S(numElem)} {incr i} {
       lappend result $i
   }
   return $result
 }
 
 # http://wiki.tcl.tk/11262
 proc NextPerm { perm } {
 
   # Find the smallest subscript j such that we have already visited
   # all permutations beginning with the first j elements.
 
   set j [expr { [llength $perm] - 1 }]
   set ajp1 [lindex $perm $j]
   while { $j > 0 } {
       incr j -1
       set aj [lindex $perm $j]
       if { [string compare $ajp1 $aj] > 0 } {
           set foundj {}
           break
       }
       set ajp1 $aj
   }
   if { ![info exists foundj] } return
 
   # Find the smallest element greater than the j'th among the elements
   # following aj. Let its index be l, and interchange aj and al.
 
   set l [expr { [llength $perm] - 1 }]
   while { $aj >= [set al [lindex $perm $l]] } {
       incr l -1
   }
   lset perm $j $al
   lset perm $l $aj
 
   # Reverse a_j+1 ... an
 
   set k [expr {$j + 1}]
   set l [expr { [llength $perm] - 1 }]
   while { $k < $l } {
       set al [lindex $perm $l]
       lset perm $l [lindex $perm $k]
       lset perm $k $al
       incr k
       incr l -1
   }
 
   return $perm
 
 }
 
 
 
 # +#
 # -#
 # nextto
 # not nextto
 # is
 # is not
 # below
 # above
 # is 2nd
 # is not 2nd
 
 # return 1 if satisfies constraint
 
 proc Test1Constraint {which} {
   global C
 
   foreach {row0 col0} [FindWho $C($which,who) $which] break
   set op $C($which,op)
   foreach {row1 col1} [FindWho $C($which,whom) $which] break
   set minCol [expr {$col0 < $col1 ? $col0 : $col1}]
 
   if {[regexp {^(\d+) below$} $op => num]} {
       set n [expr {$row0 - $num}]
       return [list [expr {$n == $row1}] $minCol]
   }
   if {[regexp {^(\d+) above$} $op => num]} {
       set n [expr {$row0 + $num}]
       return [list [expr {$n == $row1}] $minCol]
   }
   if {$op eq "is"} {
       return [list [expr {$row0 == $row1}] $minCol]
   }
   if {$op eq "is not"} {
       return [list [expr {$row0 != $row1}] $minCol]
   }
   if {$op eq "next to"} {
       set n [expr {abs($row0 - $row1)}]
       return [list [expr {$n == 1}] $minCol]
   }
   if {$op eq "not next to"} {
       set n [expr {abs($row0 - $row1)}]
       return [list [expr {$n != 1}] $minCol]
   }
   if {$op eq "above"} {
       return [list [expr {$row0 < $row1}] $minCol]
   }
   if {$op eq "not above"} {
       return [list [expr {$row0 >= $row1}] $minCol]
   }
   if {$op eq "below"} {
       return [list [expr {$row0 > $row1}] $minCol]
   }
   if {$op eq "not below"} {
       return [list [expr {$row0 <= $row1}] $minCol]
   }
   error "bad op"
   return 0
 }
 proc FindWho {who which} {
   global S TRIAL
 
   set who [string tolower $who]
 
   for {set row 0} {$row < $S(numElem)} {incr row} {
       for {set col 0} {$col < $S(numCol)} {incr col} {
           set t [string tolower $TRIAL($row,$col)]
           if {$t eq $who} { return [list $row $col] }
       }
   }
 
   set n [lsearch $::PLACES $who]
   if {$n != -1} { return [list [expr {$n - 1}] 9999] }
   error "Can't find '$who' => which: $which"
   return {-1 -1}
 }
 proc Comma { num } {
   while {[regsub {^([-+]?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num]} {}
   return $num
 }
 proc Reset {} {
   global S MASTER C
 
   #unset -nocomplain S
   unset -nocomplain MASTER
   unset -nocomplain C
   set S(numCol) 3
   set S(numElem) 4
 
 }
 proc NewPuzzle {{who ""}} {
   global S MASTER C PUZZLE
 
   set S(who) $who
   if {$who ne ""} {
       Reset
       foreach {title s m c} $PUZZLE($who) break
       array set S $s
       array set MASTER $m
       array set C $c
       set MASTER(title) $title
   } else {
       set col $S(numCol)
       set elem $S(numElem)
       Reset
       set S(numCol) $col
       set S(numElem) $elem
       foreach arr [array names MASTER] { set MASTER($arr) "" }
   }
   DrawMaster
   DrawConstraints
 }
 proc BlankDlg {} {
   global S
 
   set W .ndlg
   destroy $W
   toplevel $W
   wm title $W ""
   wm transient $W .
   wm withdraw $W
   wm protocol $W WM_DELETE_WINDOW BlankDone
 
   label $W.title -text "New Puzzle Size" -font bigBold
   label $W.lcol -text "Columns"
   tk_optionMenu $W.ecol S(numCol) 2 3 4 5 6
   label $W.lrow -text "Rows"
   tk_optionMenu $W.erow S(numElem) 2 3 4 5 6
   frame $W.buttons -bd 2 -relief ridge
   ::ttk::button $W.buttons.ok -text Okay -command BlankDone
 
   grid $W.title - -sticky ew
   grid $W.lcol -row 1 -column 0 -sticky e
   grid $W.ecol -row 1 -column 1 -sticky w
   grid $W.lrow -row 2 -column 0 -sticky e
   grid $W.erow -row 2 -column 1 -sticky w
   grid $W.buttons - -sticky ew
   pack $W.buttons.ok -pady 15 -expand 1
 
   CenterWindow $W
   wm deiconify $W
 }
 proc BlankDone {} {
   destroy .ndlg
   NewPuzzle
 }
 proc GetTitles {} {
   global PUZZLE
   set all {}
   for {set i 0} {[info exists PUZZLE($i)]} {incr i} {
       lappend all [lindex $PUZZLE($i) 0]
   }
   return $all
 }
 proc LoadPuzzle {} {
   global S PUZZLE
 
   set types {{{Puzzle Files} {.pzl}} {{All Files} *}}
   set fname [tk_getOpenFile -filetypes $types -initialfile puzzle.pzl]
   if {$fname eq ""} return
 
   if {[interp exists newInterp]} { interp delete newInterp }
   interp create -safe newInterp
   newInterp eval set P {{}}
   if {[catch {newInterp invokehidden source $fname}]} {
       interp delete newInterp
       error "Bad puzzle file: $fname"
   }
   set P [newInterp eval set P]
   interp delete newInterp
   if {[llength $P] != 4} { error "Bad puzzle file data: $fname" }
 
   if {[array names PUZZLE *,user] eq {}} {.m.puzzle add separator}
   set n [llength [array names PUZZLE]]
   set PUZZLE($n,user) $P
   set title [lindex $PUZZLE($n,user) 0]
   .m.puzzle add radiobutton -label $title -variable S(who) -value $n,user \
       -command [list NewPuzzle $n,user]
   NewPuzzle $n,user
 }
 proc SavePuzzle {} {
   set txt [SerializePuzzle]
   set types {{{Puzzle Files} {.pzl}} {{All Files} *}}
   set fname [tk_getSaveFile -filetypes $types -initialfile puzzle.pzl]
   if {$fname eq ""} return
   set fout [open $fname w]
   puts $fout $txt
   close $fout
 }
 proc SerializePuzzle {} {
   global S MASTER C
 
   set t "    "
   set p "set P {\n"
   append p "$t\"$MASTER(title)\"\n"
   append p "$t{numCol $S(numCol) numElem $S(numElem)}\n"
   append p "$t{\n$t$t"
   for {set col 0} {$col < $S(numCol)} {incr col} {
       append p "t,$col \"$MASTER(t,$col)\"\t"
   }
   for {set row 0} {$row < $S(numElem)} {incr row} {
       append p "\n$t$t"
       for {set col 0} {$col < $S(numCol)} {incr col} {
           append p "$row,$col \"$MASTER($row,$col)\"\t"
       }
   }
   append p "\n$t}\n"
   append p "$t{\n"
   foreach arr [lsort -dictionary [array names C *,who]] {
       if {$C($arr) eq ""} break
       set which [lindex [split $arr ","] 0]
       append p "$t$t$which,who \"$C($which,who)\""
       append p "\t$which,op \"$C($which,op)\""
       append p "\t$which,whom \"$C($which,whom)\"\n"
   }
   append p "$t}\n"
   append p "}"
   return $p
 }
 
 ################################################################
 set n -1
 set PUZZLE([incr n]) {
   "The Greatest Human Being"
   { numCol 3 numElem 4}
   {
       t,0 "First Name" t,1 "Surname" t,2 "Speciality"
       0,0 Isaac    0,1 Newtune  0,2 welder
       1,0 Albert   1,1 Eyeline  1,2 gardener
       2,0 Marie        2,1 Curious  2,2 cleaner
       3,0 Charles  3,1 Darling  3,2 bricklayer
   }
   {
       0,who Albert   0,op "2 above"  0,whom bricklayer
       1,who Darling  1,op "1 below"  1,whom Charles
       2,who Curious  2,op "2 below"  2,whom welder
   }
 }
 set PUZZLE([incr n]) {
   "Tape Teaser"
   { numCol 3 numElem 4 }
   {
       t,0 Nickname t,1 Surname t,2 Hometown
       0,0 Rocky 0,1 Tryson 0,2 Boston
       1,0 Sugar 1,1 Holyhead 1,2 Seattle
       2,0 Basher 2,1 McCool 2,2 Texas
       3,0 Iron 3,1 Freeman 3,2 {New York}
   }
   {
       0,op {1 below} 0,who Freeman 0,whom Boston
       1,op {1 above} 1,who Seattle 1,whom Iron
       2,op {2 below} 2,who McCool 2,whom Sugar
       3,op {} 3,who {} 3,whom {}
       4,op {} 4,who {} 4,whom {}
       5,op {} 5,who {} 5,whom {}
       6,op {} 6,who {} 6,whom {}
       7,op {} 7,who {} 7,whom {}
       8,op {} 8,who {} 8,whom {}
       9,op {} 9,who {} 9,whom {}
   }
 }
 set PUZZLE([incr n]) {
   "Puzzle in the Park"
   {numCol 3 numElem 4}
   {
       t,0 "Squirrel"  t,1 "Tree"      t,2 "Nuts"
       0,0 "Gerald"    0,1 "Birch"     0,2 "11"
       1,0 "Scamper"   1,1 "Sycamore"  1,2 "12"
       2,0 "Basil"     2,1 "Ash"       2,2 "10"
       3,0 "Tufty"     3,1 "Oak"       3,2 "9"
   }
   {
       0,who "Sycamore"        0,op "1 below"  0,whom "12"
       1,who "10"      1,op "1 above"  1,whom "Tufty"
       2,who "Ash"     2,op "2 below"  2,whom "Scamper"
       3,who "10"      3,op "is not"   3,whom "second"
   }
 }
 set PUZZLE([incr n]) {
   "Beating at Eating"
   {numCol 3 numElem 4}
   {
       t,0 "Name"      t,1 "Surname"   t,2 "Dessert"
       0,0 "Agatha"    0,1 "Greed"     0,2 "cream puffs"
       1,0 "Bugsy"     1,1 "Forager"   1,2 "trifle"
       2,0 "Delilah"   2,1 "Eatalot"   2,2 "cheesecake"
       3,0 "Chuck"     3,1 "Hunk"      3,2 "ice cream"
   }
   {
       0,who "Chuck"   0,op "1 above"  0,whom "ice cream"
       1,who "trifle"  1,op "not above"        1,whom "Delilah"
       2,who "Greed"   2,op "2 below"  2,whom "Delilah"
       3,who "trifle"  3,op "1 above"  3,whom "Forager"
   }
 }
 
 set PUZZLE([incr n]) {
   "Best Book Prize"
   { numCol 4 numElem 4}
   {
       t,0 "Verb 1" t,1 "Noun"   t,2 "Verb 2" t,3 Adverb
       0,0 Killing  0,1 Puddings 0,2 Laughing 0,3 Stupidly
       1,0 Making   1,1 Sharks   1,2 Jumping  1,3 Loudly
       2,0 Hitting  2,1 Cakes    2,2 Running  2,3 Cruelly
       3,0 Shooting 3,1 Flies    3,2 Hopping  3,3 Quickly
   }
   {
       0,who Jumping 0,op "not next to" 0,whom Running
       1,who Sharks  1,op "1 below"     1,whom Loudly
       2,who Killing 2,op "1 above"     2,whom Quickly
       3,who Sharks  3,op "is not"      3,whom Running
       4,who Making  4,op "1 below"     4,whom Jumping
       5,who Cakes   5,op "1 above"     5,whom Running
   }
 }
 set PUZZLE([incr n]) {
   "Alien Court"
   {numCol 3 numElem 5}
   {   t,0 "Captain"   t,1 "Planet"    t,2 "Spaceship"
       0,0 "Ponga"     0,1 "Blink"     0,2 "Outagas"
       1,0 "Bleep"     1,1 "Loopy"     1,2 "Boldleego"
       2,0 "Arial"     2,1 "Grunt"     2,2 "Rustcan"
       3,0 "Tweak"     3,1 "Pobble"    3,2 "Hosspuld"
       4,0 "Riddle"    4,1 "Ether"     4,2 "Supersnail"
   }
   {   0,who "Boldleego"       0,op "above"    0,whom "Pobble"
       1,who "Pobble"  1,op "not above"        1,whom "Rustcan"
       2,who "Ponga"   2,op "1 below"  2,whom "Grunt"
       3,who "Ponga"   3,op "1 above"  3,whom "Outagas"
       4,who "Arial"   4,op "is not"   4,whom "fourth"
       5,who "Blink"   5,op "2 above"  5,whom "Riddle"
       6,who "Blink"   6,op "1 above"  6,whom "Hosspuld"
   }
 }
 set PUZZLE([incr n]) {
   "Court Napping"
   { numCol 3 numElem 5}
   {
       t,0 Title    t,1 Name     t,2 "Favorite Game"
       0,0 Princess 0,1 Yawny    0,2 hearts
       1,0 Duke     1,1 Driftoff 1,2 rummy
       2,0 King     2,1 Bleereye 2,2 gin
       3,0 Queen    3,1 Mutter   3,2 bridge
       4,0 Earl     4,1 Outovit  4,2 poker
   }
   {
       0,who Earl     0,op "1 below" 0,whom Mutter
       1,who Outovit  1,op "1 above" 1,whom bridge
       2,who King     2,op "is not"  2,whom Mutter
       3,who King     3,op "is not"  3,whom bridge
       4,who hearts   4,op "1 above" 4,whom Bleereye
       5,who Bleereye 5,op "2 below" 5,whom King
       6,who Princess 6,op "2 above" 6,whom poker
   }
 }
 set PUZZLE([incr n]) {
   "The Feed'em-Fat Diner"
   {numCol 3 numElem 5}
   {
       t,0 "First Name"        t,1 "Surname"   t,2 "Occupation"
       0,0 "Dave"      0,1 "Jaffa"     0,2 "manager"
       1,0 "Connie"    1,1 "Fish"      1,2 "receptionist"
       2,0 "Bill"      2,1 "Gateau"    2,2 "chef"
       3,0 "Eleanor"   3,1 "Ingest"    3,2 "waiter"
       4,0 "Anne"      4,1 "Haddock"   4,2 "dishwasher"
   }
   {
       0,who "Haddock" 0,op "2 below"  0,whom "manager"
       1,who "Dave"    1,op "2 above"  1,whom "Ingest"
       2,who "waiter"  2,op "2 above"  2,whom "Anne"
       3,who "Eleanor" 3,op "3 below"  3,whom "receptionist"
       4,who "Fish"    4,op "is not"   4,whom "first"
   }
 }
 set PUZZLE([incr n]) {
   "Animal Races"
   {numCol 3 numElem 6}
   {
       t,0 "Animal"    t,1 "Name"      t,2 "Prize"
       0,0 "badger"    0,1 "Karen"     0,2 "Porsche"
       1,0 "elephant"  1,1 "Harry"     1,2 "spoon"
       2,0 "antelope"  2,1 "Lorna"     2,2 "television"
       3,0 "cat"       3,1 "Ian"       3,2 "microwave"
       4,0 "dog"       4,1 "George"    4,2 "carrot"
       5,0 "frog"      5,1 "Jenny"     5,2 "radiator"
   }
   {
       0,who "badger"  0,op "is not"   0,whom "sixth"
       1,who "George"  1,op "is not"   1,whom "sixth"
       2,who "microwave"       2,op "2 below"  2,whom "Harry"
       3,who "microwave"       3,op "1 above"  3,whom "elephant"
       4,who "Ian"     4,op "is not"   4,whom "carrot"
       5,who "Ian"     5,op "not next to"      5,whom "Lorna"
       6,who "spoon"   6,op "3 below"  6,whom "Ian"
       7,who "spoon"   7,op "2 below"  7,whom "dog"
       8,who "Porsche" 8,op "1 below"  8,whom "Lorna"
       9,who "Porsche" 9,op "1 above"  9,whom "antelope"
   }
 }
 set PUZZLE([incr n]) {
   "A Meal Out"
   {numCol 4 numElem 5}
   {
       t,0 "Nickname"  t,1 "Name"      t,2 "Food"      t,3 "Beverage"
       0,0 "Doghouse"  0,1 "Steve"     0,2 "pork"      0,3 "milkshake"
       1,0 "Bigears"   1,1 "Annie"     1,2 "lamb"      1,3 "latte"
       2,0 "Tender"    2,1 "Chris"     2,2 "beef"      2,3 "cappuccino"
       3,0 "Simple"    3,1 "Jackie"    3,2 "chicken"   3,3 "mocha"
       4,0 "Wimpsy"    4,1 "Georgina"  4,2 "fish"      4,3 "tea"
   }
   {
       0,who "Annie"   0,op "1 below"  0,whom "beef"
       1,who "pork"    1,op "1 above"  1,whom "Tender"
       2,who "pork"    2,op "1 below"  2,whom "tea"
       3,who "Chris"   3,op "not next to"      3,whom "Steve"
       4,who "fish"    4,op "1 below"  4,whom "mocha"
       5,who "fish"    5,op "2 below"  5,whom "Steve"
       6,who "Annie"   6,op "is not"   6,whom "fifth"
       7,who "Doghouse"        7,op "is not"   7,whom "fifth"
       8,who "Bigears" 8,op "1 above"  8,whom "latte"
       9,who "Bigears" 9,op "1 below"  9,whom "Chris"
   }
 }
 set PUZZLE([incr n]) {
   "Whodunnit?"
   { numCol 4 numElem 5}
   {
       t,0 "First Name" t,1 Surname  t,2 Weapon t,3 Location
       0,0 James        0,1 Bracket  0,2 hammer 0,3 kitchen
       1,0 Lyn          1,1 Thrust   1,2 rope   1,3 conservatory
       2,0 Sid          2,1 Nutter   2,2 gun    2,3 hall
       3,0 Alice        3,1 Kilroy   3,2 knife  3,3 library
       4,0 Eunice       4,1 Loosenut 4,2 poison 4,3 study
   }
   {
       0,who conservatory     0,op "1 below"    0,whom Nutter
       1,who conservatory     1,op "1 above"    1,whom knife
       2,who gun              2,op "below"      2,whom Alice
       3,who James            3,op "2 above"    3,whom Kilroy
       4,who poison           4,op "above"      4,whom Bracket
       5,who hall             5,op "1 below"    5,whom gun
       6,who hall             6,op "1 above"    6,whom Eunice
       7,who Alice            7,op "is"         7,whom library
   }
 }
 set PUZZLE([incr n]) {
   "Alien Ages"
   {numCol 4 numElem 6}
   {
       t,0 "Name"      t,1 "Race"      t,2 "Planet"    t,3 "Age"
       0,0 "Bleep"     0,1 "Tartan"    0,2 "Parp"      0,3 "213"
       1,0 "Ting"      1,1 "Polyp"     1,2 "Dorb"      1,3 "385"
       2,0 "Hoot"      2,1 "Bunter"    2,2 "Esther"    2,3 "706"
       3,0 "Eek"       3,1 "Crispy"    3,2 "Booper"    3,3 "503"
       4,0 "Peep"      4,1 "Winky"     4,2 "Grunt"     4,3 "897"
       5,0 "Doodah"    5,1 "Fodder"    5,2 "Flip"      5,3 "32"
   }
   {
       0,who "Grunt"   0,op "1 above"  0,whom "Fodder"
       1,who "Booper"  1,op "3 below"  1,whom "Eek"
       2,who "Booper"  2,op "2 below"  2,whom "32"
       3,who "Doodah"  3,op "2 above"  3,whom "Tartan"
       4,who "Doodah"  4,op "1 below"  4,whom "385"
       5,who "706"     5,op "3 above"  5,whom "Ting"
       6,who "Peep"    6,op "2 below"  6,whom "Bunter"
       7,who "Peep"    7,op "1 above"  7,whom "Parp"
       8,who "Esther"  8,op "1 above"  8,whom "213"
       9,who "Esther"  9,op "3 above"  9,whom "Polyp"
   }
 }
 
 set S(numCol) 3
 set S(numElem) 4
 
 DoDisplay
 NewPuzzle 0
 return

----
See also [Solving cryptarithms] - [Solving cryptograms] - [Brute force in velvet gloves]
----

[Category Application] | [Category AI]