polymorphic-monad.scm

(import (gauche base))
(import (prefix (gauche partcont) gosh-))

; = util =

(define-syntax push!
  (syntax-rules ()
    ((push! obj list)
     (set! list (cons obj list)))))

(define (filter f list)
  (if (null? list)
      '()
      (if (f (car list))
          (cons (car list)
                (filter f (cdr list)))
          (filter f (cdr list)))))

(define (print x)
  (write x)
  (newline)
  (flush-output-port)
  x)

; = partial continuation =

(define reset
  (lambda (f)
    (gosh-reset (f))))

(define shift
  (lambda (f)
    (gosh-shift k (f k))))

; = class system =

(define-record-type class-type
    (make-class membership)
    class?
  (membership class-membership))

(define-syntax define-class
  (syntax-rules ()
    ((define-class name membership)
     (define name (make-class membership)))))

(define (instance? obj class)
  ((class-membership class) obj))

(define-class <class>
  class?)

(define (<eq> x)
  (make-class (lambda (y) (equal? x y))))


; = class example =

(define-record-type option
    (make-option v b)
    option?
  (v option-value)
  (b option-valid))

(define (some x)
  (make-option x #t))

(define none
  (make-option #f #f))

(define-class <option> option?)

(define-class <any> (lambda (x) #t))
(define-class <list> list?)
(define-class <procedure> procedure?)
(define-class <number> number?)
(define-class <boolean> boolean?)


; = protocol system =

(define method-table
  '())

(define (applicative? args types)
  (cond
   ((and (null? args) (null? types))
    #true)
   ((and (pair? args) (pair? types))
    (and (instance? (car args) (car types)) (applicative? (cdr args) (cdr types))))
   (else
    #false)))

; (applicative? '(1 2 ()) (list <number> <number> <list>))
; (applicative? '(1 () 2) (list <number> <number> <number>))
; (applicative? '(1 2 ()) (list <number> <number>))

(define (find-generic generic)
  (or (assq generic method-table)
      (error "no method alist found")))

(define (find-method generic args)
  (let ((methods (cdr (find-generic generic))))
    (let ((m (filter (lambda (x) (applicative? args (cdr x))) methods)))
      (if (null? m)
          #f
          (car (car m))))))

(define (add-generic generic)
  (push! (cons generic '()) method-table))

(define (add-method generic method types)
  (let ((r (find-generic generic)))
    (set-cdr! r (cons (cons method types) (cdr r)))))

(define (add-methods methods prototypes)
  (for-each
   (lambda (method prototype)
     (add-method (car prototype) method (cdr prototype)))
   methods
   prototypes))

(import (srfi 27))
(define *dont-bug-me* 0)
(define (make-generic)
  (define aaa (random-integer 1))
  (letrec ((self (lambda args
                   (let ((m (find-method self args)))
                     (set! *dont-bug-me* aaa)
                     (if m
                         (apply m args)
                         (error "method not found"))))))
    (add-generic self)
    self))

(define-syntax define-protocol
  (syntax-rules ()
    ((define-protocol (name type ...) (method arg ...) ...)
     (begin
       (define method
         (make-generic))
       ...
       (define name
         (lambda (type ...)
           (lambda methods
             (add-methods methods (list (list method arg ...) ...)))))))))

(define-syntax define-instance
  (syntax-rules ()
    ((define-instance (name arg ...) method ...)
     ((name arg ...) method ...))))

; = protocol examples =

; show

(define-protocol (SHOW t)
  (show t))

(define-instance (SHOW <option>)
  (lambda (x)
    (if (option-valid x)
        (string-append "(some " (show (option-value x)) ")")
        "none")))

(define-instance (SHOW <boolean>)
  (lambda (x)
    (if x
        "#true"
        "#false")))

(define-instance (SHOW <number>)
  number->string)

(define-instance (SHOW <list>)
  (lambda (x)
    (if (null? x)
        "()"
        (string-append "(" (show (car x)) " . " (show (cdr x)) ")"))))

; (show (some 1))
; (show none)
; (show (some (some (some none))))
; (show (list (some 1) none (some (list 3 4 (some 4)))))
; (show #t)

; functor

(define-protocol (FUNCTOR t)
  (fmap <procedure> t))

(define-instance (FUNCTOR <list>)
  map)

(define-instance (FUNCTOR <option>)
  (lambda (f x)
    (if (option-valid x)
        (some (f (option-value x)))
        none)))

; (fmap (lambda (x) (* x 2)) '(1 2 3))
; (show (fmap (lambda (x) (* x 2)) (some 1)))
; (show (fmap (lambda (x) (* x 2)) none))


; monad (explicit context-passing)

(define-protocol (MONAD m)
  (c-unit (<eq> m))
  (c-join (<eq> m)))

(define c-list-unit
  (lambda (c)
    (lambda (x)
      (list x))))

(define c-list-join
  (lambda (c)
    (lambda (m)
      (apply append (map (lambda (m) (m c)) (m c))))))

(define-instance (MONAD <list>)
  c-list-unit
  c-list-join)

(define (join m)
  (lambda (c)
    (let ((join (c-join c)))
      (join m))))

(define (unit x)
  (lambda (c)
    (let ((unit (c-unit c)))
      (unit x))))

; ((unit 1) <list>)
; ((join (unit (unit 42))) <list>)

(define c-option-unit
  (lambda (c)
    (lambda (x)
      (some x))))

(define c-option-join
  (lambda (c)
    (lambda (m)
      (if (option-valid (m c))
          ((option-value (m c)) c)
          none))))

(define-instance (MONAD <option>)
  c-option-unit
  c-option-join)

; (show ((unit 1) <option>))
; (show ((join (unit (unit 42))) <option>))
; (show ((join (unit (unit 42))) <list>))

(define (bind m f)
  (join (lambda (c)
          (fmap f (m c)))))

; ((bind (unit 42) (lambda (x) (unit (* x 2)))) <list>)
; ((bind (lambda (c) '(1 2 3)) unit) <list>)
; ((bind (bind (lambda (c) '(1 2 3)) unit) (lambda (x) (lambda (c) (list x x)))) <list>)

; inter-operation

(define (run c)
  (lambda (m)
    (m c)))

(define (lift x)
  (lambda (c)
    x))

(define run-list (run <list>))
(define run-option (run <option>))

; (run-list (lift '(1 2 3)))
; (run-list (bind (bind (lift '(1 2 3)) unit) (lambda (x) (lift (list x x)))))


; = do-notation =

(define-syntax reify
  (syntax-rules ()
    ((_ expr)
     (reset
      (lambda ()
        expr)))))

(define (reflect m)
  (shift
   (lambda (k)
     (bind m k))))

;; (run-list
;;  (reify
;;   (let ((x (reflect (lift '(1 2 3 4))))
;;         (y (reflect (lift '(5 6 7 8)))))
;;     (unit (+ x y)))))


; = type specific notations =

(define-syntax for
  (syntax-rules ()
    ((_ expr)
     (run-list
      (reify
       expr)))))

(define (in x)
  (reflect (lift x)))

(define (return x)
  (unit x))

(define (only-when t)
  (unless t
    (in '())))

;; (for
;;  (let ((x (in (iota 30 2)))
;;        (y (in (iota 30 2))))
;;    (let ((z2 (- (* x x) (* y y))))
;;      (only-when (positive? z2))
;;      (let ((z (sqrt z2)))
;;        (only-when (integer? z))
;;        (return (list x y z))))))


; monad utilities

(define (m-map f list)
  (m-seq (map f list)))

(define (m-seq f list)
  (reify
   (if (null? list)
       (unit '())
       (let ((h (reflect (car list)))
             (t (reflect (cdr list))))
         (unit (cons h t))))))

(define (m-fold f s list)
  (reify
   (if (null? list)
       (unit s)
       (let ((x (reflect (f (car list) s))))
         (unit (m-fold f x (cdr list)))))))

polymorphic-monad2.scm

(import (scheme base)
        (gauche base)
        (gauche partcont))

(define list-map map)

(define (make-context . opts)
  opts)

(define (get prop c)
  (if (null? c)
      (error "property not found")
      (if (eq? prop (car c))
          (cadr c)
          (get prop (cddr c)))))


(define (run c m)
  (m c))

(define (lift x)
  (lambda (c)
    x))


(define (fmap f m)
  (lambda (c)
    ((get 'fmap c) f (run c m))))

; (run-list (fmap (lambda (x) (* x 2)) (lift '(1 2 3))))

(define (unit x)
  (lambda (c)
    ((get 'unit c) x)))

; (run-list (unit 1))

(define (bind m f)
  (lambda (c)
    ((get 'bind c) (run c m) (lambda args (run c (apply f args))))))

; (run-list (bind (unit 42) (lambda (x) (unit (* x 2)))))
; (run-list (bind (lift '(1 2 3)) unit))

(define-syntax reify
  (syntax-rules ()
    ((_ expr)
     (reset (unit expr)))))

(define (reflect m)
  (shift k (bind m k)))


(define list-context
  (make-context
   'fmap list-map
   'unit list
   'bind (lambda (m f) (apply append (map f m)))))

(define (run-list m) (run list-context m))

(run-list
 (reify
  1))

(run-list
 (reify
  (reflect (lift '(1 2 3)))))

(run-list
 (reify
  (let ((x (reflect (lift '(1 2 3 4))))
        (y (reflect (lift '(5 6 7 8)))))
    (+ x y))))


(define (in m)
  (reflect (lift m)))

(define-syntax for
  (syntax-rules ()
    ((_ expr)
     (run-list (reify expr)))))

(for
 (let* ((x (in '(1 2 3 4)))
        (y (in '(5 6 7 8))))
   (+ x y)))

• class
• protocol
• object

の３つの大きな要素が入ってる

monadを実現するためにlift/runを使っているけどこれは実際には他のメソッドにも使えるはずで、それを一般化してobjectにできたら嬉しいなあとか思ってる