三目並べのMinMax AIをLipsで

三目並べのMinMaxAIを書くという課題が出まして、
言語は不問ということだったのでとりあえずLispで書きました。

探索空間のサイズ

三目並べは最初がAIの手番だとすると、最大9! = 362880のパターンが有るのでしょうか？
最初に9マスの内にどこを打つのか？次にプレイヤーが残り8箇所のどこをうつのか...というのをゲームの決着の最後まで読むとそのようになるとおもいます。

このサイズの探索空間ならば全探索していても問題ないので今回はそのようにしています。

アルゴリズム

minmaxの要は各段階のスコアをどのように計算するかです。
まずはじめにトライしたのは単純に、

• プレイヤーの勝利ならば +10
• AIの勝利ならば -10
• それ以外ならば 0

というスコア基準にしました。
このように実装しても正常にプレイすることは出来ました。

ですが、何度かプレイしている内にどうもAIが十分に賢くないように感じました。もう少し早く詰めてこられるはずなのに詰めてこないなというようなことがありました。

そこで気がついたのは、この状態ではすべてのゲーム終了時が均等に扱われているということです。実際にプレイしていて早く詰めてこないということを感じるということは、この「早く」という基準を評価に含めてやればいいはずだと考えました。そこでminmaxに探索の深さを渡してやるようにし、評価時に探索が深くなった時の評価が低くなるようにしました。

• プレイヤーの勝利ならば: 10 - <探索の深さ>
• AIの勝利ならば: <探索の深さ> - 10
• それいがいならば: 0

これがうまく言ったようで、AIはこちらが愚かな手を打つやいなや詰めてくるようになりました。
探索が深くならずに早く決着がつくような手を優先するようになったのです。
とりあえず,これで僕には十分に強くなったように感じたので、ここで実装を終えました。

実行結果

今回のコードではまずCUIに対応しました。
ファイルをインタプリターにロードして

(main)

とmain関数を実行すると

* (main)

+-+-+-+
| | | |
+-+-+-+
| | | |
+-+-+-+
| | | |
+-+-+-+
Moves:[0,1,2,3,4,5,6,7,8]:
0
+-+-+-+
|O| | |
+-+-+-+
| |X| |
+-+-+-+
| | | |
+-+-+-+
Moves:[1,2,3,5,6,7,8]:
1
+-+-+-+
|O|O|X|
+-+-+-+
| |X| |
+-+-+-+
| | | |
+-+-+-+
Moves:[3,5,6,7,8]:
6
+-+-+-+
|O|O|X|
+-+-+-+
|X|X| |
+-+-+-+
|O| | |
+-+-+-+
Moves:[5,7,8]:
5
+-+-+-+
|O|O|X|
+-+-+-+
|X|X|O|
+-+-+-+
|O|X| |
+-+-+-+
Moves:[8]:
8
+-+-+-+
|O|O|X|
+-+-+-+
|X|X|O|
+-+-+-+
|O|X|O|
+-+-+-+
Draw..
* NIL

というふうにボードが表示されて、可能な手のリストが表示されるので、入力すると、
ゲームが進行するというふうになっています。

Business Card Raytracer in CL.

Redditを眺めていたらHaskellでRayTracingをしてみたよ的な記事が流れてきました。
So I (kind of) made a Haskell clone of the business card Ray Tracer : haskell

その説明を眺めてみると何やら名刺サイズのレイトレーシングというものが話題になっていたので
Haskellで実装してみたというモノのようです。なんだろうと思って確認してみたところ

Raytracing

名刺サイズにレイトレーシングの実装というものがあってそれの解説の記事が最近書かれたようで
それで話題になっていたようです。

関連する実装としてはPythonによる実装

Business Card Raytracer in Python

もあるようで、そこでいろいろと参考にしながらCLでも実装してみようと思い実装をして見ました。

card-raytracer/card-raytracer.lisp at master · pocket7878/card-raytracer · GitHub

生成される画像としては

というふうにサンプル画像と同じ物が生成されます。

P.S
すっごい遅いよ！

SECD Machine in Lisp

;; List Utilities
(defun head (lst)
  (car lst))

(defun tail (list)
  (cdr list))

;; Lambda Expression
(defun lam-expr (var body)
  `(lambda ,var ,body))

(defun is-lambda (list)
  (and (listp list) (eql 'lambda (car list))))

(defun bv (lam)
  (cadr lam))

(defun body (lam)
  (caddr lam))

;; Closure
(defun clos (e x) 
  `(clos ,e ,x))

