1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
(define (make-tagged-value tag value)
  (cons tag value))

(define (get-tag x) (car x))

(define (get-value x) (cdr x))

;; type : a -> TaggedM a
(define (return a)
  (lambda (tag) (make-tagged-value tag a)))

;; >>= bind函数，接受一个monad,以及一个函数a -> TaggedM b,
;; 返回一个新的Monad: Taggged b
(define (>>= m f) ; m is Monad a, f is a->Monad b
  (lambda (tag)
    (let* ( (m-result (m tag))
            (tag (get-tag m-result))
            (value (get-value m-result))
            (new-m (f value)) )
      (new-m tag))))

;; inc用来封装变化
;; type : int -> TaggedM int
(define (inc n)
  (make-tagged-value (+ n 1) n))

(define (make-node value lchild rchild)
  (>>= inc
       (lambda (x)
         (return (list (make-tagged-value x value) lchild rchild)) ) ) )

(define (make-tree-left-first depth)
  (if (= depth 0)
      (make-node 0 '() '())
      (>>= (make-tree-left-first (- depth 1))
           (lambda (lchild)
             (>>= (make-tree-left-first (- depth 1))
                  (lambda (rchild)
                    (make-node depth lchild rchild)))))))


(define (make-tree-right-first depth)
  (if (= depth 0)
      (make-node 0 '() '())
      (>>= (make-tree-right-first (- depth 1))
           (lambda (rchild)
             (>>= (make-tree-right-first (- depth 1))
                  (lambda (lchild)
                    (make-node depth lchild rchild)))))))

(define left-first-tree-monad (make-tree-left-first 3))
(define right-first-tree-monad (make-tree-right-first 3))


(define test-left
  (>>= (make-node 0 '() '())
       (lambda (l)
         (>>= (make-node 0 '() '())
              (lambda (r)
                (make-node 1 l r)))) ) 
  )
(define test-right
  (>>= (make-node 0 '() '())
       (lambda (r)
         (>>= (make-node 0 '() '())
              (lambda (l)
                (make-node 1 l r)))) ) 
  )