diff options
author | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-10 00:59:14 +0900 |
---|---|---|
committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-10 00:59:23 +0900 |
commit | 68ecc10a0948aea9b7fb8db56cda270b48bf8177 (patch) | |
tree | 087866b0d2a8f544b783918c6e573368adc5e508 | |
parent | 33b263f2e381501a8525d6e5463d950d863efb16 (diff) |
Add monad examples
-rw-r--r-- | examples/optional.scm | 71 | ||||
-rw-r--r-- | examples/state.scm | 56 |
2 files changed, 127 insertions, 0 deletions
diff --git a/examples/optional.scm b/examples/optional.scm new file mode 100644 index 0000000..e3f2eec --- /dev/null +++ b/examples/optional.scm @@ -0,0 +1,71 @@ +(module (data optional) (<some> some some? some-value <none> none none?) + (import scheme + (chicken base) + (chicken format)) + + (define-record-type <some> + (some value) + some? + (value some-value)) + + (set! (record-printer <some>) + (lambda (x out) + (fprintf out "#<(some ~S)>" (some-value x)))) + + (define-record-type <none> + (none) + none?) + + (set! (record-printer <none>) + (lambda (_ out) + (fprintf out "#<(none)>")))) + +(module (data optional monad base) (pure map map2 >>=) + (import (except scheme map) + (prefix (data optional) opt:) + matchable) + + (define (map f opt) + (match opt + [($ opt:<some> x) (opt:some (f x))] + [($ opt:<none>) (opt:none)])) + + (define (pure x) + (opt:some x)) + + (define (map2 f opt1 opt2) + (match opt1 + [($ opt:<some> x) + (match opt2 + [($ opt:<some> y) (opt:some (f x y))] + [($ opt:<none>) (opt:none)])] + [($ opt:<none>) (opt:none)])) + + (define (>>= opt f) + (match opt + [($ opt:<some> x) (f x)] + [($ opt:<none>) (opt:none)]))) + +(import (only (algebraic-structs functor make)) + (only (algebraic-structs applicative make)) + (only (algebraic-structs monad make))) + +(module (data optional functor) = ((algebraic-structs functor make) (data optional monad base))) +(module (data optional applicative) = ((algebraic-structs applicative make) (data optional monad base))) +(module (data optional monad) = ((algebraic-structs monad make) (data optional monad base))) + +(import (prefix (data optional) opt:) + (prefix (data optional functor) opt:) + (prefix (data optional applicative) opt:) + (prefix (data optional monad) opt:)) + +;; (opt:map (lambda (x) (* x x)) (opt:pure 5)) => (some 25) +;; (opt:map (lambda (x) (* x x)) (opt:none)) => (none) + +;; (opt:map* + (opt:pure 1) (opt:pure 2) (opt:pure 3)) => (some 6) +;; (opt:map* + (opt:pure 1) (opt:none) (opt:pure 3)) => (none) + +;; (opt:do (x <- (opt:pure 3)) +;; (y <- (opt:pure 4)) +;; (opt:pure (+ x y))) +;; => (some 7) diff --git a/examples/state.scm b/examples/state.scm new file mode 100644 index 0000000..b649859 --- /dev/null +++ b/examples/state.scm @@ -0,0 +1,56 @@ +(module (data state) + (run get put map pure map2 >>=) + (import (except scheme map) + (only (chicken base) void assert) + matchable) + + (define (run m init) + (car (m init))) + + (define get + (lambda (st) + (cons st st))) + + (define (put st) + (lambda (_st) + (cons (void) st))) + + (define (map f m) + (lambda (st) + (match-let ([(x . st*) (m st)]) + (cons (f x) st*)))) + + (define (pure x) + (lambda (st) (cons x st))) + + (define (map2 f m1 m2) + (lambda (st) + (match-let* ([(x . st*) (m1 st)] + [(y . st**) (m2 st*)]) + (cons (f x y) st**)))) + + (define (>>= m f) + (lambda (st) + (match-let* ([(x . st*) (m st)] + [(x* . st**) ((f x) st*)]) + (cons x* st**))))) + +(import (only (algebraic-structs functor make)) + (only (algebraic-structs applicative make)) + (only (algebraic-structs monad make))) +(module (data state functor) = ((algebraic-structs functor make) (data state))) +(module (data state applicative) = ((algebraic-structs applicative make) (data state))) +(module (data state monad) = ((algebraic-structs monad make) (data state))) + +(import (prefix (data state) st:) + (prefix (data state functor) st:) + (prefix (data state applicative) st:) + (prefix (data state monad) st:)) + +;; (st:run (st:do (x <- st:get) +;; (let y = (* x 3)) +;; (st:put y) +;; (z <- st:get) +;; (st:pure z)) +;; 5) +;; => 15 |