├── README.md ├── boolean-simp.ss ├── cek.ss ├── cps.ss ├── encoding.scm ├── infer.ss ├── interp-call-by-name.ss ├── interp-call-by-value.ss ├── interp-delim.ss ├── interp-lazy.rkt ├── lazy-ski.ss ├── meta-interp.ss ├── mk-c.ss ├── mut-y.ss └── pmatch.scm /README.md: -------------------------------------------------------------------------------- 1 | * cps.ss - CPS transformer without administrative redexes 2 | 3 | * compiler.ss - a compiler from Scheme to X64 assembly 4 | 5 | * meta-interp.ss - meta-circular interpreter that can interpret itself 6 | to any level 7 | 8 | * infer.ss - Hindly-Milner style type inferencer for lambda calculus 9 | (without let-polymorphism) 10 | 11 | * mk-c.ss - modified implementation of the logic language miniKanren with a 12 | constraint-based negation operator 13 | 14 | * interp-call-by-value.ss - simple call-by-value interpreter 15 | 16 | * interp-call-by-name.ss - simple call-by-name interpreter 17 | 18 | * interp-lazy.ss - interpreter with lazy semantics 19 | 20 | * interp-delim.ss - simple interpreter with delimited continuation 21 | operators (shift/reset/shift0/reset0) 22 | 23 | * lazy-ski.ss - compiler from lambda calculus to "lazy combinators" 24 | 25 | * cek.ss - a "reversible" CEK abstract machine which can run forwards and 26 | backwards and change directions. 27 | 28 | * encoding.scm - "church encoding" of various things in the lambda 29 | calculus, used by some other code (e.g. lazy-ski.ss) 30 | 31 | * pmatch.scm - supporting macro for pattern matching, used by some 32 | other programs here (compatible with most Scheme implementations) 33 | -------------------------------------------------------------------------------- /boolean-simp.ss: -------------------------------------------------------------------------------- 1 | ;; Boolean expression simplification into sum-of-products 2 | ;; author: Yin Wang (yinwang0@gmail.com) 3 | 4 | 5 | ;--------------------------------------------- 6 | ;; (1) Push 'and' into 'or' 7 | ;; (2) Push 'not' into 'and' and 'or' 8 | ;; Do (1) and (2) recursively until no more simplification can be made 9 | (define simpl 10 | (lambda (exp) 11 | (match exp 12 | [`(and (or ,a ,b) ,c) 13 | `(or ,(simpl `(and ,(simpl a) ,(simpl c))) 14 | ,(simpl `(and ,(simpl b) ,(simpl c))))] 15 | [`(and ,c (or ,a ,b)) 16 | `(or ,(simpl `(and ,(simpl c) ,(simpl a))) 17 | ,(simpl `(and ,(simpl c) ,(simpl b))))] 18 | [`(not (and ,a ,b)) 19 | `(or ,(simpl `(not ,a)) ,(simpl `(not ,b)))] 20 | [`(not (or ,a ,b)) 21 | `(and ,(simpl `(not ,a)) ,(simpl `(not ,b)))] 22 | 23 | [`(and ,a ,b) 24 | `(and ,(simpl a) ,(simpl b))] 25 | [`(or ,a ,b) 26 | `(or ,(simpl a) ,(simpl b))] 27 | [`(not ,a ,b) 28 | `(not ,(simpl a) ,(simpl b))] 29 | [other other]))) 30 | 31 | 32 | 33 | ;--------------------------------------------- 34 | ;; Combine nested expressions with same operator, for example 35 | ;; (and (and a b) c) ==> (and a b c) 36 | ;; (or a (or b c)) ==> (or a b c) 37 | ;; (not (not a)) ==> a 38 | (define combine 39 | (lambda (exp) 40 | (define combine1 41 | (lambda (ct) 42 | (lambda (exp) 43 | (match exp 44 | [`(and ,a ,a) 45 | (list a)] 46 | [`(or ,a ,a) 47 | (list a)] 48 | [`(and ,x* ...) 49 | (let ([y* (apply append (map (combine1 'and) x*))]) 50 | (if (eq? 'and ct) y* `((and ,@y*))))] 51 | [`(or ,x* ...) 52 | (let ([y* (apply append (map (combine1 'or) x*))]) 53 | (if (eq? 'or ct) y* `((or ,@y*))))] 54 | [`(not (not ,a)) 55 | ((combine1 ct) a)] 56 | [other (list other)])))) 57 | (car ((combine1 'id) exp)))) 58 | 59 | 60 | ;; Examples for combine: 61 | ;; (combine '(and (and a (and b (and c (and d e)))))) 62 | ;; (combine '(and (and (and (and a b) c) d) e)) 63 | ;; (combine '(and (and a (and b c)) (and d e))) 64 | ;; (combine '(or (and a (and b c) d))) 65 | ;; (combine '(not (not a))) 66 | ;; (combine '(not (not (not (not a))))) 67 | 68 | 69 | ;--------------------------------------------- 70 | ;; main function (simpl then combine) 71 | (define simplify 72 | (lambda (exp) 73 | (combine (simpl exp)))) 74 | 75 | 76 | 77 | ;------------------ examples ------------------ 78 | (simplify '(and (or football basketball) baby)) 79 | 80 | ;; ==> 81 | ;; '(or (and football baby) (and basketball baby)) 82 | 83 | 84 | ;--------------------------------------------- 85 | (simplify '(and (not (and a (or b c))) (or d e))) 86 | 87 | ;; ==> 88 | ;; '(or (and (not a) d) 89 | ;; (and (not b) (not c) d) 90 | ;; (and (not a) e) 91 | ;; (and (not b) (not c) e)) 92 | 93 | 94 | ;--------------------------------------------- 95 | (simplify '(not (and (not a) (not (and b c))))) 96 | 97 | ;; ==> '(or a (and b c)) 98 | 99 | 100 | ;--------------------------------------------- 101 | (simplify '(and (or a b) (or a c))) 102 | 103 | ;; ==> '(or (and a c) (and a d) (and b c) (and b d)) 104 | 105 | -------------------------------------------------------------------------------- /cek.ss: -------------------------------------------------------------------------------- 1 | (case-sensitive #t) 2 | (load "pmatch.scm") 3 | 4 | (define value? 5 | (lambda (exp) 6 | (pmatch exp 7 | [,x (guard (atom? x)) #t] 8 | [((lambda (,x) ,e) ,env) #t] 9 | [else #f]))) 10 | 11 | (define mt-env 'mt-env) 12 | (define mt-h 'mt-h) 13 | (define mt-k 'mt-k) 14 | 15 | (define --> 16 | (lambda (s) 17 | (pmatch s 18 | [(,v^ (ARG (,rand ,env) ,k) ,h) (guard (value? v^)) 19 | `((,rand ,env) (FUN ,v^ ,k) (ARG ,@h))] 20 | [(,v^ (FUN ((lambda (,x) ,body) ,env) ,k) ,h) (guard (value? v^)) 21 | `((,body ((,x ,v^) ,env)) ,k (FUN ,@h))] 22 | [((,x ,env) ,k ,h) (guard (atom? x)) 23 | `(, (apply-env env x) ,k ((ENV ,x ,env) ,@h))] 24 | [(((,rator ,rand) ,env) ,k ,h) 25 | `((,rator ,env) (ARG (,rand ,env) ,k) (APP ,@h))]))) 26 | 27 | (define <-- 28 | (lambda (s) 29 | (pmatch s 30 | [((,rand ,env) (FUN ,v^ ,k) (ARG . ,h)) 31 | `(,v^ (ARG (,rand ,env) ,k) ,h)] 32 | [((,body ((,x ,v^) ,env)) ,k (FUN . ,h)) 33 | `(,v^ (FUN ((lambda (,x) ,body) ,env) ,k) ,h)] 34 | [(,y ,k ((ENV ,x ,env) . ,h)) 35 | `((,x ,env) ,k ,h)] 36 | [((,rator ,env) (ARG (,rand ,env) ,k) (APP . ,h)) 37 | `(((,rator ,rand) ,env) ,k ,h)]))) 38 | 39 | 40 | ; For the convenience of experiments, lookup will output unbound variables 41 | ; symbolically instead of raising errors 42 | (define apply-env 43 | (lambda (env x) 44 | (pmatch env 45 | [,env (guard (eq? env mt-env)) x] 46 | [((,x^ ,v^) ,env) 47 | (if (eq? x x^) v^ (apply-env env x))]))) 48 | 49 | (define de-closure 50 | (lambda (clos) 51 | (letrec ([dec 52 | (lambda (exp bound env) 53 | (pmatch exp 54 | [,u (guard (symbol? u) (not (memq u bound))) (apply-env env u)] 55 | [(lambda (,u) ,e) 56 | `(lambda (,u) , (dec e (cons u bound) env))] 57 | [(,e1 ,e2) `(, (dec e1 bound env) , (dec e2 bound env))] 58 | [,exp exp]))]) 59 | (dec (car clos) '() (cadr clos))))) 60 | 61 | (define ==> 62 | (lambda (exp) 63 | (letrec ((step 64 | (lambda (s n) 65 | (pmatch s 66 | [(,exp ,k ,h) (guard (value? exp) (eq? k mt-k)) 67 | (printf "~a steps\n" n) 68 | s] 69 | [else (step (--> s) (add1 n))])))) 70 | (step exp 0)))) 71 | 72 | (define <== 73 | (lambda (exp) 74 | (letrec ((step 75 | (lambda (s n) 76 | (pmatch s 77 | [(,exp ,k ,h) (guard (eq? h mt-h)) 78 | (printf "~a steps\n" n) 79 | s] 80 | [else (step (<-- s) (add1 n))])))) 81 | (step exp 0)))) 82 | 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | ;;; Examples 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | ;;; go forwards, backwards, back-and-forth, ... 89 | 90 | ; source state 91 | (define s `((((lambda (x) x) ((lambda (u) u) y)) ,mt-env) ,mt-k ,mt-h)) 92 | 93 | ; go forwards (evaluate multiple times) 94 | (define s 95 | (let ([s^ (--> s)]) 96 | (printf "~a\n" s^) 97 | s^)) 98 | 99 | ;; => 100 | ;; (((lambda (x) x) mt-env) (ARG (((lambda (u) u) y) mt-env) mt-k) (APP . mt-h)) 101 | ;; ((((lambda (u) u) y) mt-env) (FUN ((lambda (x) x) mt-env) mt-k) (ARG APP . mt-h)) 102 | ;; (((lambda (u) u) mt-env) (ARG (y mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) (APP ARG APP . mt-h)) 103 | ;; ((y mt-env) (FUN ((lambda (u) u) mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) (ARG APP ARG APP . mt-h)) 104 | ;; (y (FUN ((lambda (u) u) mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) ((ENV y mt-env) ARG APP ARG APP . mt-h)) 105 | ;; ((u ((u y) mt-env)) (FUN ((lambda (x) x) mt-env) mt-k) (FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 106 | ;; (y (FUN ((lambda (x) x) mt-env) mt-k) ((ENV u ((u y) mt-env)) FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 107 | ;; ((x ((x y) mt-env)) mt-k (FUN (ENV u ((u y) mt-env)) FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 108 | ;; (y mt-k ((ENV x ((x y) mt-env)) FUN (ENV u ((u y) mt-env)) FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 109 | 110 | 111 | ; go backwards 112 | (define s 113 | (let ([s^ (<-- s)]) 114 | (printf "~a\n" s^) 115 | s^)) 116 | 117 | ;; => 118 | ;; ((x ((x y) mt-env)) mt-k (FUN (ENV u ((u y) mt-env)) FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 119 | ;; (y (FUN ((lambda (x) x) mt-env) mt-k) ((ENV u ((u y) mt-env)) FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 120 | ;; ((u ((u y) mt-env)) (FUN ((lambda (x) x) mt-env) mt-k) (FUN (ENV y mt-env) ARG APP ARG APP . mt-h)) 121 | ;; (y (FUN ((lambda (u) u) mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) ((ENV y mt-env) ARG APP ARG APP . mt-h)) 122 | ;; ((y mt-env) (FUN ((lambda (u) u) mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) (ARG APP ARG APP . mt-h)) 123 | ;; (((lambda (u) u) mt-env) (ARG (y mt-env) (FUN ((lambda (x) x) mt-env) mt-k)) (APP ARG APP . mt-h)) 124 | ;; ((((lambda (u) u) y) mt-env) (FUN ((lambda (x) x) mt-env) mt-k) (ARG APP . mt-h)) 125 | ;; (((lambda (x) x) mt-env) (ARG (((lambda (u) u) y) mt-env) mt-k) (APP . mt-h)) 126 | ;; ((((lambda (x) x) ((lambda (u) u) y)) mt-env) mt-k mt-h) 127 | 128 | ;; or switch directions any time you like 129 | 130 | 131 | ;;; Example 2: factorial 132 | (load "encoding.scm") 133 | 134 | (define s `(((,! ,lfive) ,mt-env) ,mt-k ,mt-h)) 135 | 136 | (define r1 (==> s)) 137 | ; => 1420 steps (result too large to print) 138 | 139 | (define r2 (<== r1)) 140 | ; => 1420 steps 141 | 142 | (equal? r2 s) 143 | ; => #t 144 | 145 | 146 | (define test 147 | (lambda (name exp) 148 | (let* ([s `((,exp ,mt-env) ,mt-k ,mt-h)] 149 | [r1 (==> s)] 150 | [r2 (<== r1)]) 151 | (if (equal? r2 s) 152 | (printf "test \"~a\" ... succeeded\n" name) 153 | (printf "test \"~a\" ... failed\n" name))))) 154 | 155 | (test "succ" `(,lsucc ,lfive)) 156 | (test "pred" `(,lpred ,lfive)) 157 | (test "times" `((,ltimes ,ltwo) ,lthree)) 158 | (test "plus" `((,lplus ,ltwo) ,lthree)) 159 | (test "sub" `((,lsub ,lthree) ,ltwo)) 160 | (test "pow" `((,lpow ,ltwo) ,lthree)) 161 | (test "car" `(,lcar ((,lpair ,lone) ,ltwo))) 162 | (test "!5" `(,! ,lfive)) 163 | (test "!7" `(,! ,l7)) 164 | 165 | -------------------------------------------------------------------------------- /cps.ss: -------------------------------------------------------------------------------- 1 | ;; A simple CPS transformer which does proper tail-call and does not 2 | ;; duplicate contexts for if-expressions. 3 | 4 | ;; author: Yin Wang 5 | 6 | 7 | (load "pmatch.scm") 8 | 9 | 10 | (define cps 11 | (lambda (exp) 12 | (letrec 13 | ([trivial? (lambda (x) (memq x '(zero? add1 sub1)))] 14 | [id (lambda (v) v)] 15 | [ctx0 (lambda (v) `(k ,v))] ; tail context 16 | [fv (let ([n -1]) 17 | (lambda () 18 | (set! n (+ 1 n)) 19 | (string->symbol (string-append "v" (number->string n)))))] 20 | [cps1 21 | (lambda (exp ctx) 22 | (pmatch exp 23 | [,x (guard (not (pair? x))) (ctx x)] 24 | [(if ,test ,conseq ,alt) 25 | (cps1 test 26 | (lambda (t) 27 | (cond 28 | [(memq ctx (list ctx0 id)) 29 | `(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))] 30 | [else 31 | (let ([u (fv)]) 32 | `(let ([k (lambda (,u) ,(ctx u))]) 33 | (if ,t ,(cps1 conseq ctx0) ,(cps1 alt ctx0))))])))] 34 | [(lambda (,x) ,body) 35 | (ctx `(lambda (,x k) ,(cps1 body ctx0)))] 36 | [(,op ,a ,b) 37 | (cps1 a (lambda (v1) 38 | (cps1 b (lambda (v2) 39 | (ctx `(,op ,v1 ,v2))))))] 40 | [(,rator ,rand) 41 | (cps1 rator 42 | (lambda (r) 43 | (cps1 rand 44 | (lambda (d) 45 | (cond 46 | [(trivial? r) (ctx `(,r ,d))] 47 | [(eq? ctx ctx0) `(,r ,d k)] ; tail call 48 | [else 49 | (let ([u (fv)]) 50 | `(,r ,d (lambda (,u) ,(ctx u))))])))))]))]) 51 | (cps1 exp id)))) 52 | 53 | 54 | 55 | 56 | ;;; tests 57 | 58 | ;; var 59 | (cps 'x) 60 | (cps '(lambda (x) x)) 61 | (cps '(lambda (x) (x 1))) 62 | 63 | 64 | ;; no lambda (will generate identity functions to return to the toplevel) 65 | (cps '(if (f x) a b)) 66 | (cps '(if x (f a) b)) 67 | 68 | 69 | ;; if stand-alone (tail) 70 | (cps '(lambda (x) (if (f x) a b))) 71 | 72 | 73 | ;; if inside if-test (non-tail) 74 | (cps '(lambda (x) (if (if x (f a) b) c d))) 75 | 76 | 77 | ;; both branches are trivial, should do some more optimizations 78 | (cps '(lambda (x) (if (if x (zero? a) b) c d))) 79 | 80 | 81 | ;; if inside if-branch (tail) 82 | (cps '(lambda (x) (if t (if x (f a) b) c))) 83 | 84 | 85 | ;; if inside if-branch, but again inside another if-test (non-tail) 86 | (cps '(lambda (x) (if (if t (if x (f a) b) c) e w))) 87 | 88 | 89 | ;; if as operand (non-tail) 90 | (cps '(lambda (x) (h (if x (f a) b)))) 91 | 92 | 93 | ;; if as operator (non-tail) 94 | (cps '(lambda (x) ((if x (f g) h) c))) 95 | 96 | 97 | ;; why we need more than two names 98 | (cps '(((f a) (g b)) ((f c) (g d)))) 99 | 100 | 101 | 102 | ;; factorial 103 | (define fact-cps 104 | (cps 105 | '(lambda (n) 106 | ((lambda (fact) 107 | ((fact fact) n)) 108 | (lambda (fact) 109 | (lambda (n) 110 | (if (zero? n) 111 | 1 112 | (* n ((fact fact) (sub1 n)))))))))) 113 | 114 | ;; print out CPSed function 115 | (pretty-print fact-cps) 116 | ;; => 117 | ;; '(lambda (n k) 118 | ;; ((lambda (fact k) (fact fact (lambda (v0) (v0 n k)))) 119 | ;; (lambda (fact k) 120 | ;; (k 121 | ;; (lambda (n k) 122 | ;; (if (zero? n) 123 | ;; (k 1) 124 | ;; (fact 125 | ;; fact 126 | ;; (lambda (v1) (v1 (sub1 n) (lambda (v2) (k (* n v2)))))))))) 127 | ;; k)) 128 | 129 | 130 | ((eval fact-cps) 5 (lambda (v) v)) 131 | ;; => 120 132 | -------------------------------------------------------------------------------- /encoding.scm: -------------------------------------------------------------------------------- 1 | ;; booleans and pairs 2 | (define ltrue `(lambda (x) (lambda (y) x))) 3 | (define lfalse `(lambda (x) (lambda (y) y))) 4 | (define lpair `(lambda (x) (lambda (y) (lambda (p) ((p x) y))))) 5 | (define lcar `(lambda (p) (p ,ltrue))) 6 | (define lcdr `(lambda (p) (p ,lfalse))) 7 | 8 | ;; numbers and operations 9 | (define decode-number (lambda (n) ((n add1) 0))) 10 | (define lzero `(lambda (f) (lambda (x) x))) 11 | (define lone `(lambda (f) (lambda (x) (f x)))) 12 | (define ltwo `(lambda (f) (lambda (x) (f (f x))))) 13 | (define lthree `(lambda (f) (lambda (x) (f (f (f x)))))) 14 | (define lfour `(lambda (f) (lambda (x) (f (f (f (f x))))))) 15 | (define lfive `(lambda (f) (lambda (x) (f (f (f (f (f x)))))))) 16 | (define l6 `(lambda (f) (lambda (x) (f (f (f (f (f (f x))))))))) 17 | (define l7 `(lambda (f) (lambda (x) (f (f (f (f (f (f (f x)))))))))) 18 | 19 | (define lzero? `(lambda (n) ((n (lambda (x) ,lfalse)) ,ltrue))) 20 | (define lsucc `(lambda (n) (lambda (f) (lambda (x) (f ((n f) x)))))) 21 | 22 | ; Daniel Smith's pred 23 | (define lpred 24 | '(lambda (n) 25 | (lambda (w) 26 | (lambda (z) 27 | (((n (lambda (l) (lambda (h) (h (l w))))) (lambda (d) z)) 28 | (lambda (x) x)))))) 29 | 30 | (define lpred `(lambda (n) 31 | (,lcar ((n (lambda (p) 32 | ((,lpair (,lcdr p)) (,lsucc (,lcdr p))))) 33 | ((,lpair ,lzero) ,lzero))))) 34 | 35 | (define lplus `(lambda (m) (lambda (n) (lambda (f) (lambda (x) ((m f) ((n f) x))))))) 36 | (define lsub `(lambda (m) (lambda (n) ((n ,lpred) m)))) 37 | (define ltimes `(lambda (m) (lambda (n) (lambda (f) (lambda (x) ((m (n f)) x)))))) 38 | (define lpow `(lambda (m) (lambda (n) (lambda (f) (lambda (x) (((m n) f) x)))))) 39 | 40 | ;; call-by-value Y combinator 41 | (define Y 42 | `(lambda (f) 43 | ((lambda (u) (u u)) 44 | (lambda (x) (f (lambda (t) ((x x) t))))))) 45 | 46 | ;; version 1 (using poorman's Y) 47 | (define !-half 48 | `(lambda (!) 49 | (lambda (n) 50 | ((((,lzero? n) 51 | (lambda (t) ,lone)) 52 | (lambda (t) ((,ltimes n) ((! !) (,lpred n))))) 53 | (lambda (v) v))))) 54 | 55 | (define ! `(,!-half ,!-half)) 56 | (define !-5 `(,! ,lfive)) 57 | 58 | 59 | ;; version 2 (using CBV Y) 60 | (define !-gen 61 | `(lambda (!) 62 | (lambda (n) 63 | ((((,lzero? n) 64 | (lambda (t) ,lone)) 65 | (lambda (t) ((,ltimes n) (! (,lpred n))))) 66 | (lambda (v) v))))) 67 | 68 | (define ! `(,Y ,!-gen)) 69 | 70 | ;; version 3 (CBN) 71 | ;; call-by-name Y 72 | (define Y-n 73 | `(lambda (f) 74 | ((lambda (x) (f (x x))) 75 | (lambda (x) (f (x x)))))) 76 | 77 | (define !-gen-n 78 | `(lambda (!) 79 | (lambda (n) 80 | (((,lzero? n) ,lone) ((,ltimes n) (! (,lpred n))))))) 81 | 82 | (define !-n `(,Y-n ,!-gen-n)) 83 | 84 | 85 | ;; example use: 86 | ;; (decode-number (eval `(,! ,lfive))) 87 | 88 | -------------------------------------------------------------------------------- /infer.ss: -------------------------------------------------------------------------------- 1 | ;; infer.ss 2 | ;; a type inferencer for simply typed lambda calculus 3 | 4 | 5 | (load "pmatch.scm") 6 | 7 | ;; utilities 8 | (define-syntax letv* 9 | (syntax-rules () 10 | [(_ () body ...) (begin body ...)] 11 | [(_ ([x0 v0] [x1 v1] ...) body ...) 12 | (let-values ([x0 v0]) 13 | (letv* ([x1 v1] ...) 14 | body ...))])) 15 | 16 | (define fatal 17 | (lambda (who . args) 18 | (display who) (display ": ") 19 | (for-each display args) 20 | (display "\n") 21 | (error 'infer ""))) 22 | 23 | (define add1 24 | (lambda (x) 25 | (+ x 1))) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;; types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | (define var (lambda (v) (vector v))) 29 | (define var? vector?) 30 | (define ext (lambda (x v s) `((,x . ,v) . ,s))) 31 | (define s0 '()) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;; unification ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | (define walk 35 | (lambda (x s) 36 | (let ([slot (assq x s)]) 37 | (cond 38 | [(not slot) x] 39 | [(var? (cdr slot)) (walk (cdr slot) s)] 40 | [else (cdr slot)])))) 41 | 42 | (define occurs 43 | (lambda (u v) 44 | (cond 45 | [(eq? u v) #t] 46 | [(pair? v) 47 | (or (occurs u (car v)) (occurs u (cdr v)))] 48 | [else #f]))) 49 | 50 | (define unify 51 | (lambda (u v s) 52 | (let ([u (walk u s)] 53 | [v (walk v s)]) 54 | (cond 55 | [(eq? u v) s] 56 | [(var? u) (and (not (occurs u v)) (ext u v s))] 57 | [(var? v) (and (not (occurs v u)) (ext v u s))] 58 | [(and (pair? u) (pair? v)) 59 | (let ((s^ (unify (car u) (car v) s))) 60 | (and s^ (unify (cdr u) (cdr v) s^)))] 61 | [(equal? u v) s] 62 | [else #f])))) 63 | 64 | (define reify 65 | (lambda (x s) 66 | (define name 67 | (lambda (n) 68 | (string->symbol 69 | (string-append "t" (number->string n))))) 70 | (define reify1 71 | (lambda (x n s) 72 | (let ((x (walk x s))) 73 | (cond 74 | [(pair? x) 75 | (letv* ([(u n1 s1) (reify1 (car x) n s)] 76 | [(v n2 s2) (reify1 (cdr x) n1 s1)]) 77 | (values (cons u v) n2 s2))] 78 | [(var? x) 79 | (let ([v* (name n)]) 80 | (values v* (add1 n) (ext x v* s)))] 81 | [else (values x n s)])))) 82 | (letv* ([(x* n* s*) (reify1 x 0 s)]) x*))) 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;; environment ;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | (define ext-env (lambda (x v s) `((,x . ,v) . ,s))) 86 | 87 | (define lookup 88 | (lambda (x env) 89 | (let ((slot (assq x env))) 90 | (cond 91 | [(not slot) (error 'lookup "unbound variable ~a" x)] 92 | [else (cdr slot)])))) 93 | 94 | (define env0 95 | `((zero? . (int -> bool)) 96 | (add1 . (int -> int)) 97 | (sub1 . (int -> int)) 98 | (= . (int -> (int -> bool))) 99 | (<= . (int -> (int -> bool))) 100 | (< . (int -> (int -> bool))) 101 | (>= . (int -> (int -> bool))) 102 | (> . (int -> (int -> bool))) 103 | (* . (int -> (int -> int))) 104 | (- . (int -> (int -> int))) 105 | (+ . (int -> (int -> int))))) 106 | 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; inferencer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | (define infer 109 | (lambda (exp) 110 | (define infer1 111 | (lambda (exp env s) 112 | (pmatch exp 113 | [,x (guard (number? x)) (values 'int s)] 114 | [,x (guard (boolean? x)) (values 'bool s)] 115 | [,x (guard (string? x)) (values 'string s)] 116 | [,x (guard (symbol? x)) (values (lookup x env) s)] 117 | [(if ,test ,conseq ,alt) 118 | (letv* ([(t1 s1) (infer1 test env s)] 119 | [(s1^) (unify t1 'bool s1)]) 120 | (cond 121 | [s1^ 122 | (letv* ([(t2 s2) (infer1 conseq env s1^)] 123 | [(t3 s3) (infer1 alt env s2)] 124 | [(s4) (unify t2 t3 s3)]) 125 | (cond 126 | [s4 (values t3 s4)] 127 | [else 128 | (fatal 'infer 129 | "branches must have the same type \n\n" 130 | " - expression: " exp "\n" 131 | " - true branch type: " (reify t2 s3) "\n" 132 | " - false branch type: " (reify t3 s3)) ]))] 133 | [else 134 | (fatal 'infer 135 | "test is not of type bool \n\n" 136 | "expression: " exp "\n" 137 | "irritant: " test "\n" 138 | "type: " (reify t1 s1) )]))] 139 | [(lambda (,x) ,body) 140 | (letv* ([(t1) (var x)] 141 | [(env*) (ext-env x t1 env)] 142 | [(t2 s^) (infer1 body env* s)]) 143 | (values `(,t1 -> ,t2) s^))] 144 | [(,e1 ,e2) 145 | (letv* ([(t1 s1) (infer1 e1 env s)] 146 | [(t2 s2) (infer1 e2 env s1)] 147 | [(t3) (var 't3)] 148 | [(t4) (var 't4)] 149 | [(s3) (unify t1 `(,t3 -> ,t4) s2)]) 150 | (cond 151 | [(not s3) 152 | (fatal 'infer 153 | "trying to apply non-function:\n\n" 154 | " - irritant: " e1 "\n" 155 | " - type: " (reify t1 s1) )] 156 | [else 157 | (let ([s4 (unify t2 t3 s3)]) 158 | (cond 159 | [(not s4) 160 | (fatal 'infer 161 | "wrong argument type: \n\n" 162 | " - function: " e1 "\n" 163 | " - function type: " (reify t1 s3) "\n" 164 | " - expected type: " (reify t3 s3) "\n" 165 | " - argument type: " (reify t2 s3) "\n" 166 | " - argument: " e2 )] 167 | [else 168 | (values t4 s4)]))]))]))) 169 | (letv* ([(t s) (infer1 exp env0 s0)]) 170 | (reify t s)))) 171 | 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | ; correct programs 174 | (infer 1) 175 | ; => int 176 | 177 | (infer #t) 178 | ; => bool 179 | 180 | (infer '(lambda (v) v)) 181 | ; => (t0 -> t0) 182 | 183 | (infer '(lambda (f) (lambda (x) (f x)))) 184 | ; => ((t0 -> t1) -> (t0 -> t1)) 185 | 186 | (infer '(lambda (f) (lambda (x) (f (f x))))) 187 | ; => ((t0 -> t0) -> (t0 -> t0)) 188 | 189 | (infer '((lambda (f) (lambda (x) (f (f x)))) add1)) 190 | ; => (int -> int) 191 | 192 | (infer '(if (zero? 1) #t #f)) 193 | ; => bool 194 | 195 | (infer '(lambda (f) (lambda (x) (f ((+ x) 1))))) 196 | ; => ((int -> t0) -> (int -> t0)) 197 | 198 | (infer '(lambda (m) (lambda (n) (lambda (f) (lambda (x) ((m (n f)) x)))))) 199 | ; => ((t0 -> (t1 -> t2)) -> ((t3 -> t0) -> (t3 -> (t1 -> t2)))) 200 | 201 | (infer '((lambda (f) (f 1)) (lambda (v) v))) 202 | ; => int 203 | 204 | (infer '(if (zero? 1) #f #t)) 205 | ; => bool 206 | 207 | (define S '(lambda (x) (lambda (y) (lambda (z) ((x z) (y z)))))) 208 | (define K '(lambda (x) (lambda (y) x))) 209 | 210 | (infer S) 211 | ; => ((t0 -> (t1 -> t2)) -> ((t0 -> t1) -> (t0 -> t2))) 212 | 213 | (infer `(,S ,K)) 214 | ; => ((t0 -> t1) -> (t0 -> t0)) 215 | 216 | (infer `((,S ,K) ,K)) 217 | ; => (t0 -> t0) 218 | 219 | ; incorrect programs 220 | (infer '(lambda (f) (f f))) 221 | ;; infer: trying to apply function to wrong type argument: 222 | ;; - function: f 223 | ;; - function type: (t0 -> t1) 224 | ;; - expected type: t0 225 | ;; - argument type: (t0 -> t1) 226 | ;; - argument: f 227 | 228 | (infer '(if (zero? 1) #t 1)) 229 | ;; infer: branches of conditional must have the same type 230 | ;; - expression: (if (zero? 1) #t 1) 231 | ;; - true branch type: bool 232 | ;; - false branch type: int 233 | 234 | (infer '((lambda (x) ((+ 1) x)) "hello")) 235 | ;; infer: trying to apply function to wrong type argument: 236 | ;; - function: (lambda (x) ((+ 1) x)) 237 | ;; - function type: (int -> int) 238 | ;; - expected type: int 239 | ;; - argument type: string 240 | ;; - argument: hello 241 | -------------------------------------------------------------------------------- /interp-call-by-name.ss: -------------------------------------------------------------------------------- 1 | ;; call-by-name interpreter (reducer) 2 | 3 | 4 | (load "pmatch.scm") 5 | (load "encoding.scm") 6 | 7 | 8 | (define occur-free? 9 | (lambda (y exp) 10 | (pmatch exp 11 | [(lambda (,x) ,e) (and (not (eq? y x)) (occur-free? y e))] 12 | [(,rator ,rand) (or (occur-free? y rator) (occur-free? y rand))] 13 | [,exp (eq? y exp)]))) 14 | 15 | (define value? 16 | (lambda (exp) 17 | (pmatch exp 18 | [,x (guard (symbol? x)) #t] 19 | [(lambda (,x) ,e) #t] 20 | [(,rator ,rand) #f]))) 21 | 22 | (define gensym 23 | (let ((n -1)) 24 | (lambda (x) 25 | (set! n (+ 1 n)) 26 | (string->symbol 27 | (string-append (symbol->string x) "." (number->string n)))))) 28 | 29 | (define subst 30 | (lambda (x y exp) 31 | (pmatch exp 32 | [,u (guard (symbol? u)) (if (eq? u x) y u)] 33 | [(lambda (,u) ,e) 34 | (cond 35 | [(eq? u x) exp] 36 | [(and (occur-free? u y) (occur-free? x e)) 37 | (let* ([u* (gensym u)] 38 | [e* (subst u u* e)]) 39 | `(lambda (,u*) ,(subst x y e*)))] 40 | [else 41 | `(lambda (,u) ,(subst x y e))])] 42 | [(,e1 ,e2) `(,(subst x y e1) ,(subst x y e2))] 43 | [,exp exp]))) 44 | 45 | (define redex-of car) 46 | (define ctx-of cdr) 47 | (define find-redexes 48 | (lambda (exp) 49 | (letrec ([find 50 | (lambda (exp C) 51 | (pmatch exp 52 | [(lambda (,x) ,e) 53 | (find e (lambda (v) (C `(lambda (,x) ,v))))] 54 | [((lambda (,x) ,e1) ,e2) 55 | (append `((,exp . ,C)) 56 | (find e1 (lambda (v) (C `((lambda (,x) ,v) ,e2)))) 57 | (find e2 (lambda (v) (C `((lambda (,x) ,e1) ,v)))))] 58 | [(,e1 ,e2) 59 | (append (find e1 (lambda (v) (C `(,v ,e2)))) 60 | (find e2 (lambda (v) (C `(,e1 ,v)))))] 61 | [,exp '()]))]) 62 | (find exp (lambda (v) v))))) 63 | 64 | 65 | ;; do one beta-reduction if the operand is a lambda, otherwise output it 66 | ;; verbatically. 67 | (define beta 68 | (lambda (redex) 69 | (pmatch redex 70 | [((lambda (,x) ,e1) ,e2) (subst x e2 e1)] 71 | [,other other]))) 72 | 73 | ;; deterministic reducer 74 | (define reducer 75 | (lambda (exp) 76 | (let ([redexes (find-redexes exp)]) 77 | (cond 78 | [(null? redexes) exp] 79 | [else 80 | (let ([first (car redexes)]) 81 | (reducer ((ctx-of first) (beta (redex-of first)))))])))) 82 | 83 | ;;; random reducer 84 | (define random-reducer 85 | (lambda (exp tick) 86 | (cond 87 | [(zero? tick) exp] 88 | [else 89 | (let ([redexes (find-redexes exp)]) 90 | (cond 91 | [(null? redexes) exp] 92 | [else 93 | (let* ([pick (list-ref redexes (random (length redexes)))] 94 | [new-exp ((ctx-of pick) (beta (redex-of pick)))]) 95 | (random-reducer new-exp (sub1 tick)))]))]))) 96 | 97 | 98 | ;;; tests 99 | (reducer `(,!-n ,lthree)) 100 | ; => (lambda (f) (lambda (x) (f (f (f (f (f (f x)))))))) 101 | 102 | (reducer (random-reducer `(,!-n ,lthree) 300)) 103 | ; => (lambda (f) (lambda (x.42) (f (f (f (f (f (f x.42)))))))) 104 | 105 | 106 | 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | ;; (reducer '((lambda (y) z) ((lambda (x) (x x)) (lambda (x) (x x))))) 109 | 110 | ;; (nd-reducer '((lambda (y) z) ((lambda (x) (x x)) (lambda (x) (x x)))) 3) 111 | ;; (map reducer (nd-reducer `(,! ,ltwo) 1)) 112 | 113 | 114 | 115 | ; non-deterministic reducer 116 | (define nd-reducer 117 | (lambda (exp tick) 118 | (letrec ([reduce1 119 | (lambda (redexes tick) 120 | (cond 121 | [(null? redexes) '()] 122 | [(zero? tick) (map (lambda (x) ((ctx-of x) (redex-of x))) redexes)] 123 | [else 124 | (let ([pick (list-ref redexes (random (length redexes)))]) 125 | (cond 126 | [(value? pick) 127 | (reduce1 redexes tick)] 128 | [else 129 | (let ([pick* ((ctx-of pick) (beta (redex-of pick)))] 130 | [new-redexes (append (remq pick redexes) 131 | (find-redexes pick*) `((,pick* . ,(lambda (v) v))))]) 132 | (if (null? new-redexes) 133 | 'haha 134 | (reduce1 new-redexes (sub1 tick))))]))]))]) 135 | (reduce1 (find-redexes exp) tick)))) 136 | 137 | -------------------------------------------------------------------------------- /interp-call-by-value.ss: -------------------------------------------------------------------------------- 1 | ;; A call-by-value interpreter for lambda calculus with arithmetic 2 | 3 | ;; author: Yin Wang (yw21@cs.indiana.edu) 4 | 5 | 6 | ;; environment 7 | (define env0 '()) 8 | 9 | (define ext-env 10 | (lambda (x v env) 11 | (cons `(,x . ,v) env))) 12 | 13 | (define lookup 14 | (lambda (x env) 15 | (let ([p (assq x env)]) 16 | (cond 17 | [(not p) x] 18 | [else (cdr p)])))) 19 | 20 | 21 | ;; closure "structure" 22 | (struct Closure (f env)) 23 | 24 | 25 | ;; cbv interpreter 26 | (define interp1 27 | (lambda (exp env) 28 | (match exp 29 | [(? symbol? x) (lookup x env)] 30 | [(? number? x) x] 31 | [`(lambda (,x) ,e) 32 | (Closure exp env)] 33 | [`(if ,test ,conseq ,alt) 34 | (let ([v0 (interp1 test env)]) 35 | (if v0 36 | (interp1 conseq env) 37 | (interp1 alt env)))] 38 | [`(,e1 ,e2) 39 | (let ([v1 (interp1 e1 env)] 40 | [v2 (interp1 e2 env)]) 41 | (match v1 42 | [(Closure `(lambda (,x) ,e) env1) 43 | (interp1 e (ext-env x v2 env1))] 44 | [else 45 | (error "trying to apply non-function" v1)]))] 46 | [`(,op ,e1 ,e2) 47 | (let ([v1 (interp1 e1 env)] 48 | [v2 (interp1 e2 env)]) 49 | (match op 50 | ['+ (+ v1 v2)] 51 | ['- (- v1 v2)] 52 | ['* (* v1 v2)] 53 | ['/ (/ v1 v2)] 54 | ['= (= v1 v2)]))] 55 | [else 56 | (error "unrecognized expression" exp)]))) 57 | 58 | 59 | 60 | (define interp 61 | (lambda (exp) 62 | (interp1 exp env0))) 63 | 64 | 65 | 66 | ;; ------------------------ tests ------------------------- 67 | (interp '(+ 1 2)) 68 | ;; => 3 69 | 70 | (interp '(* 2 3)) 71 | ;; => 6 72 | 73 | (interp '(* 2 (+ 3 4))) 74 | ;; => 14 75 | 76 | (interp '(* (+ 1 2) (+ 3 4))) 77 | ;; => 21 78 | 79 | 80 | (interp '(((lambda (x) (lambda (y) (* x y))) 2) 3)) 81 | ;; => 6 82 | 83 | (interp '((lambda (x) (* 2 x)) 3)) 84 | ;; => 6 85 | 86 | ;; (interp '(1 2)) 87 | ;; => ERROR: trying to apply non-function 1 88 | 89 | (interp '(if (= 1 1) 0 1)) 90 | ;; => 1 91 | 92 | (interp '(if (= 1 2) 0 1)) 93 | ;; => 1 94 | -------------------------------------------------------------------------------- /interp-delim.ss: -------------------------------------------------------------------------------- 1 | (require racket/control) 2 | 3 | (define-syntax pmatch 4 | (syntax-rules (else guard) 5 | ((_ (rator rand ...) cs ...) 6 | (let ((v (rator rand ...))) 7 | (pmatch v cs ...))) 8 | ((_ v) (error 'pmatch "failed: ~s" v)) 9 | ((_ v (else e0 e ...)) (begin e0 e ...)) 10 | ((_ v (pat (guard g ...) e0 e ...) cs ...) 11 | (let ((fk (lambda () (pmatch v cs ...)))) 12 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 13 | ((_ v (pat e0 e ...) cs ...) 14 | (let ((fk (lambda () (pmatch v cs ...)))) 15 | (ppat v pat (begin e0 e ...) (fk)))))) 16 | 17 | (define-syntax ppat 18 | (syntax-rules (_ quote unquote) 19 | ((_ v _ kt kf) kt) 20 | ((_ v () kt kf) (if (null? v) kt kf)) 21 | ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 22 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 23 | ((_ v (x . y) kt kf) 24 | (if (pair? v) 25 | (let ((vx (car v)) (vy (cdr v))) 26 | (ppat vx x (ppat vy y kt kf) kf)) 27 | kf)) 28 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 29 | 30 | (define *debug* #t) 31 | (define-syntax peek 32 | (syntax-rules () 33 | [(_ name args ...) 34 | (if *debug* 35 | (begin 36 | (printf "~s: ~s = ~s~n" name 'args args) 37 | ...) 38 | (void))])) 39 | 40 | (define ext 41 | (lambda (x v env) 42 | (cons `(,x . ,v) env))) 43 | 44 | (define lookup 45 | (lambda (x env) 46 | (cond 47 | [(assq x env) => cdr] 48 | [else #f]))) 49 | 50 | 51 | ;; using high-order representation, can't model shift0 52 | (define interp-ho 53 | (lambda (exp) 54 | (define interp1 55 | (lambda (exp env k r) 56 | (pmatch exp 57 | [,x (guard (number? x)) 58 | ((k r) x)] 59 | [,x (guard (not (pair? x))) 60 | (let ([v (lookup x env)]) 61 | (cond 62 | [(not v) 63 | (error 'interp "unbound variable ~a" x)] 64 | [else 65 | ((k r) v)]))] 66 | [(lambda (,x) ,body) 67 | ((k r) 68 | (lambda (k) 69 | (lambda (r) 70 | (lambda (v) 71 | (interp1 body (ext x v env) k r)))))] 72 | [(reset ,e) 73 | (interp1 e env 74 | (lambda (r) r) 75 | (k r))] 76 | [(shift ,x ,e) 77 | (interp1 e (ext x (lambda (k^) 78 | (lambda (r) 79 | (lambda (v) 80 | ((k (k^ r)) v)))) env) 81 | (lambda (r) r) 82 | r)] 83 | [(+ ,a ,b) 84 | (interp1 a env 85 | (lambda (r) 86 | (lambda (a^) 87 | (interp1 b env 88 | (lambda (r) 89 | (lambda (b^) 90 | ((k r) (+ a^ b^)))) 91 | r))) 92 | r)] 93 | [(,rator ,rand) 94 | (interp1 rator env 95 | (lambda (r) 96 | (lambda (f) 97 | (interp1 rand env (f k) r))) 98 | r)]))) 99 | (interp1 exp '() (lambda (r) (lambda (v) (r v))) (lambda (v) v)))) 100 | 101 | 102 | 103 | ;; using list representation, can model shift0 104 | (define interp 105 | (lambda (exp) 106 | (define idK (lambda (r v) ((car r) (cdr r) v))) 107 | (define idR (list (lambda (r v) v))) 108 | (define interp1 109 | (lambda (exp env k r) 110 | (pmatch exp 111 | [,x (guard (number? x)) 112 | (k r x)] 113 | [,x (guard (not (pair? x))) 114 | (let ([v (lookup x env)]) 115 | (cond 116 | [(not v) 117 | (error 'interp "unbound variable ~a" x)] 118 | [else 119 | (k r v)]))] 120 | [(lambda (,x) ,body) 121 | (k r (lambda (k r v) 122 | (interp1 body (ext x v env) k r)))] 123 | [(reset ,e) 124 | (interp1 e env idK (cons k r))] 125 | [(reset0 ,e) ; same as reset 126 | (interp1 e env idK (cons k r))] 127 | [(shift ,x ,e) 128 | (interp1 e (ext x (lambda (k^ r v) 129 | (k (cons k^ r) v)) env) 130 | idK r)] 131 | [(shift0 ,x ,e) 132 | (interp1 e (ext x (lambda (k^ r v) 133 | (k (cons k^ r) v)) env) 134 | (car r) (cdr r))] ; the only difference from shift 135 | [(+ ,a ,b) 136 | (interp1 a env 137 | (lambda (r a^) 138 | (interp1 b env 139 | (lambda (r b^) 140 | (k r (+ a^ b^))) 141 | r)) 142 | r)] 143 | [(,rator ,rand) 144 | (interp1 rator env 145 | (lambda (r f) 146 | (interp1 rand env (lambda (r v) (f k r v)) r)) 147 | r)]))) 148 | (interp1 exp '() idK idR))) 149 | 150 | 151 | 152 | 153 | ;-------------------- tests --------------------------- 154 | (define test-control 155 | (lambda (e) 156 | (let ([expected (eval e)] 157 | [actual (interp e)]) 158 | (cond 159 | [(eqv? expected actual) 160 | (printf "succeed. answer = ~a~n" actual)] 161 | [else 162 | (printf "error. answer = ~a, but should be ~a~n" actual expected)])))) 163 | 164 | 165 | 166 | 167 | ;; Danvy-filinski test 168 | (test-control '(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))) 169 | ; => 117 170 | 171 | ;; Danvy-filinski paper example 172 | (test-control '(+ 5 (reset (+ 3 (shift c (+ (c 0) (c 1))))))) 173 | ; => 12 174 | 175 | (test-control '(+ 1 (+ 2 (+ 4 8)))) 176 | ; => 15 177 | 178 | (test-control '(+ 1 (reset (+ 2 (+ (shift k 4) 8))))) 179 | ; => 5 180 | 181 | (test-control '(reset (+ 1 (reset (+ 2 (reset (+ 4 (shift k1 (shift k2 8))))))))) 182 | ; => 11 183 | 184 | ;; compare reset0 & shift0 185 | (test-control '(reset0 (+ 1 (reset0 (+ 2 (reset0 (+ 4 (shift0 k1 (shift0 k2 8))))))))) 186 | ; => 9 187 | 188 | 189 | (test-control '(reset (+ 1 (reset (+ 2 ((shift k1 (k1 (lambda (x) x))) 190 | (shift k2 4))))))) 191 | ; => 5 192 | 193 | (test-control '(+ 1 (reset (+ 2 3)))) 194 | ; => 6 195 | 196 | (test-control 197 | '((lambda (f) (+ 1 (reset (+ 2 (f 3))))) 198 | (lambda (x) (shift k x)))) 199 | ; => 4 200 | 201 | (test-control '(reset (+ 10 (+ (shift k (+ 1 (k 1))) (shift k 2))))) 202 | ; => 3 203 | 204 | 205 | 206 | ;------------------------ from Oleg's Shift0.hs ------------------------------- 207 | 208 | ; ts0 = run $ reset (return 1) 209 | (test-control '(reset0 1)) 210 | ;=> 1 211 | 212 | ; ts1 = run $ reset (return 1 `add` abort 2) 213 | (test-control '(reset0 (+ 1 (shift0 k 2)))) 214 | ;=> 2 215 | 216 | ; ts2 = run $ reset (return 1 `add` shift0 (\k -> k 2)) 217 | (test-control '(reset0 (+ 1 (shift0 k (k 2))))) 218 | ;=> 3 219 | 220 | 221 | ; -- shift0 spcifically 222 | ;; ts41 = run $ reset (return 1 `add` reset (return 2 `add` 223 | ;; (shift0 (\k -> k 10)))) 224 | (test-control '(reset0 (+ 1 (reset0 (+ 2 (shift0 k (k 10))))))) 225 | ;=> 13 226 | 227 | 228 | ;; ts42 = run $ reset (return 1 `add` reset (return 2 `add` 229 | ;; (shift0 (\k -> return 10)))) 230 | 231 | (test-control (reset0 (+ 1 (reset0 (+ 2 (shift0 k 10)))))) 232 | ;=> 11 233 | 234 | 235 | ;; ts43 = run $ reset (return 1 `add` reset (return 2 `add` 236 | ;; (shift0 (\k -> abort 10)))) 237 | ;; -- 10 238 | (test-control '(reset0 (+ 1 (reset0 (+ 2 (shift0 k (shift0 k 10))))))) 239 | 240 | 241 | ;; ts44 = run $ reset (return 1 `add` reset (return 2 `add` 242 | ;; reset ((shift0 (\k -> abort 10))))) 243 | (test-control '(reset0 (+ 1 (reset0 (+ 2 (reset0 (shift0 k (shift0 k 10)))))))) 244 | ;; -- 11 245 | 246 | ;; -- left-to-right evaluation 247 | ;; ts5 = run $ reset (abort 1 `add` abort 2) 248 | 249 | (test-control '(reset0 (+ (shift0 k 1) (shift0 k 2)))) 250 | ;=> 1 251 | 252 | 253 | ;; ts61 = run $ reset (return 10 `add` 254 | ;; reset (shift0 (\k -> k 1) `add` 255 | ;; shift0 (\k -> k 2))) 256 | ;; -- 13 257 | (test-control '(reset0 (+ 10 (reset0 (+ (shift0 k (k 1)) (shift0 k (k 2))))))) 258 | 259 | 260 | ;; ts62 = run $ reset (return 10 `add` 261 | ;; reset (shift0 (\k -> k 1) `add` 262 | ;; shift0 (\_ -> return 2))) 263 | ;; -- 12 264 | (test-control '(reset (+ 10 (reset (+ (shift0 k (k 1)) (shift0 k 2)))))) 265 | 266 | 267 | ;; ts63 = run $ reset (return 10 `add` 268 | ;; reset (shift0 (\k -> k 1) `add` 269 | ;; shift0 (\_ -> abort 2))) 270 | ;; -- 2 271 | (test-control '(reset0 (+ 10 (reset0 (+ (shift0 k (k 1)) (shift0 k (shift0 k 2))))))) 272 | 273 | -------------------------------------------------------------------------------- /interp-lazy.rkt: -------------------------------------------------------------------------------- 1 | ;; A lazy interpreter for lambda calculus with some primitives 2 | 3 | 4 | (define env0 '()) 5 | 6 | (define ext 7 | (lambda (x v env) 8 | (cons (cons x v) env))) 9 | 10 | (define lookup 11 | (lambda (x env) 12 | (cond 13 | [(assq x env) => cdr] 14 | [else #f]))) 15 | 16 | 17 | 18 | ;; Thunk structure. Fields: 19 | ;; 1. the function or the value depending on whether cached? is #t 20 | ;; 2. whether the function has been forced already 21 | (struct thunk (fv cached?) #:transparent #:mutable) 22 | 23 | 24 | ;; Closure structure 25 | (struct closure (fun env)) 26 | 27 | 28 | 29 | ;; Redefining "delay" and "force" of Scheme just for independence 30 | 31 | (define make-thunk 32 | (lambda (fun) 33 | (thunk fun #f))) 34 | 35 | (define force-thunk 36 | (lambda (th) 37 | (cond 38 | [(thunk-cached? th) 39 | (thunk-fv th)] 40 | [else 41 | (let loop ([val ((thunk-fv th))]) 42 | (cond 43 | [(thunk? val) 44 | (loop ((thunk-fv val)))] 45 | [else 46 | (set-thunk-fv! th val) 47 | (set-thunk-cached?! th #t) 48 | val]))]))) 49 | 50 | 51 | 52 | (define interp1 53 | (lambda (exp env) 54 | (match exp 55 | [(? number? x) x] 56 | [(? symbol? x) 57 | (lookup x env)] 58 | [`(lambda (,x) ,e) 59 | (closure exp env)] 60 | [`(,e1 ,e2) 61 | (let ([v1 (make-thunk (lambda () (interp1 e1 env)))] 62 | [v2 (make-thunk (lambda () (interp1 e2 env)))]) 63 | (make-thunk 64 | (lambda () 65 | (let ([v1+ (force-thunk v1)]) 66 | (match v1+ 67 | [(closure `(lambda (,x) ,e) env1) 68 | (interp1 e (ext x v2 env1))])))))]))) 69 | 70 | 71 | (define interp 72 | (lambda (exp) 73 | (force-thunk (interp1 exp env0)))) 74 | 75 | 76 | 77 | 78 | ;; ------------------------ tests ------------------------- 79 | 80 | (interp 81 | '((lambda (x) 42) 82 | ((lambda (x) (x x)) 83 | (lambda (x) (x x))))) 84 | 85 | (interp 86 | '((lambda (x) 42) 87 | ((lambda (x) x) 88 | ((lambda (x) (x x)) 89 | (lambda (x) (x x)))))) 90 | 91 | ;;; infinite loop 92 | ;; (interp 93 | ;; '((lambda (x) (x x)) 94 | ;; (lambda (x) (x x)))) 95 | -------------------------------------------------------------------------------- /lazy-ski.ss: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define occur-free? 4 | (lambda (y exp) 5 | (pmatch exp 6 | [,x (guard (symbol? x)) (eq? y x)] 7 | [(lambda (,x) ,e) (and (not (eq? y x)) (occur-free? y e))] 8 | [(,rator ,rand) (or (occur-free? y rator) (occur-free? y rand))]))) 9 | 10 | (define value? 11 | (lambda (exp) 12 | (pmatch exp 13 | [,x (guard (symbol? x)) #t] 14 | [(lambda (,x) ,e) #t] 15 | [(,rator ,rand) #f]))) 16 | 17 | (define app? (lambda (x) (not (value? x)))) 18 | 19 | (define term-length 20 | (lambda (exp) 21 | (pmatch exp 22 | [,x (guard (symbol? x)) 0] 23 | [(lambda (,x) ,e) (+ 1 (term-length e))] 24 | [(,rator ,rand) (+ 1 (term-length rator) (term-length rand))]))) 25 | 26 | ; call-by-name compiler to S, K, I 27 | (define compile 28 | (lambda (exp) 29 | (pmatch exp 30 | [,x (guard (symbol? x)) x] 31 | [(,M ,N) `(,(compile M) ,(compile N))] 32 | [(lambda (,x) (,M ,y)) 33 | (guard (eq? x y) (not (occur-free? x M))) (compile M)] 34 | [(lambda (,x) ,y) (guard (eq? x y)) `I] 35 | [(lambda (,x) (,M ,N)) (guard (or (occur-free? x M) (occur-free? x N))) 36 | `((S ,(compile `(lambda (,x) ,M))) ,(compile `(lambda (,x) ,N)))] 37 | [(lambda (,x) ,M) (guard (not (occur-free? x M))) `(K ,(compile M))] 38 | [(lambda (,x) ,M) (guard (occur-free? x M)) 39 | (compile `(lambda (,x) ,(compile M)))]))) 40 | 41 | ; call-by-name compiler to S, K, I, B, C 42 | (define compile-bc 43 | (lambda (exp) 44 | (pmatch exp 45 | [,x (guard (symbol? x)) x] 46 | [(,M ,N) `(,(compile-bc M) ,(compile-bc N))] 47 | [(lambda (,x) ,y) (guard (eq? x y)) `I] 48 | [(lambda (,x) (,M ,y)) 49 | (guard (eq? x y) (not (occur-free? x M))) (compile-bc M)] 50 | [(lambda (,x) (,M ,N)) (guard (and (not (occur-free? x M)) (occur-free? x N))) 51 | `((B ,(compile-bc M)) ,(compile-bc `(lambda (,x) ,N)))] 52 | [(lambda (,x) (,M ,N)) (guard (and (occur-free? x M) (not (occur-free? x N)))) 53 | `((C ,(compile-bc `(lambda (,x) ,M))) ,(compile-bc N))] 54 | [(lambda (,x) (,M ,N)) (guard (or (occur-free? x M) (occur-free? x N))) 55 | `((S ,(compile-bc `(lambda (,x) ,M))) ,(compile-bc `(lambda (,x) ,N)))] 56 | [(lambda (,x) ,M) (guard (not (occur-free? x M))) `(K ,(compile-bc M))] 57 | [(lambda (,x) ,M) (guard (occur-free? x M)) 58 | (compile-bc `(lambda (,x) ,(compile-bc M)))]))) 59 | 60 | 61 | 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | ;; ski->lanbda converter 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;; create gensyms 66 | (define fv 67 | (let ((n -1)) 68 | (lambda (x) 69 | (set! n (+ 1 n)) 70 | (string->symbol 71 | (string-append (symbol->string x) "." (number->string n)))))) 72 | 73 | ;; substitution with free variable capturing avoiding 74 | (define subst 75 | (lambda (x y exp) 76 | (pmatch exp 77 | [,u (guard (symbol? u)) (if (eq? u x) y u)] 78 | [(lambda (,u) ,e) 79 | (cond 80 | [(eq? u x) exp] 81 | [(occur-free? u y) ; possible capture, switch names 82 | (let* ([u* (fv u)] 83 | [e* (subst u u* e)]) 84 | `(lambda (,u*) ,(subst x y e*)))] 85 | [else 86 | `(lambda (,u) ,(subst x y e))])] 87 | [(,e1 ,e2) `(,(subst x y e1) ,(subst x y e2))] 88 | [,exp exp]))) 89 | 90 | 91 | ; combinator definitions 92 | (define com-table 93 | '((S . (lambda (f) (lambda (g) (lambda (x) ((f x) (g x)))))) 94 | (K . (lambda (x) (lambda (y) x))) 95 | (I . (lambda (x) x)) 96 | (B . (lambda (f) (lambda (g) (lambda (x) (f (g x)))))) 97 | (C . (lambda (a) (lambda (b) (lambda (c) ((a c) b))))))) 98 | 99 | ; substitute combinator with their lambda term definitions 100 | (define sub-com 101 | (lambda (exp defs) 102 | (cond 103 | [(null? defs) exp] 104 | [else (sub-com (subst (caar defs) (cdar defs) exp) (cdr defs))]))) 105 | 106 | (define ski->lambda 107 | (lambda (exp) 108 | (sub-com exp com-table))) 109 | 110 | 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | ;; tests 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | (define to-number `(lambda (n) ((n (lambda (x) (,add1 x))) 0))) 115 | 116 | (interp `(,to-number ,(ski->lambda (compile-bc `(,!-n ,lfive))))) 117 | ; => 120 118 | (term-length `(,! ,lfive)) 119 | ; => 93 120 | (term-length (compile `(,! ,lfive))) 121 | ; => 144 122 | (term-length (compile-bc `(,! ,lfive))) 123 | ; => 73 124 | 125 | -------------------------------------------------------------------------------- /meta-interp.ss: -------------------------------------------------------------------------------- 1 | ;; a meta-circular interpreter (reflection tower) is an 2 | ;; interpreter which can interpret itself to interpret 3 | ;; itself to interpret itself ... 4 | 5 | ;; This version saves indentation by defining 'cond'. 6 | 7 | ;; author: Yin Wang (yw21@cs.indiana.edu) 8 | 9 | 10 | 11 | (define Y 12 | '(lambda (f) 13 | ((lambda (u) (u u)) 14 | (lambda (x) (f (lambda (t) ((x x) t))))))) 15 | 16 | 17 | (define interp-text 18 | `(,Y 19 | (lambda (interp) 20 | (lambda (exp) 21 | (lambda (env) 22 | (lambda (k) 23 | (cond 24 | [(number? exp) (k exp)] 25 | [(boolean? exp) (k exp)] 26 | [(string? exp) (k exp)] 27 | [(symbol? exp) (k (env exp))] 28 | [(eq? 'cond (car exp)) 29 | ((((,Y (lambda (loop) 30 | (lambda (cls) 31 | (lambda (env) 32 | (lambda (k) 33 | (((interp (car (car cls))) env) 34 | (lambda (t) 35 | (if t 36 | (((interp (car (cdr (car cls)))) env) k) 37 | (((loop (cdr cls)) env) k))))))))) 38 | (cdr exp)) env) k)] 39 | [(eq? 'eq? (car exp)) 40 | (((interp (car (cdr exp))) env) 41 | (lambda (v1) 42 | (((interp (car (cdr (cdr exp)))) env) 43 | (lambda (v2) (k (eq? v1 v2))))))] 44 | [(eq? '= (car exp)) 45 | (((interp (car (cdr exp))) env) 46 | (lambda (v1) 47 | (((interp (car (cdr (cdr exp)))) env) 48 | (lambda (v2) (k (= v1 v2))))))] 49 | [(eq? '* (car exp)) 50 | (((interp (car (cdr exp))) env) 51 | (lambda (v1) 52 | (((interp (car (cdr (cdr exp)))) env) 53 | (lambda (v2) (k (* v1 v2))))))] 54 | [(eq? 'cons (car exp)) 55 | (((interp (car (cdr exp))) env) 56 | (lambda (v1) 57 | (((interp (car (cdr (cdr exp)))) env) 58 | (lambda (v2) (k (cons v1 v2))))))] 59 | [(eq? 'quote (car exp)) (k (car (cdr exp)))] 60 | [(eq? 'sub1 (car exp)) 61 | (((interp (car (cdr exp))) env) (lambda (v) (k (sub1 v))))] 62 | [(eq? 'number? (car exp)) 63 | (((interp (car (cdr exp))) env) (lambda (v) (k (number? v))))] 64 | [(eq? 'boolean? (car exp)) 65 | (((interp (car (cdr exp))) env) (lambda (v) (k (boolean? v))))] 66 | [(eq? 'string? (car exp)) 67 | (((interp (car (cdr exp))) env) (lambda (v) (k (string? v))))] 68 | [(eq? 'symbol? (car exp)) 69 | (((interp (car (cdr exp))) env) (lambda (v) (k (symbol? v))))] 70 | [(eq? 'zero? (car exp)) 71 | (((interp (car (cdr exp))) env) (lambda (v) (k (zero? v))))] 72 | [(eq? 'null? (car exp)) 73 | (((interp (car (cdr exp))) env) (lambda (v) (k (null? v))))] 74 | [(eq? 'car (car exp)) 75 | (((interp (car (cdr exp))) env) (lambda (v) (k (car v))))] 76 | [(eq? 'cdr (car exp)) 77 | (((interp (car (cdr exp))) env) (lambda (v) (k (cdr v))))] 78 | [(eq? 'if (car exp)) 79 | (((interp (car (cdr exp))) env) 80 | (lambda (t) 81 | (if t 82 | (((interp (car (cdr (cdr exp)))) env) k) 83 | (((interp (car (cdr (cdr (cdr exp))))) env) k))))] 84 | [(eq? 'lambda (car exp)) 85 | (k (lambda (a) 86 | (lambda (k) 87 | (((interp (car (cdr (cdr exp)))) 88 | (lambda (x^) 89 | (if (eq? x^ (car (car (cdr exp)))) a (env x^)))) 90 | k))))] 91 | [(eq? 'rho (car exp)) 92 | (k (lambda (a) 93 | (lambda (k) 94 | (((interp (car (cdr (cdr exp)))) 95 | (lambda (x^) 96 | (cond 97 | [(eq? x^ (car (cdr (cdr (car (cdr exp)))))) 98 | (lambda (a) (lambda (k^) (k a)))] 99 | [(eq? x^ (car (cdr (car (cdr exp))))) env] 100 | [(eq? x^ (car (car (cdr exp)))) a] 101 | [#t (env x^)]))) 102 | k))))] 103 | [#t 104 | (((interp (car exp)) env) 105 | (lambda (v1) 106 | (((interp (car (cdr exp))) env) 107 | (lambda (v2) 108 | ((v1 v2) k)))))]))))))) 109 | 110 | 111 | 112 | ;;;;;;;;; nested evaluators ;;;;;;;;;; 113 | 114 | ; level 0 is eval, our base evaluator 115 | (define interp0 eval) 116 | 117 | ; level 1 uses eval to interpret an interpreter text together with the 118 | ; input program 119 | (define interp1 120 | (lambda (e) 121 | (eval `(((,interp-text (quote ,e)) (lambda (x) x)) (lambda (v) v))))) 122 | 123 | ; level 2 uses interp1 to interpret an interpreter text together with the 124 | ; input program 125 | (define interp2 126 | (lambda (e) 127 | (interp1 `(((,interp-text (quote ,e)) (lambda (x) x)) (lambda (v) v))))) 128 | 129 | ; and so on ... 130 | (define interp3 131 | (lambda (e) 132 | (interp2 `(((,interp-text (quote ,e)) (lambda (x) x)) (lambda (v) v))))) 133 | 134 | 135 | ; We can extract the above pattern into a general nesting facility, which 136 | ; takes a text of interpreter and a number n, and generates an interpreter 137 | ; nested to level n. 138 | (define nest-interp 139 | (lambda (interp n) 140 | (cond 141 | [(zero? n) eval] 142 | [else 143 | (lambda (e) 144 | ((nest-interp interp (sub1 n)) 145 | `(((,interp (quote ,e)) (lambda (x) x)) (lambda (v) v))))]))) 146 | 147 | 148 | 149 | 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | (define-syntax test 152 | (syntax-rules () 153 | ((_ title tested-expression expected-result) 154 | (let* ((expected expected-result) 155 | (produced tested-expression)) 156 | (if (equal? expected produced) 157 | (printf "~s works!\n" title) 158 | (error 159 | 'test 160 | "Failed ~s: ~a\nExpected: ~a\nComputed: ~a" 161 | title 'tested-expression expected produced)))))) 162 | 163 | 164 | ;;;;;;;;;; fact 5 ;;;;;;;;;;; 165 | (define fact5 166 | `((,Y 167 | (lambda (fac) 168 | (lambda (n) 169 | (if (zero? n) 1 (* n (fac (sub1 n))))))) 170 | 5)) 171 | 172 | (test "fact5 - Level 0" 173 | ((nest-interp interp-text 0) fact5) 174 | 120) 175 | 176 | (test "fact5 - Level 1" 177 | ((nest-interp interp-text 1) fact5) 178 | 120) 179 | 180 | (test "fact5 - Level 2" 181 | ((nest-interp interp-text 2) fact5) 182 | 120) 183 | 184 | (test "fact5 - Level 3" 185 | ((nest-interp interp-text 3) fact5) 186 | 120) 187 | 188 | (time ((nest-interp interp-text 1) fact5)) 189 | ;; cpu time: 15 real time: 9 gc time: 0 190 | 191 | (time ((nest-interp interp-text 2) fact5)) 192 | ;; cpu time: 15 real time: 12 gc time: 0 193 | 194 | (time ((nest-interp interp-text 3) fact5)) 195 | ;; cpu time: 156 real time: 157 gc time: 16 196 | 197 | (time ((nest-interp interp-text 4) fact5)) 198 | ;; cpu time: 11107 real time: 11706 gc time: 1401 199 | 200 | 201 | 202 | ;;;;;;;;; member-test ;;;;;;;;;; 203 | (define member-test 204 | `(((,Y 205 | (lambda (member?) 206 | (lambda (a) 207 | (lambda (lat) 208 | (if 209 | (null? lat) #f 210 | (if (eq? a (car lat)) #t 211 | ((member? a) (cdr lat)))))))) 212 | 'a) '(b a c))) 213 | 214 | (test "member-test - Level 0" 215 | ((nest-interp interp-text 0) member-test) 216 | #t) 217 | 218 | (test "member-test - Level 1" 219 | ((nest-interp interp-text 1) member-test) 220 | #t) 221 | 222 | (test "member-test - Level 2" 223 | ((nest-interp interp-text 2) member-test) 224 | #t) 225 | 226 | (test "member-test - Level 3" 227 | ((nest-interp interp-text 3) member-test) 228 | #t) 229 | 230 | 231 | ;;;;;;;;;;;; rho-test ;;;;;;;;;;;;;; 232 | (define rho-test '(* 2 ((rho (x e k) (* 3 (k 4))) 5))) 233 | 234 | (test "rho-test - Level 1" 235 | ((nest-interp interp-text 1) rho-test) 236 | 8) 237 | 238 | (test "rho-test - Level 2" 239 | ((nest-interp interp-text 2) rho-test) 240 | 8) 241 | 242 | (test "rho-test - Level 3" 243 | ((nest-interp interp-text 3) rho-test) 244 | 8) 245 | 246 | 247 | ;;;;;;;;;;;; prod-test-rho ;;;;;;;;;;;;; 248 | (define prod-test-rho 249 | `((,Y 250 | (rho (prod _ __) 251 | (rho (ls _ k) 252 | (cond 253 | [(null? ls) 1] 254 | [(zero? (car ls)) (k 0)] 255 | [else (* (car ls) (prod (cdr ls)))])))) 256 | '(1 2 3 0 5 6))) 257 | 258 | 259 | (test "prod-test-rho - Level 1" 260 | ((nest-interp interp-text 1) prod-test-rho) 261 | 0) 262 | 263 | (test "prod-test-rho - Level 2" 264 | ((nest-interp interp-text 2) prod-test-rho) 265 | 0) 266 | 267 | (test "prod-test-rho - Level 3" 268 | ((nest-interp interp-text 3) prod-test-rho) 269 | 0) 270 | -------------------------------------------------------------------------------- /mk-c.ss: -------------------------------------------------------------------------------- 1 | ;;; miniKanren from Dan Friedman, William Byrd and Oleg Kiselyov 2 | 3 | ;;; modified by Yin Wang to support a negation operator 4 | ;;; (noto) and a disjoint branching operator (condc). The 5 | ;;; limitation is that they cannot be nested. 6 | 7 | ;;; Lazy streams are used to make the connections more modular. 8 | 9 | ;;; This file was generated by writeminikanren.pl 10 | ;;; Generated at 2007-10-25 15:24:42 11 | 12 | (define *debug-tags* '()) 13 | (define debug 14 | (lambda (tags format . args) 15 | (let* ((tags (if (not (pair? tags)) (list tags) tags)) 16 | (fs (string-append "[" (symbol->string (car tags)) "] " format "\n"))) 17 | (cond 18 | [(null? tags)] 19 | [(pair? tags) 20 | (if (member (car tags) *debug-tags*) 21 | (apply printf fs args) 22 | (void))] 23 | )))) 24 | 25 | 26 | 27 | (define-syntax lambdag@ 28 | (syntax-rules () 29 | ((_ (p ...) e ...) (lambda (p ...) e ...)))) 30 | 31 | 32 | (define-syntax lambdaf@ 33 | (syntax-rules () 34 | ((_ () e ...) (lambda () e ...)))) 35 | 36 | 37 | (define-syntax inc 38 | (syntax-rules () ((_ e) (lambdaf@ () e)))) 39 | 40 | 41 | (define defunc 42 | (lambda (f) 43 | (if (procedure? f) (defunc (f)) f))) 44 | 45 | 46 | 47 | ;;------------ stream primitives ------------ 48 | (define snull 'snull) 49 | 50 | 51 | (define snull? 52 | (lambda (s) 53 | (eq? s snull))) 54 | 55 | 56 | (define-syntax scons 57 | (syntax-rules () 58 | ((_ a d) (cons a (lambda () d))))) 59 | 60 | 61 | (define scar 62 | (lambda (s) 63 | (cond 64 | [(procedure? s) (scar (s))] 65 | [else (car s)]))) 66 | 67 | 68 | (define scdr 69 | (lambda (s) 70 | (cond 71 | [(procedure? s) (scdr (s))] 72 | [else ((cdr s))]))) 73 | 74 | 75 | (define-syntax sunit 76 | (syntax-rules () 77 | ((_ a) (scons a snull)))) 78 | 79 | 80 | (define slift 81 | (lambda (f) 82 | (lambda args 83 | (sunit (apply f args))))) 84 | 85 | 86 | (define-syntax make-stream 87 | (syntax-rules () 88 | ((_) snull) 89 | ((_ e1 e2 ...) (scons e1 (make-stream e2 ...))))) 90 | 91 | 92 | (define taken 93 | (lambda (n s) 94 | (if (and n (zero? n)) 95 | '() 96 | (let ([s (defunc s)]) 97 | (cond 98 | [(snull? s) '()] 99 | [else (cons (scar s) (taken (and n (- n 1)) (scdr s)))]))))) 100 | 101 | 102 | (define smerge 103 | (lambda (s1 s2) 104 | (cond 105 | [(snull? s1) s2] 106 | [(procedure? s1) 107 | (lambda () (smerge s2 (s1)))] 108 | [else (scons (scar s1) (smerge s2 (scdr s1)))]))) 109 | 110 | 111 | (define stream-merge 112 | (lambda (ss) 113 | (cond 114 | [(snull? ss) snull] 115 | [(procedure? ss) (lambda () (stream-merge (ss)))] 116 | [(snull? (scar ss)) (stream-merge (scdr ss))] 117 | [(procedure? (scar ss)) (lambda () 118 | (smerge (stream-merge (scdr ss)) 119 | (scar ss)))] 120 | [else (scons (scar (scar ss)) (smerge (scdr (scar ss)) 121 | (stream-merge (scdr ss))))]))) 122 | 123 | (define smap 124 | (lambda (f s) 125 | (cond 126 | [(snull? s) snull] 127 | [(procedure? s) (lambda () (smap f (s)))] 128 | [else (scons (f (scar s)) (smap f (scdr s)))]))) 129 | 130 | 131 | 132 | ;; Substitution 133 | (define-syntax rhs 134 | (syntax-rules () 135 | ((_ x) (cdr x)))) 136 | 137 | 138 | (define-syntax lhs 139 | (syntax-rules () 140 | ((_ x) (car x)))) 141 | 142 | 143 | (define-syntax size-s 144 | (syntax-rules () 145 | ((_ x) (length x)))) 146 | 147 | 148 | (define-syntax var 149 | (syntax-rules () 150 | ((_ x) (vector x)))) 151 | 152 | 153 | (define-syntax var? 154 | (syntax-rules () 155 | ((_ x) (vector? x)))) 156 | 157 | 158 | (define empty-s '()) 159 | 160 | (define ext-s 161 | (lambda (x v s) 162 | (cons `(,x . ,v) s))) 163 | 164 | 165 | (define walk 166 | (lambda (v s) 167 | (cond 168 | ((var? v) 169 | (let ((a (assq v s))) 170 | (cond 171 | (a (walk (rhs a) s)) 172 | (else v)))) 173 | (else v)))) 174 | 175 | 176 | (define unify 177 | (lambda (v w s env) 178 | ((Env-unify env) v w s env))) 179 | 180 | 181 | (define unify-good 182 | (lambda (v w s env) 183 | ; (printf "[unify-good]: ~a <--> ~a :: ~a\n" v w s) 184 | (let ((v (walk v s)) 185 | (w (walk w s))) 186 | (cond 187 | ((eq? v w) s) 188 | ((var? v) (ext-s v w s)) 189 | ((var? w) (ext-s w v s)) 190 | ((and (pair? v) (pair? w)) 191 | (let ((s (unify-good (car v) (car w) s env))) 192 | (and s (unify-good (cdr v) (cdr w) s env)))) 193 | ((equal? v w) s) 194 | (else #f))))) 195 | 196 | 197 | (define unify-evil 198 | (lambda (v w s env) 199 | (debug '(unify-evil unify) 200 | "v=~a, w=~a, cvars: ~a\n subst:~a" v w (Env-cvars env) s) 201 | (let ((vv (walk v s)) 202 | (ww (walk w s))) 203 | (cond 204 | ((eq? vv ww) s) 205 | ((and (var? vv) (memq v (Env-cvars env))) #f) 206 | ((and (var? ww) (memq w (Env-cvars env))) #f) 207 | ((var? vv) (ext-s vv ww s)) 208 | ((var? ww) (ext-s ww vv s)) 209 | ((and (pair? vv) (pair? ww)) 210 | (let ((s (unify-evil (car vv) (car ww) s env))) 211 | (and s (unify-evil (cdr vv) (cdr ww) s env)))) 212 | ((equal? vv ww) s) 213 | (else #f))))) 214 | 215 | 216 | (define switch-unify 217 | (lambda (env) 218 | (if (eq? (Env-unify env) unify-good) 219 | (change-unify env unify-evil) 220 | (change-unify env unify-good)))) 221 | 222 | 223 | (define unify-check 224 | (lambda (u v s) 225 | (let ((u (walk u s)) 226 | (v (walk v s))) 227 | (cond 228 | ((eq? u v) s) 229 | ((var? u) (ext-s-check u v s)) 230 | ((var? v) (ext-s-check v u s)) 231 | ((and (pair? u) (pair? v)) 232 | (let ((s (unify-check (car u) (car v) s))) 233 | (and s (unify-check (cdr u) (cdr v) s)))) 234 | ((equal? u v) s) 235 | (else #f))))) 236 | 237 | 238 | (define ext-s-check 239 | (lambda (x v s) 240 | (cond 241 | ((occurs-check x v s) #f) 242 | (else (ext-s x v s))))) 243 | 244 | 245 | (define occurs-check 246 | (lambda (x v s) 247 | (let ((v (walk v s))) 248 | (cond 249 | ((var? v) (eq? v x)) 250 | ((pair? v) 251 | (or 252 | (occurs-check x (car v) s) 253 | (occurs-check x (cdr v) s))) 254 | (else #f))))) 255 | 256 | 257 | (define walk* 258 | (lambda (w s) 259 | (let ((v (walk w s))) 260 | (cond 261 | ((var? v) v) 262 | ((pair? v) 263 | (cons 264 | (walk* (car v) s) 265 | (walk* (cdr v) s))) 266 | (else v))))) 267 | 268 | 269 | (define reify-s 270 | (lambda (v s) 271 | (debug 'reify-s "v: ~a\ns:~a" v s) 272 | (let ((v (walk v s))) 273 | (cond 274 | ((var? v) 275 | (ext-s v (reify-name (size-s s)) s)) 276 | ((pair? v) (reify-s (cdr v) 277 | (reify-s (car v) s))) 278 | (else s))))) 279 | 280 | 281 | (define reify-name 282 | (lambda (n) 283 | (string->symbol 284 | (string-append "_" "." (number->string n))))) 285 | 286 | 287 | (define reify 288 | (lambda (v s) 289 | (let ((v (walk* v s))) 290 | (walk* v (reify-s v empty-s))))) 291 | 292 | 293 | 294 | 295 | 296 | ;------------------------------------------------------------- 297 | ; data structures 298 | ;------------------------------------------------------------- 299 | 300 | (struct Pkg (subst constraints) #:transparent) 301 | 302 | 303 | ;; constraints save the current environment vars 304 | (struct Constraint (goal vars text) #:transparent) 305 | 306 | 307 | ;; environment 308 | (struct Env (unify constraints vars cvars) #:transparent) 309 | 310 | (define Env-constraint-goals 311 | (lambda (p) 312 | (map Constraint-goal (Env-constraint p)))) 313 | 314 | 315 | (define ext-pkg-constraints 316 | (lambda (p cs ctexts env) 317 | (let ([newc (map (lambda (g t) 318 | (Constraint g (Env-vars env) t)) 319 | cs ctexts)]) 320 | (Pkg (Pkg-subst p) (append newc (Pkg-constraints p)))))) 321 | 322 | 323 | 324 | ;; convenience functions 325 | (define change-unify 326 | (lambda (p u) 327 | (match p 328 | [(Env _ constraints vars cvars) 329 | (Env u constraints vars cvars)]))) 330 | 331 | 332 | (define change-constraints 333 | (lambda (p c) 334 | (match p 335 | [(Env unify _ vars cvars) 336 | (Env unify c vars cvars)]))) 337 | 338 | 339 | (define change-vars 340 | (lambda (p v) 341 | (match p 342 | [(Env unify constraints _ cvars) 343 | (Env unify constraints v cvars)]))) 344 | 345 | 346 | (define change-cvars 347 | (lambda (p cv) 348 | (match p 349 | [(Env unify constraints vars _) 350 | (Env unify constraints vars cv)]))) 351 | 352 | 353 | (define ext-constraint 354 | (lambda (env new-cg) 355 | (let ([newc (map (lambda (g) (Constraint g (Env-vars env) 'a)) 356 | new-cg)]) 357 | (change-constraints env newc)))) 358 | 359 | 360 | (define ext-vars 361 | (lambda (env new-vars) 362 | (change-vars env (append new-vars (Env-vars env))))) 363 | 364 | 365 | (define ext-cvars 366 | (lambda (env new-cvars) 367 | (change-cvars env (append new-cvars (Env-cvars env))))) 368 | 369 | 370 | 371 | 372 | 373 | 374 | ;------------------------------------------------------------- 375 | ; miniKanren 376 | ;------------------------------------------------------------- 377 | 378 | (define succeed (lambda (s env) (sunit s))) 379 | (define fail (lambda (s env) snull)) 380 | 381 | 382 | (define bind 383 | (lambda (s f env) 384 | (cond 385 | [(procedure? s) (lambda () (bind (s) f env))] 386 | [else 387 | (stream-merge (smap (lambda (s) (f s env)) s))]))) 388 | 389 | 390 | (define bind* 391 | (lambda (s goals env) 392 | (cond 393 | [(null? goals) 394 | (stream-merge 395 | (smap (lambda (s) 396 | (bind-constraints (sunit s) (Pkg-constraints s) env)) 397 | s))] 398 | [(snull? s) snull] 399 | [else (bind* (bind s (car goals) env) (cdr goals) env)]))) 400 | 401 | 402 | (define bind* 403 | (lambda (s goals env) 404 | (cond 405 | [(null? goals) s] 406 | [(snull? s) snull] 407 | [else (bind* (bind s (car goals) env) (cdr goals) env)]))) 408 | 409 | 410 | (define bind-constraints 411 | (lambda (s cs env) 412 | (cond 413 | [(null? cs) s] 414 | [(snull? s) snull] 415 | [else 416 | (debug 'bind-constraints 417 | "checking constraint: ~a" (Constraint-text (car cs))) 418 | (bind-constraints 419 | (bind s 420 | (Constraint-goal (car cs)) 421 | (Env (Env-unify env) 422 | '() ; no constraints 423 | (Env-vars env) 424 | (Constraint-vars (car cs)))) 425 | (cdr cs) 426 | env)]))) 427 | 428 | 429 | (define == 430 | (lambda (u v) 431 | (lambdag@ (s env) 432 | (let ((s1 ((Env-unify env) u v (Pkg-subst s) env))) 433 | (cond 434 | [(not s1) snull] 435 | [else (sunit (Pkg s1 (Pkg-constraints s)))]))))) 436 | 437 | 438 | (define == 439 | (lambda (u v) 440 | (lambdag@ (s env) 441 | (let ((s1 ((Env-unify env) u v (Pkg-subst s) env))) 442 | (cond 443 | [(not s1) snull] 444 | [else 445 | (let ([cc (bind-constraints (sunit (Pkg s1 '())) 446 | (Pkg-constraints s) env)]) 447 | (if (snull? cc) 448 | snull 449 | (sunit (Pkg s1 (filter (lambda (c) 450 | (not (tautology? c (Pkg-subst s)))) 451 | (Pkg-constraints s))))))]))))) 452 | 453 | 454 | (define ando 455 | (lambda goals 456 | (lambdag@ (s env) 457 | (bind* (sunit s) goals env)))) 458 | 459 | 460 | (define org2 461 | (lambda (goals) 462 | (lambdag@ (s env) 463 | (cond 464 | [(null? goals) snull] 465 | [else 466 | (scons (bind (sunit s) (car goals) env) 467 | ((org2 (cdr goals)) s env))])))) 468 | 469 | 470 | (define oro 471 | (lambda goals 472 | (lambdag@ (s env) 473 | (stream-merge ((org2 goals) s env))))) 474 | 475 | (define noto 476 | (lambda (g) 477 | (lambdag@ (s env) 478 | (let ([ans (defunc (g s (switch-unify env)))]) 479 | (if (snull? ans) 480 | (succeed s env) 481 | (fail s env)))))) 482 | 483 | 484 | (define-syntax exist 485 | (syntax-rules () 486 | ((_ (x ...) g0 g ...) 487 | (lambdag@ (s env) 488 | (inc 489 | (let ((x (var 'x)) ...) 490 | ((ando g0 g ...) s (ext-vars env (list x ...))))))))) 491 | 492 | 493 | (define-syntax forall 494 | (syntax-rules () 495 | ((_ (x ...) g0 g ...) 496 | (lambdag@ (s env) 497 | (inc 498 | (let ((x (var 'x)) ...) 499 | ((ando g0 g ...) 500 | (let loop ([ss (Pkg-subst s)] [vars (list x ...)]) 501 | (cond 502 | [(null? vars) ss] 503 | [else (loop (ext-s (car vars) (gensym) ss) (cdr vars))])) 504 | (ext-vars env (list x ...))))))))) 505 | 506 | 507 | (define-syntax conde 508 | (syntax-rules () 509 | ((_ (g0 g ...) (g1 g^ ...) ...) 510 | (lambdag@ (s env) 511 | (inc 512 | ((oro (ando g0 g ...) 513 | (ando g1 g^ ...) ...) s env)))))) 514 | 515 | 516 | (define-syntax condc 517 | (syntax-rules () 518 | ((_ (g0 g ...)) (ando g0 g ...)) 519 | ((_ (g0 g ...) g^ ...) 520 | (lambdag@ (s env) 521 | (inc 522 | ((oro (ando g0 g ...) 523 | (assert ((noto g0)) 524 | (condc g^ ...))) s env)))))) 525 | 526 | 527 | (define reify-constraint 528 | (lambda (s) 529 | (lambda (c) 530 | (let ((ct (Constraint-text c))) 531 | (cond 532 | [(pair? ct) 533 | (cons (car ct) 534 | (map (lambda (v) (walk* v (Pkg-subst s))) (cdr ct)))] 535 | [else ct]))))) 536 | 537 | 538 | (define format-constraints 539 | (lambda (s) 540 | (debug 'format-constraints "subst: ~a\nconstraints: ~a\n" 541 | (Pkg-subst s) 542 | (Pkg-constraints s)) 543 | (map (reify-constraint s) 544 | (filter (lambda (c) 545 | (not (tautology? c (Pkg-subst s)))) 546 | (Pkg-constraints s))))) 547 | 548 | 549 | (define-syntax run 550 | (syntax-rules () 551 | ((_ n (x) g0 g ...) 552 | (let ((x (var 'x))) 553 | (let ([ss ((ando g0 g ...) (Pkg empty-s '()) 554 | (Env unify-good '() (list x) '()))]) 555 | (taken n (smap (lambda (s) 556 | (let* ((x (walk* x (Pkg-subst s))) 557 | (rs (reify-s x empty-s))) 558 | (list 559 | (walk* x rs) 560 | (let ((ctext (walk* (format-constraints s) rs))) 561 | (if (null? ctext) 562 | '() 563 | (list 'constraints: ctext)))))) 564 | ss))))))) 565 | 566 | 567 | (define tautology? 568 | (lambda (c s) 569 | (debug 'tautology? 570 | "constraint: ~a\nvars: ~a\nsubst:~a\n" 571 | (Constraint-text c) 572 | (Constraint-vars c) 573 | s) 574 | (not (snull? 575 | (defunc ((Constraint-goal c) 576 | (Pkg s '()) 577 | (Env unify-evil '() '() (Constraint-vars c)))))))) 578 | 579 | 580 | (define-syntax run* 581 | (syntax-rules () 582 | ((_ (x) g ...) (run #f (x) g ...)))) 583 | 584 | 585 | (define-syntax make-text 586 | (syntax-rules (quote quasiquote) 587 | ((_ (quote a)) (quote a)) 588 | ((_ (quasiquote a)) (quasiquote a)) 589 | ((_ (g a0 ...)) (list 'g (make-text a0) ...)) 590 | ((_ a) a))) 591 | 592 | 593 | (define-syntax make-text* 594 | (syntax-rules (quote quasiquote) 595 | ((_) '()) 596 | ((_ (quote a)) (quote a)) 597 | ((_ (quasiquote a)) (quasiquote a)) 598 | ((_ (g0 a ...) g ...) 599 | (list (make-text (g0 a ...)) (make-text g) ...)) 600 | ((_ a) 'a))) 601 | 602 | 603 | ;; (make-text* `b) 604 | ;; (make-text* (noto (== `(,a ,d) (cons u v))) (noto (appendo a b c))) 605 | ;; (define a 1) 606 | ;; (define b 2) 607 | ;; (define c 3) 608 | ;; (define d 4) 609 | ;; (define u 5) 610 | ;; (define v 6) 611 | ;; (make-text* (a b c) `(,c a)) 612 | ;; (define q 10) 613 | ; (make-text* (noto (== q 3))) 614 | 615 | 616 | (define-syntax assert 617 | (syntax-rules () 618 | ((_ (c0 c ...) g ...) 619 | (lambdag@ (s env) 620 | (inc 621 | ((ando g ...) 622 | (ext-pkg-constraints s (list c0 c ...) (make-text* c0 c ...) env) 623 | (ext-constraint env (list c0 c ...)))))))) 624 | 625 | 626 | (define-syntax conda 627 | (syntax-rules () 628 | ((_ (g0 g ...) (g1 g^ ...) ...) 629 | (lambdag@ (s) 630 | (inc 631 | (ifa ((g0 s) g ...) 632 | ((g1 s) g^ ...) ...)))))) 633 | 634 | 635 | (define-syntax ifa 636 | (syntax-rules () 637 | ((_) snull) 638 | ((_ (e g ...) b ...) 639 | (cond 640 | [(snull? (defunc e)) (ifa b ...)] 641 | [else (bind* e (list g ...))])))) 642 | 643 | 644 | (define-syntax condu 645 | (syntax-rules () 646 | ((_ (g0 g ...) (g1 g^ ...) ...) 647 | (lambdag@ (s) 648 | (inc 649 | (ifu ((g0 s) g ...) 650 | ((g1 s) g^ ...) ...)))))) 651 | 652 | 653 | (define-syntax ifu 654 | (syntax-rules () 655 | ((_) snull) 656 | ((_ (e g ...) b ...) 657 | (cond 658 | [(snull? (defunc e)) (ifa b ...)] 659 | [else (bind* (sunit (scar e)) (list g ...))])))) 660 | 661 | 662 | (define-syntax project 663 | (syntax-rules () 664 | ((_ (x ...) g g* ...) 665 | (lambdag@ (s env) 666 | (let ((x (walk* x s)) ...) 667 | ((exist () g g* ...) s env)))))) 668 | 669 | 670 | 671 | (define prints 672 | (lambda (s env) 673 | (begin 674 | (printf "#[prints]:: ~s\n" s) 675 | (succeed s env)))) 676 | 677 | 678 | (define print-env 679 | (lambdag@ (s env) 680 | (begin 681 | (printf "env: ~s\n" env) 682 | (succeed s env)))) 683 | 684 | 685 | (define print-var 686 | (lambda (name v) 687 | (lambda (s env) 688 | (begin 689 | (printf "#[print-var] ~a = ~s\n" name (walk v s)) 690 | (succeed s env))))) 691 | 692 | 693 | (define-syntax print-var 694 | (syntax-rules () 695 | ((_ v) (lambda (s env) 696 | (begin 697 | (printf "#[print-var] ~a = ~s\n" 'v (walk* v (Pkg-subst s))) 698 | (succeed s env)))))) 699 | 700 | 701 | (define print-constraintso 702 | (lambda (s env) 703 | (printf "#[constraints] \n~a\n" 704 | (map (lambda (s) (format "~a\n" s)) 705 | (map (reify-constraint s) (Pkg-constraints s)))) 706 | (succeed s env))) 707 | 708 | 709 | 710 | 711 | 712 | ;------------------------------------------------------------- 713 | ; basic definitions (from TRS) 714 | ;------------------------------------------------------------- 715 | 716 | (define caro 717 | (lambda (p a) 718 | (exist (d) 719 | (== (cons a d) p)))) 720 | 721 | 722 | (define cdro 723 | (lambda (p d) 724 | (exist (a) 725 | (== (cons a d) p)))) 726 | 727 | 728 | (define conso 729 | (lambda (a d p) 730 | (== (cons a d) p))) 731 | 732 | 733 | (define nullo 734 | (lambda (x) 735 | (== '() x))) 736 | 737 | 738 | (define eqo 739 | (lambda (x y) 740 | (== x y))) 741 | 742 | 743 | (define pairo 744 | (lambda (p) 745 | (exist (a d) 746 | (conso a d p)))) 747 | 748 | 749 | (define nullo 750 | (lambda (x) 751 | (== '() x))) 752 | 753 | 754 | 755 | 756 | ;------------------------------------------------------------- 757 | ; rembero (TRS frame 30) 758 | ;------------------------------------------------------------- 759 | 760 | ;; using conde operator 761 | (define rembero1 762 | (lambda (x l out) 763 | (conde 764 | ((nullo l) (== '() out)) 765 | ((caro l x) (cdro l out)) 766 | ((exist (res) 767 | (exist (d) 768 | (cdro l d) 769 | (rembero1 x d res)) 770 | (exist (a) 771 | (caro l a) 772 | (conso a res out))))))) 773 | 774 | 775 | ;; example 776 | (run* (out) 777 | (exist (y) 778 | (rembero1 y `(a b ,y d peas e) out))) 779 | 780 | 781 | ;; We got 7 answers, 4 of which shouldn't happen, because 782 | ;; the fresh variable y should never fail to remove itself 783 | ;; and thus go on to remove d, peas and e. 784 | 785 | ;; => 786 | ;; (((b a d peas e) ()) ; y == a 787 | ;; ((a b d peas e) ()) ; y == b 788 | ;; ((a b d peas e) ()) ; y == y 789 | ;; ((a b d peas e) ()) ; unreasonable beyond this point 790 | ;; ((a b peas d e) ()) 791 | ;; ((a b e d peas) ()) 792 | ;; ((a b _.0 d peas e) ())) 793 | 794 | 795 | 796 | ;; using condc operator 797 | (define rembero 798 | (lambda (x l out) 799 | (condc 800 | ((nullo l) (== '() out)) 801 | ((caro l x) (cdro l out)) 802 | ((exist (res) 803 | (exist (d) 804 | (cdro l d) 805 | (rembero x d res)) 806 | (exist (a) 807 | (caro l a) 808 | (conso a res out))))))) 809 | 810 | 811 | ;; example 812 | (run* (out) 813 | (exist (y) 814 | (rembero y `(a b ,y d peas e) out))) 815 | 816 | 817 | ;; We got only 3 answers, plus two constraints for the third 818 | ;; answer. The constraints are basically saying: If we are 819 | ;; to have this answer, neither (caro (b y d peas e) y) nor 820 | ;; (caro (a b y d peas e) y) should hold. 821 | 822 | ;; => 823 | ;; (((b a d peas e) ()) 824 | ;; ((a b d peas e) ()) 825 | ;; ((a b d peas e) 826 | ;; (constraints: 827 | ;; ((noto (caro (b #1(y) d peas e) #1(y))) 828 | ;; (noto (caro (a b #1(y) d peas e) #1(y))))))) 829 | 830 | 831 | 832 | 833 | 834 | ;------------------------------------------------------------- 835 | ; Oleg's comments (Jul 23) 836 | ;------------------------------------------------------------- 837 | 838 | (run 5 (out) 839 | (exist (y l r) 840 | (== out (list y l r)) 841 | (rembero y l r))) 842 | 843 | ;; => 844 | ;; '(((_.0 () ()) ()) 845 | ;; ((_.0 (_.0 . _.1) _.1) ()) 846 | ;; ((_.0 (_.1) (_.1)) 847 | ;; (constraints: ((noto (caro (_.1) _.0))))) 848 | ;; ((_.0 (_.1 _.0 . _.2) (_.1 . _.2)) 849 | ;; (constraints: ((noto (caro (_.1 _.0 . _.2) _.0))))) 850 | ;; ((_.0 (_.1 _.2) (_.1 _.2)) 851 | ;; (constraints: ((noto (caro (_.2) _.0)) 852 | ;; (noto (caro (_.1 _.2) _.0)))))) 853 | 854 | 855 | ;; Here, the constraints are really part of the answer: the answer 856 | ;; (_.0 (_.1) (_.1)) does not make sense without the constraint that 857 | ;; _.0 must be different from _.1. The easy way to see that (_.0 (_.1) 858 | ;; (_.1)) is not an answer is to instantiate both variables to 1: 859 | 860 | (run 5 (out) 861 | (exist (y l r) 862 | (== out '(1 (1) (1))) 863 | (== out (list y l r)) 864 | (rembero y l r))) 865 | 866 | 867 | ;; produces (). Thus constraints must be, in general, part of the 868 | ;; answer. Hence what I said about the need to normalize constraints 869 | ;; applies. Here is the simple example where constraint normalization 870 | ;; may help: 871 | 872 | (run* (out) 873 | (exist (x y) 874 | (== out (list x y)) 875 | (condc 876 | ((caro (list x) y)) 877 | ((caro (list y) x)) 878 | ((caro (list y) 1)) 879 | ((caro (list x) 1))))) 880 | 881 | ;; => 882 | ;; '(((_.0 _.0) ()) 883 | ;; ((_.0 1) 884 | ;; (constraints: 885 | ;; ((noto (caro (list 1) _.0)) 886 | ;; (noto (caro (list _.0) 1))))) 887 | ;; ((1 _.0) 888 | ;; (constraints: 889 | ;; ((noto (caro (list _.0) 1)) 890 | ;; (noto (caro (list _.0) 1)) 891 | ;; (noto (caro (list 1) _.0)))))) 892 | 893 | 894 | ;; The three constraints in the last answer are identical, aren't they? 895 | 896 | ;; Here is why we need a genuine constraint solver. 897 | 898 | ; num predicate 899 | (define (num x) 900 | (conde 901 | ((== x '())) 902 | ((exist (y) 903 | (== x (cons 1 y)) 904 | (num y))))) 905 | 906 | (run 5 (out) (num out)) 907 | 908 | 909 | ; greater-than on num 910 | (define (gt x y) 911 | (conde 912 | ((== y '()) (pairo x)) 913 | ((exist (x1 y1) 914 | (== x (cons 1 x1)) 915 | (== y (cons 1 y1)) 916 | (gt x1 y1))))) 917 | 918 | (run* (out) (gt '(1 1 1 1) out)) 919 | 920 | 921 | ;; (run 1 (out) 922 | ;; (exist (x y) 923 | ;; (condc 924 | ;; ((gt x y) fail) 925 | ;; ((gt x (cons 1 y)) 926 | ;; (num x) (num y) (== out 'really?))))) 927 | 928 | ;; => diverges 929 | 930 | ;; rewritten this way 931 | ;; (run 1 (out) 932 | ;; (exist (x y) 933 | ;; (== out (list x y)) 934 | ;; (num x) (num y) 935 | ;; (condc 936 | ;; ((gt x y) fail) 937 | ;; ((gt x (cons 1 y)))))) 938 | 939 | 940 | ;; The genuine constraint solver for naturals would have determined 941 | ;; that if NOT(x > y) then x > y+1 cannot succeed. The CLP system will 942 | ;; return the finite failure. This is the fundamental difference 943 | ;; between CLP and ordinary Prolog: Prolog is based on `generate and 944 | ;; test', whereas CLP do `test and then generate'. They solve 945 | ;; constraints using uninstantiated variables; they instantiate 946 | ;; afterwards. 947 | 948 | ;; Incidentally, your noto does not play well will committed choice 949 | ;; like condu and conda, which is expected (one has to be very careful 950 | ;; nesting of condu and conda). There is an easy way to make condu and 951 | ;; conda sound (at least, reporting a run-time error when attempting 952 | ;; to instantiate a non-local variable). The best way to solve this 953 | ;; problems is with mode inference (as Mercury or Twelf do). 954 | 955 | ;; Incidentally, the mini-Kanren is based on lazy lists (on streams). 956 | ;; The monad of mini-Kanren is 957 | 958 | ;; data L a = Zero | One a | Cons a (() -> L a) 959 | 960 | ;; which is the ordinary lazy list with the special case for 961 | ;; one-element list. 962 | 963 | ;; Cheers, 964 | ;; Oleg 965 | 966 | -------------------------------------------------------------------------------- /mut-y.ss: -------------------------------------------------------------------------------- 1 | ;; deriving a "Y combinator" for mutual recursion 2 | 3 | 4 | (define even 5 | (lambda (x) 6 | (cond 7 | [(zero? x) #t] 8 | [(= 1 x) #f] 9 | [else (odd (sub1 x))]))) 10 | 11 | 12 | (define odd 13 | (lambda (x) 14 | (cond 15 | [(zero? x) #f] 16 | [(= 1 x) #t] 17 | [else (even (sub1 x))]))) 18 | 19 | 20 | 21 | ;; Step 1: package up functions, make a copy, create a cycle 22 | (let ([p ((lambda (eo) 23 | (cons 24 | (lambda (x) ; even 25 | (cond 26 | [(zero? x) #t] 27 | [(= 1 x) #f] 28 | [else ((cdr (eo eo)) (sub1 x))])) ; (cdr (eo eo)) is odd 29 | (lambda (x) ; odd 30 | (cond 31 | [(zero? x) #f] 32 | [(= 1 x) #t] 33 | [else ((car (eo eo)) (sub1 x))])))) ; (car (eo eo)) is even 34 | 35 | (lambda (eo) ; identical copy 36 | (cons 37 | (lambda (x) 38 | (cond 39 | [(zero? x) #t] 40 | [(= 1 x) #f] 41 | [else ((cdr (eo eo)) (sub1 x))])) 42 | (lambda (x) 43 | (cond 44 | [(zero? x) #f] 45 | [(= 1 x) #t] 46 | [else ((car (eo eo)) (sub1 x))])))))]) 47 | (let ([even (car p)] 48 | [odd (cdr p)]) 49 | (even 21))) 50 | 51 | 52 | 53 | ;; Step 2: extract the outer self-application pattern 54 | (let ([p ((lambda (x) (x x)) 55 | (lambda (eo) 56 | (cons 57 | (lambda (x) 58 | (cond 59 | [(zero? x) #t] 60 | [(= 1 x) #f] 61 | [else ((cdr (eo eo)) (sub1 x))])) 62 | (lambda (x) 63 | (cond 64 | [(zero? x) #f] 65 | [(= 1 x) #t] 66 | [else ((car (eo eo)) (sub1 x))])))))]) 67 | (let ([even (car p)] 68 | [odd (cdr p)]) 69 | (even 22))) 70 | 71 | 72 | 73 | ;; Step 3: extract inner self-application pattern 74 | (let ([p ((lambda (x) (x x)) 75 | (lambda (eo) 76 | (cons 77 | (lambda (x) 78 | ((lambda (y) 79 | (cond 80 | [(zero? x) #t] 81 | [(= 1 x) #f] 82 | [else ((cdr y) (sub1 x))])) 83 | (eo eo))) 84 | (lambda (x) 85 | ((lambda (y) 86 | (cond 87 | [(zero? x) #f] 88 | [(= 1 x) #t] 89 | [else ((car y) (sub1 x))])) 90 | (eo eo))))))]) 91 | (let ([even (car p)] 92 | [odd (cdr p)]) 93 | (even 22))) 94 | 95 | 96 | ;; Oh no. The nice form of Y combinator doesn't seem to show up in 97 | ;; mutual recursion! Backtrack to Step 2 would be good enough. 98 | -------------------------------------------------------------------------------- /pmatch.scm: -------------------------------------------------------------------------------- 1 | ;;; Code written by Oleg Kiselyov 2 | ;; (http://pobox.com/~oleg/ftp/) 3 | ;;; 4 | ;;; Taken from leanTAP.scm 5 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 6 | 7 | ; A simple linear pattern matcher 8 | ; It is efficient (generates code at macro-expansion time) and simple: 9 | ; it should work on any R5RS Scheme system. 10 | 11 | ; (pmatch exp ...[]) 12 | ; ::= ( exp ...) 13 | ; ::= (else exp ...) 14 | ; ::= boolean exp | () 15 | ; :: = 16 | ; ,var -- matches always and binds the var 17 | ; pattern must be linear! No check is done 18 | ; _ -- matches always 19 | ; 'exp -- comparison with exp (using equal?) 20 | ; exp -- comparison with exp (using equal?) 21 | ; ( ...) -- matches the list of patterns 22 | ; ( . ) -- ditto 23 | ; () -- matches the empty list 24 | 25 | (define-syntax pmatch 26 | (syntax-rules (else guard) 27 | ((_ (rator rand ...) cs ...) 28 | (let ((v (rator rand ...))) 29 | (pmatch v cs ...))) 30 | ((_ v) (error 'pmatch "failed: ~s" v)) 31 | ((_ v (else e0 e ...)) (begin e0 e ...)) 32 | ((_ v (pat (guard g ...) e0 e ...) cs ...) 33 | (let ((fk (lambda () (pmatch v cs ...)))) 34 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 35 | ((_ v (pat e0 e ...) cs ...) 36 | (let ((fk (lambda () (pmatch v cs ...)))) 37 | (ppat v pat (begin e0 e ...) (fk)))))) 38 | 39 | (define-syntax ppat 40 | (syntax-rules (_ quote unquote) 41 | ((_ v _ kt kf) kt) 42 | ((_ v () kt kf) (if (null? v) kt kf)) 43 | ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 44 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 45 | ((_ v (x . y) kt kf) 46 | (if (pair? v) 47 | (let ((vx (car v)) (vy (cdr v))) 48 | (ppat vx x (ppat vy y kt kf) kf)) 49 | kf)) 50 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 51 | --------------------------------------------------------------------------------