Fri Mar 22 01:41:07 JST 2013

;; State Monad in Scheme

; where f g ... h :: a -> (values b a) -- a is State
; runState (f g ... h) a :: (values b a)
; runState (f g ... h) a =
;     (receive (_ a) (f a)
;         (receive (_ a) (g a)
;             ...
;             (h a)))

; data Tree = () | '(Int Tree Tree)
; push :: Int -> (values Int Tree)
; pop :: Int -> (values Int Tree)

; gosh> (runState ((push 1)) ())
; 1
; (1 () ())
; gosh> (runState ((push 1) (push 2)) ())
; 2
; (1 () (2 () ()))
; gosh> (runState ((push 1) (push 2) pop) ())
; 1
; (2 () ())
; gosh> (runState ((push 1) (push 2) pop (push 3) pop) ())
; 2
; (3 () ())

(use util.match)

(define-syntax runState
    (syntax-rules ()
        [(_ (f) x) (f x)]
        [(_ (f g ...) x) (receive (_ y) (f x) (runState (g ...) y))] ))

(define (push n)
    (define (%push tr n)
        (match tr
            [() (values n (list n () ()))]
            [(m left right)
                (values n
                        (if (> m n)
                            (list m (receive (_ tr) (%push left n) tr) right)
                            (list m left (receive (_ tr) (%push right n) tr))))] ))
    (lambda (tr) (%push tr n)))

(define (pop tr)
    (match tr
        [(m () right)            (values m right)]
        [(m (n () right2) right) (values n (list m right2 right))]
        [(m left right)          (receive (n tr) (pop left) (values n (list m tr right)))] ))

; i learned State Monad yesterday. and i learned util.match today.
; i think match macro is too strong. awesome!