Programming Praxis

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