はいはいー。@nobkzです。
Lispでモナドやってみた話
はいはい。なんとなくLispでモナドやった話を書きます。
optimaをload
はいはい
(ql:quickload :optima)
モナドのreturn関数とbindをまずdefgenericメソッドとする。
;; return
(defgeneric ret (type x))
;; >>=
(defgeneric bind (m func))
Optionモナドをつくる
Optionモナドとかについてはみなさんご存知ですね。
はいはいー。HaskellではMaybeという、値があるかないかの型がありまして、それをつくります。
構造体でつくりました。
(defstruct option)
(defstruct (just (:constructor just (content))
(:include option))
content)
(defstruct (none (:constructor none)
(:include option)))
Optionのretとbindを実装する
はいはい、こんな感じになります。
(defmethod ret ((type (eql 'option)) x)
(just x))
(defmethod bind ((m option) proc-returning-option)
(match m
((just :content x) (funcall proc-returning-option x))
((none) (none))))
つかってみる。
簡単にやってみると...
(bind (ret 'option 1) (lambda (x) (ret 'option (+ x 1))))
;; -> #S(JUST :CONTENT 2)
(bind (none) (lambda (x) (ret 'option (+ x 1))))
;; -> #S(NONE)
さて簡単にするため20を超えると、失敗する計算をやってみる。(つまり、計算して20を超えたときnoneを返し、成功すると、justを返す計算をつくる。)
まず add-option20をつくる。
(defun add-option20 (x)
(lambda (y)
(let ((ans (+ x y)))
(if (< ans 20)
(just ans)
(none)))))
bindで組み合せる。
(bind (ret 'option 1) (add-option20 1))
;; -> #S(JUST :CONTENT 2)
(bind (ret 'option 10) (add-option20 10))
;; -> #S(NONE)
(bind
(bind
(bind (ret 'option 1)
(add-option20 1))
(add-option20 1))
(add-option20 1))
;; -> #S(JUST :CONTENT 4)
(bind
(bind
(bind (ret 'option 1)
(add-option20 1))
(add-option20 20))
(add-option20 1))
;; -> #S(NONE)
bindが面倒なので、bindsを作った。
毎回bind、bindと書くの面倒なので、こんなの作ったー。
(defun binds (m &rest funcs)
(if funcs
(reduce #'bind (cons m funcs))
m))
つかってみる。
(binds (ret 'option 1)
(add-option20 1)
(add-option20 1)
(add-option20 1))
;; -> #S(JUST :CONTENT 4)
(binds (ret 'option 1)
(add-option20 1)
(add-option20 20)
(add-option20 1))
;; -> #S(NONE)
良い感じですね。
do記法ぽいものをつくったー。
こんな感じ。
(defmacro do-monad (type &body body)
(let ((_ (gensym)))
(let ((first (car body))
(rest (cdr body)))
(let ((ret-first (ret-add-types type first)))
(match ret-first
((list 'setm arg monad-proc)
`(binds ,monad-proc
,(if rest
`(lambda (,arg)
(do-monad ,type ,@rest)))))
(_
(if (null rest)
ret-first
`(binds ,ret-first
(lambda (,_)
(declare (ignore ,_))
(do-monad ,type ,@rest))))))))))
(defun ret-add-types (type list)
(let ((first (car list))
(rest (cdr list)))
(cond ((null list) nil)
((eq first 'do-monad) list)
((eq first 'ret)
`(ret ,type ,@(ret-add-types type rest)))
((listp first)
(cons (ret-add-types type first)
(ret-add-types type rest)))
(t (cons first (ret-add-types type rest))))))
まだ完全な実装じゃないけど、とりあえず簡単なdo記法は実装できる。
つかってみる。
(do-monad 'option
(setm x (ret 10))
(funcall (add-option20 x) 1))
;; -> #S(JUST :CONTENT 11)
(do-monad 'option
(setm x (ret 10))
(none)
(funcall (add-option20 x) 1))
;; -> #S(NONE)
Stateモナドをつくってみる。
Stateモナドは一つ関数値を持ちます。そのStateの関数値は、状態を取り、 新しい状態と値を返す関数でなくてはなりません。
lispでは、「状態を取り、 新しい状態と値を返す関数」というデータ指定はできないので、ここでは「新しい状態と値」を持つtransite-resultを定義しています。
そして、Stateモナド遷移関数を適用するrun-trasitを定義しています。
;; state monad
(defstruct (transition (:constructor transition (proc)))
proc)
(defstruct (transited-result
(:constructor transited-result
(value state)))
value
state)
(defun run-transit (transit state)
(funcall (transition-proc transit) state))
とするとret と bindはこうなります
(defmethod ret ((type (eql 'transition)) x)
(transition
(lambda (state)
(transited-result x state))))
(defmethod bind ((transition transition) proc-returning-transition)
(transition
(lambda (state)
(let* ((first-transited-result
(run-transit transition state))
(new-transition
(funcall proc-returning-transition
(transited-result-value first-transited-result))))
(run-transit new-transition
(transited-result-state first-transited-result))))))
つかってみる
;; state-example
(defun transit-push (a)
(transition
(lambda (state)
(transited-result nil (cons a state)))))
(defun transit-pop ()
(transition
(lambda (state)
(transited-result (car state) (cdr state)))))
(defun fib-transit1 ()
(do-monad 'transition
(setm x (transit-pop))
(setm y (transit-pop))
(transit-push y)
(transit-push x)
(transit-push (+ x y))
(ret (+ x y))))
(defun fib-transit5 ()
(do-monad 'transition
(fib-transit1)
(fib-transit1)
(fib-transit1)
(fib-transit1)
(fib-transit1)))
(run-transit (fib-transit5) '(1 1))
;; -> #S(TRANSITED-RESULT :VALUE 13 :STATE (13 8 5 3 2 1 1))
モナディックParsecぽいの
説明すんのダルくなってきた...
;; parser
(defstruct (parser (:constructor parser (proc)))
proc)
(defun parse (parser text)
(funcall (parser-proc parser) text))
(defstruct (parse-result (:constructor parse-result (value text)))
value text)
(defstruct (failed-result (:constructor failed-result (msg)))
msg)
(defmethod ret ((type (eql 'parser)) x)
(parser
(lambda (text)
(parse-result x text))))
(defmethod bind ((parser parser) proc-returning-parser)
(parser
(lambda (text)
(let ((parse-result
(parse parser text)))
(match parse-result
((failed-result :msg _)
parse-result)
((parse-result :value value :text text)
(let ((new-parser
(funcall proc-returning-parser value)))
(parse new-parser text))))))))
(defun item ()
(parser
(lambda (text)
(if (string= text "")
(failed-result "getiing text error")
(parse-result (subseq text 0 1)
(subseq text 1
(length text)))))))
(defun failure (msg)
(parser (lambda (text)
(declare (ignore text))
(failed-result msg))))
(defun spaces ()
(parser (lambda (text)
(parse-result nil (front-space-delete text)))))
(defun front-space-delete (text)
(let ((result
(position-if-not (lambda (s) (string= s " ")) text)))
(if result
(subseq text result (length text))
"")))
(defun number ()
(do-monad 'parser
(setm c (item))
(if (find c "1234567890" :test #'string=)
(ret (parse-integer c))
(failure "not number"))))
(defun eof ()
(parser
(lambda (text)
(if (string= text "")
(parse-result nil "")
(failed-result "not end")))))
(defun plus ()
(do-monad 'parser
(setm c (item))
(if (string= c "+")
(ret t)
(failure "not + at plus"))))
(defun my-parser1 ()
(do-monad 'parser
(spaces)
(setm x (number))
(spaces)
(plus)
(spaces)
(setm y (number))
(spaces)
(ret (+ x y))))
(parse (my-parser1) "1 + 1")
;; -> #S(PARSE-RESULT :VALUE 2 :TEXT "")
課題
- lifting、モナド変換子の実装
- do記法の、文脈指定を無くす。(関数より、手続きのとして考えたら可能?)