Common Lispでモナドみたいなことやった話

はいはいー。@nobkzです。

# Lispでモナドやってみた話

はいはい。なんとなくLispでモナドやった話を書きます。

## optimaをload

はいはい

```cl
(ql:quickload :optima)
```

## モナドのreturn関数とbindをまずdefgenericメソッドとする。

```cl
;; return
(defgeneric ret (type x))

;; >>=
(defgeneric bind (m func))
```


## Optionモナドをつくる

Optionモナドとかについてはみなさんご存知ですね。

はいはいー。HaskellではMaybeという、値があるかないかの型がありまして、それをつくります。
構造体でつくりました。

```cl
(defstruct option)
(defstruct (just (:constructor just (content))
		 (:include option))
  content)
(defstruct (none (:constructor none)
		 (:include option)))
```

### Optionのretとbindを実装する

はいはい、こんな感じになります。

```cl
(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))))
```

### つかってみる。

簡単にやってみると...

```cl
(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をつくる。

```cl
(defun add-option20 (x) 
  (lambda (y) 
    (let ((ans (+ x y)))
      (if (< ans 20)
	  (just ans)
	  (none)))))
```

bindで組み合せる。

```cl
(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と書くの面倒なので、こんなの作ったー。

```cl
(defun binds (m &rest funcs)
  (if funcs
      (reduce #'bind (cons m funcs))
      m))
```

つかってみる。

```cl
(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記法ぽいものをつくったー。

こんな感じ。

```cl
(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記法は実装できる。

### つかってみる。

```cl
(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を定義しています。

```cl
;; 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はこうなります

```cl
(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))))))
```


### つかってみる

```cl
;; 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ぽいの

説明すんのダルくなってきた...

```cl
 ;; 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記法の、文脈指定を無くす。(関数より、手続きのとして考えたら可能?)