LISPUSER

LISPMEMOQ: How can you tell when you've reached Lisp Enlightenment?
A: The parentheses disappear. -- Anonymous

(top)  (memo)  (rss)

SEND + MORE = MONEY

ネタがないので http://www.shiro.dreamhost.com/scheme/wiliki/wiliki.cgi?Scheme%3a%e6%95%b0%e9%81%8a%e3%81%b3 よりパズルに挑戦。

  S E N D
+ M O R E
---------
M O N E Y     (S, M != 0 かつ S, E, N, D, M, O, R, Y はユニークな 0..9 の整数)

まず欲しい関数を考える。↓のような感じでズバっと解答がほしい。

CL-USER> (solve "SEND" "MORE" "MONEY")
SEND + MORE = MONEY
???? + ???? = ?????
CL-USER> 

全組み合わせを考えるとー 10 個の数値から 8 個を取り出すんだから (* 10 9 8 7 6 5 4 3) で 1814400 程度かな?この程度であれば、探索時間はあまり 問題にならないような気もするけれど、メモリはどうかなー。全リストを返す と、たとえば S, E, N, D, M, O, R, Y を fixnum のリストで表現したとして コンスセルで 8 セル。CAR, CDR がそれぞれ 4 バイトとして、文字に対応する 数値のリストが 8 x 8 = 64 バイト。全部 collect すると、

64 バイト * 1814400 通り = 116,121,600 バイト = 100MB

これは、現在メモを書いている Lisp 環境 (CLISP on coLinux メモリ 256MB 割り当て) では厳しそうなので、パターンをリストにあつめてから map する 方向ではなく、パターンを生成したらそれを引数に関数を呼び出すようにしよう。

