SEND + MORE = MONEY, Part 2
August 3, 2012
In the previous exercise we wrote programs to solve the cryptarithm SEND + MORE = MONEY. In today’s exercise we will be more general, writing programs that solve any cryptarithm of the form x + y = z. Cryptarithms can be even more general, such as TED + HAS + GOOD = TASTE, but the extension to such forms is straight forward, and we don’t bother. Making cryptarithms general means we have to provide more infrastructure, beginning with a function make-key
that makes a list of all the letters present in a cryptarithm and extends it to length ten by adding nulls (the underscore) if necessary; the key for SEND + MORE = MONEY looks like (#\_ #\_ #\y #\r #\o #\m #\d #\n #\e #\s)
:
(define (make-key . words)
(let loop ((cs (mappend string->list words)) (ks (list)))
(cond ((null? cs)
(append (make-list (- 10 (length ks)) #\_) ks))
((member (car cs) ks) (loop (cdr cs) ks))
(else (loop (cdr cs) (cons (car cs) ks))))))
The key could be stored as list or a vector; there are advantages and disadvantages to each. We choose a list, because lists are ubiquitous in Scheme. Function lookup
converts a letter to a digit by linear search, and function number
converts a string to a number by calling lookup
repeatedly:
(define (lookup k ks)
(let loop ((i 0) (ks ks))
(if (char=? (car ks) k) i
(loop (+ i 1) (cdr ks)))))
(define (number cs ks)
(let loop ((s 0) (cs cs))
(if (null? cs) s
(loop (+ (* 10 s) (lookup (car cs) ks)) (cdr cs)))))
The two functions that implement the hill-climbing operators are swap
and score
; swap
returns a newly-allocated list with two (possibly-identical) elements interchanged, but is careful not to return a key that makes an invalid number starting with a zero digit, and score
returns the difference between the sum of the first two operands in the cryptarithm and its total:
(define (swap ks a b firsts) ; fix this
(let* ((vs (list->vector ks))
(t (vector-ref vs a)))
(vector-set! vs a (vector-ref vs b))
(vector-set! vs b t)
(if (member (vector-ref vs 0) firsts)
ks (vector->list vs))))
(define (score xs ys zs key)
(abs (- (number zs key) (number ys key) (number xs key))))
The last bit of infrastructure that we need writes the output in a convenient form:
(define (output xs ks)
(let loop ((xs xs) (zs (list)))
(if (null? xs) (reverse zs)
(loop (cdr xs) (cons (lookup (car xs) ks) zs)))))
We are ready now for the hill-climbing function. Input is the three words in the form of a string. The initial let
converts all three input strings to lists of characters, makes a list of the letters which cannot represent zero, chooses an initial key, and scores it. The main loop keeps the key and the score and, unless a solution has been found, at each step computes and scores a modified key and keeps both if they are an improvement:
(define (solve x y z)
(let* ((xs (string->list x))
(ys (string->list y))
(zs (string->list z))
(firsts (map car (list xs ys zs)))
(ks (make-key x y z))
(s (score xs ys zs ks)))
(let loop ((ks ks) (s s))
(if (zero? s)
(list (output xs ks) (output ys ks) (output zs ks))
(let* ((new-ks (swap ks (randint 10) (randint 10) firsts))
(new-s (score xs ys zs new-ks)))
(if (< new-s s) (loop new-ks new-s) (loop ks s)))))))
Here’s a sample run:
> (solve "SEND" "MORE" "MONEY")
^C
> (solve "SEND" "MORE" "MONEY")
^C
> (solve "SEND" "MORE" "MONEY")
^C
> (solve "SEND" "MORE" "MONEY")
^C
> (solve "SEND" "MORE" "MONEY")
((9 5 6 7) (1 0 8 5) (1 0 6 5 2))
The first four runs had to be aborted when they reached local optimums, and the fifth run found a solution in about a tenth of a second.
The change that fixes the problem of getting stuck in a local optimum is quite simple. The if
statement on the last line gains a second clause, and is satisfied if the new key improves the current key or, if the new key is worse than the current key, one time in a hundred:
(define (solve x y z)
(let* ((xs (string->list x))
(ys (string->list y))
(zs (string->list z))
(firsts (map car (list xs ys zs)))
(ks (make-key x y z))
(s (score xs ys zs ks)))
(let loop ((ks ks) (s s))
(if (zero? s)
(list (output xs ks) (output ys ks) (output zs ks))
(let* ((new-ks (swap ks (randint 10) (randint 10) firsts))
(new-s (score xs ys zs new-ks)))
(if (or (< new-s s) (zero? (randint 100)))
(loop new-ks new-s)
(loop ks s)))))))
Here’s a sample run:
> (solve "SEND" "MORE" "MONEY")
((9 5 6 7) (1 0 8 5) (1 0 6 5 2))
> (solve "CROSS" "ROADS" "DANGER")
((9 6 2 3 3) (6 2 5 1 3) (1 5 8 7 4 6))
> (solve "GREEN" "ORANGE" "COLORS")
((8 3 4 4 6) (1 3 5 6 8 4) (2 1 9 1 3 0))
> (solve "TAURUS" "PISCES" "SCORPIO")
((8 5 9 0 9 1) (4 6 1 3 7 1) (1 3 2 0 4 6 2))
> (solve "FIFTY" "STATES" "AMERICA")
((6 5 6 8 2) (9 8 1 8 4 9) (1 0 4 7 5 3 1))
> (solve "THIS" "SIZE" "SHORT")
((9 0 5 1) (1 5 7 8) (1 0 6 2 9))
> (solve "LYNNE" "LOOKS" "SLEEPY")
((9 4 5 5 3) (9 8 8 2 1) (1 9 3 3 7 4))
> (solve "NINE" "FINE" "WIVES")
((7 6 7 5) (8 6 7 5) (1 6 3 5 0))
It works every time, typically in somewhere between a tenth and a half a second, depending on the random number sequence, which is much better than the half minute required by the programs of the prior exercise.
We used mappend
, make-list
and randint
from the Standard Prelude. You can run the program at http://programmingpraxis.codepad.org/40TnHqmA.
[…] Pages: 1 2 […]
Prolog code (mostly since the first exercise was in Prolog, there’s little other reason to use it here, it’s not particularly well suited…)
A Python 2.7 solution based on original Scheme solution:
[…] was a post at Programming Praxis about the old mathematical problem SEND + MORE = MONEY. Basically, you have the following […]
I went ahead and wrote a Scheme version before I actually read yours but they actually ended up pretty similar. Check it out here.
Can you put the C version of this? Thank you.