(defun is-closure (list)
  (and (listp list) (eql 'clos (car list))))

(defun environment-part (clos)
  (values (cadr clos)
          (caddr clos)))

;; Identifier 
;;
(defun is-identifier (x)
  (and (atom x) (not (is-ap x))))

;; Special Object AP
(defun is-ap (x)
  (eql 'ap x))


;; Environment
(defun look-up (e x)
  (let ((res (cdr (assoc x e))) )
    (if res
      res
      x)))

;; Combination
(defun rator (x)
  (car x))

(defun rand (x)
  (cadr x))

;; SECD Machine
(defun mk-machine-state (s e c d)
  `(,s ,e ,c ,d))

(defun show-machine-state (machine-state)
  (format t "S:~A E:~A C:~A D:~A~%" 
          (car machine-state)
          (cadr machine-state)
          (caddr machine-state)
          (cadddr machine-state)))

(defun transform (machine-state)
  (destructuring-bind (s e c d) machine-state
    (if (null c)
      (if (not (null d))
        (destructuring-bind (ds de dc dd) d
          (values (mk-machine-state (cons (head s) ds) de dc dd) t))
        (values machine-state nil))
      (let ((x (head c)))
        (cond ((is-identifier x)
               (values (mk-machine-state (cons (look-up e x) s) e (tail c) d) t))
              ((is-lambda x)
               (values (mk-machine-state (cons (clos e x) s) e (tail c) d) t))
              ((is-ap x)
               (if (is-closure (head s))
                 (multiple-value-bind (de dx) (environment-part (head s))
                   (values (mk-machine-state nil (cons (cons (bv dx) (cadr s)) de) (list (body dx)) (list (tail (tail s)) e (tail c) d)) t))
                   (values (mk-machine-state (cons (cons (cadr s) (car s)) (tail (tail s))) e (tail c) d) t)))
              ((consp x)
               (values (mk-machine-state s e `(,(rand x) ,(rator x) ap ,@(tail c)) d) t))
              (t nil))))))

(defun run-transform (machine-state)
  (labels ((run-transform% (machine-state status)
             (if (null status)
               machine-state
               (progn 
                 (format t "=> ~A~%" machine-state)
                 (multiple-value-bind (new-state st) (transform machine-state)
                   (run-transform% new-state st))))))
    (run-transform% machine-state t)))