;; こんなつもり
(combinations fn 0..9 8)
=> (funcall fn '(8 7 6 5 4 3 2 1 0))
=> (funcall fn '(9 7 6 5 4 3 2 1 0))
=> (funcall fn '(7 8 6 5 4 3 2 1 0))
...
=> (funcall fn '(1 2 3 4 5 6 7 8 9))

で、このリストの数字と文字との対応をとって SEND + MORE = MONEY を満すか どうかを検査する、と。

とりあえず、なんにも考えずに総あたりで解く。そのためには S, E, N, D, M, O, R, Y に 0..9 を当てはめるんだろう。組み合わせは〜。一個選んで、残 りのやつから一個選んでをすべて試してみればいい。

(defun combinations (fn lst n &optional acc)
  (dotimes (e lst)
    (if (= n 1)
      (funcall fn (cons e acc))
      (combinations fn (remove e lst) (1- n) (cons e acc)))))

ちょっとテストしてみる。

CL-USER> (combinations #'print '(1 2 3) 2)
>=: #1=(1 2 3) is not a real number
  [Condition of type simple-type-error]

Restarts:
  0: [use-value] You may input a value to be used instead.
  1: [abort-request] Abort handling SLIME request.
  2: [close-connection] Close SLIME connection
  3: [skip] skip (progn # # ...)
  4: [stop] stop loading file /home/onjo/.slime.lisp
  5: [skip] skip (saveinitmem)
  6: [stop] stop loading file /home/onjo/lisp/build/make-clisp-image
  7: [abort] abort
  8: [abort] abort
  9: [abort] abort
  10: [abort] abort

ぎゃあぁぁ。なにか間違えたようだ。エラーは ``(1 2 3)`` は数字じゃないよ、 とゆっている。… dotimes じゃなかった。 dolist ですね。

(defun combinations (fn lst n &optional acc)
  (dolist (e lst)
    (if (= n 1)
      (funcall fn (cons e acc))
      (combinations fn (remove e lst) (1- n) (cons e acc)))))
CL-USER> (combinations #'print '(1 2 3) 2)

(2 1) 
(3 1) 
(1 2) 
(3 2) 
(1 3) 
(2 3) 
nil
CL-USER> 

できてるできてる。次に文字列を渡すと、"SEND" "MORE" "MONEY" から ``'(#\S #\E #\N #\D #\M #\O #\R #\Y)`` を作り出す関数を用意する。

(defun character-set-of (&rest strings)
  (let* ((chars (apply #'concatenate 'list strings))
         (set   (loop for (e . rest) on chars
                  unless (member e rest)
                  collect e)))
   (sort set #'char<)))

富豪的にぜんぶ集めてから重複を取り除く。

CL-USER> (character-set-of "SEND" "MORE" "MONEY")
(#\D #\E #\M #\N #\O #\R #\S #\Y)

できた!! ついでに ``S, M != 0`` の条件の元となる各文字列一番左の文字を 取り出す関数を用意する。

(defun first-chars (&rest strings)
  (mapcar #'(lambda (s) (char s 0)) strings))
cs-user> (first-chars "SEND" "MORE" "MONEY")
(#\S #\M #\M)

さらに、 "SEND" という文字列を数値に変換するための関数も用意する。 文字と数値は連想リストで表現するとしよう。

(defun to-int (str alist)
  (loop for c in (reverse (coerce str 'list))
        for i from 0
        for e = (cdr (assoc c alist))
        sum (* e (expt 10 i))))

連想配列から数値を引いて、桁数を調整したものを合計している。

CL-USER> (to-int "SEND" '((#\S . 1) (#\E . 2) (#\N . 3) (#\D . 4)))
1234

これも動いた。あとは、次のような手順でいけるはず。

1. "SEND" + "MORE" = "MONEY" 
2. 文字集合を作る:  (#\D #\E #\M #\N #\O #\R #\S #\Y)
3. 先頭文字の集合:  (#\S #\M #\M)
4. 0 .. 9 から (length '(#\D #\E #\M #\N #\O #\R #\S #\Y)) だけ取り出した組み合わせを総当たり
   4-1. 組合せで作った 8 個の数字を文字集合に割り当てる
   4-2. 先頭文字の集合で 0 になっているものがないかチェック
   4-3. 文字と数値の対応をベースに "SEND" + "MORE" = "MONEY"  の等式をチェック
   4-4. 答を見つけたらプリント

こんな感じで

(defun solve (pat1 pat2 answer)
  (let* ((chars  (character-set-of pat1 pat2 answer))
         (fchars (first-chars pat1 pat2 answer))
         (alist  (loop for c in chars collect (cons c nil))))
    (labels ((check (lst)
              (loop for c in alist
                    for i in lst
                    do (setf (cdr c) i))
              (unless (some #'zerop (mapcar #'(lambda (c) (cdr (assoc c alist))) fchars))
                (let ((p1  (to-int pat1 alist))
                      (p2  (to-int pat2 alist))
                      (ans (to-int answer alist)))
                  (when (= (+ p1 p2) ans)
                    (format t "~&~A + ~A = ~A~%~A + ~A = ~A~%" pat1 pat2 answer p1 p2 ans))))))
     (combinations #'check '(0 1 2 3 4 5 6 7 8 9) (length chars)))))

できた!! 早速ためしてみましょう。

 CL-USER> (time (solve "SEND" "MORE" "MONEY"))
 SEND + MORE = MONEY
 9567 + 1085 = 10652
 Real time: 42.497505 sec.
 Run time: 42.44 sec.
 Space: 376755264 Bytes
 GC: 95, GC time: 5.7 sec.
 nil

うーん、ちょっと遅いですかねぇ。とりあえずメモリをいっぱい使っているの で、改善点を探します。ふーむ、 ``10C8 = 1814400`` ですので、この回数ループ している ``check`` 関数内の処理をまず見直してみます。 ``to-int`` の内部で 毎回 ``(corece pat1 'list)`` , ``(corece pat2 'list)`` , ``(corece ans 'list)`` をしている。これはだいたい一ループあたり文字数(8文字)x cons セル (8byte) 、で しかも ``reverse`` してるからこれの二倍、と考えらる。

;; 節約できるバイト数
CL-USER> (* 1814400 8 8 2)
232243200
;; 節約後のバイト数
CL-USER> (- 376755264  232243200)
144512064

ほほう、これは結構期待できそうだ。早速実装してみる。

(defun to-int (lst alist)
  (loop for c in lst ; 最適化
        for i from (1- (length lst)) downto 0 ; 最適化
        for e = (cdr (assoc c alist))
        sum (* e (expt 10 i))))

;; 1. "SEND" + "MORE" = "MONEY" 
(defun solve (pat1 pat2 answer &aux (p1 (coerce pat1 'list)) (p2 (coerce pat2 'list)) (ans (coerce answer 'list)) )
  ;; 2. 文字集合を作る:  (#\D #\E #\M #\N #\O #\R #\S #\Y)
  ;; 3. 先頭文字の集合:  (#\S #\M #\M)
  (let* ((chars  (character-set-of pat1 pat2 answer))
         (fchars (first-chars pat1 pat2 answer))
         (alist  (loop for c in chars collect (cons c nil))))
    ;; 4-1. 組合せで作った 8 個の数字を文字集合に割り当てる
    (labels ((check (lst)
               (loop for c in alist
                     for i in lst
                     do (setf (cdr c) i))
              ;; 4-2. 先頭文字の集合で 0 になっているものがないかチェック
               (unless (some #'zerop (mapcar #'(lambda (c) (cdr (assoc c alist))) fchars))
                 ;; 4-3. 文字と数値の対応をベースに "SEND" + "MORE" = "MONEY"  の等式をチェック
                 (let ((p1  (to-int p1 alist))
                       (p2  (to-int p2 alist))
                       (ans (to-int ans alist)))
                   (when (= (+ p1 p2) ans)
                     ;; 4-4. 答を見つけたらプリント
                     (format t "~&~A + ~A = ~A~%~A + ~A = ~A~%" pat1 pat2 answer p1 p2 ans))))))
      ;; 4. 0 .. 9 から (length '(#\D #\E #\M #\N #\O #\R #\S #\Y)) だけ取り出した組み合わせを総当たり
      (combinations #'check '(0 1 2 3 4 5 6 7 8 9) (length chars))))) 

とりあえず、これで試してみる。

 CL-USER> (time (solve "SEND" "MORE" "MONEY"))
 SEND + MORE = MONEY
 9567 + 1085 = 10652
 Real time: 22.253815 sec.
 Run time: 22.22 sec.
 Space: 74839224 Bytes
 GC: 19, GC time: 1.09 sec.

…ほほう予想とは異なるが、だいぶ改善できた。ここで Scheme のやつでも 見てみるかと、 WiLiKi にあったShiro さんの版を Common Lisp に直して試して みる。

(defun combinations-for-each (lst n fn)
  (labels ((iter (lst n path)
             (dolist (e lst)
               (if (= n 1)
                   (funcall fn (cons e path))
                 (iter (remove e lst) (1- n) (cons e path))))))
    (iter lst n nil)))

(defun to-integer (&rest lst)
  (loop for e in (nreverse lst)
        for i from 0
        sum (* e (expt 10 i))))

(defun solve2 ()
  (combinations-for-each '(0 1 2 3 4 5 6 7 8 9)
                         8
                         (lambda (comb)
                           (destructuring-bind (S E N D M O R Y) comb
                             (unless (or (= S 0) (= M 0))
                               (let ((SEND  (to-integer S E N D))
                                     (MORE  (to-integer M O R E))
                                     (MONEY (to-integer M O N E Y)))
                                 (when (= (+ SEND MORE) MONEY)
                                   (return-from solve2 (list SEND MORE MONEY)))))))))
 CL-USER> (time (solve2))
 Real time: 5.250739 sec.
 Run time: 5.24 sec.
 Space: 53800648 Bytes
 GC: 14, GC time: 0.79 sec.
 (9567 1085 10652)
 CL-USER> 

これははやい。つうか、途中で探索を打ち切ってるし。そりゃそうか。 じゃあ return-from を導入しよう。

;; 1. "SEND" + "MORE" = "MONEY" 
(defun solve (pat1 pat2 answer &aux (p1 (coerce pat1 'list)) (p2 (coerce pat2 'list)) (ans (coerce answer 'list)) )
;;(defun solve (pat1 pat2 answer)
  ;; 2. 文字集合を作る:  (#\D #\E #\M #\N #\O #\R #\S #\Y)
  ;; 3. 先頭文字の集合:  (#\S #\M #\M)
  (let* ((chars  (character-set-of pat1 pat2 answer))
         (fchars (first-chars pat1 pat2 answer))
         (alist  (loop for c in chars collect (cons c nil))))
    ;; 4-1. 組合せで作った 8 個の数字を文字集合に割り当てる
    (labels ((check (lst)
               (loop for c in alist
                     for i in lst
                     do (setf (cdr c) i))
              ;; 4-2. 先頭文字の集合で 0 になっているものがないかチェック
               (unless (some #'zerop (mapcar #'(lambda (c) (cdr (assoc c alist))) fchars))
                 ;; 4-3. 文字と数値の対応をベースに "SEND" + "MORE" = "MONEY"  の等式をチェック
                 (let ((p1  (to-int p1 alist))
                       (p2  (to-int p2 alist))
                       (ans (to-int ans alist)))
                   (when (= (+ p1 p2) ans)
                     ;; 4-4. 答を見つけたらプリント
                     (format t "~&~A + ~A = ~A~%~A + ~A = ~A~%" pat1 pat2 answer p1 p2 ans)
                        (return-from solve (list p1 p2 ans)))))))
      ;; 4. 0 .. 9 から (length '(#\D #\E #\M #\N #\O #\R #\S #\Y)) だけ取り出した組み合わせを総当たり
      (combinations #'check '(0 1 2 3 4 5 6 7 8 9) (length chars)))))
 CL-USER> (time (solve "SEND" "MORE" "MONEY"))
 SEND + MORE = MONEY
 9567 + 1085 = 10652
 Real time: 7.091073 sec.
 Run time: 7.06 sec.
 Space: 22369032 Bytes
 GC: 6, GC time: 0.39 sec.
 (9567 1085 10652)
 CL-USER> (time (solve "APPLE" "GRAPE" "CHERRY"))
 APPLE + GRAPE = CHERRY
 63374 + 90634 = 154008
 Real time: 38.72908 sec.
 Run time: 38.56 sec.
 Space: 130179560 Bytes
 GC: 33, GC time: 2.19 sec.
 (63374 90634 154008)

おまけ:コンパイラにがんばってもらう

使用者はなんにもせずに、コンパイラにがんばってもらう事で性能を上げる編。 ループ回数が多いので、 CLISP から SBCL に変更します。これでバイトコード → ネイティブコード動作となるのでかなりの性能向上がみこめます。

 CL-USER> (time (solve "SEND" "MORE" "MONEY"))
 SEND + MORE = MONEY
 9567 + 1085 = 10652
 Evaluation took:
   2.277 seconds of real time
   0.31 seconds of user run time
   1.83 seconds of system run time
   [Run times include 0.39 seconds GC run time.]
   0 calls to %EVAL
   1 page fault and
   31,714,864 bytes consed.
 (9567 1085 10652)
 CL-USER> (time (solve "APPLE" "GRAPE" "CHERRY"))
 APPLE + GRAPE = CHERRY
 63374 + 90634 = 154008
 Evaluation took:
   10.438 seconds of real time
   0.83 seconds of user run time
   9.58 seconds of system run time
   [Run times include 0.21 seconds GC run time.]
   0 calls to %EVAL
   0 page faults and
   190,338,176 bytes consed.
 (63374 90634 154008)

かなりはやくなりました。さらに、何も考えずに最適化を追加。ヒャッホーやっ ぱループにはコンパイラですね!! 型を宣言するのはだるいので、とりあえず デバッグ情報を落としてみる。

(declaim (optimize (speed 3) (safety 0) (debug 0) (space 0)))
CL-USER> (time (solve "SEND" "MORE" "MONEY"))
SEND + MORE = MONEY
9567 + 1085 = 10652
Evaluation took:
  1.65 seconds of real time
  0.81 seconds of user run time
  0.84 seconds of system run time
  [Run times include 0.02 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  31,710,688 bytes consed.
(9567 1085 10652)
CL-USER> (time (solve "APPLE" "GRAPE" "CHERRY"))
APPLE + GRAPE = CHERRY
63374 + 90634 = 154008
Evaluation took:
  8.772 seconds of real time
  0.17 seconds of user run time
  8.5 seconds of system run time
  [Run times include 0.11 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  190,324,736 bytes consed.
(63374 90634 154008)

はやいなー。

posted: 2006/11/04 00:11 | permanent link to this entry | Tags: LISP

(top)  (memo)  (rss)