ネタがないので 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