Introduction edit
This page was spun off from Solving cryptarithms, numeric puzzles in which digits have been replaced by letters. See also Brute force againTFW (Feb, 23 2004) - Got frustrated helping my 5th grade son solve some extra credit homework.
Program 1 edit
We must solve the equation below, where ABCDE*4=EDCBA, nothing fancy but the brute force methods solved it before your finger leaves the keyboard.#---------------------------------------------------------------------------- puts { # Solve the problem # ABCDE # X4 #------ # EDCBA } #---------------------------------------------------------------------------- proc ABCDE {args} { set nums {1 2 3 4 5 6 7 8 9} set counter 0 foreach a $nums { foreach b $nums { foreach c $nums { foreach d $nums { foreach e $nums { set n1 [expr {"$a$b$c$d$e"*4}] set n2 "$e$d$c$b$a" incr counter if {$n1==$n2} { puts "We solved it! $a$b$c$d$e * 4 = $n2 at $counter tries" return } } } } } } puts "Not Solved" }
Program 2 edit
Here is another one, we have $1 in coins but only one can be a nickel. So we know that 19 coins must add to 95 cents using only pennies, dimes, quarters and half-dollars. Again, the simple brute force method yields an answer before your finger leaves the keyboard#---------------------------------------------------------------------------- puts { # Solve the problem # 20 coins = $1.00, only one is a nickel # so we have 19 coins = 95 cents } #---------------------------------------------------------------------------- proc solve2 {args} { set nums {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19} set counter 0 foreach penny $nums { foreach dime $nums { foreach quarter $nums { foreach halfdollar $nums { if {($penny+$dime+$quarter+$halfdollar)==19} { set value [expr {$penny*1+$dime*10+$quarter*25+$halfdollar*50}] incr counter if {$value==95} { puts "We solved it! penny=$penny dime=$dime quarter=$quarter halfdollar=$halfdollar at $counter tries" return } } } } } } puts "Not Solved" }
Program 3 edit
rdt (2004.08.02) Well this is certainly brute force and it gets the job done. However, here is my take on that:proc solve2a {args} { set counter 0 for {set penny 0} {$penny < 20} {incr penny} { for {set dime 0} {$dime < 10} {incr dime} { for {set quarter 0} {$quarter < 4} {incr quarter} { for {set halfdollar 0} {$halfdollar < 2} {incr halfdollar} { if {($penny+$dime+$quarter+$halfdollar)==19} { incr counter set value [expr {$penny*1+$dime*10+$quarter*25+$halfdollar*50}] if {$value==95} { puts "We solved it! penny=$penny dime=$dime quarter=$quarter halfdollar=$halfdollar at counter tries" return } } } } } } puts "Not Solved" }If I did not mis-transcribe it. :) This results in the correct answer in only 62 tries!
Program 4 edit
RS experiments with the following "General Problem Solver" (for small values of General), which, with heavy metaprogramming, builds up a nest of foreachs suiting the problem, quick kills (with continue) to force unique values for the variables, and returns the first solution found, or else an empty string:proc solve {problem {domain0 {0 1 2 3 4 5 6 7 8 9}}} { set vars [lsort -u [split [regsub -all {[^A-Z]} $problem ""] ""]] set map {= ==} set outers {} set initials [regexp -all -inline {[^A-Z]([A-Z])} /$problem] set pos [lsearch $domain0 0] set domain1 [lreplace $domain0 $pos $pos] foreach var $vars { append body "foreach $var \$domain[expr [lsearch $initials $var]>=0] \{\n" lappend map $var $$var foreach outer $outers { append body "if {$$var eq $$outer} continue\n" } lappend outers $var append epilog \} } set test [string map $map $problem] append body "if {\[expr $test\]} {return \[subst $test\]}" $epilog if 1 $body }This passes the tests from earlier in this page:
% solve SEND+MORE=MONEY 9567+1085==10652 % solve SAVE+MORE=MONEY 9386+1076==10462 % solve YELLOW+YELLOW+RED=ORANGE 143329+143329+846==287504So this routine is not blindingly fast, but can process a number of problems from earlier in this page, without other configuration than specifying the problem.
Program 5 edit
Another kind of cryptarithm I found in Martin Gardner's Mathematical Circus:EVE/DID=.TALKTALKTALK...requires epsilon comparison with a periodic fraction... Any takers? - Took it myself, by replacing == equality with abs(delta)<epsilon:GWM 13.10.04 the fraction .talktalk... can be expressed as the rational fraction TALK/9999. So the problem comes down to 9999*EVE = TALK*DID. Surely this is much easier, and involves only integer comparisons.
proc solve {problem {domain0 {0 1 2 3 4 5 6 7 8 9}}} { set vars [lsort -u [split [regsub -all {[^A-Z]} $problem ""] ""]] set map {= )-( ... ""} set outers {} set initials [regexp -all -inline {[^A-Z]([A-Z])} /$problem] set pos [lsearch $domain0 0] set domain1 [lreplace $domain0 $pos $pos] foreach var $vars { append body "foreach $var \$domain[expr [lsearch $initials $var]>=0] \{\n" lappend map $var $$var foreach outer $outers { append body "if {$$var eq $$outer} continue\n" } lappend outers $var append epilog \} } set test abs(([string map $map $problem]))<=.00000001 append body "if {\[expr $test\]} {return \[subst $test\]}" $epilog if 1 $body }
The other tests still pass, but the output is a bit harder to read:
% solve EVE/DID.=.TALKTALK... abs((212/606.)-(.34983498))<=.00000001 % solve SEND+MORE=MONEY abs((9567+1085)-(10652))<=.00000001 % solve ABCDE*4=EDCBA abs((21978*4)-(87912))<=.00000001 % solve 7AB*CD=EFGHJ abs((713*59)-(42067))<=.00000001The last example comes wrong, because the fixed "7" in front is re-used for J in the end.
Program 6 edit
PWQ 25 Feb 04, Can TFW please post an example of the problem:7ab * cd = efghi?I tried a version, but my fingers have finished typing and I am still waiting for an answer. Thanks.
TFW 25 Feb 04, OK here is one that solves 7AB*CD=EFGHI (without reusing the 7 and no duplicates)
proc 7AB {args} { set nums {0 1 2 3 4 5 6 7 8 9} foreach A $nums { if {[string first $A "70"]>=0} continue foreach B $nums { if {[string first $B "70$A"]>=0} continue foreach C $nums { if {[string first $C "70$A$B"]>=0} continue foreach D $nums { if {[string first $D "7$A$B$C"]>=0} continue foreach E $nums { if {[string first $E "70$A$B$C$D"]>=0} continue foreach F $nums { if {[string first $F "7$A$B$C$D$E"]>=0} continue foreach G $nums { if {[string first $G "7$A$B$C$D$E$F"]>=0} continue foreach H $nums { if {[string first $H "7$A$B$C$D$E$F$G"]>=0} continue foreach I $nums { if {[string first $I "7$A$B$C$D$E$F$G$H"]>=0} continue if {"7$A$B" * "$C$D"=="$E$F$G$H$I"} { return "7$A$B*$C$D==$E$F$G$H$I" } } } } } } } } } } }PS. The answer is 715*46==32890
RS got that too (with the first solve version), after respecifying the problem in a slightly clumsy way, and 27 minutes:
% solve Z=7&&ZAB*CD=EFGHI 7==7&&715*46==32890
TFW either of the GPS solvers work fine if you specify the domain as not having 7 as an option (since it is already used)
% solve 7AB*CD=EFGHI {0 1 2 3 4 5 6 8 9} 715*46==32890I get an answer back in about 5 seconds. - RS: Clever - I didn't think of that...
A nice cryptarithm given by Donald E. Knuth, was solved in 30 seconds on XP:
% solve VIOLIN+VIOLIN+VIOLA=TRIO+SONATA 176478+176478+17640==2576+368020
Program 7 edit
SMH 20.03.2005. I adapted Richard's solution and produced a version which runs faster (at least on my computer, running tcl 8.5 on windows 2003)proc solve1 {problem {domain0 {0 1 2 3 4 5 6 7 8 9}}} { set vars [lsort -u [split [regsub -all {[^A-Z]} $problem ""] ""]] set map {= ==} set initials [regexp -all -inline {[^A-Z0-9]([A-Z])} /$problem] # remove 'given' digits foreach d [regexp -all -inline {([0-9])} /$problem] { set l [lsearch $domain0 $d] if { $l >= 0 } {set domain0 [lreplace $domain0 $l $l] } } set pos [lsearch $domain0 0] set str [join $domain0 ""] set l [expr [string length $str] + 1] set epilog "" set ind "" ;# used for producing indented loops set lastVar [lindex $vars end] set str$l $str foreach var $vars { set sow [expr [lsearch $initials $var]>=0] set oldl $l incr l -1 append body "$ind for {set i$var 0} {\$i$var<$l} {incr i$var} \{\n" set oldind $ind; append ind " " append body "$ind set $var \[string range \$str$oldl \$i$var \$i$var]\n" if {$sow} { append body "$ind if {\$$var == 0} continue\n"} if { $var ne $lastVar} { append body "$ind set str$l \[string replace \$str$oldl \$i$var \$i$var]\n"} lappend map $var $$var set epilog "$oldind \}\n $epilog" } set test [string map $map $problem] append body "$ind if {\[expr $test\]} {return \[subst $test\]}\n" $epilog if {1} $body else {puts $body} }I made additional changes to allow for digits which are already given (7AB*CD=EFGHJ) and to allow 0 to be considered as a solition for A in this case.Timings
solve0 SEND+MORE=MONEY 9567+1085==10652 59704109 microseconds per iteration solve1 SEND+MORE=MONEY 9567+1085==10652 35950294 microseconds per iteration solve0 SAVE+MORE=MONEY 9386+1076==10462 83318251 microseconds per iteration solve1 SAVE+MORE=MONEY 9386+1076==10462 37336192 microseconds per iteration solve0 YELLOW+YELLOW+RED=ORANGE 143329+143329+846==287504 335511905 microseconds per iteration solve1 YELLOW+YELLOW+RED=ORANGE 143329+143329+846==287504 114768229 microseconds per iteration solve0 ABCDE*4=EDCBA 21978*4==87912 98717 microseconds per iteration solve1 ABCDE*4=EDCBA 21978*4==87912 54209 microseconds per iteration solve0 7AB*CD=EFGHI 713*59==42067 6058217 microseconds per iteration solve1 7AB*CD=EFGHI 715*46==32890 2423831 microseconds per iteration solve0 VIOLIN+VIOLIN+VIOLA=TRIO+SONATA 176478+176478+17640==2576+368020 22872194 microseconds per iteration solve1 VIOLIN+VIOLIN+VIOLA=TRIO+SONATA 176478+176478+17640==2576+368020 13372726 microseconds per iteration
See also The Einstein puzzle