Monads/Writer monad: Difference between revisions
Content added Content deleted
Line 1,207: | Line 1,207: | ||
Added one: 3.23606797749979 |
Added one: 3.23606797749979 |
||
Divided by 2: 1.618033988749895 |
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> |
</pre> |
||