; Richard Uhtenwoldt’s examples
; Monads in Scheme

; monad basis:
(define (bind p k)
 (cond ((not (procedure? p)) (error "first arg to bind must be a procedure"))
       ((not (procedure? k)) (error "second arg to bind must be a procedure"))
       (#t
         (lambda ()
           (let* ((p2 (p))
                  (q (k p2)) )
             (if (not (procedure? q)) 
               (error "second arg to bind must be a procedure that returns a procedure")
               (q) ))))))
(define (return v) (lambda () v))


; particular monadic primitives
(define (display2 a) (lambda() (display a)))
(define read2 (lambda () (read)))

; Test code employing the monadic primitives: copy input to output

;((bind read2 (lambda (x) (display2 x))))

; Test code employing the monadic primitives: copy input to output
;((bind read2 (lambda (x) (display2 x)))) xx

(define (then p q) (bind p (lambda (ignored) q)))
(define-syntax do-notation
 (syntax-rules (<-)
   ((do-notation clause) clause)
   ((do-notation (<- var exp) clauses ...)
     (bind exp (lambda (var) (do-notation clauses ...))))
   ((do-notation exp clauses ...)
     (then exp (do-notation clauses ...)))))

;((do-notation (<- x read2) (display2 x)))

(define new-cell2 
 (lambda () (vector #f)))
(define (cell-ref2 cell)
 (lambda () (vector-ref cell 0)))
(define (cell-set2 cell new-value)
 (lambda () (vector-set! cell 0 new-value)))

;((bind new-cell2 (lambda (cell) (then (cell-set2 cell 5) (bind (cell-ref2 cell) display2)))))
;; should print 5

(define (make-spaceship2 fuel-capacity)
 (do-notation
   (<- position new-cell2)
   (cell-set2 position 0)
   (<- fuel new-cell2) 
   (cell-set2 fuel 0) ;deliver the new spaceship unfueled for safety!
   (<- some-constant (return 1))
   (return (lambda (method)
     (case method
       ((add-fuel) (lambda (fuel-to-add) 
          (bind (cell-ref2 fuel) (lambda (f)
            (cell-set2 fuel (min (+ f fuel-to-add) fuel-capacity))))))
       ((move) (lambda (displacement-desired) 
          (bind (cell-ref2 fuel) (lambda (f)
            (let* ( (cost-in-fuel-of-displacement-desired 
                      (* some-constant (abs displacement-desired)))
                    )
              (if (>= f cost-in-fuel-of-displacement-desired)
                (then
                  (cell-set2 fuel (- f cost-in-fuel-of-displacement-desired))
                  (bind (cell-ref2 position) (lambda (p) 
                    (cell-set2 position (+ p displacement-desired)))))
                (display2 "Not enough fuel.  Move command ignored.\n"))
              )))))
       ((dock) (lambda ()
         ;; returns nil or t according as docking fails or succeeds.
         ;; docking succeeds if and only if the spaceship is where it was
         ;; when it was delivered.
         (bind (cell-ref2 position) (lambda (p) (return (equal? 0 p)))) ))
       )))))
(define (add-fuel spaceship fuel-to-add)
 ((spaceship 'add-fuel) fuel-to-add) )
(define (move spaceship displacement-desired)
 ((spaceship 'move) displacement-desired) )
(define (dock spaceship)
 ((spaceship 'dock)) )

;; some tests of the above code follow

((do-notation
  (<- enterprise (make-spaceship2 100))
  (add-fuel enterprise 80)
  (move enterprise 30)
  (move enterprise -30)
  (<- outcome (dock enterprise))
  ;; #f was chosen because it is the standard "uninteresting" value in Scheme:
  (if (not outcome) (display2 "Unit test #0 failed.\n") (return #f))
  (add-fuel enterprise 20)
  (move enterprise 30)
  (move enterprise -30)
  ;; the Enterprise runs out of fuel before it can get back to Starbase
  (<- outcome2 (dock enterprise))
  (if outcome2 (display2 "Unit test #1 failed.\n") (return #f))
  (display2 "Unit tests completed.\n")
  ))