63340 GrayShade #!mzscheme (require mzlib/defmacro srfi/1) (define-macro (>> x f) `(bind ,x (lambda _ ,f))) (define-macro (>>= x f) `(bind ,x ,f)) (define-macro (do . exprs) (if (null? (cdr exprs)) (car exprs) `(>> ,(car exprs) (do ,@(cdr exprs))))) (define-macro (let-m binding expr) `(>>= ,(cadr binding) (lambda (,(car binding)) ,expr))) (define-macro (let-m* bindings expr) `(let-m ,(car bindings) ,(if (null? (cdr bindings)) expr `(let-m* ,(cdr bindings) ,expr)))) (define-macro (guard f) `(if ,f (return ()) mzero)) (define (concat-map f xs) (apply append (map f xs))) (define list-return list) (define (list-bind xs f) (concat-map f xs)) (define list-mzero '()) (define-macro (instance-monad name) `(define-macro (,(string->symbol (string-append "monad-" (symbol->string name))) expr) `(let ((bind ,(string->symbol (string-append (symbol->string ',name) "-bind"))) (return ,(string->symbol (string-append (symbol->string ',name) "-return")))) ,expr))) (define-macro (instance-monadplus name) `(define-macro (,(string->symbol (string-append "monadplus-" (symbol->string name))) expr) `(let ((mzero ,(string->symbol (string-append (symbol->string ',name) "-mzero")))) ,expr))) ;(define-macro (declare-class name members) ; (let ((s (map ; (lambda (member) ; `(,member ,(string->symbol (string-append (symbol->string name) "-" (symbol->string member))))) ; members))) ; `(define-macro (,(string->symbol (string-append "instace-" (symbol->string name))) expr) ; `(let ; ,,(map ; (lambda (member) ; `(,member ,(string->symbol (string-append (symbol->string name) "-" (symbol->string member))))) ; members) ; ,expr)))) (define-macro (declare-class name members) (let ((env (map (lambda (member) `(,member ,(string->symbol (string-append (symbol->string name) "-" (symbol->string member))))) members))) `(define-macro (,(string->symbol (string-append "instace-" (symbol->string name))) expr) `(let ,,env ,expr)))) ;(instance-monad list) ;(instance-monadplus list) (declare-class monad (return bind)) (define run-me (monad-list (monadplus-list (let-m* ((x (iota 4 1)) (y (iota 4 1))) (do (guard (even? x)) (guard (odd? y)) (return (cons x y))))))) 3424337956 None Scheme TRUE