P.J.Landin The mechanical evaluation of expressions (1964)
の中にかかれているTransformの実装です。

 (run-transform (mk-machine-state '() '() `((((lambda x (lambda y y)) a) b)) '())
)
=> (NIL NIL ((((LAMBDA X (LAMBDA Y Y)) A) B)) NIL)
=> (NIL NIL (B ((LAMBDA X (LAMBDA Y Y)) A) AP) NIL)
=> ((B) NIL (((LAMBDA X (LAMBDA Y Y)) A) AP) NIL)
=> ((B) NIL (A (LAMBDA X (LAMBDA Y Y)) AP AP) NIL)
=> ((A B) NIL ((LAMBDA X (LAMBDA Y Y)) AP AP) NIL)
=> (((CLOS NIL (LAMBDA X (LAMBDA Y Y))) A B) NIL (AP AP) NIL)
=> (NIL ((X . A)) ((LAMBDA Y Y)) ((B) NIL (AP) NIL))
=> (((CLOS ((X . A)) (LAMBDA Y Y))) ((X . A)) NIL ((B) NIL (AP) NIL))
=> (((CLOS ((X . A)) (LAMBDA Y Y)) B) NIL (AP) NIL)
=> (NIL ((Y . B) (X . A)) (Y) (NIL NIL NIL NIL))
=> ((B) ((Y . B) (X . A)) NIL (NIL NIL NIL NIL))
=> ((B) NIL NIL NIL)
((B) NIL NIL NIL)

SuffixArrayを使った簡易検索エンジンやってみた。

文字列の検索アルゴリズムについてしらべていたら、良いチュートリアルを発見したので
やってみました。
簡単なWebサーチエンジンの作り方

(defun all-suffix-node (str)
  (loop for s from 1 to (length str)
       collect (cons s (subseq str (1- s)))))

(defun suffix-array (str)
  (mapcar #'car (sort (all-suffix-node str)
		      (lambda (a b) (string<= (cdr a) (cdr b))))))

(defun suffix (str idx)
  (subseq str (1- idx)))

(defun prefix-p (str sub)
  (when (>= (length str) (length sub))
    (string= (subseq str 0 (length sub))
	     sub)))

(defun sfx-search (str sub)
  (labels ((search% (str sub sfx-array)
	     (when (not (null sfx-array))
	       (let* ((center (ash (length sfx-array) -1))
		      (center-idx (nth center sfx-array))
		      (center-str (suffix str center-idx)))
		 (cond ((string< center-str sub)
			(search% str sub (nthcdr (1+ center) sfx-array)))
		       ((string= center-str sub)
			(cons center-idx
			      (search% str sub (nthcdr (1+ center) sfx-array))))
		       ((string> center-str sub)
			(cond ((prefix-p center-str sub)
			       (list center-idx
				     (search% str sub (subseq sfx-array 0 center))
				     (search% str sub (nthcdr (1+ center) sfx-array))))
			      (t (search% str sub (subseq sfx-array 0 center))))))))))
    (search% str sub (suffix-array str))))

実行結果は

CL-USER> (sfx-search "abcbccab" "ab")
(1 7)

とりあえず第三課題まで。

特定のパターンでクラスを継承した時に発動する機能を設定したい

タイトルの通り、あるクラスが特定のクラス(複数可)を継承した時になにか処理を実行させたいのです(たとえば、メソッドを定義したり、ログに出力したり..)
で、CLOSならなんとかなるんじゃないかと、ちょっと作ってみています。

(eval-when (:load-toplevel :compile-toplevel :execute)
  #+sbcl (use-package :sb-mop))

(defclass addable-class (standard-class)
  ())

(defmethod validate-superclass ((class addable-class)
                                (super standard-class))
  t)

(defvar *class-add-rules* '())

(defun define-class-union-rule (cls-name1 cls-name2 action)
  (pushnew
   (cons (cons cls-name1 cls-name2)
	 action)
   *class-add-rules*))

(defmethod ensure-class-using-class :after ((class addable-class) name &rest keys)
  (declare (ignore keys))
  ;;Ensure finalize inheritance
  (finalize-inheritance class)
  ;;Get all super-class-list
  (let ((super-class-names
	 (mapcar #'(lambda (cls)
		     (class-name cls)) (class-precedence-list class))))
    ;;Get all matched rule from rule table
    (let ((matched-rules
	   (remove-if-not
	    (lambda (rule) (and (member (caar rule) super-class-names)
				(member (cdar rule) super-class-names))) *class-add-rules*)))
      (loop
	 for rule in matched-rules
	 do
	   (funcall (cdr rule) class)))))

(define-class-union-rule 'A-class 'B-class
  (lambda (cls)
    (format t "Class: ~A is union of A-class & B-class.~%" cls)))

(defclass A-class ()
  ((name :initarg :name :accessor name :initform "A"))
  (:metaclass addable-class))

(defclass B-class ()
  ((x :initarg :x :accessor x :initform 0)
   (y :initarg :y :accessor y :initform 0))
  (:metaclass addable-class))

(defclass AB-class (A-class B-class)
  ()
  (:metaclass addable-class))

やってる事としては
継承とはクラスの和算であるとかんがえて
Meta-Classとしてaddable-class(足したときの演算が定義できるクラス)を定義します。
そして、addable-classをメタクラスとして持つクラスを定義したときに、そのクラスの継承関係をチェックして、定義してあるルールにマッチしたらなにか処理を実行したいのです。
その処理の中でクラスにメソッドを追加したりできたら便利だろうと...

今の所は非常に素な実装であって、できる事は2つのクラスを継承している状態になったら発動するだけです。この実装で方向性が見えてきたら機能を追加したり、もっとパターンをちゃんと定義できるようにしたいとおもっています。

困っている事

今現在、ensure-class-using-classのafterメソッドとして何かの処理を実行しているため、
処理の引数にはclass自体がわたってきます。このクラスをベースにしてインスタンスメソッドを定義したりする方法がわからず困っています。アドバイスがありましたら、是非よろしくおねがいいたします。

CL向けのCSSセレクターベースのテンプレートエンジン Caramelを作った（作っている）

ClojureのEnliveというテンプレートエンジンはClojureのWeb開発界では有名だとおもいます。
そのEnliveのAPIが綺麗でCommon Lispでも同じようなテンプレートエンジンがあったらなぁ
とおもってました。
そこで調べてみるとcss-selectorsというcssセレクタを利用してノードの検索ができるライブラリがCLにもある事がわかり、これをつかえばEnlive的なテンプレートエンジンに発展させられるんじゃないかなとおもいました。

そこで、CaramelというCSSセレクターベースのテンプレートエンジンをつくりました。

特徴としては、

• ファイルベースのテンプレートエンジンである
• CSSセレクターでノードの選択ができる

といった感じですかね、基本的なAPIはEnliveを踏襲しています。
サンプルコードはリポジトリのほうに掲載しております。

実装にあたってはChatonでshiroさん及びg000001さんにはお世話になりました。ありがとうございます。

大津の閾値判別法

大津の閾値判別法

(ql:quickload :iterate)
(ql:quickload :lispbuilder-sdl)
(ql:quickload :lispbuilder-sdl-gfx)
(use-package :iterate)

(defclass <data> ()
  ((max :initform (error "max must specified") :reader data-max :initarg :max)
   (min :initform (error "min must specified") :reader data-min :initarg :min)
   (data :initform (error "data must specified") :reader data :initarg :data)))

(defun my-random (min max)
  (+ min (random (1+ (- max min)))))

(defun make-random-data (len min max)
  (loop repeat len
       for datum = (my-random min max)
       maximize datum into data-max
       minimize datum into data-min
       collect datum into data
       finally (return (make-instance '<data>
				      :min data-min
				      :max data-max
				      :data data))))

(defmethod make-hist-gram ((data <data>))
  (let ((hist-gram (make-hash-table)))
    (loop for datum in (data data)
       do
	 (incf (gethash datum hist-gram 0)))
    hist-gram))

(defun calc-avarage (data)
  (/ (loop for datum in data
	  sum datum)
     (length data)))

(defmethod split-by ((data <data>) (threshold number))
  (loop for datum in (data data)
       if (<= datum threshold)
       collect datum into class1
       else
       collect datum into class2
     finally (return
	       (cons class1 class2))))

(defmethod calc-threshold ((data <data>))
  (iter:iter (for th from (data-min data) below (data-max data))
	     (finding th maximizing
		      (let* ((cls(split-by data th))
                             (c1 (car cls)) (c2 (cdr cls)))
                        (* (length c1)
                           (length c2)
                           (expt (- (calc-avarage c1)
                                    (calc-avarage c2)) 2))))))

(defmethod threshold-viewer ((data <data>))
  (let* ((hist-gram (make-hist-gram data))
         (threshold (calc-threshold data))
         (width (+ (data-max data) 50))
         (height (+ (loop for datum in (data data)
                          maximizing (gethash datum hist-gram))
                    25)))
    (sdl:with-init ()
        (sdl:window width height)
        (sdl:clear-display sdl:*white*)
        ;;Draw data
        (loop for datum in (data data)
              do
              (sdl:draw-line-* 
                (+ 25 datum) height
                (+ 25 datum) (- height (gethash datum hist-gram))
                :color sdl:*black*)) 
        ;;show threshold
        (sdl:draw-line-* 
          threshold 0
          threshold height
          :color sdl:*red*)
        (sdl:update-display)
        (sdl:with-events ()
          (:quit-event () t)))))

CL-USER(3): (calc-threshold (make-random-data 10000 0 255))

128

迷路解答もLispで

cl-mazeという名前でgithubに置くことにした、前の迷路を構築するプロジェクトをいくつかアップデートしました。

• 部屋をroomというstructで管理する事にした
• Dijkstra法をもちいて解答を計算するようにした

以下は、そのメソッドと表示される結果

(defmethod solve ((maze <maze>))
  ;;Calcurate each cell minimum distance from start
  (let ((U (queues:make-queue :priority-queue
                              :compare (lambda (r1 r2) (< (cdr r1) (cdr r2)))))
        (V (make-hash-table))) 
    ;;Add First node
    (queues:qpush U (cons (aref (rooms maze) 0) 0))
    ;;Add Rest nodes
    (loop for idx from 1 below (* (w maze) (h maze))
          do
          (queues:qpush U (cons (aref (rooms maze) idx) most-positive-fixnum)))
    (loop while (not (zerop (queues:qsize U)))
          do
          (let ((p (queues:qtop U)))
            ;;Remove p from U add to V
            (queues:qpop U)
            ;; roomIdx -> distance
            (setf (gethash (room-idx (car p)) V) (cdr p))
            (loop for adj in (room-adjacency (car p))
                  when #1=(queues:queue-find U (lambda (n) (equalp (car n) (aref (rooms maze) adj))))
                  do
                  (setf (gethash (room-idx (car #2=(queues::node-value #1#))) V)
                        #3=(min (cdr #2#) (1+ (cdr p))))
                  (queues:queue-change U #1# (cons (car #2#) #3#)) )))
    ;;Create route from distance table
    (let ((current-idx (1- (* (w maze) (h maze)))))
      (loop
        collect current-idx into route
        do
        (setf current-idx
              (find-if (lambda (idx) (= (gethash idx V)
                                        (1- (gethash current-idx V))))
                       (room-adjacency (aref (rooms maze) current-idx))))
        until (zerop current-idx)
        finally (return (cons 0 (nreverse route)))))))

まずダイクストラ法で重さを求めてから、それを利用して最短ルートを計算しています。
それを利用して表示するようにしたのが以下のスクリーンショット

ローマ字からひらがなへの変換

ローマ字入力の文字をひらがなの文字に変換してみました。
まだ異常入力への対応やら小文字への変換やら濁音拗音促音などの対応とかはしてませんけど
基礎的な変換はできてます。

(defparameter 
  *boin-table*
  '(("a" . "あ")
    ("i" . "い")
    ("u" . "う")
    ("e" . "え")
    ("o" . "お")))

(defun create-kana-row (prefix-str kanas)
  (loop for boin in *boin-table*
        for kana in kanas
        collect 
        (cons (concatenate 'string prefix-str (car boin))
              kana)))

(defparameter 
  *hiragana-table*
  `(,@*boin-table*
     ,@(create-kana-row "k" '("か" "き" "く" "け" "こ"))
     ,@(create-kana-row "s" '("さ" "し" "す" "せ" "そ"))
     ,@(create-kana-row "t" '("た" "ち" "つ" "て" "と"))
     ,@(create-kana-row "n" '("な" "に" "ぬ" "ね" "の"))
     ,@(create-kana-row "h" '("は" "ひ" "ふ" "へ" "ほ"))
     ,@(create-kana-row "m" '("ま" "み" "む" "め" "も"))
     ("ya" . "や") ("yu" . "ゆ") ("yo" . "よ")
     ,@(create-kana-row "r" '("ら" "り" "る" "れ" "ろ"))
     ("wa" . "わ") ("wo" . "を") 
     ("nn" . "ん")))

(defun translate-roman-to-hiragana (roman-str)
  (labels ((%translate-roman-to-hiragana (carry-char acc char-list)
             (cond ((null char-list) 
                    (apply #'concatenate 'string (nreverse acc)))
                   (#1=(assoc (coerce `(,@(if carry-char (list carry-char) nil)
                                         ,(car char-list)) 'string) *hiragana-table* :test #'string=)
                    (%translate-roman-to-hiragana
                      nil (cons (cdr #1#) acc) (cdr char-list)))
                   (t
                    (%translate-roman-to-hiragana
                      (car char-list)
                      acc
                      (cdr char-list))))))
    (%translate-roman-to-hiragana nil '() (coerce roman-str 'list))))

まずは、ka=>か 等の変換テーブルをつくっておきます。
変換は
1. 文字がもうなかったら、結果を文字列にして返す
2. 繰りこしてある文字と、今の先頭の文字を接合して、変換テーブルを検索、みつかれば3へそうでなければ4
3. みつかった文字を保存して、繰りこし文字を消去して2へもどる
4. 先頭の一文字を繰りこして、2へもどる
とやっています。
最初は子音の変換のモードかどうかとかを判定しようかなとか考えたのですが、
冗長だなぁとおもい、また今は小文字などの3文字以上の入力を見ることも考えていないので
一つ前の文字さえ確認できれば十分だなぁという事で、このようにしています。

CL-USER(62): (translate-roman-to-hiragana "konnnitiwa")

"こんにちわ"

迷路生成をLispでPart2

LispbuilderSDLを利用しての可視化をしました、
あと、アルゴリズムの実装にミスがあったのでそちらも修正してちゃんとした迷路ができるようになりました。

(ql:quickload :lispbuilder-sdl)
(ql:quickload :lispbuilder-sdl-gfx)

;;迷路のデータ構造
(defclass <maze> ()
  ((width :initarg :w :accessor w)
   (height :initarg :h :accessor h)
   (rooms :initarg :rooms :accessor rooms)))

;;部屋の情報を管理するリストをつくる
(defun make-room-list (w h)
  (let ((array (make-array (* w h) :initial-element 0)))
    (loop for idx from 0 upto (1- (* w h))
          do
          (setf (aref array idx) (list idx idx nil)))
    array))

;;単純なグリッドの部屋をつくる
(defun make-base-maze (w h)
  (make-instance '<maze>
                 :w w :h h
                 :rooms (make-room-list w h)))

;;対応する番号の部屋を返す
(defmethod get-room ((maze <maze>) idx)
    (aref (rooms maze) idx))

;;部屋のクラスタ番号を返す
(defmethod get-cluster-id ((maze <maze>) idx)
  (cadr (get-room maze idx)))

;;部屋のクラスタ番号を設定する
(defmethod set-cluster-id ((maze <maze>) idx new-id)
  (setf (cadr (aref (rooms maze) idx)) new-id))


;;全ての部屋がクラスタ0に属していたら終了
#|
| 初期状態ではクラスタ番号 i は i >= 0 を満している
| 部屋と部屋を接続する時には、かならず小さい方のクラスタ番号に属させるようにしている、よって
| 0 n = 0
| n m = if n > m then n else n
| とクラスタ番号が決められていくので、部屋を繋げていくたびに、クラスタ番号は単調減少していく。
| よって最終状態では、クラスタ番号は確実に全て0になっている。
 |#
(defmethod build-finished-p ((maze <maze>))
  (every (lambda (room) (zerop (cadr room)))
         (rooms maze)))

;;x座標とy座標を計算
(defmethod calc-x-y (idx w)
  (values
    (mod idx w))
    (truncate idx w))

;;隣接した部屋かどうか
(defmethod neighbor-room-p ((maze <maze>) from to)
  (multiple-value-bind (from-x from-y) (calc-x-y from (w maze))
    (multiple-value-bind (to-x to-y) (calc-x-y to (w maze))
      (= (+ (abs (- from-x to-x)) 
            (abs (- from-y to-y))) 1))))

;;隣接した部屋ならば、繋げる
(defmethod connect-room ((maze <maze>) i j)
  (let ((id-i (get-cluster-id maze i))
        (id-j (get-cluster-id maze j)))
    (when (and (not (equal id-i id-j)) (neighbor-room-p maze i j))
      ;それぞれの部屋の隣接リストに相手の部屋を追加する
      (pushnew j (caddr (aref (rooms maze) i)))
      (pushnew i (caddr (aref (rooms maze) j)))
      ;小さい方のクラスタ番号を採用
      (if (< id-i id-j)
        (loop for room across (rooms maze)
              when (= (cadr room) id-j)
              do
              (setf (cadr room) id-i))
        (loop for room across (rooms maze)
              when (= (cadr room) id-i)
              do
              (setf (cadr room) id-j))))))

;;初期迷路を生成し、全ての部屋が同じクラスタに属するまで
;;部屋をつなげていく
(defun build-maze (w h)
  (let ((maze (make-base-maze w h)))
    (loop until (build-finished-p maze)
          do
          (connect-room maze
                        (random (* w h))
                        (random (* w h))))
    maze))

(defun t-or-nil (val)
  (not (not val)))

;;部屋の接続リストを各部屋の壁のリストにする
(defun room-list-to-wall-list (room-list w h)
  (loop for r across room-list
        for room-id = (car r)
        for con-list = (sort (copy-list (caddr r)) #'<)
        collect `(,room-id 
                   ,(list 
                      (t-or-nil (member (- room-id w) con-list))
                      (t-or-nil (member (1- room-id) con-list))
                      (t-or-nil (member (1+ room-id) con-list))
                      (t-or-nil (member (+ room-id w) con-list))))))

(defmethod display-maze ((maze <maze>) cell-size)
  (let ((wall-list (room-list-to-wall-list (rooms maze)
                                           (w maze)
                                           (h maze))))
    (format t "Maze: ~A~%" (rooms maze))
    (format t "Wall: ~A~%" wall-list)
    (sdl:with-init ()
        (sdl:window (* cell-size (+ 2 (w maze))) (* cell-size (+ 2 (h maze))) :title-caption "Maze")
        (sdl:clear-display sdl:*white*)
        (loop for w in wall-list
              for id = (car w)
              for w-list = (cadr w)
              do
              (multiple-value-bind (y x) (calc-x-y id (w maze))
                (let ((x (+ cell-size (* x cell-size)))
                      (y (+ cell-size (* y cell-size))))
                  (format t "~A: ~A ~A~%" id x y)
                (let ((f-dif-x `(0 0 ,cell-size 0))
                      (f-dif-y `(0 0 0 ,cell-size))
                      (t-dif-x `(,cell-size 0 ,cell-size ,cell-size))
                      (t-dif-y `(0 ,cell-size ,cell-size ,cell-size)))
                  (loop for wall in w-list
                        for widx from 0
                        for from-x = (+ x (nth widx f-dif-x))
                        for from-y = (+ y (nth widx f-dif-y))
                        for to-x = (+ x (nth widx t-dif-x))
                        for to-y = (+ y (nth widx t-dif-y))
                        when (null wall)
                        do
                        (format t "line: (~A,~A) => (~A,~A)~%" from-x from-y to-x to-y)
                        (sdl:draw-line-* from-x from-y to-x to-y :color sdl:*black*))))))
        (sdl:update-display)
        (sdl:with-events ()
          (:quit-event () t)
          (:idle () (sdl:update-display))))))

迷路の表示にすこしてこずってます。
ですが、

このようにちゃんと表示されます。
実装の修正は、部屋と部屋をつなげる箇所で、つなげた部屋しか同じクラスターに属していなかったので、それをなおしました。

今後のTODOとしては、まずこのクラスタリングをちゃんとしたUnion-FindTree的にする事と、他のアルゴリズムをためしてみる事があるでしょう。今のところ、どうもそれぞれのフィールドがどのクラスタに所属してるかを持っている実装になっているので、これは冗長だとおもいますので、それを修正したいです。

迷路生成をLispで

迷路を生成したいとおもい、Lispで簡単なクラスタリング法で生成してみました。

;;迷路のデータ構造
(defclass <maze> ()
  ((width :initarg :w :accessor w)
   (height :initarg :h :accessor h)
   (rooms :initarg :rooms :accessor rooms)))

;;部屋の情報を管理するリストをつくる
(defun make-room-list (w h)
  (let ((array (make-array (* w h) :initial-element 0)))
    (loop for idx from 0 upto (1- (* w h))
          do
          (setf (aref array idx) (list idx idx nil)))
    array))

;;単純なグリッドの部屋をつくる
(defun make-base-maze (w h)
  (make-instance '<maze>
                 :w w :h h
                 :rooms (make-room-list w h)))

;;対応する番号の部屋を返す
(defmethod get-room ((maze <maze>) idx)
    (aref (rooms maze) idx))

;;部屋のクラスタ番号を返す
(defmethod get-cluster-id ((maze <maze>) idx)
  (cadr (get-room maze idx)))

;;部屋のクラスタ番号を設定する
(defmethod set-cluster-id ((maze <maze>) idx new-id)
  (setf (cadr (aref (rooms maze) idx)) new-id))


;;全ての部屋がクラスタ0に属していたら終了
#|
| 初期状態ではクラスタ番号 i は i >= 0 を満している
| 部屋と部屋を接続する時には、かならず小さい方のクラスタ番号に属させるようにしている、よって
| 0 n = 0
| n m = if n > m then m else n
| とクラスタ番号が決められていくので、部屋を繋げていくたびに、クラスタ番号は単調減少していく。
| よって最終状態では、クラスタ番号は確実に全て0になっている。
 |#
(defmethod build-finished-p ((maze <maze>))
  (every (lambda (room) (zerop (cadr room)))
         (rooms maze)))

;;x座標とy座標を計算
(defmethod calc-x-y ((maze <maze>) idx)
  (values
    (mod idx (w maze)))
    (truncate idx (w maze)))

;;隣接した部屋かどうか
(defmethod neighbor-room-p ((maze <maze>) from to)
  (multiple-value-bind (from-x from-y) (calc-x-y maze from)
    (multiple-value-bind (to-x to-y) (calc-x-y maze to)
      (= (+ (abs (- from-x to-x)) 
            (abs (- from-y to-y))) 1))))

;;隣接した部屋ならば、繋げる
(defmethod connect-room ((maze <maze>) i j)
  (let ((id-i (get-cluster-id maze i))
        (id-j (get-cluster-id maze j)))
    (when (and (not (equal id-i id-j)) (neighbor-room-p maze i j))
      ;それぞれの部屋の隣接リストに相手の部屋を追加する
      (push j (caddr (aref (rooms maze) i)))
      (push i (caddr (aref (rooms maze) j)))
      ;小さい方のクラスタ番号を採用
      (set-cluster-id maze i (min id-i id-j))
      (set-cluster-id maze j (min id-i id-j)))))

;;初期迷路を生成し、全ての部屋が同じクラスタに属するまで
;;部屋をつなげていく
(defun build-maze (w h)
  (let ((maze (make-base-maze w h)))
    (loop until (build-finished-p maze)
          do
          (connect-room maze
                        (random (* w h))
                        (random (* w h))))
    maze))

実行すると

CL-USER(46): (rooms (build-maze 5 5 ))

#((0 0 (1 5)) (1 0 (0 2 6)) (2 0 (7 3 1)) (3 0 (2 4 8)) (4 0 (9 3))
  (5 0 (0 6 10)) (6 0 (7 5 11 1)) (7 0 (8 2 6 12)) (8 0 (7 3)) (9 0 (4 14))
  (10 0 (15 11 5)) (11 0 (6 10 16 12)) (12 0 (13 17 7 11)) (13 0 (14 12 18))
  (14 0 (13 19 9)) (15 0 (20 10 16)) (16 0 (21 17 15 11)) (17 0 (18 22 12 16))
  (18 0 (17 23 19 13)) (19 0 (14 18 24)) (20 0 (15 21)) (21 0 (16 20 22))
  (22 0 (17 23 21)) (23 0 (18 22 24)) (24 0 (19 23)))

このように部屋の間の接続がなされている事がわかります。
次はこの迷路をどのように視覚化するかですね。あとは、すこし壁がすくない気がするので、アルゴリズムを変項するとかしても良いかもしれませんね。

チューリングマシンのエミュレート(2) 定義の厳密化

停止性を保証する必要はないという事で最終状態はacceptになるかどうかだけで良いという
事でerror状態を削減したり、メモリーというのはそもそも無いという事でメモリーを削除したり
make-machine時に利用可能な記号列を渡す事で先に定義がただしいかチェックする昨日を追加しました。

;;
;; Infinity Tape
;; 
(defclass <tape> ()
  ((data :initform 
         (make-array 10 
                     :initial-element nil
                     :adjustable t)
         :initarg :data
         :accessor data)
   (look-at :initform 0
            :accessor look-at)))

(defun make-tape-with (list)
  (make-instance '<tape>
                 :data
                 (make-array (length list)
                                :initial-contents list
                                :adjustable t)))

(defmethod get-datum ((tape <tape>))
  (aref (data tape)
        (look-at tape)))

(defmethod set-datum ((tape <tape>) val)
  (setf (aref (data tape)
              (look-at tape)) val))

(defmethod move-left ((tape <tape>) &optional (blanc *blanc-code*))
  (decf (look-at tape))
  ;;underflow tape
  (when (= -1 (look-at tape))
    (setf (data tape)
          (concatenate 'vector 
                       (vector blanc)
                       (data tape)))
    (setf (look-at tape) 0)))

(defmethod move-right ((tape <tape>) &optional (blanc *blanc-code*))
  (incf (look-at tape))
  (when (= (length (data tape))
           (look-at tape))
    ;;overflow tape
    (vector-push-extend (data tape) blanc)))

;;
;; Turing Machine
;; 
 
;
; CONSTANT SYMBOL
(defvar *init-state* 'init)
(defvar *accept-state* 'accept)
(defvar *blanc-code* 'N)

(defclass <machine> ()
  ((input-tape
     :initarg :input
     :initform
     (error "Input tape was not specified.")
     :reader input-tape)
   (alphabet 
     :initform ()
     :initarg :alphabet
     :reader alphabet)
   (blanc
     :initform ()
     :initarg :blanc
     :reader blanc)
   (final-state
     :initform *accept-state*
     :initarg :final-state
     :reader final-state)
   (state :initform *init-state*
          :initarg :state
          :accessor state)
   (rules :initform ()
          :initarg :rules
          :accessor rules)))


(defun check-machine-definition 
  (input-data
    states symbols blanc-symbol input-symbols initial-state final-state transition-table)
  (when (not (subsetp input-data symbols))
    (error "Input tape conteins illigal character"))
  ;;Check states not empty
  (when (null states)
    (error "State set is empty"))
  ;;Check symbols not empty
  (when (null symbols)
    (error "Symbol set is empty"))
  ;;Check blance symbol is member of symbols
  (when (not (and (atom blanc-symbol)
                  (member blanc-symbol 
                          symbols)))
    (error "Blanc symbols isn't member of symbols"))
  ;;Check input-symbols is subset of (symbols - blanc-symbol)
  (when (not (subsetp input-symbols
                      (remove blanc-symbol
                              symbols)))
    (error "Input symbol-set is subset of (symbols - blanc-symbol)"))
  (when (not (member initial-state
                     states))
    (error "Initial state is not member of states"))
  (when (not (member final-state states))
    (error "Finish state is not member of states"))
  (check-machine-transition-table
    states symbols transition-table))

(defun check-machine-transition-table
  (states symbols table)
  (loop for rule in table
        when (not (member (car rule)
                           states))
        do
        (error "Unknown state : ~A~%" (car rule))
        do
        (loop for trans in (cdr rule)
              for in = (nth 0 trans)
              for put = (nth 1 trans)
              for move = (nth 2 trans)
              for next-state = (nth 3 trans)
              when (not (member in symbols))
              do
              (error "Unknown input: ~A in ~A~%" in trans)
              when (not (member put symbols))
              do
              (error "Illigal put: ~A in ~A ~%" put trans)
              when (not (member move '(left right)))
              do
              (error "Illigal move: ~A in ~A~%" move trans)
              when (not (member next-state states))
              do
              (error "Unknown next-state: ~A in ~A~%"
                     next-state trans))))


(defun make-machine 
  (input-data states symbols 
              blanc-symbol input-symbols 
              &optional
              (initial-state *init-state*)
              (final-state *accept-state*)
              (transition-table nil))

  (check-machine-definition 
    input-data
    states symbols blanc-symbol
    input-symbols initial-state
    final-state transition-table)

  (make-instance '<machine>
                 :input (make-tape-with input-data)
                 :state initial-state
                 :final-state final-state
                 :blanc blanc-symbol
                 :alphabet input-symbols
                 :rules transition-table))

(defmethod lookup-rule ((m <machine>))
  (assoc (state m) (rules m)))

(defmethod update ((m <machine>))
  (when (not (accept-p m))
    (let ((input (get-datum (input-tape m)))
          (rule  (cdr (lookup-rule m))))
      (let ((match-rule (assoc input rule)))
        (if match-rule
          (progn
            (set-datum (input-tape m)
                       (nth 1 match-rule))
            (cond ((eql 'left (nth 2 match-rule))
                   (move-left (input-tape m) (blanc m)))
                  ((eql 'right (nth 2 match-rule))
                   (move-right (input-tape m) (blanc m)))
                  (t
                   (error "Illigal move ~A"
                          (nth 2 match-rule))))
            (setf (state m) (nth 3 match-rule)))
          (error "No match rule"))))))



(defmethod accept-p ((m <machine>))
  (eql (final-state m)
       (state m)))

(defmethod show-machine-state ((m <machine>))
  (format t "State: ~A~%" (state m))
  (format t "[~A] (~A)~%" (data (input-tape m))
          (look-at (input-tape m)))
  (format t "   ~A^~%"
          (make-string (* (look-at (input-tape m))
                              2)
                       :initial-element #\Space)))

(defparameter *sample-adder*
  (make-machine '(N 1 1 1 0 1 1 1 1)
                '(init find-zero find-num add shift go-head accept)
                '(N 0 1)
                'N '(0 1)
                'init 'accept
                `((init
                    (N N right find-zero))
                  (find-zero
                    (1 1 right find-zero)
                    (0 M right find-num))
                  (find-num
                    (0 0 left go-head)
                    (1 1 left add))
                  (add
                   (1 0 left shift)
                   (0 0 right add)
                   (N N left go-head))
                  (shift
                    (0 1 right add)
                    (1 1 right go-head))
                  (go-head
                    (N N left accept)
                    (0 0 left go-head)
                    (1 1 left go-head)))))

(defmethod run-machine ((m <machine>) cnt)
  (loop repeat cnt
        until (accept-p m) 
        do
        (format t "--------------------~%")
        (show-machine-state m)
        (update m)))

定義が変更されたのみで、run-machineした時の結果はかわってません。
そろそろ万能チューリングマシンをつくりたい。