読者です 読者をやめる 読者になる 読者になる

レガシーコード生産ガイド

私に教えられることなら

Common Lispでコンピュテーションをアンダースタンディングする

CommonLisp 学習記録

アンダースタンディング・コンピュテーションを読み始めた。サンプルコードはRubyで書かれているけど、Common Lispの練習をしたいのでCommon Lispで書いてみる。 また、ボトムアップ設計の練習として、簡単なリストを使った構造から始める。 それで対応できなくなったら構造体やCLOSを使ってみる。それでもわからなくなったらRubyで書いてみることにする。

まずは2.3.1 スモールステップ意味論での、2.3.1.1のコードを書いてみる。

抽象構文木

Rubyコードではクラス名で数字、加算、乗算を表し、オブジェクトのleft,rightスロット(プロパティ?メンバ?)に左右のノードを入れているけど、まずは(ノードのタイプ 値 左 右)という簡単なリストにする。ノードのタイプはシンボルで表す。それに伴い、後々仕様変更した時のためにs-type/s-value/s-left/s-right関数でそれぞれの情報を取り出すことにする。sはsimpleのs。

(defun make-number (value) (list 'number value nil nil))
(defun make-add    (left right) (list 'add nil left right))
(defun make-mul    (left right) (list 'mul nil left right))

(defun s-type  (node) (first  node))
(defun s-value (node) (second node))
(defun s-left  (node) (third  node))
(defun s-right (node) (fourth node))

試してみる。

CL-USER> (make-add (make-number 3) (make-number 4))
(ADD NIL (NUMBER 3 NIL NIL) (NUMBER 4 NIL NIL))
CL-USER> (s-left (make-add (make-number 3) (make-number 4)))
(NUMBER 3 NIL NIL)
CL-USER> (s-type (make-add (make-number 3) (make-number 4)))
ADD

inspect

優先順位は気にせず、そのまま再帰下降で文字列を作っていく。

(defun s-inspect (expr)
  (let ((value (s-value expr))
        (left  (s-left  expr))
        (right (s-right expr)))
    (case (s-type expr)
      ((number) (format nil "~A" value))
      ((add) (format nil "~A + ~A" (s-inspect left) (s-inspect right)))
      ((mul) (format nil "~A * ~A" (s-inspect left) (s-inspect right))))))

;; こういう場合にformatより適切な関数があれば教えて欲しい。

実行結果

(s-inspect 
 (make-add 
  (make-mul (make-number 3) (make-number 4))
  (make-mul (make-number 5) (make-number 6))))

;; => "3 * 4 + 5 * 6"

reduce

再帰下降で一気に評価するのではなく、左から、最も深いものから、一度ずつ簡約していく。+と*を子がどちらも数字(簡約不可能)と仮定して簡約し、数字はそのまま返すs-reduce,一度だけ式を簡約するs-reduce-1を作る。

そのためにreducible?メソッドを各クラスに追加しているが、今回はただの関数として用意する。さらに、それぞれのクラスでNumber.newみたいに木を生成する代わりに、対象の木の左右どちらかのノードを別のノードで入れ替えた木を返すs-replaced-left/s-replaced-rightを作る。

(defun reducible? (expr)
  (case (s-type expr)
    ((add mul) t)
    (otherwise nil)))

;; (reducible? (make-mul (make-number 4) (make-number 5))) => T
;; (reducible? (make-number 3)) => NIL

(defun s-replaced-left (expr node)
  (list (s-type expr) (s-value expr) node (s-right expr)))

(defun s-replaced-right (expr node)
  (list (s-type expr) (s-value expr) (s-left expr) node))

(defun s-reduce (expr)
  (let ((value (s-value expr))
        (left  (s-left  expr))
        (right (s-right expr)))
    (case (s-type expr)
      ((add) (s-reduce-add (s-value left) (s-value right)))
      ((mul) (s-reduce-mul (s-value left) (s-value right)))
      (otherwise value))))

(defun s-reduce-add (x y)
  (make-number (+ x y)))

(defun s-reduce-mul (x y)
  (make-number (* x y)))

(defun s-reduce-1 (expr)
  (cond
    ((reducible? (s-left expr))  (s-replaced-left  expr (s-reduce-1 (s-left  expr))))
    ((reducible? (s-right expr)) (s-replaced-right expr (s-reduce-1 (s-right expr))))
    (t (s-reduce expr))))

本の例を試してみる。

(s-inspect 
 (make-add
  (make-mul (make-number 1) (make-number 2))
  (make-mul (make-number 3) (make-number 4))))
;; => "1 * 2 + 3 * 4"

(s-inspect
 (s-reduce-1
  (make-add
   (make-mul (make-number 1) (make-number 2))
   (make-mul (make-number 3) (make-number 4)))))
;; => "2 + 3 * 4"

(s-inspect
 (s-reduce-1
  ;; 上をs-reduce-1した結果
  '(ADD NIL (NUMBER 2 NIL NIL) (MUL NIL (NUMBER 3 NIL NIL) (NUMBER 4 NIL NIL)))))
;; => "2 + 12"

(s-inspect
 (s-reduce-1
  '(ADD NIL (NUMBER 2 NIL NIL) (NUMBER 12 NIL NIL))))
;; => "14"

virtual machine

さて、値になるまで式を簡約する抽象機械を手でシミュレートしたわけだけど、それを自動実行してくれる仮想機械を作る。最初はreduceは一発で再帰下降で簡約してしまえばいいんじゃないかと思ったけど、一度ずつやることで計算の過程を表示するのが狙いみたいだ。

実装してみる。式をinspectして、式が簡約できるなら簡約、と再帰する。

(defun vm-run (expr)
  (format t "~A~%" (s-inspect expr))
  (if (reducible? expr) (vm-run (s-reduce-1 expr)) expr))

さっきの例を試してみる。

CL-USER> (vm-run  (make-add
  (make-mul (make-number 1) (make-number 2))
  (make-mul (make-number 3) (make-number 4))))
1 * 2 + 3 * 4
2 + 3 * 4
2 + 12
14
(NUMBER 14 NIL NIL)

ブール値・比較演算の追加とマクロ

さて、計算ができるようになったのでいろいろな値や演算子を追加するのだけど、現状では、追加する度に

  • make-hoge関数
  • s-inspectのcase
  • s-reduceのcase
  • それぞれの関数

と4つの位置を変更する必要がある。DRY原則に反して、ヒューマンエラーが生まれやすくなり、コードの見通しが悪くなり、大地の怒りが聞こえるようになる。データ構造を変更した後、関数とマクロでどうにかする。

まずmake-hoge。それぞれ個別にnumber,add,mulとやるのではなく、値(value)と演算子(op)に抽象化する。さらに、変数の実装の為に、それぞれの値にreducibleをつけておく。

(defun make-value (type value &optional (reducible nil)) (list type value nil nil reducible))
(defun make-op    (type left right &optional (reducible t)) (list type nil left right reducible))

make-hogeを使ってる場所を置き換える。

(defun s-reduce-add (x y)
  (make-value 'number (+ x y)))

(defun s-reduce-mul (x y)
  (make-value 'number (* x y)))

reducibleを、それぞれの値で参照するようにする。データ構造に組み込まれたので、アクセサを定義してるところに持ってきておく。

(defun s-type  (node) (first  node))
(defun s-value (node) (second node))
(defun s-left  (node) (third  node))
(defun s-right (node) (fourth node))
(defun reducible? (node) (fifth node))

試してみる。

CL-USER> (make-value 'number 3)
(NUMBER 3 NIL NIL NIL)
CL-USER> (reducible? (make-value 'number 3))
NIL
CL-USER> (make-op 'add (make-value 'number 4) (make-value 'number 5))
(ADD NIL (NUMBER 4 NIL NIL NIL) (NUMBER 5 NIL NIL NIL) T)
CL-USER> (reducible? (make-op 'add (make-value 'number 4) (make-value 'number 5)))
T

次にinspect。今、caseあたりは

    (case (s-type expr)
      ((number) (format nil "~A" value))
      ((add) (format nil "~A + ~A" (s-inspect left) (s-inspect right)))
      ((mul) (format nil "~A * ~A" (s-inspect left) (s-inspect right))))))

こういう実装になっている。どういう実装がいいだろうか?

  1. フォーマット文字列を値に持たせる。オプションはvalueかopかで変更される。
  2. フォーマット文字列と値の組を値に持たせる。
  3. 文字列化関数を値に持たせる。その値が引数として渡される。
  4. 文字列化関数をグローバル変数に登録する。alistやハッシュにtypeと関数の組を登録。

1と2は柔軟性に欠けるし、実装も汚くなりそうだ。3は一番シンプルだけど、全ての値がlambdaを持つのでメモリ効率が悪い。4で行こう。

(defvar *inspect-function-table* '())
(defun inspect-function (type)
  (cdr (assoc type *inspect-function-table*)))

(defun s-inspect (expr)
  (funcall (inspect-function (s-type expr)) expr))

試してみる。

(push (cons 'number (lambda (expr) (format nil "~A" (s-value expr)))) *inspect-function-table*)
(push (cons 'add (lambda (expr)
                   (format nil "~A + ~A" 
                           (s-inspect (s-left expr))
                           (s-inspect (s-right expr))))) *inspect-function-table*)
(push (cons 'mul (lambda (expr)
                   (format nil "~A * ~A" 
                           (s-inspect (s-left expr))
                           (s-inspect (s-right expr))))) *inspect-function-table*)

(s-inspect (make-op 'mul (make-value 'number 4) (make-value 'number 5)))
;; => "4 * 5"

reduceへの登録と併せたいので、後で消すかもしれないけど、練習と思ってマクロを書いてみる。

分配とか、変数名指定マクロとかあるけど、まず「同じコードを繰り返さない」を求めて、type,value,left,rightなどで暗黙の変数として使えるようにする。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-inspect-fn (&rest body)
    `(lambda (expr)
       (let (($type  (s-type expr))
             ($value (s-value expr))
             ($left  (s-left expr))
             ($right (s-right expr))
             ($reducible (reducible? expr)))
         ,@body))))

(defmacro regist-inspect-fn (type &body body)
  `(push (cons ',type ,(apply #'make-inspect-fn body)) *inspect-function-table*))

これで

(regist-inspect-fn number (format nil "~A" $value))
(regist-inspect-fn add
  (format nil "~A + ~A" (s-inspect $left) (s-inspect $right)))
(regist-inspect-fn mul
  (format nil "~A * ~A" (s-inspect $left) (s-inspect $right)))

こう書ける。

$hogeを使ってない場合、$hoge is defined but never usedの警告が出る。全部ignoreしてしまうと逆に使われていると警告が出る。 警告を消す方法調べようと思ったけど、そもそもこういう設計あんまり良くないんだろうな。aifとか一つだけぐらいなら、itを使うならaif、使わないならそもそもifでやる、とか指針ができるけど、複数だとそういうわけにもいかない。使う変数名を明記した方が良さそうだ。

というわけで修正する。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun declare-inspect-arg (arg)
    (case arg
      (($type)  '($type  (s-type expr)))
      (($value) '($value (s-value expr)))
      (($left)  '($left  (s-left expr)))
      (($right) '($right (s-right expr)))
      (($reducible) '($reducible (reducible? expr)))))

  (defun declares-inspect-args (args)
    (reduce (lambda (ds arg) 
              (cons (declare-inspect-arg arg) ds))
            args :initial-value '()))

  (defun make-inspect-fn (args &rest body)
    `(lambda (expr)
       (let ,(declares-inspect-args args) ,@(car body)))))

(defmacro regist-inspect-fn (type args &body body)
  `(push (cons ',type ,(make-inspect-fn args body)) *inspect-function-table*))

(regist-inspect-fn number ($value) (format nil "~A" $value))
(regist-inspect-fn add ($left $right)
  (format nil "~A + ~A" (s-inspect $left) (s-inspect $right)))
(regist-inspect-fn mul ($left $right)
  (format nil "~A * ~A" (s-inspect $left) (s-inspect $right)))

最後はs-reduceのcaseとそれぞれの関数定義をまとめる。

s-reduceのcaseはこうなっている

    (case (s-type expr)
      ((add) (s-reduce-add (s-value left) (s-value right)))
      ((mul) (s-reduce-mul (s-value left) (s-value right)))
      (otherwise value))))

それぞれの関数はこう

(defun s-reduce-add (x y)
  (make-value 'number (+ x y)))

(defun s-reduce-mul (x y)
  (make-value 'number (* x y)))

これも、ノードのタイプと関数の組でいけそうだ。declares-inspect-argsはそのまま使える。makeとregistを少し修正したものを新たに加える。

まず関数テーブル

(defvar *type-function-table* '())
(defun type-function (type)
  (cdr (assoc type *type-function-table*)))

マクロ用補助関数の名前を修正する

  (defun declare-destructed-arg (arg) ...

  (defun declares-destructed-args (args) ...

  (defun make-expr-fn (args &rest body) ...

マクロを編集・追加し、s-reduceを各タイプの関数を使うように修正

(defmacro regist-inspect-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *inspect-function-table*))

(defmacro regist-type-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *type-function-table*))

(defun s-reduce (expr)
  (funcall (type-function (s-type expr)) expr))

さらに、replaceも変更する。ここを忘れていて、しばらく悩んだ。構造に関するものはまとめておくべきだった。

(defun s-replaced-left (expr node)
  (list (s-type expr) (s-value expr) node (s-right expr) (reducible? expr)))

(defun s-replaced-right (expr node)
  (list (s-type expr) (s-value expr) (s-left expr) node (reducible? expr)))

試してみる。まずは定義

(regist-type-fn number ($value) $value)
(regist-type-fn add ($left $right)
  (make-value 'number (+ (s-value $left) (s-value $right))))
(regist-type-fn mul ($left $right) 
  (make-value 'number (* (s-value $left) (s-value $right))))

試してみる。

CL-USER> (vm-run  (make-op 'add
  (make-op 'mul (make-value 'number 1) (make-value 'number 2))
  (make-op 'mul (make-value 'number 3) (make-value 'number 4))))

1 * 2 + 3 * 4
2 + 3 * 4
2 + 12
14
(NUMBER 14 NIL NIL NIL)

最後に、inspect用の関数と簡約用の関数を一度に定義するマクロ、それを使った二項演算子定義用のマクロを作る。ついでに減算と除算、boolと比較演算子も追加する

(defmacro regist-type (type inspect-fn type-fn)
  `(progn
     (regist-inspect-fn ,type ,@inspect-fn)
     (regist-type-fn ,type ,@type-fn)))

(defmacro regist-binop (type result-type fn)
  (let ((format (concatenate 'string "~A " (symbol-name fn) " ~A")))
    `(regist-type ,type
                  (($left $right)
                   (format nil ,format (s-inspect $left) (s-inspect $right)))
                  (($left $right)
                   (make-value ',result-type (,fn (s-value $left) (s-value $right)))))))

(regist-type number
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-type bool
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-binop add number +)
(regist-binop sub number -)
(regist-binop mul number *)
(regist-binop div number /)
(regist-binop gt bool >)
(regist-binop lt bool <)
(regist-binop eq bool =)

試してみる。

CL-USER> (vm-run (make-op 'gt (make-value 'number 3) (make-value 'number 4)))
3 > 4
NIL
(BOOL NIL NIL NIL NIL)
CL-USER> (vm-run (make-op 'lt (make-value 'number 3) (make-value 'number 4)))
3 < 4
T
(BOOL T NIL NIL NIL)
CL-USER> (vm-run 
 (make-op 'eq 
          (make-op 'sub 
                   (make-value 'number 6) 
                   (make-value 'number 3))
          (make-value 'number 3)))
6 - 3 = 3
3 = 3
T
(BOOL T NIL NIL NIL)

うまくいってるみたいだ。

長くなりすぎたので、変数からは次回へ。

はてなに貼れるかなこれ…

感想

  • 読み、作りながら記事を書くの、かなり作業に指向性が生まれていいかもしれない
  • それを読み返したらどう感じるかは謎
  • マクロじゃなくて関数でよかったかな〜というところがちらほらある。実際にできるかはわからないけど。シンボルを'hogeで書くの、そんなに面倒でもないし。
  • 今の俺レベルでの学習記録残すの、誰の参考にもならないだろうし正直ウーンとは思うんだけど、いずれ上手くなったときに「こんな上手い人でもこんな下手な時代あったんだ、自分もがんばろう」となってもらえればいいかな。。

全コード

(defun make-value (type value &optional (reducible nil)) (list type value nil nil reducible))
(defun make-op    (type left right &optional (reducible t)) (list type nil left right reducible))

(defun s-type  (node) (first  node))
(defun s-value (node) (second node))
(defun s-left  (node) (third  node))
(defun s-right (node) (fourth node))
(defun reducible? (node) (fifth node))

(defun s-replaced-left (expr node)
  (list (s-type expr) (s-value expr) node (s-right expr) (reducible? expr)))

(defun s-replaced-right (expr node)
  (list (s-type expr) (s-value expr) (s-left expr) node (reducible? expr)))

(defvar *inspect-function-table* '())
(defun inspect-function (type)
  (cdr (assoc type *inspect-function-table*)))

(defun s-inspect (expr)
  (funcall (inspect-function (s-type expr)) expr))

(defvar *type-function-table* '())
(defun type-function (type)
  (cdr (assoc type *type-function-table*)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun declare-destructed-arg (arg)
    (case arg
      (($type)  '($type  (s-type expr)))
      (($value) '($value (s-value expr)))
      (($left)  '($left  (s-left expr)))
      (($right) '($right (s-right expr)))
      (($reducible) '($reducible (reducible? expr)))))

  (defun declares-destructed-args (args)
    (reduce (lambda (ds arg) 
              (cons (declare-destructed-arg arg) ds))
            args :initial-value '()))

  (defun make-expr-fn (args &rest body)
    `(lambda (expr)
       (let ,(declares-destructed-args args) ,@(car body)))))

(defmacro regist-inspect-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *inspect-function-table*))

(defmacro regist-type-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *type-function-table*))

(defmacro regist-type (type inspect-fn type-fn)
  `(progn
     (regist-inspect-fn ,type ,@inspect-fn)
     (regist-type-fn ,type ,@type-fn)))

(defmacro regist-binop (type result-type fn)
  (let ((format (concatenate 'string "~A " (symbol-name fn) " ~A")))
    `(regist-type ,type
                  (($left $right)
                   (format nil ,format (s-inspect $left) (s-inspect $right)))
                  (($left $right)
                   (make-value ',result-type (,fn (s-value $left) (s-value $right)))))))

(regist-type number
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-type bool
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-binop add number +)
(regist-binop sub number -)
(regist-binop mul number *)
(regist-binop div number /)
(regist-binop gt bool >)
(regist-binop lt bool <)
(regist-binop eq bool =)

(defun s-reduce (expr)
  (funcall (type-function (s-type expr)) expr))

(defun s-reduce-1 (expr)
  (cond
    ((reducible? (s-left expr))  (s-replaced-left  expr (s-reduce-1 (s-left  expr))))
    ((reducible? (s-right expr)) (s-replaced-right expr (s-reduce-1 (s-right expr))))
    (t (s-reduce expr))))

(defun vm-run (expr)
  (format t "~A~%" (s-inspect expr))
  (if (reducible? expr) (vm-run (s-reduce-1 expr)) expr))
広告を非表示にする