kaw

最初に触ったLisp処理系は、OS-9/6809の上で動作するLisp-09。

一応MacLisp?系の処理系なのかな。 8bitの処理系でしたけど、学習用には十分でした。

手元に残ってたソースを紹介します。
パズルののぐらむを解くプログラム。とりあえず張ってみます。

;------------------------------------------
;   ののぐらむ解法プログラム (Lisp-09版)
;                                   v0.2
;   19th, Jan. '93    [SIN4103 / Nimbus]
;------------------------------------------
;
; 関数の呼出し関係
;
;   nono
;       read-data-file
;           read-token
;           read-fill-list
;               read-token
;               unread-token
;               *read-fill-list*
;                   read-token
;       fill
;       combine-matrix
;           combine-line
;       scan-matrix
;           scan-line
;               traverse-patterns
;                   unify-patterns
;                       unify-p
;                       *unify-patterns*
;               make-template
;                   fill
;       transpose-matrix
;       print-matrix

;
; メイン関数
; 起動方法  -  (nono 'data-file-name)
;
; 重要な変数 : row-fill-list  行方向の欄外データ
;              col-fill-list  列方向の欄外データ
;              board          盤面の状態
;              new-board      探索後の盤面の状態
;              盤面の要素 :   u = 未確定
;                             b = 空白に確定
;                             f = 塗つぶしに確定
;
(defun nono (data-file)
       ; 欄外データの読み込み
       (read-data-file data-file)
       ; 盤面の初期化と表示
       (setq board (fill (fill 'u (length col-fill-list))
                         (length row-fill-list)))
       (print-matrix '"initial board" board)
       ; 探索の実行
       (loop ()
             ; 行方向の走査
             (setq new-board
                   (combine-matrix (scan-matrix board row-fill-list)
                                   board))
             (print-matrix '"row scanned" new-board)
             (if (equal board new-board)
                 (return)
                 (setq board new-board))
             ; 列方向の走査
             (setq new-board
                   (combine-matrix
                       (transpose-matrix
                           (scan-matrix
                               (transpose-matrix board)
                               col-fill-list))
                       board))
             (print-matrix '"col scanned" new-board)
             (if (equal board new-board)
                 (return)
                 (setq board new-board)))
       '"Nonogram complete.")

;
; file-name の名前のファイルから欄外データを読む
;
(defun read-data-file (file-name)
       (cond ((not (probef file-name)) ; ファイルの存在の確認
              (prin1 '"error: can't open data file - ")
              (print file-name)
              (colds)))
       (prog (; 局所変数の定義と初期化
              (terminal (std-in))        ; 端末ファイル識別子を保存
              (data (std-in file-name))  ; ディスクファイルをオープン
              (prev-token nil)
              token
              (row-num nil)
              (col-num nil))
             ; データ個数の読み込み
             (loop ()
                   (read-token)
                   (cond ((and row-num col-num)
                          (return))
                         ((equal token 'yoko)
                          (setq row-num (read-token)))   ; 行データの個数
                         ((equal token 'tate)
                          (setq col-num (read-token))))) ; 列データの個数
             ; データ本体の読み込み
             (loop ((row-read nil)
                    (col-read nil))
                   (cond ((and row-read col-read (return)))
                         ((equal token 'yoko)
                          (setq row-fill-list (read-fill-list)
                                row-read      t))
                         ((equal token 'tate)
                          (setq col-fill-list (read-fill-list)
                                col-read      t))
                         ((equal token 'end)
                          (return))
                         (t
                          (prin1 '"error: unexpected symbol - ")
                          (print token)
                          (colds))))
             (std-in terminal)
             (close data)
             (prin1 '"row-fill-list : ") (print row-fill-list)
             (prin1 '"col-fill-list : ") (print col-fill-list)
             ; データ個数と実際に読み込んだデータ数の照合
             (cond ((or (not (equal row-num (length col-fill-list)))
                        (not (equal col-num (length row-fill-list))))
                    (print '"error: error in data numbers")
                    (colds)))))

;
; トークンの読み込み
; 読み込んだトークンは値として返されるとともに
; アトム token に保存される
;
(defun read-token ()
       (cond (prev-token (setq token prev-token ; 読み戻しされている場合
                               prev-token nil)
                         token)
             (t (setq prev-token nil
                      token      (read)))))

;
; 欄外データを読み込み、リストとして返す
; 形式は ((1行目のデータ) (2行目のデータ) ...)
; 列方向についても同じ
;
(defun read-fill-list ()
       (loop (l)
             (cond ((numberp (read-token))
                    (unread-token)
                    (setq l
                          (cons (*read-fill-list*)
                                l)))
                   (t (return (reverse l))))))

;
; トークンの読み戻し
; 次回の (read-token) で同じデータが返される
;
(defun unread-token ()
       (setq prev-token token))

;
; read-fill-list の下請け関数
;
(defun *read-fill-list* ()
       (if (zerop (read-token)) ; データ終端子
           nil
           (cons token
                 (*read-fill-list*))))

;
; e が len 個並んだリストを返す
;
(defun fill (e len)
       (if (lessp len 1)
           nil
           (cons e
                 (fill e
                       (sub1 len)))))

;
; 文字列 message と 盤面 matrix を表示する。
;
(defun print-matrix (message matrix)
       (or  (null message)
            (terpri)
            (print message))
       (mapc '(lambda (line)
                      (mapc '(lambda (point)
                                     (prin1 (cond ((equal point 'u) '"?")
                                                  ((equal point 'b) '" ")
                                                  ((equal point 'f) '"*")
                                                  (t point))))
                            line)
                      (terpri))
             matrix))

;
; 盤面 mat1 と mat2 のどちらかに確定した要素があれば、
; それを要素とする新たな盤面を返す
;
(defun combine-matrix (mat1 mat2)
       (and mat1
            (cons (combine-line (car mat1)
                                (car mat2))
                  (combine-matrix (cdr mat1)
                                  (cdr mat2)))))

;
; リスト l1 と l2 のどちらかに確定した要素があれば、
; それを要素とする新たなリストを返す
;
(defun combine-line (l1 l2)
       (and l1
            (cons (if (equal (car l2) 'u)
                      (car l1)
                      (car l2))
                  (combine-line (cdr l1)
                                (cdr l2)))))

;
; 盤面 matrix と欄外データ fill-list を照合し
; 新しい確定要素を探索し、その結果を返す。
;
(defun scan-matrix (matrix fill-list)
       (if (car matrix)
           (cons (scan-line (car matrix)
                            (car fill-list))
                 (scan-matrix (cdr matrix)
                              (cdr fill-list)))))

;
; 盤面の行(又は列)o-pat とテンプレート temp を照合し、
; 新しい確定要素を探索し、その結果を返す。
;
(defun scan-line (o-pat fill-list)
       (prog (comp-pat ; 照合結果の保存用リスト
              (rev-o-pat (reverse o-pat)))
             ; 要素がすべて未決定で、探索しても明らかに決定できない
             ; 場合は探索しない。
             (if (and (apply 'and (mapcar '(lambda (e) (equal e 'u))
                                          o-pat))
                      (greaterp (difference (length o-pat)
                                            (apply 'plus fill-list)
                                            (length fill-list)
                                            -1)
                                (apply 'max fill-list)))
                 (return o-pat))
             ; 要素がすべて決定済みなら探索しない。
             (if (apply 'and (mapcar '(lambda (e) (not (equal e 'u)))
                                     o-pat))
                 (return o-pat))
             (traverse-patterns (make-template fill-list)
                                (length o-pat)
                                nil
                                (cons 's o-pat))
             (return (if comp-pat
                         (reverse comp-pat)
                         o-pat))))

;
; テンプレート temp を長さ len の要素に展開し、
; 展開した結果が正しければ、盤面の行(又は列)
; o-pat との照合を試みる。
; pat は展開済みの要素のリスト。
;
(defun traverse-patterns (temp len pat sub-o-pat)
       (prog (top) ; temp の先頭要素
             (cond ((null temp)
                    (and (zerop len)                      ; 展開の終了
                         (unify-patterns rev-o-pat pat))  ; 照合の実行
                    nil)
                   ((minusp len)                          ; 展開に失敗した
                    nil)
                   ((and pat                              ; 盤面との照合
                         (not (equal (car sub-o-pat) 's)) ; 決定されているなら
                         (not (equal (car sub-o-pat) 'u)) ; 再帰しない
                         (not (equal (car pat)
                                     (car sub-o-pat))))
                    (return))
                   ((equal (setq top (car temp)) 'b*)     ; 0個以上の b の
                    (loop ((addlen len)                   ; 並びの展開
                           (addpat pat))
                          (if (minusp addlen)
                              (return))
                          (traverse-patterns (cdr temp)
                                             addlen
                                             addpat
                                             sub-o-pat)
                          (setq addlen
                                (sub1 addlen))
                          (setq addpat (cons 'b addpat))
                          (setq sub-o-pat (cdr sub-o-pat))))
                   (t                                     ; b または fの展開
                    (traverse-patterns (cdr temp)
                                       (sub1 len)
                                       (cons top pat)
                                       (cdr sub-o-pat))))))

;
; 照合の実行
; 盤面中の行(又は列)o-pat と展開されたパターン pat を
; 照合し、結果を comp-pat に残す
;
(defun unify-patterns (o-pat pat)
       (if (unify-p o-pat pat)
           (if (null comp-pat)
               (setq comp-pat pat)
               (setq comp-pat
                     (*unify-patterns* comp-pat pat)))))

;
; 盤面中の行(又は列)o-pat と展開されたパターン pat を
; 照合し、確定した要素がある場合 T, そうでなければ
; NIL を返す
;
(defun unify-p (o-pat pat)
       (if (null o-pat)
           t
           (if (or (equal (car o-pat) 'u)
                   (equal (car o-pat) (car pat)))
               (unify-p (cdr o-pat) (cdr pat))
               nil)))

;
; パターン pat1, pat2 を比較し、どちらか一方に
; 確定した要素があれば、それを要素とする新たな
; リストを返す。
;
(defun *unify-patterns* (pat1 pat2)
       (if (null pat1)
           nil
           (cons (if (equal (car pat1) (car pat2))
                     (car pat1)
                     'u)
                 (*unify-patterns* (cdr pat1) (cdr pat2)))))

;
; 欄外データをテンプレートに変換したものを返す
; 例: (make-template '(1 2 3)) → (b* f b b* f f b b* f f f b*)
;
; 要素の意味 : f     =  塗つぶし要素
;            : b     =  空白要素
;            : b*    =  0個以上の b (空白)の並び
;
(defun make-template (temp)
       (cdr (append (mapcan '(lambda (e) (append '(b b*) (fill 'f e)))
                            temp)
            '(b*))))

;
; 盤面 matrix の行と列を転置したものを返す
;
(defun transpose-matrix (matrix)
       (cond ((car matrix)
              (cons (mapcar 'car
                            matrix)
                    (transpose-matrix (mapcar 'cdr
                                              matrix))))))

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2009-12-01 (火) 02:20:01 (2767d)