Monads/Writer monad: Difference between revisions
→{{header|Wren}}
Line 1,207:
Added one: 3.23606797749979
Divided by 2: 1.618033988749895
</pre>
=={{header|Scheme}}==
{{works with|Gauche Scheme|0.9.12}}
{{works with|CHICKEN Scheme|5.3.0}}
The program is written in R7RS-small Scheme. For CHICKEN you will need the <code>r7rs</code> egg.
<syntaxhighlight lang="scheme">
(define-library (monad base)
(export make-monad monad? monad-identifier
monad-object monad-additional
>>= >=>)
(import (scheme base)
(scheme case-lambda))
(begin
(define-record-type <monad>
(make-monad identifier bind object additional)
monad?
(identifier monad-identifier)
(bind monad-bind)
(object monad-object)
(additional monad-additional))
(define >>=
(case-lambda
((m f) ((monad-bind m) m f))
((m f . g*) (apply >>= (cons (>>= m f) g*)))))
(define >=>
(case-lambda
((f g) (lambda (x) (>>= (f x) g)))
((f g . h*) (apply >=> (cons (>=> f g) h*)))))
)) ;; end library
(define-library (monad perform)
(export perform)
(import (scheme base)
(monad base))
(begin
(define-syntax perform
;; "do" is already one of the loop syntaxes, so I call this
;; syntax "perform" instead.
(syntax-rules (<-)
((perform (x <- action) clause clause* ...)
(>>= action (lambda (x) (perform clause clause* ...))))
((perform action)
action)
((perform action clause clause* ...)
(action (perform clause clause* ...)))))
)) ;; end library
(define-library (monad writer-monad)
(export make-writer-monad writer-monad?)
(import (scheme base)
(monad base))
(begin
;; The messages are a list, most recent message first, of whatever
;; data f decides to log.
(define (make-writer-monad object messages)
(define (bind m f)
(let ((ym (f (monad-object m))))
(let ((old-messages (monad-additional m))
(new-messages (monad-additional ym))
(y (monad-object ym)))
(make-monad 'writer-monad bind y
(append new-messages old-messages)))))
(unless (or (null? messages) (pair? messages))
;;
;; I do not actually test whether the list is proper, because
;; to do so would be inefficient.
;;
;; The R7RS-small test for properness of a list is called
;; "list?" (and the report says something tendentious in
;; defense of this name, but really it is simply historical
;; usage). The SRFI-1 procedure, by constrast, is called
;; "proper-list?".
;;
(error "should be a proper list" messages))
(make-monad 'writer-monad bind object messages))
(define (writer-monad? object)
(and (monad? object)
(eq? (monad-identifier object) 'writer-monad)))
)) ;; end library
(import (scheme base)
(scheme inexact)
(scheme write)
(monad base)
(monad perform)
(monad writer-monad))
(define root sqrt)
(define (addOne x) (+ x 1))
(define (half x) (/ x 2))
(define-syntax make-logging
(syntax-rules ()
((_ proc)
(lambda (x)
(define (make-msg x y) (list x 'proc y))
(let ((y (proc x)))
(make-writer-monad y (list (make-msg x y))))))))
(define logging-root (make-logging root))
(define logging-addOne (make-logging addOne))
(define logging-half (make-logging half))
(define (display-messages messages)
(if (writer-monad? messages)
(display-messages (monad-additional messages))
(begin
(display " messages:")
(newline)
(let loop ((lst (reverse messages)))
(when (pair? lst)
(display " ")
(write (car lst))
(newline)
(loop (cdr lst)))))))
(display "---------------") (newline)
(display "Using just >>=") (newline)
(display "---------------") (newline)
(define result
(>>= (make-writer-monad 5 '((new writer-monad 5)))
logging-root logging-addOne logging-half))
(display " (1 + sqrt(5))/2 = ")
(write (monad-object result)) (newline)
(display-messages result)
(newline)
(display "------------------") (newline)
(display "Using >>= and >=>") (newline)
(display "------------------") (newline)
(define result
(>>= (make-writer-monad 5 '((new writer-monad 5)))
(>=> logging-root logging-addOne logging-half)))
(display " (1 + sqrt(5))/2 = ")
(write (monad-object result)) (newline)
(display-messages result)
(newline)
(display "-----------------------") (newline)
(display "Using 'perform' syntax") (newline)
(display "-----------------------") (newline)
(define result
(perform (x <- (make-writer-monad 5 '((new writer-monad 5))))
(x <- (logging-root x))
(x <- (logging-addOne x))
(logging-half x)))
(display " (1 + sqrt(5))/2 = ")
(write (monad-object result)) (newline)
(display-messages result)
</syntaxhighlight>
{{out}}
Compile and run with <pre>gosh -r7 writer_monad_r7rs.scm</pre> or <pre>csc -O5 -X r7rs -R r7rs writer_monad_r7rs.scm && ./writer_monad_r7rs</pre>
(I use the high optimization level <code>-O5</code> to check I have done nothing to impede such optimization.)
The result is computed in three different notations. The <code>perform</code> syntax is something that looks like Haskell's <code>do</code> syntax. (The name <code>do</code> is already used as the Scheme and Common Lisp name for a kind of for-loop.)
Notice that the <code>>>=</code> and <code>>-></code> are ordinary "prefix" procedures, rather than infix operators. One might think this would make them very difficult to write with, but a Scheme procedure can be made to recursively perform a chain of operations, so that you will need to write the procedure name only once. I have made <code>>>=</code> and <code>>-></code> work that way.
<pre>
---------------
Using just >>=
---------------
(1 + sqrt(5))/2 = 1.61803398874989
messages:
(new writer-monad 5)
(5 root 2.23606797749979)
(2.23606797749979 addOne 3.23606797749979)
(3.23606797749979 half 1.61803398874989)
------------------
Using >>= and >=>
------------------
(1 + sqrt(5))/2 = 1.61803398874989
messages:
(new writer-monad 5)
(5 root 2.23606797749979)
(2.23606797749979 addOne 3.23606797749979)
(3.23606797749979 half 1.61803398874989)
-----------------------
Using 'perform' syntax
-----------------------
(1 + sqrt(5))/2 = 1.61803398874989
messages:
(new writer-monad 5)
(5 root 2.23606797749979)
(2.23606797749979 addOne 3.23606797749979)
(3.23606797749979 half 1.61803398874989)
</pre>
| |||