SEND + MORE = MONEY


There was a post at Programming Praxis about the old mathematical problem SEND + MORE = MONEY. Basically, you have the following equation:

  SEND
+ MORE
------
 MONEY

From here, you have to take each character and replace it with a single digit, 0-9.

If you would like to download the source code from this post, you can do so here.

There are a few ways that you could brute force the problem (discussed in a previous Programming Praxis article), but where's the fun in that? I wanted to go ahead and work on the hill climbing version in part 2.

Basically, the idea is to generate a random possible solution. From there, you keep swapping two digits at a time, only keeping solutions that are better than you already have. There's a bit of a random wiggle to keep from finding a local optimum (as discussed in the article), but that's enough talking. How about some code? (I'm going to generalize to the case of any number of words added together.)

(The code below is all written to run with Chez Scheme 8.4, although it should run on other Schemes with only a few minor modifications.)

Start with some helper functions. First, a combination of map and append, then a function to remove duplicated items from a list (fold is awesome!), and then a function to get the first index of an item in a vector:


; map then append
(define (mappend f . lss)
  (apply append (apply map (cons f lss))))

; test if a list is unique
(define (unique ls)
  (fold-right
    (lambda (x ls) (if (member x ls) ls (cons x ls)))
    '()
    ls))

; get the first index of an item in a vector, error if not found
(define (index-of x v)
  (let loop ([i 0])
    (cond
     [(= i (vector-length v))
      (error "index-of" "~s not found in ~s" x v)]
     [(eq? x (vector-ref v i))
      i]
     [else
      (loop (add1 i))])))

Next, we need a function to take a list of words and get all of the unique letters. If there are less than ten, pad with underscores (#\_ in Scheme). If there are more than ten, there is no possible solution so return an error.


; get unique letters in any number of words
; if less than ten, pad with #\_
; if more than ten, error
(define (get-letters words)
  (let ([ls (unique (mappend string->list words))])
    (if (> (length ls) 10)
        (error "get-letters" "no solution, too many letters")
        (list->vector
          (append (map (lambda (_) #\_) (iota (- 10 (length ls)))) ls)))))

After that, we can take a key and a word and figure out what the numeric value of the word should be. I'll admit that this function is a little bit wonky with two values being passed through the fold, although I think it's still clear enough.


; get the value of a word using a given key
; return #f for words that start with 0
(define (score-word key word)
  (and (not (zero? (index-of (string-ref word 0) key)))
       (car
         (fold-right
           (lambda (c n/i)
             (cons (+ (car n/i) (* (index-of c key) (cdr n/i)))
                   (* (cdr n/i) 10)))
           (cons 0 1)
           (string->list word)))))

Now that we have that, we can figure out a value for the entire equation. Basically, add up all of the words except for the last one. Compare that sum to the last word to determine how far we are for an optimal solution (returning 0). Invalid solutions (where a number starts with 0) will return #f / false.


; score a solution by summing all words except subtracting the last
; return #f for invalid scores
(define (score-words key words)
  (let ([scores (map (lambda (word) (score-word key word)) words)])
    (and (andmap number? scores)
         (abs
           (let loop ([ls scores])
             (if (null? (cdr ls))
                 (- (car ls))
                 (+ (car ls) (loop (cdr ls)))))))))

Two more helper functions: one to create a new vector with two elements swapped and another to display solutions in a more or less pleasant manner:


; scramble a solution by swapping two elements (might be the same one)
(define (swap-two v)
  (let* ([n (vector-copy v)]
         [i (random (vector-length v))]
         [j (random (vector-length v))])
    (vector-set! n i (vector-ref v j))
    (vector-set! n j (vector-ref v i))
    n))

; print out a solution nicely
(define (display-solution key words)
  (newline)
  (printf "~a " (car words))
  (let loop ([words (cdr words)])
    (if (null? (cdr words))
        (printf " = ~a" (car words))
        (begin
          (printf " + ~a" (car words))
          (loop (cdr words)))))
  (newline)
  (printf "~a " (score-word key (car words)))
  (let loop ([words (cdr words)])
    (if (null? (cdr words))
        (printf " = ~a" (score-word key (car words)))
        (begin
          (printf " + ~a" (score-word key (car words)))
          (loop (cdr words)))))
  (newline))

And now that we have all of that work, how about the final solution? Basically, all we are doing is repeatedly swapping two elements. If the new solution is better (or sometimes even if it's worse to avoid local bests), keep it. Eventually, we should get the best possible solution:


; solve a puzzle using a hill-climbing algorithm with some random jitter
(define (solve . words)
  (let loop ([soln (get-letters words)]
             [best (score-words (get-letters words) words)])
    (let* ([new-soln (swap-two soln)]
           [new-best (score-words new-soln words)])
      (cond
        [(and new-best (= 0 new-best))
         (display-solution new-soln words)]
        [(or (not best)
             (and new-best (< new-best best))
             (zero? (random 100)))
         (loop new-soln new-best)]
        [else
         (loop soln best)]))))

Here are a few sample runs:

~ (solve "SEND" "MORE" "MONEY")

SEND  + MORE = MONEY
9567  + 1085 = 10652

~ (solve "FIFTY" "STATES" "AMERICA")

FIFTY  + STATES = AMERICA
65682  + 981849 = 1047531

~ (solve "THIS" "IS" "COOL")

THIS  + IS = COOL
2954  + 54 = 3008

~ (solve "RED" "GREEN" "BLUE" "COLOR")

RED  + GREEN + BLUE = COLOR
457  + 84552 + 6305 = 91314

If you would like to download the source code from this post, you can do so here.

    comments powered by Disqus