├── README.md ├── mk.scm ├── mkdefs.scm └── mktests.scm /README.md: -------------------------------------------------------------------------------- 1 | simple-miniKanren 2 | ================= 3 | 4 | Simple miniKanren, with only ==, fresh, and conde. 5 | A good starting point for exploratory hacking. 6 | 7 | This is essentially a modernized, cleaned up version of the 8 | implementation in The Reasoned Schemer. -------------------------------------------------------------------------------- /mk.scm: -------------------------------------------------------------------------------- 1 | ;;; This file was generated by writeminikanren.pl 2 | ;;; Generated at 2007-10-25 15:24:42 3 | 4 | (define-syntax lambdag@ 5 | (syntax-rules () 6 | ((_ (p) e) (lambda (p) e)))) 7 | 8 | (define-syntax lambdaf@ 9 | (syntax-rules () 10 | ((_ () e) (lambda () e)))) 11 | 12 | (define-syntax run* 13 | (syntax-rules () 14 | ((_ (x) g ...) (run #f (x) g ...)))) 15 | 16 | (define-syntax rhs 17 | (syntax-rules () 18 | ((_ x) (cdr x)))) 19 | 20 | (define-syntax lhs 21 | (syntax-rules () 22 | ((_ x) (car x)))) 23 | 24 | (define-syntax size-s 25 | (syntax-rules () 26 | ((_ x) (length x)))) 27 | 28 | (define-syntax var 29 | (syntax-rules () 30 | ((_ x) (vector x)))) 31 | 32 | (define-syntax var? 33 | (syntax-rules () 34 | ((_ x) (vector? x)))) 35 | 36 | (define empty-s '()) 37 | 38 | (define walk 39 | (lambda (u S) 40 | (cond 41 | ((and (var? u) (assq u S)) => 42 | (lambda (pr) (walk (rhs pr) S))) 43 | (else u)))) 44 | 45 | (define ext-s 46 | (lambda (x v s) 47 | (cons `(,x . ,v) s))) 48 | 49 | (define unify 50 | (lambda (u v s) 51 | (let ((u (walk u s)) 52 | (v (walk v s))) 53 | (cond 54 | ((eq? u v) s) 55 | ((var? u) (ext-s-check u v s)) 56 | ((var? v) (ext-s-check v u s)) 57 | ((and (pair? u) (pair? v)) 58 | (let ((s (unify 59 | (car u) (car v) s))) 60 | (and s (unify 61 | (cdr u) (cdr v) s)))) 62 | ((equal? u v) s) 63 | (else #f))))) 64 | 65 | (define ext-s-check 66 | (lambda (x v s) 67 | (cond 68 | ((occurs-check x v s) #f) 69 | (else (ext-s x v s))))) 70 | 71 | (define occurs-check 72 | (lambda (x v s) 73 | (let ((v (walk v s))) 74 | (cond 75 | ((var? v) (eq? v x)) 76 | ((pair? v) 77 | (or 78 | (occurs-check x (car v) s) 79 | (occurs-check x (cdr v) s))) 80 | (else #f))))) 81 | 82 | (define walk* 83 | (lambda (w s) 84 | (let ((v (walk w s))) 85 | (cond 86 | ((var? v) v) 87 | ((pair? v) 88 | (cons 89 | (walk* (car v) s) 90 | (walk* (cdr v) s))) 91 | (else v))))) 92 | 93 | (define reify-s 94 | (lambda (v s) 95 | (let ((v (walk v s))) 96 | (cond 97 | ((var? v) 98 | (ext-s v (reify-name (size-s s)) s)) 99 | ((pair? v) (reify-s (cdr v) 100 | (reify-s (car v) s))) 101 | (else s))))) 102 | 103 | (define reify-name 104 | (lambda (n) 105 | (string->symbol 106 | (string-append "_" "." (number->string n))))) 107 | 108 | (define reify 109 | (lambda (v s) 110 | (let ((v (walk* v s))) 111 | (walk* v (reify-s v empty-s))))) 112 | 113 | (define-syntax mzero 114 | (syntax-rules () ((_) #f))) 115 | 116 | (define-syntax inc 117 | (syntax-rules () ((_ e) (lambdaf@ () e)))) 118 | 119 | (define-syntax unit 120 | (syntax-rules () ((_ a) a))) 121 | 122 | (define-syntax choice 123 | (syntax-rules () ((_ a f) (cons a f)))) 124 | 125 | (define-syntax case-inf 126 | (syntax-rules () 127 | ((_ e (() e0) ((f^) e1) ((a^) e2) ((a f) e3)) 128 | (let ((a-inf e)) 129 | (cond 130 | ((not a-inf) e0) 131 | ((procedure? a-inf) (let ((f^ a-inf)) e1)) 132 | ((not (and (pair? a-inf) 133 | (procedure? (cdr a-inf)))) 134 | (let ((a^ a-inf)) e2)) 135 | (else (let ((a (car a-inf)) (f (cdr a-inf))) 136 | e3))))))) 137 | 138 | (define-syntax run 139 | (syntax-rules () 140 | ((_ n (x) g0 g ...) 141 | (take n 142 | (lambdaf@ () 143 | ((fresh (x) g0 g ... 144 | (lambdag@ (s) 145 | (cons (reify x s) '()))) 146 | empty-s)))))) 147 | 148 | (define take 149 | (lambda (n f) 150 | (if (and n (zero? n)) 151 | '() 152 | (case-inf (f) 153 | (() '()) 154 | ((f) (take n f)) 155 | ((a) a) 156 | ((a f) 157 | (cons (car a) 158 | (take (and n (- n 1)) f))))))) 159 | 160 | (define == 161 | (lambda (u v) 162 | (lambdag@ (s) 163 | (unify u v s)))) 164 | 165 | (define-syntax fresh 166 | (syntax-rules () 167 | ((_ (x ...) g0 g ...) 168 | (lambdag@ (s) 169 | (inc 170 | (let ((x (var 'x)) ...) 171 | (bind* (g0 s) g ...))))))) 172 | 173 | (define-syntax bind* 174 | (syntax-rules () 175 | ((_ e) e) 176 | ((_ e g0 g ...) (bind* (bind e g0) g ...)))) 177 | 178 | (define bind 179 | (lambda (a-inf g) 180 | (case-inf a-inf 181 | (() (mzero)) 182 | ((f) (inc (bind (f) g))) 183 | ((a) (g a)) 184 | ((a f) (mplus (g a) (lambdaf@ () (bind (f) g))))))) 185 | 186 | (define-syntax conde 187 | (syntax-rules () 188 | ((_ (g0 g ...) (g1 g^ ...) ...) 189 | (lambdag@ (s) 190 | (inc 191 | (mplus* 192 | (bind* (g0 s) g ...) 193 | (bind* (g1 s) g^ ...) ...)))))) 194 | 195 | (define-syntax mplus* 196 | (syntax-rules () 197 | ((_ e) e) 198 | ((_ e0 e ...) (mplus e0 199 | (lambdaf@ () (mplus* e ...)))))) 200 | 201 | (define mplus 202 | (lambda (a-inf f) 203 | (case-inf a-inf 204 | (() (f)) 205 | ((f^) (inc (mplus (f) f^))) 206 | ((a) (choice a f)) 207 | ((a f^) (choice a (lambdaf@ () (mplus (f) f^))))))) 208 | 209 | (define-syntax conda 210 | (syntax-rules () 211 | ((_ (g0 g ...) (g1 g^ ...) ...) 212 | (lambdag@ (s) 213 | (inc 214 | (ifa ((g0 s) g ...) 215 | ((g1 s) g^ ...) ...)))))) 216 | 217 | (define-syntax ifa 218 | (syntax-rules () 219 | ((_) (mzero)) 220 | ((_ (e g ...) b ...) 221 | (let loop ((a-inf e)) 222 | (case-inf a-inf 223 | (() (ifa b ...)) 224 | ((f) (inc (loop (f)))) 225 | ((a) (bind* a-inf g ...)) 226 | ((a f) (bind* a-inf g ...))))))) 227 | 228 | (define-syntax condu 229 | (syntax-rules () 230 | ((_ (g0 g ...) (g1 g^ ...) ...) 231 | (lambdag@ (s) 232 | (inc 233 | (ifu ((g0 s) g ...) 234 | ((g1 s) g^ ...) ...)))))) 235 | 236 | (define-syntax ifu 237 | (syntax-rules () 238 | ((_) (mzero)) 239 | ((_ (e g ...) b ...) 240 | (let loop ((a-inf e)) 241 | (case-inf a-inf 242 | (() (ifu b ...)) 243 | ((f) (inc (loop (f)))) 244 | ((a) (bind* a-inf g ...)) 245 | ((a f) (bind* (unit a) g ...))))))) 246 | 247 | (define-syntax project 248 | (syntax-rules () 249 | ((_ (x ...) g g* ...) 250 | (lambdag@ (s) 251 | (let ((x (walk* x s)) ...) 252 | ((fresh () g g* ...) s)))))) 253 | 254 | (define succeed (== #f #f)) 255 | 256 | (define fail (== #f #t)) 257 | 258 | (define onceo 259 | (lambda (g) 260 | (condu 261 | (g succeed) 262 | ((== #f #f) fail)))) 263 | -------------------------------------------------------------------------------- /mkdefs.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | 3 | (define-syntax run1 (syntax-rules () ((_ (x) g0 g ...) (run 1 (x) g0 g ...)))) 4 | (define-syntax run2 (syntax-rules () ((_ (x) g0 g ...) (run 2 (x) g0 g ...)))) 5 | (define-syntax run3 (syntax-rules () ((_ (x) g0 g ...) (run 3 (x) g0 g ...)))) 6 | (define-syntax run4 (syntax-rules () ((_ (x) g0 g ...) (run 4 (x) g0 g ...)))) 7 | (define-syntax run5 (syntax-rules () ((_ (x) g0 g ...) (run 5 (x) g0 g ...)))) 8 | (define-syntax run6 (syntax-rules () ((_ (x) g0 g ...) (run 6 (x) g0 g ...)))) 9 | (define-syntax run7 (syntax-rules () ((_ (x) g0 g ...) (run 7 (x) g0 g ...)))) 10 | (define-syntax run8 (syntax-rules () ((_ (x) g0 g ...) (run 8 (x) g0 g ...)))) 11 | (define-syntax run9 (syntax-rules () ((_ (x) g0 g ...) (run 9 (x) g0 g ...)))) 12 | (define-syntax run10 (syntax-rules () ((_ (x) g0 g ...) (run 10 (x) g0 g ...)))) 13 | 14 | (define-syntax run11 (syntax-rules () ((_ (x) g0 g ...) (run 11 (x) g0 g ...)))) 15 | (define-syntax run12 (syntax-rules () ((_ (x) g0 g ...) (run 12 (x) g0 g ...)))) 16 | (define-syntax run13 (syntax-rules () ((_ (x) g0 g ...) (run 13 (x) g0 g ...)))) 17 | (define-syntax run14 (syntax-rules () ((_ (x) g0 g ...) (run 14 (x) g0 g ...)))) 18 | (define-syntax run15 (syntax-rules () ((_ (x) g0 g ...) (run 15 (x) g0 g ...)))) 19 | (define-syntax run16 (syntax-rules () ((_ (x) g0 g ...) (run 16 (x) g0 g ...)))) 20 | (define-syntax run17 (syntax-rules () ((_ (x) g0 g ...) (run 17 (x) g0 g ...)))) 21 | (define-syntax run18 (syntax-rules () ((_ (x) g0 g ...) (run 18 (x) g0 g ...)))) 22 | (define-syntax run19 (syntax-rules () ((_ (x) g0 g ...) (run 19 (x) g0 g ...)))) 23 | (define-syntax run20 (syntax-rules () ((_ (x) g0 g ...) (run 20 (x) g0 g ...)))) 24 | 25 | (define-syntax run21 (syntax-rules () ((_ (x) g0 g ...) (run 21 (x) g0 g ...)))) 26 | (define-syntax run22 (syntax-rules () ((_ (x) g0 g ...) (run 22 (x) g0 g ...)))) 27 | (define-syntax run23 (syntax-rules () ((_ (x) g0 g ...) (run 23 (x) g0 g ...)))) 28 | (define-syntax run24 (syntax-rules () ((_ (x) g0 g ...) (run 24 (x) g0 g ...)))) 29 | (define-syntax run25 (syntax-rules () ((_ (x) g0 g ...) (run 25 (x) g0 g ...)))) 30 | (define-syntax run26 (syntax-rules () ((_ (x) g0 g ...) (run 26 (x) g0 g ...)))) 31 | (define-syntax run27 (syntax-rules () ((_ (x) g0 g ...) (run 27 (x) g0 g ...)))) 32 | (define-syntax run28 (syntax-rules () ((_ (x) g0 g ...) (run 28 (x) g0 g ...)))) 33 | (define-syntax run29 (syntax-rules () ((_ (x) g0 g ...) (run 29 (x) g0 g ...)))) 34 | (define-syntax run30 (syntax-rules () ((_ (x) g0 g ...) (run 30 (x) g0 g ...)))) 35 | 36 | (define-syntax run31 (syntax-rules () ((_ (x) g0 g ...) (run 31 (x) g0 g ...)))) 37 | (define-syntax run32 (syntax-rules () ((_ (x) g0 g ...) (run 32 (x) g0 g ...)))) 38 | (define-syntax run33 (syntax-rules () ((_ (x) g0 g ...) (run 33 (x) g0 g ...)))) 39 | (define-syntax run34 (syntax-rules () ((_ (x) g0 g ...) (run 34 (x) g0 g ...)))) 40 | (define-syntax run35 (syntax-rules () ((_ (x) g0 g ...) (run 35 (x) g0 g ...)))) 41 | (define-syntax run36 (syntax-rules () ((_ (x) g0 g ...) (run 36 (x) g0 g ...)))) 42 | (define-syntax run37 (syntax-rules () ((_ (x) g0 g ...) (run 37 (x) g0 g ...)))) 43 | (define-syntax run38 (syntax-rules () ((_ (x) g0 g ...) (run 38 (x) g0 g ...)))) 44 | (define-syntax run39 (syntax-rules () ((_ (x) g0 g ...) (run 39 (x) g0 g ...)))) 45 | (define-syntax run40 (syntax-rules () ((_ (x) g0 g ...) (run 40 (x) g0 g ...)))) 46 | 47 | (define caro 48 | (lambda (p a) 49 | (fresh (d) 50 | (== (cons a d) p)))) 51 | 52 | (define cdro 53 | (lambda (p d) 54 | (fresh (a) 55 | (== (cons a d) p)))) 56 | 57 | (define conso 58 | (lambda (a d p) 59 | (== (cons a d) p))) 60 | 61 | (define nullo 62 | (lambda (x) 63 | (== '() x))) 64 | 65 | (define eqo 66 | (lambda (x y) 67 | (== x y))) 68 | 69 | (define pairo 70 | (lambda (p) 71 | (fresh (a d) 72 | (conso a d p)))) 73 | 74 | (define membero 75 | (lambda (x l) 76 | (conde 77 | ((fresh (a) 78 | (caro l a) 79 | (== a x))) 80 | ((fresh (d) 81 | (cdro l d) 82 | (membero x d)))))) 83 | 84 | (define rembero 85 | (lambda (x l out) 86 | (conde 87 | ((nullo l) (== '() out)) 88 | ((caro l x) (cdro l out)) 89 | ((fresh (a d res) 90 | (conso a d l) 91 | (rembero x d res) 92 | (conso a res out)))))) 93 | 94 | (define appendo 95 | (lambda (l s out) 96 | (conde 97 | ((nullo l) (== s out)) 98 | ((fresh (a d res) 99 | (conso a d l) 100 | (conso a res out) 101 | (appendo d s res)))))) 102 | 103 | (define flatteno 104 | (lambda (s out) 105 | (conde 106 | ((nullo s) (== '() out)) 107 | ((pairo s) 108 | (fresh (a d res-a res-d) 109 | (conso a d s) 110 | (flatteno a res-a) 111 | (flatteno d res-d) 112 | (appendo res-a res-d out))) 113 | ((conso s '() out))))) 114 | 115 | (define anyo 116 | (lambda (g) 117 | (conde 118 | (g) 119 | ((anyo g))))) 120 | 121 | (define nevero (anyo fail)) 122 | (define alwayso (anyo succeed)) 123 | 124 | 125 | 126 | (define build-num 127 | (lambda (n) 128 | (cond 129 | ((odd? n) 130 | (cons 1 131 | (build-num (quotient (- n 1) 2)))) 132 | ((and (not (zero? n)) (even? n)) 133 | (cons 0 134 | (build-num (quotient n 2)))) 135 | ((zero? n) '())))) 136 | 137 | (define poso 138 | (lambda (n) 139 | (fresh (a d) 140 | (== `(,a . ,d) n)))) 141 | 142 | (define >1o 143 | (lambda (n) 144 | (fresh (a ad dd) 145 | (== `(,a ,ad . ,dd) n)))) 146 | 147 | (define full-addero 148 | (lambda (b x y r c) 149 | (conde 150 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 151 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 152 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 153 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 154 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 155 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 156 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 157 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c))))) 158 | 159 | (define addero 160 | (lambda (d n m r) 161 | (conde 162 | ((== 0 d) (== '() m) (== n r)) 163 | ((== 0 d) (== '() n) (== m r) 164 | (poso m)) 165 | ((== 1 d) (== '() m) 166 | (addero 0 n '(1) r)) 167 | ((== 1 d) (== '() n) (poso m) 168 | (addero 0 '(1) m r)) 169 | ((== '(1) n) (== '(1) m) 170 | (fresh (a c) 171 | (== `(,a ,c) r) 172 | (full-addero d 1 1 a c))) 173 | ((== '(1) n) (gen-addero d n m r)) 174 | ((== '(1) m) (>1o n) (>1o r) 175 | (addero d '(1) n r)) 176 | ((>1o n) (gen-addero d n m r))))) 177 | 178 | (define gen-addero 179 | (lambda (d n m r) 180 | (fresh (a b c e x y z) 181 | (== `(,a . ,x) n) 182 | (== `(,b . ,y) m) (poso y) 183 | (== `(,c . ,z) r) (poso z) 184 | (full-addero d a b c e) 185 | (addero e x y z)))) 186 | 187 | (define pluso 188 | (lambda (n m k) 189 | (addero 0 n m k))) 190 | 191 | (define minuso 192 | (lambda (n m k) 193 | (pluso m k n))) 194 | 195 | (define *o 196 | (lambda (n m p) 197 | (conde 198 | ((== '() n) (== '() p)) 199 | ((poso n) (== '() m) (== '() p)) 200 | ((== '(1) n) (poso m) (== m p)) 201 | ((>1o n) (== '(1) m) (== n p)) 202 | ((fresh (x z) 203 | (== `(0 . ,x) n) (poso x) 204 | (== `(0 . ,z) p) (poso z) 205 | (>1o m) 206 | (*o x m z))) 207 | ((fresh (x y) 208 | (== `(1 . ,x) n) (poso x) 209 | (== `(0 . ,y) m) (poso y) 210 | (*o m n p))) 211 | ((fresh (x y) 212 | (== `(1 . ,x) n) (poso x) 213 | (== `(1 . ,y) m) (poso y) 214 | (odd-*o x n m p)))))) 215 | 216 | (define odd-*o 217 | (lambda (x n m p) 218 | (fresh (q) 219 | (bound-*o q p n m) 220 | (*o x m q) 221 | (pluso `(0 . ,q) m p)))) 222 | 223 | (define bound-*o 224 | (lambda (q p n m) 225 | (conde 226 | ((nullo q) (pairo p)) 227 | ((fresh (x y z) 228 | (cdro q x) 229 | (cdro p y) 230 | (conde 231 | ((nullo n) 232 | (cdro m z) 233 | (bound-*o x y z '())) 234 | ((cdro n z) 235 | (bound-*o x y z m)))))))) 236 | 237 | (define =lo 238 | (lambda (n m) 239 | (conde 240 | ((== '() n) (== '() m)) 241 | ((== '(1) n) (== '(1) m)) 242 | ((fresh (a x b y) 243 | (== `(,a . ,x) n) (poso x) 244 | (== `(,b . ,y) m) (poso y) 245 | (=lo x y)))))) 246 | 247 | (define 1o m)) 252 | ((fresh (a x b y) 253 | (== `(,a . ,x) n) (poso x) 254 | (== `(,b . ,y) m) (poso y) 255 | (1o b) (=lo n b) (pluso r b n)) 339 | ((== '(1) b) (poso q) (pluso r '(1) n)) 340 | ((== '() b) (poso q) (== r n)) 341 | ((== '(0 1) b) 342 | (fresh (a ad dd) 343 | (poso dd) 344 | (== `(,a ,ad . ,dd) n) 345 | (exp2 n '() q) 346 | (fresh (s) 347 | (splito n dd r s)))) 348 | ((fresh (a ad add ddd) 349 | (conde 350 | ((== '(1 1) b)) 351 | ((== `(,a ,ad ,add . ,ddd) b)))) 352 | (1o n) (== '(1) q) 384 | (fresh (s) 385 | (splito n b s '(1)))) 386 | ((fresh (q1 b2) 387 | (== `(0 . ,q1) q) 388 | (poso q1) 389 | (1o q) 406 | (fresh (q1 nq1) 407 | (pluso q1 '(1) q) 408 | (repeated-mul n q1 nq1) 409 | (*o nq1 n nq)))))) 410 | 411 | (define expo 412 | (lambda (b q n) 413 | (logo n b q '()))) 414 | -------------------------------------------------------------------------------- /mktests.scm: -------------------------------------------------------------------------------- 1 | ;;; This file was generated by writeminikanren.pl 2 | ;;; Generated at 2007-10-25 15:24:42 3 | 4 | (load "mk.scm") 5 | 6 | 7 | (define-syntax test-check 8 | (syntax-rules () 9 | ((_ title tested-expression expected-result) 10 | (begin 11 | (cout "Testing " title nl) 12 | (let* ((expected expected-result) 13 | (produced tested-expression)) 14 | (or (equal? expected produced) 15 | (errorf 'test-check 16 | "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 17 | 'tested-expression expected produced))))))) 18 | 19 | (define max-ticks 10) 20 | ;;; Will sez: Uncomment the following line to properly test divergent code. 21 | ;;; (define max-ticks 10) 22 | (define max-ticks 10) 23 | ;;; Will sez: Uncomment the following line to properly test divergent code. 24 | ;;; (define max-ticks 10000000) 25 | 26 | (define-syntax test-divergence 27 | (syntax-rules () 28 | ((_ title tested-expression) 29 | (let ((max-ticks 1000000)) 30 | (printf "Testing ~s (engine with ~s ticks fuel)\n" title max-ticks) 31 | ((make-engine (lambda () tested-expression)) 32 | max-ticks 33 | (lambda (t v) 34 | (error title "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 35 | (lambda (e^) (void))))))) 36 | 37 | 38 | ;;; Redefine 'test-check' to make the file load quickly. 39 | '(define-syntax test-check 40 | (syntax-rules () 41 | ((_ title tested-expression expected-result) 42 | (if #f #f)))) 43 | 44 | (define nl (string #\newline)) 45 | 46 | (define (cout . args) 47 | (for-each (lambda (x) 48 | (if (procedure? x) (x) (display x))) 49 | args)) 50 | 51 | (define errorf 52 | (lambda (tag . args) 53 | (printf "Failed: ~s: ~%" tag) 54 | (apply printf args) 55 | (error 'WiljaCodeTester "That's all, folks!"))) 56 | 57 | ;;; Max fuel for engines 58 | (define max-ticks 10) 59 | ;;; Will sez: Uncomment the following line to properly test divergent code. 60 | ;;; (define max-ticks 10000000) 61 | 62 | 63 | (define-syntax run1 (syntax-rules () ((_ (x) g0 g ...) (run 1 (x) g0 g ...)))) 64 | (define-syntax run2 (syntax-rules () ((_ (x) g0 g ...) (run 2 (x) g0 g ...)))) 65 | (define-syntax run3 (syntax-rules () ((_ (x) g0 g ...) (run 3 (x) g0 g ...)))) 66 | (define-syntax run4 (syntax-rules () ((_ (x) g0 g ...) (run 4 (x) g0 g ...)))) 67 | (define-syntax run5 (syntax-rules () ((_ (x) g0 g ...) (run 5 (x) g0 g ...)))) 68 | (define-syntax run6 (syntax-rules () ((_ (x) g0 g ...) (run 6 (x) g0 g ...)))) 69 | (define-syntax run7 (syntax-rules () ((_ (x) g0 g ...) (run 7 (x) g0 g ...)))) 70 | (define-syntax run8 (syntax-rules () ((_ (x) g0 g ...) (run 8 (x) g0 g ...)))) 71 | (define-syntax run9 (syntax-rules () ((_ (x) g0 g ...) (run 9 (x) g0 g ...)))) 72 | (define-syntax run10 (syntax-rules () ((_ (x) g0 g ...) (run 10 (x) g0 g ...)))) 73 | 74 | (define-syntax run11 (syntax-rules () ((_ (x) g0 g ...) (run 11 (x) g0 g ...)))) 75 | (define-syntax run12 (syntax-rules () ((_ (x) g0 g ...) (run 12 (x) g0 g ...)))) 76 | (define-syntax run13 (syntax-rules () ((_ (x) g0 g ...) (run 13 (x) g0 g ...)))) 77 | (define-syntax run14 (syntax-rules () ((_ (x) g0 g ...) (run 14 (x) g0 g ...)))) 78 | (define-syntax run15 (syntax-rules () ((_ (x) g0 g ...) (run 15 (x) g0 g ...)))) 79 | (define-syntax run16 (syntax-rules () ((_ (x) g0 g ...) (run 16 (x) g0 g ...)))) 80 | (define-syntax run17 (syntax-rules () ((_ (x) g0 g ...) (run 17 (x) g0 g ...)))) 81 | (define-syntax run18 (syntax-rules () ((_ (x) g0 g ...) (run 18 (x) g0 g ...)))) 82 | (define-syntax run19 (syntax-rules () ((_ (x) g0 g ...) (run 19 (x) g0 g ...)))) 83 | (define-syntax run20 (syntax-rules () ((_ (x) g0 g ...) (run 20 (x) g0 g ...)))) 84 | 85 | (define-syntax run21 (syntax-rules () ((_ (x) g0 g ...) (run 21 (x) g0 g ...)))) 86 | (define-syntax run22 (syntax-rules () ((_ (x) g0 g ...) (run 22 (x) g0 g ...)))) 87 | (define-syntax run23 (syntax-rules () ((_ (x) g0 g ...) (run 23 (x) g0 g ...)))) 88 | (define-syntax run24 (syntax-rules () ((_ (x) g0 g ...) (run 24 (x) g0 g ...)))) 89 | (define-syntax run25 (syntax-rules () ((_ (x) g0 g ...) (run 25 (x) g0 g ...)))) 90 | (define-syntax run26 (syntax-rules () ((_ (x) g0 g ...) (run 26 (x) g0 g ...)))) 91 | (define-syntax run27 (syntax-rules () ((_ (x) g0 g ...) (run 27 (x) g0 g ...)))) 92 | (define-syntax run28 (syntax-rules () ((_ (x) g0 g ...) (run 28 (x) g0 g ...)))) 93 | (define-syntax run29 (syntax-rules () ((_ (x) g0 g ...) (run 29 (x) g0 g ...)))) 94 | (define-syntax run30 (syntax-rules () ((_ (x) g0 g ...) (run 30 (x) g0 g ...)))) 95 | 96 | (define-syntax run31 (syntax-rules () ((_ (x) g0 g ...) (run 31 (x) g0 g ...)))) 97 | (define-syntax run32 (syntax-rules () ((_ (x) g0 g ...) (run 32 (x) g0 g ...)))) 98 | (define-syntax run33 (syntax-rules () ((_ (x) g0 g ...) (run 33 (x) g0 g ...)))) 99 | (define-syntax run34 (syntax-rules () ((_ (x) g0 g ...) (run 34 (x) g0 g ...)))) 100 | (define-syntax run35 (syntax-rules () ((_ (x) g0 g ...) (run 35 (x) g0 g ...)))) 101 | (define-syntax run36 (syntax-rules () ((_ (x) g0 g ...) (run 36 (x) g0 g ...)))) 102 | (define-syntax run37 (syntax-rules () ((_ (x) g0 g ...) (run 37 (x) g0 g ...)))) 103 | (define-syntax run38 (syntax-rules () ((_ (x) g0 g ...) (run 38 (x) g0 g ...)))) 104 | (define-syntax run39 (syntax-rules () ((_ (x) g0 g ...) (run 39 (x) g0 g ...)))) 105 | (define-syntax run40 (syntax-rules () ((_ (x) g0 g ...) (run 40 (x) g0 g ...)))) 106 | 107 | (test-check "testc11.tex-1" 108 | (run* (q) 109 | fail) 110 | 111 | `()) 112 | 113 | (test-check "testc11.tex-2" 114 | (run* (q) 115 | (== #t q)) 116 | 117 | `(#t)) 118 | 119 | (test-check "testc11.tex-3" 120 | (run* (q) 121 | fail 122 | (== #t q)) 123 | 124 | `()) 125 | 126 | (define g fail) 127 | 128 | 129 | (test-check "testc11.tex-4" 130 | (run* (q) 131 | succeed 132 | (== #t q)) 133 | 134 | (list #t)) 135 | 136 | (test-check "testc11.tex-5" 137 | (run* (q) 138 | succeed 139 | (== #t q)) 140 | 141 | `(#t)) 142 | 143 | (test-check "testc11.tex-6" 144 | (run* (r) 145 | succeed 146 | (== 'corn r)) 147 | 148 | (list 'corn)) 149 | 150 | (test-check "testc11.tex-7" 151 | (run* (r) 152 | succeed 153 | (== 'corn r)) 154 | 155 | `(corn)) 156 | 157 | (test-check "testc11.tex-8" 158 | (run* (r) 159 | fail 160 | (== 'corn r)) 161 | 162 | `()) 163 | 164 | (test-check "testc11.tex-9" 165 | (run* (q) 166 | succeed 167 | (== #f q)) 168 | 169 | `(#f)) 170 | 171 | (test-check "testc11.tex-10" 172 | (run* (x) 173 | (let ((x #f)) 174 | (== #t x))) 175 | 176 | '()) 177 | 178 | (test-check "testc11.tex-11" 179 | (run* (q) 180 | (fresh (x) 181 | (== #t x) 182 | (== #t q))) 183 | 184 | (list #t)) 185 | 186 | (run* (q) 187 | (fresh (x) 188 | (== #t x) 189 | (== #t q))) 190 | 191 | 192 | (test-check "testc11.tex-12" 193 | (run* (q) 194 | (fresh (x) 195 | (== x #t) 196 | (== #t q))) 197 | 198 | (list #t)) 199 | 200 | (test-check "testc11.tex-13" 201 | (run* (q) 202 | (fresh (x) 203 | (== x #t) 204 | (== q #t))) 205 | 206 | (list #t)) 207 | 208 | (test-check "testc11.tex-14" 209 | (run* (x) 210 | succeed) 211 | 212 | (list `_.0)) 213 | 214 | (test-check "testc11.tex-15" 215 | (run* (x) 216 | (let ((x #f)) 217 | (fresh (x) 218 | (== #t x)))) 219 | 220 | `(_.0)) 221 | 222 | (test-check "testc11.tex-16" 223 | (run* (r) 224 | (fresh (x y) 225 | (== (cons x (cons y '())) r))) 226 | 227 | (list `(_.0 _.1))) 228 | 229 | (test-check "testc11.tex-17" 230 | (run* (s) 231 | (fresh (t u) 232 | (== (cons t (cons u '())) s))) 233 | 234 | (list `(_.0 _.1))) 235 | 236 | (test-check "testc11.tex-18" 237 | (run* (r) 238 | (fresh (x) 239 | (let ((y x)) 240 | (fresh (x) 241 | (== (cons y (cons x (cons y '()))) r))))) 242 | 243 | (list `(_.0 _.1 _.0))) 244 | 245 | (test-check "testc11.tex-19" 246 | (run* (r) 247 | (fresh (x) 248 | (let ((y x)) 249 | (fresh (x) 250 | (== (cons x (cons y (cons x '()))) r))))) 251 | 252 | (list `(_.0 _.1 _.0))) 253 | 254 | (test-check "testc11.tex-20" 255 | (run* (q) 256 | (== #f q) 257 | (== #t q)) 258 | 259 | `()) 260 | 261 | (test-check "testc11.tex-21" 262 | (run* (q) 263 | (== #f q) 264 | (== #f q)) 265 | 266 | '(#f)) 267 | 268 | (test-check "testc11.tex-22" 269 | (run* (q) 270 | (let ((x q)) 271 | (== #t x))) 272 | 273 | (list #t)) 274 | 275 | (test-check "testc11.tex-23" 276 | (run* (r) 277 | (fresh (x) 278 | (== x r))) 279 | 280 | (list `_.0)) 281 | 282 | (test-check "testc11.tex-24" 283 | (run* (q) 284 | (fresh (x) 285 | (== #t x) 286 | (== x q))) 287 | 288 | (list #t)) 289 | 290 | (test-check "testc11.tex-25" 291 | (run* (q) 292 | (fresh (x) 293 | (== x q) 294 | (== #t x))) 295 | 296 | (list #t)) 297 | 298 | (run* (q) 299 | (fresh (x) 300 | (== #t x) 301 | (== x q))) 302 | 303 | 304 | (test-check "testc11.tex-26" 305 | (run* (q) 306 | (fresh (x) 307 | (== (eq? x q) q))) 308 | 309 | 310 | (list #f)) 311 | 312 | 313 | (test-check "testc11.tex-27" 314 | (run* (q) 315 | (let ((x q)) 316 | (fresh (q) 317 | (== (eq? x q) x)))) 318 | 319 | (list #f)) 320 | 321 | (test-check "testc11.tex-28" 322 | (cond 323 | (#f #t) 324 | (#t #f)) 325 | 326 | #f) 327 | 328 | (test-check "testc11.tex-29" 329 | (cond 330 | (#f succeed) 331 | (#t fail)) 332 | 333 | 334 | fail) 335 | 336 | 337 | (test-check "testc13.tex-fail1" (run* (q) 338 | 339 | 340 | (conde 341 | (fail succeed) 342 | (succeed fail)) 343 | 344 | 345 | ) '()) 346 | 347 | 348 | (test-check "testc13.tex-succeed1" (not (null? (run* (q) 349 | 350 | 351 | (conde 352 | (fail fail) 353 | (succeed succeed)) 354 | 355 | 356 | ))) #t) 357 | 358 | 359 | (test-check "testc13.tex-succeed2" (not (null? (run* (q) 360 | 361 | 362 | (conde 363 | (succeed succeed) 364 | (succeed fail)) 365 | 366 | 367 | ))) #t) 368 | 369 | 370 | (test-check "testc11.tex-30" 371 | (run* (x) 372 | (conde 373 | ((== 'olive x) succeed) 374 | ((== 'oil x) succeed))) 375 | 376 | `(olive oil)) 377 | 378 | (test-check "testc11.tex-31" 379 | (run1 (x) 380 | (conde 381 | ((== 'olive x) succeed) 382 | ((== 'oil x) succeed))) 383 | 384 | `(olive)) 385 | 386 | (test-check "testc11.tex-32" 387 | (run* (x) 388 | (conde 389 | ((== 'virgin x) fail) 390 | ((== 'olive x) succeed) 391 | (succeed succeed) 392 | ((== 'oil x) succeed))) 393 | 394 | `(olive _.0 oil)) 395 | 396 | (test-check "testc13.tex-conde1" (run* (x) 397 | 398 | 399 | (conde 400 | ((== 'olive x) succeed) 401 | (succeed succeed) 402 | ((== 'oil x) succeed)) 403 | 404 | 405 | ) `(olive _.0 oil)) 406 | 407 | 408 | (test-check "testc11.tex-33" 409 | (run2 (x) 410 | (conde 411 | ((== 'extra x) succeed) 412 | ((== 'virgin x) fail) 413 | ((== 'olive x) succeed) 414 | ((== 'oil x) succeed))) 415 | 416 | `(extra olive)) 417 | 418 | (test-check "testc11.tex-34" 419 | (run* (r) 420 | (fresh (x y) 421 | (== 'split x) 422 | (== 'pea y) 423 | (== (cons x (cons y '())) r))) 424 | 425 | (list `(split pea))) 426 | 427 | (test-check "testc11.tex-35" 428 | (run* (r) 429 | (fresh (x y) 430 | (conde 431 | ((== 'split x) (== 'pea y)) 432 | ((== 'navy x) (== 'bean y))) 433 | (== (cons x (cons y '())) r))) 434 | 435 | `((split pea) (navy bean))) 436 | 437 | (test-check "testc11.tex-36" 438 | (run* (r) 439 | (fresh (x y) 440 | (conde 441 | ((== 'split x) (== 'pea y)) 442 | ((== 'navy x) (== 'bean y))) 443 | (== (cons x (cons y (cons 'soup '()))) r))) 444 | 445 | `((split pea soup) (navy bean soup))) 446 | 447 | (define teacupo 448 | (lambda (x) 449 | (conde 450 | ((== 'tea x) succeed) 451 | ((== 'cup x) succeed)))) 452 | 453 | 454 | (test-check "testc11.tex-37" 455 | (run* (x) 456 | (teacupo x)) 457 | 458 | `(tea cup)) 459 | 460 | (test-check "testc11.tex-38" 461 | (run* (r) 462 | (fresh (x y) 463 | (conde 464 | ((teacupo x) (== #t y) succeed) 465 | ((== #f x) (== #t y))) 466 | (== (cons x (cons y '())) r))) 467 | 468 | `((#f #t) (tea #t) (cup #t))) 469 | 470 | (test-check "testc11.tex-39" 471 | (run* (r) 472 | (fresh (x y z) 473 | (conde 474 | ((== y x) (fresh (x) (== z x))) 475 | ((fresh (x) (== y x)) (== z x))) 476 | (== (cons y (cons z '())) r))) 477 | 478 | `((_.0 _.1) (_.0 _.1))) 479 | 480 | (test-check "testc11.tex-40" 481 | (run* (r) 482 | (fresh (x y z) 483 | (conde 484 | ((== y x) (fresh (x) (== z x))) 485 | ((fresh (x) (== y x)) (== z x))) 486 | (== #f x) 487 | (== (cons y (cons z '())) r))) 488 | 489 | `((#f _.0) (_.0 #f))) 490 | 491 | (test-check "testc11.tex-41" 492 | (run* (q) 493 | (let ((a (== #t q)) 494 | (b (== #f q))) 495 | b)) 496 | 497 | '(#f)) 498 | 499 | (test-check "testc11.tex-42" 500 | (run* (q) 501 | (let ((a (== #t q)) 502 | (b (fresh (x) 503 | (== x q) 504 | (== #f x))) 505 | (c (conde 506 | ((== #t q) succeed) 507 | (succeed (== #f q))))) 508 | b)) 509 | 510 | '(#f)) 511 | 512 | (test-check "testc12.tex-1" 513 | (let ((x (lambda (a) a)) 514 | (y 'c)) 515 | (x y)) 516 | 517 | 'c) 518 | 519 | (test-check "testc12.tex-2" 520 | (run* (r) 521 | (fresh (y x) 522 | (== `(,x ,y) r))) 523 | 524 | (list `(_.0 _.1))) 525 | 526 | (test-check "testc12.tex-3" 527 | (run* (r) 528 | (fresh (v w) 529 | (== (let ((x v) (y w)) `(,x ,y)) r))) 530 | 531 | `((_.0 _.1))) 532 | 533 | (test-check "testc12.tex-4" 534 | (car `(grape raisin pear)) 535 | 536 | `grape) 537 | 538 | (test-check "testc12.tex-5" 539 | (car `(a c o r n)) 540 | 541 | 'a) 542 | 543 | 544 | (define caro 545 | (lambda (p a) 546 | (fresh (d) 547 | (== (cons a d) p)))) 548 | 549 | 550 | (test-check "testc12.tex-6" 551 | (run* (r) 552 | (caro `(a c o r n) r)) 553 | 554 | (list 'a)) 555 | 556 | (test-check "testc12.tex-7" 'a 557 | 558 | (car 559 | 560 | `(a c o r n) 561 | 562 | )) 563 | 564 | 565 | (test-check "testc12.tex-8" 566 | (run* (q) 567 | (caro `(a c o r n) 'a) 568 | (== #t q)) 569 | 570 | (list #t)) 571 | 572 | (test-check "testc12.tex-9" 'a 573 | 574 | (car 575 | 576 | `(a c o r n) 577 | 578 | )) 579 | 580 | 581 | (test-check "testc12.tex-10" 582 | (run* (r) 583 | (fresh (x y) 584 | (caro `(,r ,y) x) 585 | (== 'pear x))) 586 | 587 | (list 'pear)) 588 | 589 | 590 | (test-check "testc12.tex-11" 591 | (cons 592 | (car `(grape raisin pear)) 593 | (car `((a) (b) (c)))) 594 | 595 | `(grape a)) 596 | 597 | (test-check "testc12.tex-12" 598 | (run* (r) 599 | (fresh (x y) 600 | (caro `(grape raisin pear) x) 601 | (caro `((a) (b) (c)) y) 602 | (== (cons x y) r))) 603 | 604 | (list `(grape a))) 605 | 606 | (test-check "testc12.tex-13" 607 | (cdr `(grape raisin pear)) 608 | 609 | `(raisin pear)) 610 | 611 | (test-check "testc12.tex-14" 612 | (car (cdr `(a c o r n))) 613 | 614 | 'c) 615 | 616 | 617 | (define cdro 618 | (lambda (p d) 619 | (fresh (a) 620 | (== (cons a d) p)))) 621 | 622 | 623 | (test-check "testc12.tex-15" 624 | (run* (r) 625 | (fresh (v) 626 | (cdro `(a c o r n) v) 627 | (caro v r))) 628 | 629 | (list 'c)) 630 | 631 | 632 | (test-check "testc12.tex-16" 633 | (cons 634 | (cdr `(grape raisin pear)) 635 | (car `((a) (b) (c)))) 636 | 637 | `((raisin pear) a)) 638 | 639 | (test-check "testc12.tex-17" 640 | (run* (r) 641 | (fresh (x y) 642 | (cdro `(grape raisin pear) x) 643 | (caro `((a) (b) (c)) y) 644 | (== (cons x y) r))) 645 | 646 | (list `((raisin pear) a))) 647 | 648 | (test-check "testc12.tex-18" 649 | (run* (q) 650 | (cdro '(a c o r n) '(c o r n)) 651 | (== #t q)) 652 | 653 | (list #t)) 654 | 655 | (test-check "testc12.tex-19" `(c o r n) 656 | 657 | (cdr 658 | 659 | '(a c o r n) 660 | 661 | )) 662 | 663 | 664 | (test-check "testc12.tex-20" 665 | (run* (x) 666 | (cdro '(c o r n) `(,x r n))) 667 | 668 | (list 'o)) 669 | 670 | (test-check "testc12.tex-21" `(o r n) 671 | 672 | (cdr 673 | 674 | `(c o r n) 675 | 676 | )) 677 | 678 | 679 | (test-check "testc12.tex-22" 680 | (run* (l) 681 | (fresh (x) 682 | (cdro l '(c o r n)) 683 | (caro l x) 684 | (== 'a x))) 685 | 686 | (list `(a c o r n))) 687 | 688 | 689 | (define conso 690 | (lambda (a d p) 691 | (== (cons a d) p))) 692 | 693 | 694 | (test-check "testc12.tex-23" 695 | (run* (l) 696 | (conso '(a b c) '(d e) l)) 697 | 698 | (list `((a b c) d e))) 699 | 700 | (test-check "testc12.tex-24" 701 | (run* (x) 702 | (conso x '(a b c) '(d a b c))) 703 | 704 | (list 'd)) 705 | 706 | (test-check "testc12.tex-25" (cons 'd '(a b c)) 707 | `(d a b c)) 708 | 709 | (test-check "testc12.tex-26" 710 | (run* (r) 711 | (fresh (x y z) 712 | (== `(e a d ,x) r) 713 | (conso y `(a ,z c) r))) 714 | 715 | (list `(e a d c))) 716 | 717 | (test-check "testc12.tex-27" 718 | (run* (x) 719 | (conso x `(a ,x c) `(d a ,x c))) 720 | 721 | (list 'd)) 722 | 723 | (define x 'd) 724 | 725 | 726 | (test-check "testc12.tex-28" (cons x `(a ,x c)) 727 | `(d a ,x c)) 728 | 729 | (test-check "testc12.tex-29" 730 | (run* (l) 731 | (fresh (x) 732 | (== `(d a ,x c) l) 733 | (conso x `(a ,x c) l))) 734 | 735 | (list `(d a d c))) 736 | 737 | (test-check "testc12.tex-30" 738 | (run* (l) 739 | (fresh (x) 740 | (conso x `(a ,x c) l) 741 | (== `(d a ,x c) l))) 742 | 743 | (list `(d a d c))) 744 | 745 | 746 | (test-check "testc12.tex-31" 747 | (run* (l) 748 | (fresh (d x y w s) 749 | (conso w '(a n s) s) 750 | (cdro l s) 751 | (caro l x) 752 | (== 'b x) 753 | (cdro l d) 754 | (caro d y) 755 | (== 'e y))) 756 | 757 | (list `(b e a n s))) 758 | 759 | (test-check "testc12.tex-32" 760 | (null? `(grape raisin pear)) 761 | 762 | #f) 763 | 764 | (test-check "testc12.tex-33" 765 | (null? '()) 766 | 767 | #t) 768 | 769 | 770 | (define nullo 771 | (lambda (x) 772 | (== '() x))) 773 | 774 | 775 | (test-check "testc12.tex-34" 776 | (run* (q) 777 | (nullo `(grape raisin pear)) 778 | (== #t q)) 779 | 780 | `()) 781 | 782 | (test-check "testc12.tex-35" 783 | (run* (q) 784 | (nullo '()) 785 | (== #t q)) 786 | 787 | `(#t)) 788 | 789 | (test-check "testc12.tex-36" 790 | (run* (x) 791 | (nullo x)) 792 | 793 | `(())) 794 | 795 | 796 | (test-check "testc12.tex-37" 797 | (eq? 'pear 'plum) 798 | 799 | #f) 800 | 801 | (test-check "testc12.tex-38" 802 | (eq? 'plum 'plum) 803 | 804 | #t) 805 | 806 | 807 | (define eqo 808 | (lambda (x y) 809 | (== x y))) 810 | 811 | 812 | (test-check "testc12.tex-39" 813 | (run* (q) 814 | (eqo 'pear 'plum) 815 | (== #t q)) 816 | 817 | `()) 818 | 819 | (test-check "testc12.tex-40" 820 | (run* (q) 821 | (eqo 'plum 'plum) 822 | (== #t q)) 823 | 824 | `(#t)) 825 | 826 | 827 | (test-check "testc12.tex-41" 828 | (pair? `((split) . pea)) 829 | 830 | #t) 831 | 832 | (test-check "testc12.tex-42" 833 | (pair? '()) 834 | 835 | #f) 836 | 837 | (test-check "testc12.tex-43" 838 | (car `(pear)) 839 | 840 | `pear) 841 | 842 | (test-check "testc12.tex-44" 843 | (cdr `(pear)) 844 | 845 | `()) 846 | 847 | (test-check "testc12.tex-45" 848 | (cons `(split) 'pea) 849 | 850 | `((split) . pea)) 851 | 852 | (test-check "testc12.tex-46" 853 | (run* (r) 854 | (fresh (x y) 855 | (== (cons x (cons y 'salad)) r))) 856 | 857 | (list `(_.0 _.1 . salad))) 858 | 859 | (define pairo 860 | (lambda (p) 861 | (fresh (a d) 862 | (conso a d p)))) 863 | 864 | 865 | (test-check "testc12.tex-47" 866 | (run* (q) 867 | (pairo (cons q q)) 868 | (== #t q)) 869 | 870 | `(#t)) 871 | 872 | (test-check "testc12.tex-48" 873 | (run* (q) 874 | (pairo '()) 875 | (== #t q)) 876 | 877 | `()) 878 | 879 | (test-check "testc12.tex-49" 880 | (run* (q) 881 | (pairo 'pair) 882 | (== #t q)) 883 | 884 | `()) 885 | 886 | (test-check "testc12.tex-50" 887 | (run* (x) 888 | (pairo x)) 889 | 890 | (list `(_.0 . _.1))) 891 | 892 | (test-check "testc12.tex-51" 893 | (run* (r) 894 | (pairo (cons r 'pear))) 895 | 896 | (list `_.0)) 897 | 898 | (define new-list? 899 | (lambda (l) 900 | (cond 901 | ((null? l) #t) 902 | ((pair? l) (new-list? (cdr l))) 903 | (else #f)))) 904 | 905 | 906 | (test-check "testc14.tex-1" 907 | (new-list? `((a) (a b) c)) 908 | 909 | #t) 910 | 911 | (test-check "testc14.tex-2" 912 | (new-list? `()) 913 | 914 | #t) 915 | 916 | (test-check "testc14.tex-3" 917 | (new-list? 's) 918 | 919 | #f) 920 | 921 | (test-check "testc14.tex-4" 922 | (new-list? `(d a t e . s)) 923 | 924 | #f) 925 | 926 | (define listo 927 | (lambda (l) 928 | (conde 929 | ((nullo l) succeed) 930 | ((pairo l) 931 | (fresh (d) 932 | (cdro l d) 933 | (listo d))) 934 | ((== #f #f) fail)))) 935 | 936 | 937 | (define listo 938 | (lambda (l) 939 | (conde 940 | ((nullo l) succeed) 941 | ((pairo l) 942 | (fresh (d) 943 | (cdro l d) 944 | (listo d))) 945 | (succeed fail)))) 946 | 947 | 948 | (define listo 949 | (lambda (l) 950 | (conde 951 | ((nullo l) succeed) 952 | ((pairo l) 953 | (fresh (d) 954 | (cdro l d) 955 | (listo d)))))) 956 | 957 | 958 | (test-check "testc14.tex-5" 959 | (run* (x) 960 | (listo `(a b ,x d))) 961 | 962 | (list `_.0)) 963 | 964 | (test-check "testc14.tex-6" 965 | (run1 (x) 966 | (listo `(a b c . ,x))) 967 | 968 | (list `())) 969 | (define e (make-engine (lambda () 970 | (run* (x) 971 | (listo `(a b c . ,x))) 972 | ))) 973 | (printf "Testing testc14.tex-7 (engine with ~s ticks fuel)\n" max-ticks) 974 | (e max-ticks 975 | (lambda (t v) (error 'testc14.tex-7 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 976 | (lambda (e^) (void))) 977 | 978 | 979 | (test-check "testc14.tex-8" 980 | (run5 (x) 981 | (listo `(a b c . ,x))) 982 | 983 | 984 | `(() 985 | (_.0) 986 | (_.0 _.1) 987 | (_.0 _.1 _.2) 988 | (_.0 _.1 _.2 _.3)) 989 | ) 990 | 991 | (define lol? 992 | (lambda (l) 993 | (cond 994 | ((null? l) #t) 995 | ((new-list? (car l)) (lol? (cdr l))) 996 | (else #f)))) 997 | 998 | 999 | (define lolo 1000 | (lambda (l) 1001 | (conde 1002 | ((nullo l) succeed) 1003 | ((fresh (a) 1004 | (caro l a) 1005 | (listo a)) 1006 | (fresh (d) 1007 | (cdro l d) 1008 | (lolo d)))))) 1009 | 1010 | 1011 | (test-check "testc14.tex-9" 1012 | (run1 (l) 1013 | (lolo l)) 1014 | 1015 | `(())) 1016 | 1017 | (test-check "testc14.tex-10" 1018 | (run* (q) 1019 | (fresh (x y) 1020 | (lolo `((a b) (,x c) (d ,y))) 1021 | (== #t q))) 1022 | 1023 | (list #t)) 1024 | 1025 | (test-check "testc14.tex-11" 1026 | (run1 (q) 1027 | (fresh (x) 1028 | (lolo `((a b) . ,x)) 1029 | (== #t q))) 1030 | 1031 | (list #t)) 1032 | 1033 | (test-check "testc14.tex-12" 1034 | (run1 (x) 1035 | (lolo `((a b) (c d) . ,x))) 1036 | 1037 | `(())) 1038 | 1039 | (test-check "testc14.tex-13" 1040 | (run5 (x) 1041 | (lolo `((a b) (c d) . ,x))) 1042 | 1043 | 1044 | `(() 1045 | (()) 1046 | ((_.0)) 1047 | (() ()) 1048 | ((_.0 _.1))) 1049 | ) 1050 | 1051 | (define twinso 1052 | (lambda (s) 1053 | (fresh (x y) 1054 | (conso x y s) 1055 | (conso x '() y)))) 1056 | 1057 | 1058 | (test-check "testc14.tex-14" 1059 | (run* (q) 1060 | (twinso '(tofu tofu)) 1061 | (== #t q)) 1062 | 1063 | (list #t)) 1064 | 1065 | (test-check "testc14.tex-15" 1066 | (run* (z) 1067 | (twinso `(,z tofu))) 1068 | 1069 | (list `tofu)) 1070 | 1071 | (define loto 1072 | (lambda (l) 1073 | (conde 1074 | ((nullo l) succeed) 1075 | ((fresh (a) 1076 | (caro l a) 1077 | (twinso a)) 1078 | (fresh (d) 1079 | (cdro l d) 1080 | (loto d)))))) 1081 | 1082 | 1083 | (test-check "testc14.tex-16" 1084 | (run1 (z) 1085 | (loto `((g g) . ,z))) 1086 | 1087 | (list `())) 1088 | 1089 | (test-check "testc14.tex-17" 1090 | (run5 (z) 1091 | (loto `((g g) . ,z))) 1092 | 1093 | 1094 | '(() 1095 | ((_.0 _.0)) 1096 | ((_.0 _.0) (_.1 _.1)) 1097 | ((_.0 _.0) (_.1 _.1) (_.2 _.2)) 1098 | ((_.0 _.0) (_.1 _.1) (_.2 _.2) (_.3 _.3))) 1099 | ) 1100 | 1101 | (test-check "testc14.tex-18" 1102 | (run5 (r) 1103 | (fresh (w x y z) 1104 | (loto `((g g) (e ,w) (,x ,y) . ,z)) 1105 | (== `(,w (,x ,y) ,z) r))) 1106 | 1107 | 1108 | '((e (_.0 _.0) ()) 1109 | (e (_.0 _.0) ((_.1 _.1))) 1110 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2))) 1111 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2) (_.3 _.3))) 1112 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2) (_.3 _.3) (_.4 _.4)))) 1113 | ) 1114 | 1115 | (test-check "testc14.tex-19" 1116 | (run3 (out) 1117 | (fresh (w x y z) 1118 | (== `((g g) (e ,w) (,x ,y) . ,z) out) 1119 | (loto out))) 1120 | 1121 | 1122 | `(((g g) (e e) (_.0 _.0)) 1123 | ((g g) (e e) (_.0 _.0) (_.1 _.1)) 1124 | ((g g) (e e) (_.0 _.0) (_.1 _.1) (_.2 _.2))) 1125 | ) 1126 | 1127 | (define listofo 1128 | (lambda (predo l) 1129 | (conde 1130 | ((nullo l) succeed) 1131 | ((fresh (a) 1132 | (caro l a) 1133 | (predo a)) 1134 | (fresh (d) 1135 | (cdro l d) 1136 | (listofo predo d)))))) 1137 | 1138 | 1139 | (test-check "testc14.tex-20" 1140 | (run3 (out) 1141 | (fresh (w x y z) 1142 | (== `((g g) (e ,w) (,x ,y) . ,z) out) 1143 | (listofo twinso out))) 1144 | 1145 | 1146 | `(((g g) (e e) (_.0 _.0)) 1147 | ((g g) (e e) (_.0 _.0) (_.1 _.1)) 1148 | ((g g) (e e) (_.0 _.0) (_.1 _.1) (_.2 _.2))) 1149 | ) 1150 | 1151 | (define loto 1152 | (lambda (l) 1153 | (listofo twinso l))) 1154 | 1155 | 1156 | (define member? 1157 | (lambda (x l) 1158 | (cond 1159 | ((null? l) #f) 1160 | ((eq? (car l) x) #t) 1161 | (else (member? x (cdr l)))))) 1162 | 1163 | 1164 | (test-check "testc14.tex-21" 1165 | (member? 'olive `(virgin olive oil)) 1166 | 1167 | #t) 1168 | 1169 | (define membero 1170 | (lambda (x l) 1171 | (conde 1172 | ((nullo l) fail) 1173 | ((fresh (a) 1174 | (caro l a) 1175 | (== a x)) 1176 | succeed) 1177 | (succeed 1178 | (fresh (d) 1179 | (cdro l d) 1180 | (membero x d)))))) 1181 | 1182 | 1183 | (test-check "testc14.tex-22" 1184 | (run* (q) 1185 | (membero 'olive `(virgin olive oil)) 1186 | (== #t q)) 1187 | 1188 | (list #t)) 1189 | 1190 | (test-check "testc14.tex-23" 1191 | (run1 (y) 1192 | (membero y `(hummus with pita))) 1193 | 1194 | (list `hummus)) 1195 | 1196 | (test-check "testc14.tex-24" 1197 | (run1 (y) 1198 | (membero y `(with pita))) 1199 | 1200 | (list `with)) 1201 | 1202 | (test-check "testc14.tex-25" 1203 | (run1 (y) 1204 | (membero y `(pita))) 1205 | 1206 | (list `pita)) 1207 | 1208 | (test-check "testc14.tex-26" 1209 | (run* (y) 1210 | (membero y `())) 1211 | 1212 | `()) 1213 | 1214 | (test-check "testc14.tex-27" 1215 | (run* (y) 1216 | (membero y `(hummus with pita))) 1217 | 1218 | `(hummus with pita)) 1219 | 1220 | (test-check "testc14.tex-28" 1221 | (run* (x) 1222 | (membero 'e `(pasta ,x fagioli))) 1223 | 1224 | (list `e)) 1225 | 1226 | (test-check "testc14.tex-29" 1227 | (run1 (x) 1228 | (membero 'e `(pasta e ,x fagioli))) 1229 | 1230 | (list `_.0)) 1231 | 1232 | (test-check "testc14.tex-30" 1233 | (run1 (x) 1234 | (membero 'e `(pasta ,x e fagioli))) 1235 | 1236 | (list `e)) 1237 | 1238 | (test-check "testc14.tex-31" 1239 | (run* (r) 1240 | (fresh (x y) 1241 | (membero 'e `(pasta ,x fagioli ,y)) 1242 | (== `(,x ,y) r))) 1243 | 1244 | `((e _.0) (_.0 e))) 1245 | 1246 | (test-check "testc14.tex-32" 1247 | (run1 (l) 1248 | (membero 'tofu l)) 1249 | 1250 | `((tofu . _.0))) 1251 | (define e (make-engine (lambda () 1252 | (run* (l) 1253 | (membero 'tofu l)) 1254 | ))) 1255 | (printf "Testing testc14.tex-33 (engine with ~s ticks fuel)\n" max-ticks) 1256 | (e max-ticks 1257 | (lambda (t v) (error 'testc14.tex-33 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 1258 | (lambda (e^) (void))) 1259 | 1260 | 1261 | (test-check "testc14.tex-34" 1262 | (run5 (l) 1263 | (membero 'tofu l)) 1264 | 1265 | 1266 | `((tofu . _.0) 1267 | (_.0 tofu . _.1) 1268 | (_.0 _.1 tofu . _.2) 1269 | (_.0 _.1 _.2 tofu . _.3) 1270 | (_.0 _.1 _.2 _.3 tofu . _.4)) 1271 | ) 1272 | 1273 | (define pmembero 1274 | (lambda (x l) 1275 | (conde 1276 | ((caro l x) (cdro l '())) 1277 | ((fresh (d) 1278 | (cdro l d) 1279 | (pmembero x d)))))) 1280 | 1281 | 1282 | (test-check "testc14.tex-35" 1283 | (run5 (l) 1284 | (pmembero 'tofu l)) 1285 | 1286 | 1287 | `((tofu) 1288 | (_.0 tofu) 1289 | (_.0 _.1 tofu) 1290 | (_.0 _.1 _.2 tofu) 1291 | (_.0 _.1 _.2 _.3 tofu)) 1292 | ) 1293 | 1294 | (test-check "testc14.tex-36" 1295 | (run* (q) 1296 | (pmembero 'tofu `(a b tofu d tofu)) 1297 | (== #t q)) 1298 | 1299 | `(#t)) 1300 | 1301 | (define pmembero 1302 | (lambda (x l) 1303 | (conde 1304 | ((caro l x) 1305 | (conde 1306 | ((cdro l '())) 1307 | (succeed))) 1308 | ((fresh (d) 1309 | (cdro l d) 1310 | (pmembero x d)))))) 1311 | 1312 | 1313 | (test-check "testc14.tex-37" 1314 | (run* (q) 1315 | (pmembero 'tofu `(a b tofu d tofu)) 1316 | (== #t q)) 1317 | 1318 | `(#t #t #t)) 1319 | 1320 | (define pmembero 1321 | (lambda (x l) 1322 | (conde 1323 | ((caro l x) 1324 | (conde 1325 | ((cdro l '())) 1326 | ((fresh (a d) 1327 | (cdro l `(,a . ,d)))))) 1328 | ((fresh (d) 1329 | (cdro l d) 1330 | (pmembero x d)))))) 1331 | 1332 | 1333 | (test-check "testc14.tex-38" 1334 | (run* (q) 1335 | (pmembero 'tofu `(a b tofu d tofu)) 1336 | (== #t q)) 1337 | 1338 | `(#t #t)) 1339 | 1340 | (test-check "testc14.tex-39" 1341 | (run12 (l) 1342 | (pmembero 'tofu l)) 1343 | 1344 | 1345 | `((tofu) 1346 | (tofu _.0 . _.1) 1347 | (_.0 tofu) 1348 | (_.0 tofu _.1 . _.2) 1349 | (_.0 _.1 tofu) 1350 | (_.0 _.1 tofu _.2 . _.3) 1351 | (_.0 _.1 _.2 tofu) 1352 | (_.0 _.1 _.2 tofu _.3 . _.4) 1353 | (_.0 _.1 _.2 _.3 tofu) 1354 | (_.0 _.1 _.2 _.3 tofu _.4 . _.5 ) 1355 | (_.0 _.1 _.2 _.3 _.4 tofu) 1356 | (_.0 _.1 _.2 _.3 _.4 tofu _.5 . _.6)) 1357 | ) 1358 | 1359 | (define mem 1360 | (lambda (x l) 1361 | (cond 1362 | ((null? l) #f) 1363 | ((eq? (car l) x) l) 1364 | (else (mem x (cdr l)))))) 1365 | 1366 | 1367 | (test-check "testc15.tex-1" 1368 | (mem 'tofu `(a b tofu d peas e)) 1369 | 1370 | `(tofu d peas e)) 1371 | 1372 | (test-check "testc15.tex-2" 1373 | (mem 'tofu `(a b peas d peas e)) 1374 | 1375 | #f) 1376 | 1377 | (test-check "testc15.tex-3" 1378 | (run* (out) 1379 | (== (mem 'tofu `(a b tofu d peas e)) out)) 1380 | 1381 | (list `(tofu d peas e))) 1382 | 1383 | (test-check "testc15.tex-4" 1384 | (mem 'peas 1385 | (mem 'tofu `(a b tofu d peas e))) 1386 | 1387 | `(peas e)) 1388 | 1389 | (test-check "testc15.tex-5" 1390 | (mem 'tofu 1391 | (mem 'tofu `(a b tofu d tofu e))) 1392 | 1393 | `(tofu d tofu e)) 1394 | 1395 | (test-check "testc15.tex-6" 1396 | (mem 'tofu 1397 | (cdr (mem 'tofu `(a b tofu d tofu e)))) 1398 | 1399 | `(tofu e)) 1400 | 1401 | (define memo 1402 | (lambda (x l out) 1403 | (conde 1404 | ((nullo l) fail) 1405 | ((fresh (a) 1406 | (caro l a) 1407 | (== a x)) 1408 | (== l out)) 1409 | (succeed 1410 | (fresh (d) 1411 | (cdro l d) 1412 | (memo x d out)))))) 1413 | 1414 | 1415 | (define memo 1416 | (lambda (x l out) 1417 | (conde 1418 | ((fresh (a) 1419 | (caro l a) 1420 | (== a x)) 1421 | (== l out)) 1422 | ((fresh (d) 1423 | (cdro l d) 1424 | (memo x d out)))))) 1425 | 1426 | 1427 | (define memo 1428 | (lambda (x l out) 1429 | (conde 1430 | ((caro l x) (== l out)) 1431 | ((fresh (d) 1432 | (cdro l d) 1433 | (memo x d out)))))) 1434 | 1435 | 1436 | (test-check "testc15.tex-7" 1437 | (run1 (out) 1438 | (memo 'tofu `(a b tofu d tofu e) out)) 1439 | 1440 | `((tofu d tofu e))) 1441 | 1442 | (test-check "testc15.tex-8" 1443 | (run1 (out) 1444 | (fresh (x) 1445 | (memo 'tofu `(a b ,x d tofu e) out))) 1446 | 1447 | `((tofu d tofu e))) 1448 | 1449 | (test-check "testc15.tex-9" 1450 | (run* (r) 1451 | (memo r 1452 | `(a b tofu d tofu e) 1453 | `(tofu d tofu e))) 1454 | 1455 | (list `tofu)) 1456 | 1457 | (test-check "testc15.tex-10" 1458 | (run* (q) 1459 | (memo 'tofu '(tofu e) '(tofu e)) 1460 | (== #t q)) 1461 | 1462 | (list #t)) 1463 | 1464 | (test-check "testc15.tex-11" 1465 | (run* (q) 1466 | (memo 'tofu '(tofu e) '(tofu)) 1467 | (== #t q)) 1468 | 1469 | `()) 1470 | 1471 | (test-check "testc15.tex-12" 1472 | (run* (x) 1473 | (memo 'tofu '(tofu e) `(,x e))) 1474 | 1475 | (list `tofu)) 1476 | 1477 | (test-check "testc15.tex-13" 1478 | (run* (x) 1479 | (memo 'tofu '(tofu e) `(peas ,x))) 1480 | 1481 | `()) 1482 | 1483 | (test-check "testc15.tex-14" 1484 | (run* (out) 1485 | (fresh (x) 1486 | (memo 'tofu `(a b ,x d tofu e) out))) 1487 | 1488 | `((tofu d tofu e) (tofu e))) 1489 | 1490 | (test-check "testc15.tex-15" 1491 | (run12 (z) 1492 | (fresh (u) 1493 | (memo 'tofu `(a b tofu d tofu e . ,z) u))) 1494 | 1495 | 1496 | `(_.0 1497 | _.0 1498 | (tofu . _.0) 1499 | (_.0 tofu . _.1) 1500 | (_.0 _.1 tofu . _.2) 1501 | (_.0 _.1 _.2 tofu . _.3) 1502 | (_.0 _.1 _.2 _.3 tofu . _.4) 1503 | (_.0 _.1 _.2 _.3 _.4 tofu . _.5) 1504 | (_.0 _.1 _.2 _.3 _.4 _.5 tofu . _.6) 1505 | (_.0 _.1 _.2 _.3 _.4 _.5 _.6 tofu . _.7) 1506 | (_.0 _.1 _.2 _.3 _.4 _.5 _.6 _.7 tofu . _.8) 1507 | (_.0 _.1 _.2 _.3 _.4 _.5 _.6 _.7 _.8 tofu . _.9)) 1508 | ) 1509 | 1510 | (define rember 1511 | (lambda (x l) 1512 | (cond 1513 | ((null? l) '()) 1514 | ((eq? (car l) x) (cdr l)) 1515 | (else 1516 | (cons (car l) 1517 | (rember x (cdr l))))))) 1518 | 1519 | 1520 | (test-check "testc15.tex-16" 1521 | (rember 'peas '(a b peas d peas e)) 1522 | 1523 | `(a b d peas e)) 1524 | 1525 | (define rembero 1526 | (lambda (x l out) 1527 | (conde 1528 | ((nullo l) (== '() out)) 1529 | ((fresh (a) 1530 | (caro l a) 1531 | (== a x)) 1532 | (cdro l out)) 1533 | ((fresh (res) 1534 | (fresh (d) 1535 | (cdro l d) 1536 | (rembero x d res)) 1537 | (fresh (a) 1538 | (caro l a) 1539 | (conso a res out))))))) 1540 | 1541 | 1542 | (define rembero 1543 | (lambda (x l out) 1544 | (conde 1545 | ((nullo l) (== '() out)) 1546 | ((caro l x) (cdro l out)) 1547 | ((fresh (res) 1548 | (fresh (d) 1549 | (cdro l d) 1550 | (rembero x d res)) 1551 | (fresh (a) 1552 | (caro l a) 1553 | (conso a res out))))))) 1554 | 1555 | 1556 | (fresh (res) 1557 | (fresh (d) 1558 | (cdro l d) 1559 | (rembero x d res)) 1560 | (fresh (a) 1561 | (caro l a) 1562 | (conso a res out))) 1563 | 1564 | 1565 | (fresh (a d res) 1566 | (cdro l d) 1567 | (rembero x d res) 1568 | (caro l a) 1569 | (conso a res out)) 1570 | 1571 | 1572 | (define rembero 1573 | (lambda (x l out) 1574 | (conde 1575 | ((nullo l) (== '() out)) 1576 | ((caro l x) (cdro l out)) 1577 | ( 1578 | 1579 | 1580 | (fresh (a d res) 1581 | (conso a d l) 1582 | (rembero x d res) 1583 | (conso a res out)) 1584 | 1585 | 1586 | )))) 1587 | 1588 | 1589 | (test-check "testc15.tex-17" 1590 | (run1 (out) 1591 | (fresh (y) 1592 | (rembero 'peas `(a b ,y d peas e) out))) 1593 | 1594 | `((a b d peas e))) 1595 | 1596 | (test-check "testc15.tex-18" 1597 | (run* (out) 1598 | (fresh (y z) 1599 | (rembero y `(a b ,y d ,z e) out))) 1600 | 1601 | 1602 | `((b a d _.0 e) 1603 | (a b d _.0 e) 1604 | (a b d _.0 e) 1605 | (a b d _.0 e) 1606 | (a b _.0 d e) 1607 | (a b e d _.0) 1608 | (a b _.0 d _.1 e)) 1609 | ) 1610 | 1611 | (test-check "testc15.tex-19" 1612 | (run* (r) 1613 | (fresh (y z) 1614 | (rembero y `(,y d ,z e) `(,y d e)) 1615 | (== `(,y ,z) r))) 1616 | 1617 | 1618 | `((d d) 1619 | (d d) 1620 | (_.0 _.0) 1621 | (e e)) 1622 | ) 1623 | 1624 | (test-check "testc15.tex-20" 1625 | (run13 (w) 1626 | (fresh (y z out) 1627 | (rembero y `(a b ,y d ,z . ,w) out))) 1628 | 1629 | 1630 | `(_.0 1631 | _.0 1632 | _.0 1633 | _.0 1634 | _.0 1635 | () 1636 | (_.0 . _.1) 1637 | (_.0) 1638 | (_.0 _.1 . _.2) 1639 | (_.0 _.1) 1640 | (_.0 _.1 _.2 . _.3) 1641 | (_.0 _.1 _.2) 1642 | (_.0 _.1 _.2 _.3 . _.4)) 1643 | ) 1644 | 1645 | (define surpriseo 1646 | (lambda (s) 1647 | (rembero s '(a b c) '(a b c)))) 1648 | 1649 | 1650 | (test-check "testc15.tex-21" 1651 | (run* (r) 1652 | (== 'd r) 1653 | (surpriseo r)) 1654 | 1655 | (list 'd)) 1656 | 1657 | (test-check "testc15.tex-22" 1658 | (run* (r) 1659 | (surpriseo r)) 1660 | 1661 | `(_.0)) 1662 | 1663 | (test-check "testc15.tex-23" 1664 | (run* (r) 1665 | (== 'b r) 1666 | (surpriseo r)) 1667 | 1668 | `(b)) 1669 | 1670 | (define new-append 1671 | (lambda (l s) 1672 | (cond 1673 | ((null? l) s) 1674 | (else (cons (car l) 1675 | (new-append (cdr l) s)))))) 1676 | 1677 | 1678 | (test-check "testc16.tex-1" 1679 | (new-append `(a b c) `(d e)) 1680 | 1681 | `(a b c d e)) 1682 | 1683 | (test-check "testc16.tex-2" 1684 | (new-append '(a b c) '()) 1685 | 1686 | `(a b c)) 1687 | 1688 | (test-check "testc16.tex-3" 1689 | (new-append '() '(d e)) 1690 | 1691 | `(d e)) 1692 | 1693 | (test-check "testc16.tex-4" 1694 | (new-append '(d e) 'a) 1695 | 1696 | `(d e . a)) 1697 | 1698 | (define appendo 1699 | (lambda (l s out) 1700 | (conde 1701 | ((nullo l) (== s out)) 1702 | ((fresh (a d res) 1703 | (caro l a) 1704 | (cdro l d) 1705 | (appendo d s res) 1706 | (conso a res out)))))) 1707 | 1708 | 1709 | (test-check "testc16.tex-5" 1710 | (run* (x) 1711 | (appendo 1712 | '(cake) 1713 | '(tastes yummy) 1714 | x)) 1715 | 1716 | (list `(cake tastes yummy))) 1717 | 1718 | (test-check "testc16.tex-6" 1719 | (run* (x) 1720 | (fresh (y) 1721 | (appendo 1722 | `(cake with ice ,y) 1723 | '(tastes yummy) 1724 | x))) 1725 | 1726 | (list `(cake with ice _.0 tastes yummy))) 1727 | 1728 | (test-check "testc16.tex-7" 1729 | (run* (x) 1730 | (fresh (y) 1731 | (appendo 1732 | '(cake with ice cream) 1733 | y 1734 | x))) 1735 | 1736 | (list `(cake with ice cream . _.0))) 1737 | 1738 | (test-check "testc16.tex-8" 1739 | (run1 (x) 1740 | (fresh (y) 1741 | (appendo `(cake with ice . ,y) '(d t) x))) 1742 | 1743 | (list `(cake with ice d t))) 1744 | 1745 | (test-check "testc16.tex-9" 1746 | (run1 (y) 1747 | (fresh (x) 1748 | (appendo `(cake with ice . ,y) '(d t) x))) 1749 | 1750 | 1751 | (list '())) 1752 | 1753 | 1754 | (define appendo 1755 | (lambda (l s out) 1756 | (conde 1757 | ((nullo l) (== s out)) 1758 | ((fresh (a d res) 1759 | (conso a d l) 1760 | (appendo d s res) 1761 | (conso a res out)))))) 1762 | 1763 | 1764 | (test-check "testc16.tex-10" 1765 | (run5 (x) 1766 | (fresh (y) 1767 | (appendo `(cake with ice . ,y) '(d t) x))) 1768 | 1769 | 1770 | `((cake with ice d t) 1771 | (cake with ice _.0 d t) 1772 | (cake with ice _.0 _.1 d t) 1773 | (cake with ice _.0 _.1 _.2 d t) 1774 | (cake with ice _.0 _.1 _.2 _.3 d t)) 1775 | ) 1776 | 1777 | (test-check "testc16.tex-11" 1778 | (run5 (y) 1779 | (fresh (x) 1780 | (appendo `(cake with ice . ,y) '(d t) x))) 1781 | 1782 | 1783 | `(() 1784 | (_.0) 1785 | (_.0 _.1) 1786 | (_.0 _.1 _.2) 1787 | (_.0 _.1 _.2 _.3)) 1788 | ) 1789 | 1790 | (define y 1791 | 1792 | `(_.0 _.1 _.2) 1793 | 1794 | ) 1795 | 1796 | 1797 | (test-check "testc16.tex-12" 1798 | `(cake with ice . ,y) 1799 | 1800 | 1801 | `(cake with ice . (_.0 _.1 _.2)) 1802 | ) 1803 | 1804 | (test-check "testc16.tex-13" 1805 | (run5 (x) 1806 | (fresh (y) 1807 | (appendo 1808 | `(cake with ice . ,y) 1809 | `(d t . ,y) 1810 | x))) 1811 | 1812 | 1813 | `((cake with ice d t) 1814 | (cake with ice _.0 d t _.0) 1815 | (cake with ice _.0 _.1 d t _.0 _.1) 1816 | (cake with ice _.0 _.1 _.2 d t _.0 _.1 _.2) 1817 | (cake with ice _.0 _.1 _.2 _.3 d t _.0 _.1 _.2 _.3)) 1818 | ) 1819 | 1820 | (test-check "testc16.tex-14" 1821 | (run* (x) 1822 | (fresh (z) 1823 | (appendo 1824 | `(cake with ice cream) 1825 | `(d t . ,z) 1826 | x))) 1827 | 1828 | 1829 | `((cake with ice cream d t . _.0)) 1830 | ) 1831 | 1832 | (test-check "testc16.tex-15" 1833 | (run6 (x) 1834 | (fresh (y) 1835 | (appendo x y `(cake with ice d t)))) 1836 | 1837 | 1838 | `(() 1839 | (cake) 1840 | (cake with) 1841 | (cake with ice) 1842 | (cake with ice d) 1843 | (cake with ice d t)) 1844 | ) 1845 | 1846 | (test-check "testc16.tex-16" 1847 | (run6 (y) 1848 | (fresh (x) 1849 | (appendo x y `(cake with ice d t)))) 1850 | 1851 | 1852 | `((cake with ice d t) 1853 | (with ice d t) 1854 | (ice d t) 1855 | (d t) 1856 | (t) 1857 | ()) 1858 | ) 1859 | 1860 | (define appendxyquestion 1861 | (lambda () 1862 | 1863 | 1864 | (run6 (r) 1865 | (fresh (x y) 1866 | (appendo x y `(cake with ice d t)) 1867 | (== `(,x ,y) r))) 1868 | 1869 | 1870 | )) 1871 | (define appendxyanswer 1872 | 1873 | 1874 | `((() (cake with ice d t)) 1875 | ((cake) (with ice d t)) 1876 | ((cake with) (ice d t)) 1877 | ((cake with ice) (d t)) 1878 | ((cake with ice d) (t)) 1879 | ((cake with ice d t) ())) 1880 | 1881 | 1882 | ) 1883 | (test-check "appendxy" 1884 | (appendxyquestion) 1885 | appendxyanswer) 1886 | 1887 | (define e (make-engine (lambda () 1888 | (run7 (r) 1889 | (fresh (x y) 1890 | (appendo x y `(cake with ice d t)) 1891 | (== `(,x ,y) r))) 1892 | ))) 1893 | (printf "Testing testc16.tex-17 (engine with ~s ticks fuel)\n" max-ticks) 1894 | (e max-ticks 1895 | (lambda (t v) (error 'testc16.tex-17 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 1896 | (lambda (e^) (void))) 1897 | 1898 | 1899 | (define appendo 1900 | (lambda (l s out) 1901 | (conde 1902 | ((nullo l) (== s out)) 1903 | ((fresh (a d res) 1904 | (conso a d l) 1905 | (conso a res out) 1906 | (appendo d s res)))))) 1907 | 1908 | 1909 | (test-check "testc16.tex-18" 1910 | (run7 (r) 1911 | (fresh (x y) 1912 | (appendo x y `(cake with ice d t)) 1913 | (== `(,x ,y) r))) 1914 | 1915 | 1916 | appendxyanswer) 1917 | 1918 | 1919 | (test-check "testc16.tex-19" 1920 | (run7 (x) 1921 | (fresh (y z) 1922 | (appendo x y z))) 1923 | 1924 | 1925 | `(() 1926 | (_.0) 1927 | (_.0 _.1) 1928 | (_.0 _.1 _.2) 1929 | (_.0 _.1 _.2 _.3) 1930 | (_.0 _.1 _.2 _.3 _.4) 1931 | (_.0 _.1 _.2 _.3 _.4 _.5)) 1932 | ) 1933 | 1934 | (test-check "testc16.tex-20" 1935 | (run7 (y) 1936 | (fresh (x z) 1937 | (appendo x y z))) 1938 | 1939 | 1940 | `(_.0 1941 | _.0 1942 | _.0 1943 | _.0 1944 | _.0 1945 | _.0 1946 | _.0) 1947 | ) 1948 | 1949 | (test-check "testc16.tex-21" 1950 | (run7 (z) 1951 | (fresh (x y) 1952 | (appendo x y z))) 1953 | 1954 | 1955 | `(_.0 1956 | (_.0 . _.1) 1957 | (_.0 _.1 . _.2) 1958 | (_.0 _.1 _.2 . _.3) 1959 | (_.0 _.1 _.2 _.3 . _.4) 1960 | (_.0 _.1 _.2 _.3 _.4 . _.5) 1961 | (_.0 _.1 _.2 _.3 _.4 _.5 . _.6)) 1962 | ) 1963 | 1964 | (test-check "testc16.tex-22" 1965 | (run7 (r) 1966 | (fresh (x y z) 1967 | (appendo x y z) 1968 | (== `(,x ,y ,z) r))) 1969 | 1970 | 1971 | `((() _.0 _.0) 1972 | ((_.0) _.1 (_.0 . _.1)) 1973 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 1974 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 1975 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)) 1976 | ((_.0 _.1 _.2 _.3 _.4) _.5 (_.0 _.1 _.2 _.3 _.4 . _.5)) 1977 | ((_.0 _.1 _.2 _.3 _.4 _.5) _.6 (_.0 _.1 _.2 _.3 _.4 _.5 . _.6))) 1978 | ) 1979 | 1980 | (define swappendo 1981 | (lambda (l s out) 1982 | (conde 1983 | ((fresh (a d res) 1984 | (conso a d l) 1985 | (conso a res out) 1986 | (swappendo d s res))) 1987 | ((nullo l) (== s out))))) 1988 | 1989 | 1990 | (test-check "testc16.tex-23" 1991 | (run7 (r) 1992 | (fresh (x y z) 1993 | (swappendo x y z) 1994 | (== `(,x ,y ,z) r))) 1995 | 1996 | 1997 | `((() _.0 _.0) 1998 | ((_.0) _.1 (_.0 . _.1)) 1999 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 2000 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 2001 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)) 2002 | ((_.0 _.1 _.2 _.3 _.4) _.5 (_.0 _.1 _.2 _.3 _.4 . _.5)) 2003 | ((_.0 _.1 _.2 _.3 _.4 _.5) _.6 (_.0 _.1 _.2 _.3 _.4 _.5 . _.6))) 2004 | ) 2005 | 2006 | (define unwrap 2007 | (lambda (x) 2008 | (cond 2009 | ((pair? x) (unwrap (car x))) 2010 | (else x)))) 2011 | 2012 | 2013 | (test-check "testc16.tex-24" 2014 | (unwrap '((((pizza))))) 2015 | 2016 | `pizza) 2017 | 2018 | (test-check "testc16.tex-25" 2019 | (unwrap '((((pizza pie) with)) extra cheese)) 2020 | 2021 | `pizza) 2022 | 2023 | (define unwrapo 2024 | (lambda (x out) 2025 | (conde 2026 | ((pairo x) 2027 | (fresh (a) 2028 | (caro x a) 2029 | (unwrapo a out))) 2030 | ((== x out))))) 2031 | 2032 | 2033 | (test-check "testc16.tex-26" 2034 | (run* (x) 2035 | (unwrapo '(((pizza))) x)) 2036 | 2037 | 2038 | `((((pizza))) 2039 | ((pizza)) 2040 | (pizza) 2041 | pizza) 2042 | ) 2043 | 2044 | (test-check "testc16.tex-27" 2045 | (run1 (x) 2046 | (unwrapo x 'pizza)) 2047 | 2048 | 2049 | `(pizza) 2050 | ) 2051 | 2052 | (test-check "testc16.tex-28" 2053 | (run1 (x) 2054 | (unwrapo `((,x)) 'pizza)) 2055 | 2056 | 2057 | `(pizza) 2058 | ) 2059 | 2060 | (test-check "testc16.tex-29" 2061 | (run5 (x) 2062 | (unwrapo x 'pizza)) 2063 | 2064 | 2065 | `(pizza 2066 | (pizza . _.0) 2067 | ((pizza . _.0) . _.1) 2068 | (((pizza . _.0) . _.1) . _.2) 2069 | ((((pizza . _.0) . _.1) . _.2) . _.3)) 2070 | ) 2071 | 2072 | (test-check "testc16.tex-30" 2073 | (run5 (x) 2074 | (unwrapo x '((pizza)))) 2075 | 2076 | 2077 | `(((pizza)) 2078 | (((pizza)) . _.0) 2079 | ((((pizza)) . _.0) . _.1) 2080 | (((((pizza)) . _.0) . _.1) . _.2) 2081 | ((((((pizza)) . _.0) . _.1) . _.2) . _.3)) 2082 | ) 2083 | 2084 | (test-check "testc16.tex-31" 2085 | (run5 (x) 2086 | (unwrapo `((,x)) 'pizza)) 2087 | 2088 | 2089 | `(pizza 2090 | (pizza . _.0) 2091 | ((pizza . _.0) . _.1) 2092 | (((pizza . _.0) . _.1) . _.2) 2093 | ((((pizza . _.0) . _.1) . _.2) . _.3)) 2094 | ) 2095 | 2096 | (define flatten 2097 | (lambda (s) 2098 | (cond 2099 | ((null? s) '()) 2100 | ((pair? s) 2101 | (new-append 2102 | (flatten (car s)) 2103 | (flatten (cdr s)))) 2104 | (else (cons s '()))))) 2105 | 2106 | 2107 | (test-check "testc16.tex-32" 2108 | (flatten '((a b) c)) 2109 | 2110 | `(a b c)) 2111 | 2112 | (define flatteno 2113 | (lambda (s out) 2114 | (conde 2115 | ((nullo s) (== '() out)) 2116 | ((pairo s) 2117 | (fresh (a d res-a res-d) 2118 | (conso a d s) 2119 | (flatteno a res-a) 2120 | (flatteno d res-d) 2121 | (appendo res-a res-d out))) 2122 | ((conso s '() out))))) 2123 | 2124 | 2125 | (test-check "testc16.tex-33" 2126 | (run10 (x) 2127 | (flatteno '((a b) c) x)) 2128 | 2129 | 2130 | `((((a b) c)) 2131 | ((a b) (c)) 2132 | ((a b) c) 2133 | (a (b) (c)) 2134 | ((a b) c ()) 2135 | (a (b) c) 2136 | (a (b) c ()) 2137 | (a b (c)) 2138 | (a b () (c)) 2139 | (a b c)) 2140 | ) 2141 | 2142 | (test-check "testc16.tex-34" 2143 | (run10 (x) 2144 | (flatteno '(a (b c)) x)) 2145 | 2146 | 2147 | `(((a (b c))) 2148 | (a ((b c))) 2149 | (a (b c)) 2150 | (a (b c) ()) 2151 | (a b (c)) 2152 | (a b (c) ()) 2153 | (a b c) 2154 | (a b c ()) 2155 | (a b c ()) 2156 | (a b c () ())) 2157 | ) 2158 | 2159 | (test-check "testc16.tex-35" 2160 | (run* (x) 2161 | (flatteno '(a) x)) 2162 | 2163 | 2164 | `(((a)) 2165 | (a) 2166 | (a ())) 2167 | ) 2168 | 2169 | (test-check "testc16.tex-36" 2170 | (run* (x) 2171 | (flatteno '((a)) x)) 2172 | 2173 | 2174 | `((((a))) 2175 | ((a)) 2176 | ((a) ()) 2177 | (a) 2178 | (a ()) 2179 | (a ()) 2180 | (a () ())) 2181 | ) 2182 | 2183 | (test-check "testc16.tex-37" 2184 | (run* (x) 2185 | (flatteno '(((a))) x)) 2186 | 2187 | 2188 | `(((((a)))) 2189 | (((a))) 2190 | (((a)) ()) 2191 | ((a)) 2192 | ((a) ()) 2193 | ((a) ()) 2194 | ((a) () ()) 2195 | (a) 2196 | (a ()) 2197 | (a ()) 2198 | (a () ()) 2199 | (a ()) 2200 | (a () ()) 2201 | (a () ()) 2202 | (a () () ())) 2203 | ) 2204 | 2205 | (define flattenogrumblequestion 2206 | (lambda () 2207 | 2208 | 2209 | (run* (x) 2210 | (flatteno '((a b) c) x)) 2211 | 2212 | 2213 | )) 2214 | (define flattenogrumbleanswer 2215 | 2216 | 2217 | `((((a b) c)) 2218 | ((a b) (c)) 2219 | ((a b) c) 2220 | (a (b) (c)) 2221 | ((a b) c ()) 2222 | (a (b) c) 2223 | (a (b) c ()) 2224 | (a b (c)) 2225 | (a b () (c)) 2226 | (a b c) 2227 | (a b c ()) 2228 | (a b () c) 2229 | (a b () c ())) 2230 | 2231 | 2232 | ) 2233 | (test-check "flattenogrumble" 2234 | (flattenogrumblequestion) 2235 | flattenogrumbleanswer) 2236 | 2237 | (define e (make-engine (lambda () 2238 | (run* (x) 2239 | (flatteno x '(a b c))) 2240 | ))) 2241 | (printf "Testing testc16.tex-38 (engine with ~s ticks fuel)\n" max-ticks) 2242 | (e max-ticks 2243 | (lambda (t v) (error 'testc16.tex-38 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2244 | (lambda (e^) (void))) 2245 | 2246 | 2247 | (test-check "testc16.tex-39" 2248 | (length 2249 | (run* (x) 2250 | (flatteno '((((a (((b))) c))) d) x))) 2251 | 2252 | 574) 2253 | 2254 | (define strangeo 2255 | (fresh () 2256 | strangeo)) 2257 | 2258 | (define e (make-engine (lambda () 2259 | (run1 (x) 2260 | strangeo) 2261 | ))) 2262 | (printf "Testing testc17.tex-1 (engine with ~s ticks fuel)\n" max-ticks) 2263 | (e max-ticks 2264 | (lambda (t v) (error 'testc17.tex-1 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2265 | (lambda (e^) (void))) 2266 | 2267 | 2268 | (test-check "testc17.tex-2" 2269 | (run1 (q) 2270 | (conde 2271 | (strangeo) 2272 | (succeed))) 2273 | 2274 | `(_.0)) 2275 | 2276 | (define strangero 2277 | (conde 2278 | (strangero (conde 2279 | (strangero) 2280 | (succeed))) 2281 | (succeed))) 2282 | 2283 | 2284 | (test-check "testc17.tex-3" 2285 | (run5 (q) 2286 | strangero) 2287 | 2288 | `(_.0 _.0 _.0 _.0 _.0)) 2289 | 2290 | (define strangesto 2291 | (lambda (x y) 2292 | (conde 2293 | ((strangesto y x) (== #f y)) 2294 | ((== #f x))))) 2295 | 2296 | 2297 | (test-check "testc17.tex-4" 2298 | (run5 (q) 2299 | (fresh (x y) 2300 | (strangesto x y) 2301 | (== `(,x ,y) q))) 2302 | 2303 | `((#f _.0) (_.0 #f) (#f #f) (#f #f) (#f #f))) 2304 | 2305 | (define any* 2306 | (lambda (g) 2307 | (conde 2308 | (g) 2309 | ((any* g))))) 2310 | 2311 | 2312 | (define never (any* fail)) 2313 | 2314 | (define e (make-engine (lambda () 2315 | (run1 (q) 2316 | never 2317 | (== #t q)) 2318 | ))) 2319 | (printf "Testing testc17.tex-5 (engine with ~s ticks fuel)\n" max-ticks) 2320 | (e max-ticks 2321 | (lambda (t v) (error 'testc17.tex-5 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2322 | (lambda (e^) (void))) 2323 | 2324 | 2325 | (run1 (q) 2326 | fail 2327 | never) 2328 | 2329 | 2330 | (define always (any* succeed)) 2331 | 2332 | 2333 | (test-check "testc17.tex-6" 2334 | (run1 (q) 2335 | always 2336 | (== #t q)) 2337 | 2338 | (list #t)) 2339 | (define e (make-engine (lambda () 2340 | (run* (q) 2341 | always 2342 | (== #t q)) 2343 | ))) 2344 | (printf "Testing testc17.tex-7 (engine with ~s ticks fuel)\n" max-ticks) 2345 | (e max-ticks 2346 | (lambda (t v) (error 'testc17.tex-7 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2347 | (lambda (e^) (void))) 2348 | 2349 | 2350 | (test-check "testc17.tex-8" 2351 | (run5 (q) 2352 | always 2353 | (== #t q)) 2354 | 2355 | `(#t #t #t #t #t)) 2356 | 2357 | (test-check "testc17.tex-9" 2358 | (run5 (q) 2359 | (== #t q) 2360 | always) 2361 | 2362 | `(#t #t #t #t #t)) 2363 | 2364 | (define salo 2365 | (lambda (g) 2366 | (conde 2367 | (succeed) 2368 | (g)))) 2369 | 2370 | 2371 | (test-check "testc17.tex-10" 2372 | (run1 (q) 2373 | (salo always) 2374 | (== #t q)) 2375 | 2376 | `(#t)) 2377 | 2378 | (test-check "testc17.tex-11" 2379 | (run1 (q) 2380 | (salo never) 2381 | (== #t q)) 2382 | 2383 | `(#t)) 2384 | (define e (make-engine (lambda () 2385 | (run* (q) 2386 | (salo never) 2387 | (== #t q)) 2388 | ))) 2389 | (printf "Testing testc17.tex-12 (engine with ~s ticks fuel)\n" max-ticks) 2390 | (e max-ticks 2391 | (lambda (t v) (error 'testc17.tex-12 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2392 | (lambda (e^) (void))) 2393 | 2394 | (define e (make-engine (lambda () 2395 | (run1 (q) 2396 | (salo never) 2397 | fail 2398 | (== #t q)) 2399 | ))) 2400 | (printf "Testing testc17.tex-13 (engine with ~s ticks fuel)\n" max-ticks) 2401 | (e max-ticks 2402 | (lambda (t v) (error 'testc17.tex-13 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2403 | (lambda (e^) (void))) 2404 | 2405 | (define e (make-engine (lambda () 2406 | (run1 (q) 2407 | always 2408 | fail 2409 | (== #t q)) 2410 | ))) 2411 | (printf "Testing testc17.tex-14 (engine with ~s ticks fuel)\n" max-ticks) 2412 | (e max-ticks 2413 | (lambda (t v) (error 'testc17.tex-14 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2414 | (lambda (e^) (void))) 2415 | 2416 | 2417 | (test-check "testc17.tex-15" 2418 | (run1 (q) 2419 | (conde 2420 | ((== #f q) always) 2421 | ((== #t q))) 2422 | (== #t q)) 2423 | 2424 | `(#t)) 2425 | (define e (make-engine (lambda () 2426 | (run2 (q) 2427 | (conde 2428 | ((== #f q) always) 2429 | ((== #t q))) 2430 | (== #t q)) 2431 | ))) 2432 | (printf "Testing testc17.tex-16 (engine with ~s ticks fuel)\n" max-ticks) 2433 | (e max-ticks 2434 | (lambda (t v) (error 'testc17.tex-16 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 2435 | (lambda (e^) (void))) 2436 | 2437 | 2438 | (test-check "testc17.tex-17" 2439 | (run5 (q) 2440 | (conde 2441 | ((== #f q) always) 2442 | ((any* (== #t q)))) 2443 | (== #t q)) 2444 | 2445 | 2446 | `(#t #t #t #t #t) 2447 | ) 2448 | 2449 | (test-check "testc17.tex-18" 2450 | (run5 (q) 2451 | (conde 2452 | (always) 2453 | (never)) 2454 | (== #t q)) 2455 | 2456 | `(#t #t #t #t #t)) 2457 | 2458 | (test-check "testc17.tex-19" 2459 | (run1 (q) 2460 | (fresh () 2461 | (conde 2462 | ((== #f q)) 2463 | ((== #t q))) 2464 | always) 2465 | (== #t q)) 2466 | 2467 | `(#t)) 2468 | 2469 | (test-check "testc17.tex-20" 2470 | (run5 (q) 2471 | (fresh () 2472 | (conde 2473 | ((== #f q)) 2474 | ((== #t q))) 2475 | always) 2476 | (== #t q)) 2477 | 2478 | `(#t #t #t #t #t)) 2479 | 2480 | (test-check "testc17.tex-21" 2481 | (run5 (q) 2482 | (fresh () 2483 | (conde 2484 | ((== #t q)) 2485 | ((== #f q))) 2486 | always) 2487 | (== #t q)) 2488 | 2489 | `(#t #t #t #t #t)) 2490 | 2491 | (define bit-xoro 2492 | (lambda (x y r) 2493 | (conde 2494 | ((== 0 x) (== 0 y) (== 0 r)) 2495 | ((== 0 x) (== 1 y) (== 1 r)) 2496 | ((== 1 x) (== 0 y) (== 1 r)) 2497 | ((== 1 x) (== 1 y) (== 0 r))))) 2498 | 2499 | 2500 | (test-check "testc20.tex-1" 2501 | (run* (s) 2502 | (fresh (x y) 2503 | (bit-xoro x y 0) 2504 | (== `(,x ,y) s))) 2505 | 2506 | 2507 | `((0 0) 2508 | (1 1)) 2509 | ) 2510 | 2511 | (test-check "testc20.tex-2" 2512 | (run* (s) 2513 | (fresh (x y) 2514 | (bit-xoro x y 1) 2515 | (== `(,x ,y) s))) 2516 | 2517 | 2518 | `((0 1) 2519 | (1 0)) 2520 | ) 2521 | 2522 | (test-check "testc20.tex-3" 2523 | (run* (s) 2524 | (fresh (x y r) 2525 | (bit-xoro x y r) 2526 | (== `(,x ,y ,r) s))) 2527 | 2528 | 2529 | `((0 0 0) 2530 | (0 1 1) 2531 | (1 0 1) 2532 | (1 1 0)) 2533 | ) 2534 | 2535 | (define bit-ando 2536 | (lambda (x y r) 2537 | (conde 2538 | ((== 0 x) (== 0 y) (== 0 r)) 2539 | ((== 1 x) (== 0 y) (== 0 r)) 2540 | ((== 0 x) (== 1 y) (== 0 r)) 2541 | ((== 1 x) (== 1 y) (== 1 r))))) 2542 | 2543 | 2544 | (test-check "testc20.tex-4" 2545 | (run* (s) 2546 | (fresh (x y) 2547 | (bit-ando x y 1) 2548 | (== `(,x ,y) s))) 2549 | 2550 | 2551 | `((1 1)) 2552 | ) 2553 | 2554 | (define half-addero 2555 | (lambda (x y r c) 2556 | (fresh () 2557 | (bit-xoro x y r) 2558 | (bit-ando x y c)))) 2559 | 2560 | 2561 | (test-check "testc20.tex-5" 2562 | (run* (r) 2563 | (half-addero 1 1 r 1)) 2564 | 2565 | (list 0)) 2566 | 2567 | (test-check "testc20.tex-6" 2568 | (run* (s) 2569 | (fresh (x y r c) 2570 | (half-addero x y r c) 2571 | (== `(,x ,y ,r ,c) s))) 2572 | 2573 | 2574 | `((0 0 0 0) 2575 | (0 1 1 0) 2576 | (1 0 1 0) 2577 | (1 1 0 1)) 2578 | ) 2579 | 2580 | (define full-addero 2581 | (lambda (b x y r c) 2582 | (fresh (w xy wz) 2583 | (half-addero x y w xy) 2584 | (half-addero w b r wz) 2585 | (bit-xoro xy wz c)))) 2586 | 2587 | 2588 | (test-check "testc20.tex-7" 2589 | (run* (s) 2590 | (fresh (r c) 2591 | (full-addero 0 1 1 r c) 2592 | (== `(,r ,c) s))) 2593 | 2594 | (list `(0 1))) 2595 | 2596 | (define full-addero 2597 | (lambda (b x y r c) 2598 | (conde 2599 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 2600 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 2601 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 2602 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 2603 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 2604 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 2605 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 2606 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c))))) 2607 | 2608 | 2609 | (test-check "testc20.tex-8" 2610 | (run* (s) 2611 | (fresh (r c) 2612 | (full-addero 1 1 1 r c) 2613 | (== `(,r ,c) s))) 2614 | 2615 | (list `(1 1))) 2616 | 2617 | (test-check "testc20.tex-9" 2618 | (run* (s) 2619 | (fresh (b x y r c) 2620 | (full-addero b x y r c) 2621 | (== `(,b ,x ,y ,r ,c) s))) 2622 | 2623 | 2624 | `((0 0 0 0 0) 2625 | (1 0 0 1 0) 2626 | (0 1 0 1 0) 2627 | (1 1 0 0 1) 2628 | (0 0 1 1 0) 2629 | (1 0 1 0 1) 2630 | (0 1 1 0 1) 2631 | (1 1 1 1 1)) 2632 | ) 2633 | 2634 | 2635 | (define build-num 2636 | (lambda (n) 2637 | (cond 2638 | ((zero? n) '()) 2639 | ((and (not (zero? n)) (even? n)) 2640 | (cons 0 2641 | (build-num (quotient n 2)))) 2642 | ((odd? n) 2643 | (cons 1 2644 | (build-num (quotient (- n 1) 2))))))) 2645 | 2646 | 2647 | (test-check "testc20.tex-10" `(1 0 1) 2648 | 2649 | (build-num 2650 | 2651 | 5 2652 | 2653 | )) 2654 | 2655 | 2656 | (test-check "testc20.tex-11" `(1 1 1) 2657 | 2658 | (build-num 2659 | 2660 | 7 2661 | 2662 | )) 2663 | 2664 | (test-check "nine" (build-num 2665 | 9 2666 | 2667 | ) 2668 | 2669 | `(1 0 0 1) 2670 | 2671 | ) 2672 | 2673 | (test-check "six" (build-num 2674 | 6 2675 | 2676 | ) 2677 | 2678 | `(0 1 1) 2679 | 2680 | ) 2681 | 2682 | (test-check "nineteen" (build-num 2683 | 19 2684 | 2685 | ) 2686 | 2687 | `(1 1 0 0 1) 2688 | 2689 | ) 2690 | 2691 | (test-check "biggie" (build-num 2692 | 17290 2693 | 2694 | ) 2695 | 2696 | `(0 1 0 1 0 0 0 1 1 1 0 0 0 0 1) 2697 | 2698 | ) 2699 | 2700 | 2701 | (test-check "testc20.tex-12" (build-num 0) 2702 | `()) 2703 | 2704 | (test-check "testc20.tex-13" (build-num 36) 2705 | `(0 0 1 0 0 1)) 2706 | 2707 | (test-check "testc20.tex-14" (build-num 19) 2708 | `(1 1 0 0 1)) 2709 | 2710 | 2711 | (define build-num 2712 | (lambda (n) 2713 | (cond 2714 | ((odd? n) 2715 | (cons 1 2716 | (build-num (quotient (- n 1) 2)))) 2717 | ((and (not (zero? n)) (even? n)) 2718 | (cons 0 2719 | (build-num (quotient n 2)))) 2720 | ((zero? n) '())))) 2721 | 2722 | 2723 | (define poso 2724 | (lambda (n) 2725 | (fresh (a d) 2726 | (== `(,a . ,d) n)))) 2727 | 2728 | 2729 | (test-check "testc20.tex-15" 2730 | (run* (q) 2731 | (poso '(0 1 1)) 2732 | (== #t q)) 2733 | 2734 | (list #t)) 2735 | 2736 | (test-check "testc20.tex-16" 2737 | (run* (q) 2738 | (poso '(1)) 2739 | (== #t q)) 2740 | 2741 | (list #t)) 2742 | 2743 | (test-check "testc20.tex-17" 2744 | (run* (q) 2745 | (poso '()) 2746 | (== #t q)) 2747 | 2748 | `()) 2749 | 2750 | (test-check "testc20.tex-18" 2751 | (run* (r) 2752 | (poso r)) 2753 | 2754 | (list `(_.0 . _.1))) 2755 | 2756 | (define >1o 2757 | (lambda (n) 2758 | (fresh (a ad dd) 2759 | (== `(,a ,ad . ,dd) n)))) 2760 | 2761 | 2762 | (test-check "testc20.tex-19" 2763 | (run* (q) 2764 | (>1o '(0 1 1)) 2765 | (== #t q)) 2766 | 2767 | (list #t)) 2768 | 2769 | (test-check "testc20.tex-20" 2770 | (run* (q) 2771 | (>1o '(0 1)) 2772 | (== #t q)) 2773 | 2774 | `(#t)) 2775 | 2776 | (test-check "testc20.tex-21" 2777 | (run* (q) 2778 | (>1o '(1)) 2779 | (== #t q)) 2780 | 2781 | `()) 2782 | 2783 | (test-check "testc20.tex-22" 2784 | (run* (q) 2785 | (>1o '()) 2786 | (== #t q)) 2787 | 2788 | `()) 2789 | 2790 | (test-check "testc20.tex-23" 2791 | (run* (r) 2792 | (>1o r)) 2793 | 2794 | (list 2795 | `(_.0 _.1 . _.2) 2796 | )) 2797 | 2798 | 2799 | (define addero 2800 | (lambda (d n m r) 2801 | (conde 2802 | ((== 0 d) (== '() m) (== n r)) 2803 | ((== 0 d) (== '() n) (== m r) 2804 | (poso m)) 2805 | ((== 1 d) (== '() m) 2806 | (addero 0 n '(1) r)) 2807 | ((== 1 d) (== '() n) (poso m) 2808 | (addero 0 '(1) m r)) 2809 | ((== '(1) n) (== '(1) m) 2810 | (fresh (a c) 2811 | (== `(,a ,c) r) 2812 | (full-addero d 1 1 a c))) 2813 | ((== '(1) n) (gen-addero d n m r)) 2814 | ((== '(1) m) (>1o n) (>1o r) 2815 | (addero d '(1) n r)) 2816 | ((>1o n) (gen-addero d n m r))))) 2817 | 2818 | (define gen-addero 2819 | (lambda (d n m r) 2820 | (fresh (a b c e x y z) 2821 | (== `(,a . ,x) n) 2822 | (== `(,b . ,y) m) (poso y) 2823 | (== `(,c . ,z) r) (poso z) 2824 | (full-addero d a b c e) 2825 | (addero e x y z)))) 2826 | 2827 | 2828 | (test-check "testc20.tex-24" 2829 | (run3 (s) 2830 | (fresh (x y r) 2831 | (addero 0 x y r) 2832 | (== `(,x ,y ,r) s))) 2833 | 2834 | 2835 | `((_.0 () _.0) 2836 | (() (_.0 . _.1) (_.0 . _.1)) 2837 | ((1) (1) (0 1))) 2838 | ) 2839 | 2840 | (test-check "testc20.tex-25" 2841 | (run22 (s) 2842 | (fresh (x y r) 2843 | (addero 0 x y r) 2844 | (== `(,x ,y ,r) s))) 2845 | 2846 | 2847 | `((_.0 () _.0) 2848 | (() (_.0 . _.1) (_.0 . _.1)) 2849 | ((1) (1) (0 1)) 2850 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 2851 | ((1) (1 1) (0 0 1)) 2852 | ((0 _.0 . _.1) (1) (1 _.0 . _.1)) 2853 | ((1) (1 0 _.0 . _.1) (0 1 _.0 . _.1)) 2854 | ((0 1) (0 1) (0 0 1)) 2855 | ((1) (1 1 1) (0 0 0 1)) 2856 | ((1 1) (1) (0 0 1)) 2857 | ((1) (1 1 0 _.0 . _.1) (0 0 1 _.0 . _.1)) 2858 | ((1 1) (0 1) (1 0 1)) 2859 | ((1) (1 1 1 1) (0 0 0 0 1)) 2860 | ((1 0 _.0 . _.1) (1) (0 1 _.0 . _.1)) 2861 | ((1) (1 1 1 0 _.0 . _.1) (0 0 0 1 _.0 . _.1)) 2862 | ((1) (1 1 1 1 1) (0 0 0 0 0 1)) 2863 | ((1 1 1) (1) (0 0 0 1)) 2864 | ((1) (1 1 1 1 0 _.0 . _.1) (0 0 0 0 1 _.0 . _.1)) 2865 | ((1) (1 1 1 1 1 1) (0 0 0 0 0 0 1)) 2866 | ((0 1) (1 1) (1 0 1)) 2867 | ((1 1 0 _.0 . _.1) (1) (0 0 1 _.0 . _.1)) 2868 | ((1) (1 1 1 1 1 0 _.0 . _.1) (0 0 0 0 0 1 _.0 . _.1))) 2869 | ) 2870 | 2871 | 2872 | 2873 | (test-check "testc20.tex-26" 2874 | (run* (s) 2875 | (gen-addero 1 '(0 1 1) '(1 1) s)) 2876 | 2877 | (list `(0 1 0 1))) 2878 | 2879 | (test-check "testc20.tex-27" 2880 | (run* (s) 2881 | (fresh (x y) 2882 | (addero 0 x y '(1 0 1)) 2883 | (== `(,x ,y) s))) 2884 | 2885 | 2886 | `(((1 0 1) ()) 2887 | (() (1 0 1)) 2888 | ((1) (0 0 1)) 2889 | ((0 0 1) (1)) 2890 | ((1 1) (0 1)) 2891 | ((0 1) (1 1))) 2892 | ) 2893 | 2894 | (run* (s) 2895 | (fresh (x y) 2896 | (addero 0 x y '(1 0 1)) 2897 | (== `(,x ,y) s))) 2898 | 2899 | 2900 | (define pluso 2901 | (lambda (n m k) 2902 | (addero 0 n m k))) 2903 | 2904 | 2905 | (run* (s) 2906 | (fresh (x y) 2907 | (pluso x y '(1 0 1)) 2908 | (== `(,x ,y) s))) 2909 | 2910 | 2911 | (test-check "testc20.tex-28" 2912 | (run* (s) 2913 | (fresh (x y) 2914 | (pluso x y '(1 0 1)) 2915 | (== `(,x ,y) s))) 2916 | 2917 | 2918 | `(((1 0 1) ()) 2919 | (() (1 0 1)) 2920 | ((1) (0 0 1)) 2921 | ((0 0 1) (1)) 2922 | ((1 1) (0 1)) 2923 | ((0 1) (1 1))) 2924 | ) 2925 | 2926 | (define minuso 2927 | (lambda (n m k) 2928 | (pluso m k n))) 2929 | 2930 | 2931 | (test-check "testc20.tex-29" 2932 | (run* (q) 2933 | (minuso '(0 0 0 1) '(1 0 1) q)) 2934 | 2935 | 2936 | `((1 1)) 2937 | ) 2938 | 2939 | (test-check "testc20.tex-30" 2940 | (run* (q) 2941 | (minuso '(0 1 1) '(0 1 1) q)) 2942 | 2943 | 2944 | `(()) 2945 | ) 2946 | 2947 | (test-check "testc20.tex-31" 2948 | (run* (q) 2949 | (minuso '(0 1 1) '(0 0 0 1) q)) 2950 | 2951 | 2952 | `() 2953 | ) 2954 | 2955 | 2956 | (define *o 2957 | (lambda (n m p) 2958 | (conde 2959 | ((== '() n) (== '() p)) 2960 | ((poso n) (== '() m) (== '() p)) 2961 | ((== '(1) n) (poso m) (== m p)) 2962 | ((>1o n) (== '(1) m) (== n p)) 2963 | ((fresh (x z) 2964 | (== `(0 . ,x) n) (poso x) 2965 | (== `(0 . ,z) p) (poso z) 2966 | (>1o m) 2967 | (*o x m z))) 2968 | ((fresh (x y) 2969 | (== `(1 . ,x) n) (poso x) 2970 | (== `(0 . ,y) m) (poso y) 2971 | (*o m n p))) 2972 | ((fresh (x y) 2973 | (== `(1 . ,x) n) (poso x) 2974 | (== `(1 . ,y) m) (poso y) 2975 | (odd-*o x n m p)))))) 2976 | 2977 | (define odd-*o 2978 | (lambda (x n m p) 2979 | (fresh (q) 2980 | (bound-*o q p n m) 2981 | (*o x m q) 2982 | (pluso `(0 . ,q) m p)))) 2983 | 2984 | (define bound-*o 2985 | (lambda (q p n m) 2986 | (conde 2987 | ((nullo q) (pairo p)) 2988 | ((fresh (x y z) 2989 | (cdro q x) 2990 | (cdro p y) 2991 | (conde 2992 | ((nullo n) 2993 | (cdro m z) 2994 | (bound-*o x y z '())) 2995 | ((cdro n z) 2996 | (bound-*o x y z m)))))))) 2997 | 2998 | 2999 | (test-check "testc21.tex-1" 3000 | (run34 (t) 3001 | (fresh (x y r) 3002 | (*o x y r) 3003 | (== `(,x ,y ,r) t))) 3004 | 3005 | 3006 | `((() _.0 ()) 3007 | ((_.0 . _.1) () ()) 3008 | ((1) (_.0 . _.1) (_.0 . _.1)) 3009 | ((_.0 _.1 . _.2) (1) (_.0 _.1 . _.2)) 3010 | ((0 1) (_.0 _.1 . _.2) (0 _.0 _.1 . _.2)) 3011 | ((0 0 1) (_.0 _.1 . _.2) (0 0 _.0 _.1 . _.2)) 3012 | ((1 _.0 . _.1) (0 1) (0 1 _.0 . _.1)) 3013 | ((0 0 0 1) (_.0 _.1 . _.2) (0 0 0 _.0 _.1 . _.2)) 3014 | ((1 _.0 . _.1) (0 0 1) (0 0 1 _.0 . _.1)) 3015 | ((0 1 _.0 . _.1) (0 1) (0 0 1 _.0 . _.1)) 3016 | ((0 0 0 0 1) (_.0 _.1 . _.2) (0 0 0 0 _.0 _.1 . _.2)) 3017 | ((1 _.0 . _.1) (0 0 0 1) (0 0 0 1 _.0 . _.1)) 3018 | ((0 1 _.0 . _.1) (0 0 1) (0 0 0 1 _.0 . _.1)) 3019 | ((0 0 1 _.0 . _.1) (0 1) (0 0 0 1 _.0 . _.1)) 3020 | ((1 1) (1 1) (1 0 0 1)) 3021 | ((0 0 0 0 0 1) (_.0 _.1 . _.2) (0 0 0 0 0 _.0 _.1 . _.2)) 3022 | ((1 _.0 . _.1) (0 0 0 0 1) (0 0 0 0 1 _.0 . _.1)) 3023 | ((0 1 _.0 . _.1) (0 0 0 1) (0 0 0 0 1 _.0 . _.1)) 3024 | ((0 0 1 _.0 . _.1) (0 0 1) (0 0 0 0 1 _.0 . _.1)) 3025 | ((0 0 0 1 _.0 . _.1) (0 1) (0 0 0 0 1 _.0 . _.1)) 3026 | ((1 1) (1 0 1) (1 1 1 1)) 3027 | ((0 1 1) (1 1) (0 1 0 0 1)) 3028 | ((1 1) (1 1 1) (1 0 1 0 1)) 3029 | ((1 1) (0 1 1) (0 1 0 0 1)) 3030 | ((0 0 0 0 0 0 1) (_.0 _.1 . _.2) (0 0 0 0 0 0 _.0 _.1 . _.2)) 3031 | ((1 _.0 . _.1) (0 0 0 0 0 1) (0 0 0 0 0 1 _.0 . _.1)) 3032 | ((0 1 _.0 . _.1) (0 0 0 0 1) (0 0 0 0 0 1 _.0 . _.1)) 3033 | ((0 0 1 _.0 . _.1) (0 0 0 1) (0 0 0 0 0 1 _.0 . _.1)) 3034 | ((0 0 0 1 _.0 . _.1) (0 0 1) (0 0 0 0 0 1 _.0 . _.1)) 3035 | ((1 0 1) (1 1) (1 1 1 1)) 3036 | ((0 0 0 0 1 _.0 . _.1) (0 1) (0 0 0 0 0 1 _.0 . _.1)) 3037 | ((0 1 1) (1 0 1) (0 1 1 1 1)) 3038 | ((0 0 1 1) (1 1) (0 0 1 0 0 1)) 3039 | ((1 1) (1 0 0 1) (1 1 0 1 1))) 3040 | ) 3041 | 3042 | (test-check "testc21.tex-2" 3043 | (run* (p) 3044 | (*o '(0 1) '(0 0 1) p)) 3045 | 3046 | (list `(0 0 0 1))) 3047 | 3048 | 3049 | 3050 | (define bound-*o 3051 | (lambda (q p n m) 3052 | succeed)) 3053 | 3054 | 3055 | (test-check "testc21.tex-3" 3056 | (run1 (t) 3057 | (fresh (n m) 3058 | (*o n m '(1)) 3059 | (== `(,n ,m) t))) 3060 | 3061 | (list `((1) (1)))) 3062 | (define e (make-engine (lambda () 3063 | (run2 (t) 3064 | (fresh (n m) 3065 | (*o n m '(1)) 3066 | (== `(,n ,m) t))) 3067 | ))) 3068 | (printf "Testing testc21.tex-4 (engine with ~s ticks fuel)\n" max-ticks) 3069 | (e max-ticks 3070 | (lambda (t v) (error 'testc21.tex-4 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3071 | (lambda (e^) (void))) 3072 | 3073 | 3074 | 3075 | (define bound-*o 3076 | (lambda (q p n m) 3077 | (conde 3078 | ((nullo q) (pairo p)) 3079 | ((fresh (x y z) 3080 | (cdro q x) 3081 | (cdro p y) 3082 | (conde 3083 | ((nullo n) 3084 | (cdro m z) 3085 | (bound-*o x y z '())) 3086 | ((cdro n z) 3087 | (bound-*o x y z m)))))))) 3088 | 3089 | 3090 | 3091 | (test-check "testc21.tex-5" 3092 | (run2 (t) 3093 | (fresh (n m) 3094 | (*o n m '(1)) 3095 | (== `(,n ,m) t))) 3096 | 3097 | `(((1) (1)))) 3098 | 3099 | (test-check "testc21.tex-6" 3100 | (run* (p) 3101 | (*o '(1 1 1) '(1 1 1 1 1 1) p)) 3102 | 3103 | (list `(1 0 0 1 1 1 0 1 1))) 3104 | 3105 | (define =lo 3106 | (lambda (n m) 3107 | (conde 3108 | ((== '() n) (== '() m)) 3109 | ((== '(1) n) (== '(1) m)) 3110 | ((fresh (a x b y) 3111 | (== `(,a . ,x) n) (poso x) 3112 | (== `(,b . ,y) m) (poso y) 3113 | (=lo x y)))))) 3114 | 3115 | 3116 | (test-check "testc21.tex-7" 3117 | (run* (t) 3118 | (fresh (w x y) 3119 | (=lo `(1 ,w ,x . ,y) '(0 1 1 0 1)) 3120 | (== `(,w ,x ,y) t))) 3121 | 3122 | (list `(_.0 _.1 (_.2 1)))) 3123 | 3124 | (test-check "testc21.tex-8" 3125 | (run* (b) 3126 | (=lo '(1) `(,b))) 3127 | 3128 | (list 1)) 3129 | 3130 | (test-check "testc21.tex-9" 3131 | (run* (n) 3132 | (=lo `(1 0 1 . ,n) '(0 1 1 0 1))) 3133 | 3134 | (list 3135 | `(_.0 1) 3136 | )) 3137 | 3138 | (test-check "testc21.tex-10" 3139 | (run5 (t) 3140 | (fresh (y z) 3141 | (=lo `(1 . ,y) `(1 . ,z)) 3142 | (== `(,y ,z) t))) 3143 | 3144 | 3145 | `((() ()) 3146 | ((1) (1)) 3147 | ((_.0 1) (_.1 1)) 3148 | ((_.0 _.1 1) (_.2 _.3 1)) 3149 | ((_.0 _.1 _.2 1) (_.3 _.4 _.5 1))) 3150 | ) 3151 | 3152 | (test-check "testc21.tex-11" 3153 | (run5 (t) 3154 | (fresh (y z) 3155 | (=lo `(1 . ,y) `(0 . ,z)) 3156 | (== `(,y ,z) t))) 3157 | 3158 | 3159 | `(((1) (1)) 3160 | ((_.0 1) (_.1 1)) 3161 | ((_.0 _.1 1) (_.2 _.3 1)) 3162 | ((_.0 _.1 _.2 1) (_.3 _.4 _.5 1)) 3163 | ((_.0 _.1 _.2 _.3 1) (_.4 _.5 _.6 _.7 1))) 3164 | ) 3165 | 3166 | (test-check "testc21.tex-12" 3167 | (run5 (t) 3168 | (fresh (y z) 3169 | (=lo `(1 . ,y) `(0 1 1 0 1 . ,z)) 3170 | (== `(,y ,z) t))) 3171 | 3172 | 3173 | `(((_.0 _.1 _.2 1) ()) 3174 | ((_.0 _.1 _.2 _.3 1) (1)) 3175 | ((_.0 _.1 _.2 _.3 _.4 1) (_.5 1)) 3176 | ((_.0 _.1 _.2 _.3 _.4 _.5 1) (_.6 _.7 1)) 3177 | ((_.0 _.1 _.2 _.3 _.4 _.5 _.6 1) (_.7 _.8 _.9 1))) 3178 | ) 3179 | 3180 | (define 1o m)) 3185 | ((fresh (a x b y) 3186 | (== `(,a . ,x) n) (poso x) 3187 | (== `(,b . ,y) m) (poso y) 3188 | (1o b) (=lo n b) (pluso r b n)) 3535 | ((== '(1) b) (poso q) (pluso r '(1) n)) 3536 | ((== '() b) (poso q) (== r n)) 3537 | ((== '(0 1) b) 3538 | (fresh (a ad dd) 3539 | (poso dd) 3540 | (== `(,a ,ad . ,dd) n) 3541 | (exp2 n '() q) 3542 | (fresh (s) 3543 | (splito n dd r s)))) 3544 | ((fresh (a ad add ddd) 3545 | (conde 3546 | ((== '(1 1) b)) 3547 | ((== `(,a ,ad ,add . ,ddd) b)))) 3548 | (1o n) (== '(1) q) 3581 | (fresh (s) 3582 | (splito n b s '(1)))) 3583 | ((fresh (q1 b2) 3584 | (== `(0 . ,q1) q) 3585 | (poso q1) 3586 | (1o q) 3604 | (fresh (q1 nq1) 3605 | (pluso q1 '(1) q) 3606 | (repeated-mul n q1 nq1) 3607 | (*o nq1 n nq)))))) 3608 | 3609 | 3610 | (test-check "testc21.tex-26" 3611 | (run* (r) 3612 | (logo '(0 1 1 1) '(0 1) '(1 1) r)) 3613 | 3614 | (list `(0 1 1))) 3615 | 3616 | 3617 | '(printf "This next test takes several minutes to run!\n") 3618 | 3619 | 3620 | '(test-check "testc21.tex-27" 3621 | (run9 (s) 3622 | (fresh (b q r) 3623 | (logo '(0 0 1 0 0 0 1) b q r) 3624 | (>1o q) 3625 | (== `(,b ,q ,r) s))) 3626 | 3627 | 3628 | `((() (_.0 _.1 . _.2) (0 0 1 0 0 0 1)) 3629 | ((1) (_.0 _.1 . _.2) (1 1 0 0 0 0 1)) 3630 | ((0 1) (0 1 1) (0 0 1)) 3631 | ((1 1) (1 1) (1 0 0 1 0 1)) 3632 | ((0 0 1) (1 1) (0 0 1)) 3633 | ((0 0 0 1) (0 1) (0 0 1)) 3634 | ((1 0 1) (0 1) (1 1 0 1 0 1)) 3635 | ((0 1 1) (0 1) (0 0 0 0 0 1)) 3636 | ((1 1 1) (0 1) (1 1 0 0 1))) 3637 | ) 3638 | 3639 | (define expo 3640 | (lambda (b q n) 3641 | (logo n b q '()))) 3642 | 3643 | 3644 | '(test-check "testc21.tex-28" 3645 | (run* (t) 3646 | (expo '(1 1) '(1 0 1) t)) 3647 | 3648 | (list `(1 1 0 0 1 1 1 1))) 3649 | 3650 | (define u (var 'u)) 3651 | 3652 | (define v (var 'v)) 3653 | 3654 | (define w (var 'w)) 3655 | 3656 | 3657 | (define x (var 'x)) 3658 | 3659 | (define y (var 'y)) 3660 | 3661 | (define z (var 'z)) 3662 | 3663 | 3664 | (test-check "testc22.tex-1" 3665 | (rhs `(,z . b)) 3666 | 3667 | 'b) 3668 | 3669 | (test-check "testc22.tex-2" 3670 | (rhs `(,z . ,w)) 3671 | 3672 | w) 3673 | 3674 | (test-check "testc22.tex-3" 3675 | (rhs `(,z . (,x e ,y))) 3676 | 3677 | `(,x e ,y)) 3678 | 3679 | 3680 | (test-check "testc22.tex-4" 3681 | (walk z `((,z . a) (,x . ,w) (,y . ,z))) 3682 | 3683 | 'a) 3684 | 3685 | (test-check "testc22.tex-5" 3686 | (walk y `((,z . a) (,x . ,w) (,y . ,z))) 3687 | 3688 | 'a) 3689 | 3690 | (test-check "testc22.tex-6" 3691 | (walk x `((,z . a) (,x . ,w) (,y . ,z))) 3692 | 3693 | w) 3694 | 3695 | (test-check "testc22.tex-7" 3696 | (walk w `((,z . a) (,x . ,w) (,y . ,z))) 3697 | 3698 | w) 3699 | 3700 | (test-check "testc22.tex-8" 3701 | (walk u `((,x . b) (,w . (,x e ,x)) (,u . ,w))) 3702 | 3703 | `(,x e ,x)) 3704 | 3705 | 3706 | (test-check "testc22.tex-9" 3707 | (walk y (ext-s x 'e `((,z . ,x) (,y . ,z)))) 3708 | 3709 | 'e) 3710 | 3711 | (test-check "testc22.tex-10" 3712 | (walk y `((,x . e))) 3713 | 3714 | y) 3715 | 3716 | (test-check "testc22.tex-11" 3717 | (walk x `((,y . ,z) (,x . ,y))) 3718 | 3719 | z) 3720 | 3721 | (test-check "testc22.tex-12" 3722 | (walk x (ext-s y z `((,x . ,y)))) 3723 | 3724 | z) 3725 | 3726 | (test-check "testc22.tex-13" 3727 | (walk x (ext-s z 'b `((,y . ,z) (,x . ,y)))) 3728 | 3729 | 'b) 3730 | 3731 | (test-check "testc22.tex-14" 3732 | (walk x (ext-s z w `((,y . ,z) (,x . ,y)))) 3733 | 3734 | w) 3735 | 3736 | 3737 | (test-check "testc22.tex-15" 3738 | (occurs-check z u 3739 | `((,x . (a ,y)) (,w . (,x e ,x)) (,u . ,w) (,y . (,z)))) 3740 | 3741 | #t) 3742 | 3743 | 3744 | 3745 | (test-check "testc22.tex-16" 3746 | (walk* x 3747 | `((,y . (a ,z c)) (,x . ,y) (,z . a))) 3748 | 3749 | `(a a c)) 3750 | 3751 | (test-check "testc22.tex-17" 3752 | (walk* x 3753 | `((,y . (,z ,w c)) (,x . ,y) (,z . a))) 3754 | 3755 | `(a ,w c)) 3756 | 3757 | (test-check "testc22.tex-18" 3758 | (walk* y 3759 | `((,y . (,w ,z c)) (,v . b) (,x . ,v) (,z . ,x))) 3760 | 3761 | `(,w b c)) 3762 | 3763 | 3764 | 3765 | (test-check "testc22.tex-19" 3766 | (run* (q) 3767 | (== #f q) 3768 | (project (q) 3769 | (== (not (not q)) q))) 3770 | 3771 | '(#f)) 3772 | 3773 | 3774 | 3775 | (test-check "testc22.tex-20" 3776 | (let ((r (walk* `(,x ,y ,z) empty-s))) 3777 | (walk* r (reify-s r empty-s))) 3778 | 3779 | `(_.0 _.1 _.2)) 3780 | 3781 | (test-check "testc22.tex-21" 3782 | (let ((r `(,u (,v (,w ,x) ,y) ,x))) 3783 | (walk* r (reify-s r empty-s))) 3784 | 3785 | `(_.0 (_.1 (_.2 _.3) _.4) _.3)) 3786 | 3787 | (test-check "testc22.tex-22" 3788 | (let ((s `((,y . (,z ,w c ,w)) (,x . ,y) (,z . a)))) 3789 | (let ((r (walk* x s))) 3790 | (walk* r (reify-s r empty-s)))) 3791 | 3792 | `(a _.0 c _.0)) 3793 | 3794 | (test-check "testc22.tex-23" 3795 | (let ((s `((,y . (,z ,w c ,w)) (,x . ,y) (,z . ,u)))) 3796 | (let ((r (walk* x s))) 3797 | (walk* r (reify-s r empty-s)))) 3798 | 3799 | `(_.0 _.1 c _.1)) 3800 | 3801 | 3802 | (test-check "testc22.tex-24" 3803 | (let ((s `((,y . (,z ,w c ,w)) (,x . ,y) (,z . a)))) 3804 | (reify x s)) 3805 | 3806 | `(a _.0 c _.0)) 3807 | (define e (make-engine (lambda () 3808 | (run1 (x) 3809 | (== `(,x) x)) 3810 | ))) 3811 | (printf "Testing testc22.tex-25 (engine with ~s ticks fuel)\n" max-ticks) 3812 | (e max-ticks 3813 | (lambda (t v) (error 'testc22.tex-25 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3814 | (lambda (e^) (void))) 3815 | 3816 | (test-check "testc22.tex-28" 3817 | (run1 (x) 3818 | (== `(,x) x)) 3819 | 3820 | `()) 3821 | (define e (make-engine (lambda () 3822 | (run1 (x) 3823 | (fresh (y z) 3824 | (== x z) 3825 | (== `(a b ,z) y) 3826 | (== x y))) 3827 | ))) 3828 | (printf "Testing testc22.tex-29 (engine with ~s ticks fuel)\n" max-ticks) 3829 | (e max-ticks 3830 | (lambda (t v) (error 'testc22.tex-29 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3831 | (lambda (e^) (void))) 3832 | 3833 | 3834 | (test-check "testc22.tex-30" 3835 | (run1 (x) 3836 | (fresh (y z) 3837 | (== x z) 3838 | (== `(a b ,z) y) 3839 | (== x y))) 3840 | `()) 3841 | (define e (make-engine (lambda () 3842 | (run1 (x) 3843 | (== `(,x) x)) 3844 | ))) 3845 | (printf "Testing testc22.tex-31 (engine with ~s ticks fuel)\n" max-ticks) 3846 | (e max-ticks 3847 | (lambda (t v) (error 'testc22.tex-31 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3848 | (lambda (e^) (void))) 3849 | 3850 | 3851 | (test-check "testc23.tex-fail1" (run* (q) 3852 | 3853 | 3854 | (conda 3855 | (fail succeed) 3856 | (fail)) 3857 | 3858 | 3859 | ) '()) 3860 | 3861 | 3862 | (test-check "testc23.tex-succeed1" (not (null? (run* (q) 3863 | 3864 | 3865 | (conda 3866 | (fail succeed) 3867 | (succeed)) 3868 | 3869 | 3870 | ))) #t) 3871 | 3872 | 3873 | (test-check "testc23.tex-succeed1" (not (null? (run* (q) 3874 | 3875 | 3876 | (conda 3877 | (succeed fail) 3878 | (succeed)) 3879 | 3880 | 3881 | ))) #f) 3882 | 3883 | 3884 | (test-check "testc23.tex-succeed2" (not (null? (run* (q) 3885 | 3886 | 3887 | (conda 3888 | (succeed succeed) 3889 | (fail)) 3890 | 3891 | 3892 | ))) #t) 3893 | 3894 | 3895 | (test-check "testc23.tex-1" 3896 | (run* (x) 3897 | (conda 3898 | ((== 'olive x) succeed) 3899 | ((== 'oil x) succeed))) 3900 | 3901 | `(olive)) 3902 | 3903 | (test-check "testc23.tex-2" 3904 | (run* (x) 3905 | (conda 3906 | ((== 'virgin x) fail) 3907 | ((== 'olive x) succeed) 3908 | ((== 'oil x) succeed))) 3909 | 3910 | `()) 3911 | 3912 | (test-check "testc23.tex-3" 3913 | (run* (q) 3914 | (fresh (x y) 3915 | (== 'split x) 3916 | (== 'pea y) 3917 | (conda 3918 | ((== 'split x) (== x y)) 3919 | (succeed))) 3920 | (== #t q)) 3921 | 3922 | `()) 3923 | 3924 | (test-check "testc23.tex-4" 3925 | (run* (q) 3926 | (fresh (x y) 3927 | (== 'split x) 3928 | (== 'pea y) 3929 | (conda 3930 | ((== x y) (== 'split x)) 3931 | (succeed))) 3932 | (== #t q)) 3933 | 3934 | (list #t)) 3935 | 3936 | (define notpastao 3937 | (lambda (x) 3938 | (conda 3939 | ((== 'pasta x) fail) 3940 | (succeed)))) 3941 | 3942 | 3943 | (test-check "testc23.tex-5" 3944 | (run* (x) 3945 | (conda 3946 | ((notpastao x) fail) 3947 | ((== 'spaghetti x)))) 3948 | 3949 | '(spaghetti)) 3950 | 3951 | (test-check "testc23.tex-6" 3952 | (run* (x) 3953 | (== 'spaghetti x) 3954 | (conda 3955 | ((notpastao x) fail) 3956 | ((== 'spaghetti x)))) 3957 | 3958 | '()) 3959 | (define e (make-engine (lambda () 3960 | (run* (q) 3961 | (conda 3962 | (always succeed) 3963 | (fail)) 3964 | (== #t q)) 3965 | ))) 3966 | (printf "Testing testc23.tex-7 (engine with ~s ticks fuel)\n" max-ticks) 3967 | (e max-ticks 3968 | (lambda (t v) (error 'testc23.tex-7 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3969 | (lambda (e^) (void))) 3970 | 3971 | 3972 | (test-check "testc23.tex-8" 3973 | (run* (q) 3974 | (condu 3975 | (always succeed) 3976 | (fail)) 3977 | (== #t q)) 3978 | 3979 | `(#t)) 3980 | (define e (make-engine (lambda () 3981 | (run* (q) 3982 | (condu 3983 | (succeed always) 3984 | (fail)) 3985 | (== #t q)) 3986 | ))) 3987 | (printf "Testing testc23.tex-9 (engine with ~s ticks fuel)\n" max-ticks) 3988 | (e max-ticks 3989 | (lambda (t v) (error 'testc23.tex-9 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 3990 | (lambda (e^) (void))) 3991 | 3992 | (define e (make-engine (lambda () 3993 | (run1 (q) 3994 | (conda 3995 | (always succeed) 3996 | (fail)) 3997 | fail 3998 | (== #t q)) 3999 | ))) 4000 | (printf "Testing testc23.tex-10 (engine with ~s ticks fuel)\n" max-ticks) 4001 | (e max-ticks 4002 | (lambda (t v) (error 'testc23.tex-10 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 4003 | (lambda (e^) (void))) 4004 | 4005 | 4006 | (test-check "testc23.tex-11" 4007 | (run1 (q) 4008 | (condu 4009 | (always succeed) 4010 | (fail)) 4011 | fail 4012 | (== #t q)) 4013 | 4014 | `()) 4015 | 4016 | (define onceo 4017 | (lambda (g) 4018 | (condu 4019 | (g succeed)))) 4020 | 4021 | 4022 | (test-check "testc23.tex-12" 4023 | (run* (x) 4024 | (onceo (teacupo x))) 4025 | 4026 | `(tea)) 4027 | 4028 | (test-check "testc23.tex-13" 4029 | (run1 (q) 4030 | (onceo (salo never)) 4031 | fail) 4032 | 4033 | `()) 4034 | 4035 | (test-check "testc23.tex-14" 4036 | (run* (r) 4037 | (conde 4038 | ((teacupo r) succeed) 4039 | ((== #f r) succeed))) 4040 | 4041 | `(#f tea cup)) 4042 | 4043 | (test-check "testc23.tex-15" 4044 | (run* (r) 4045 | (conda 4046 | ((teacupo r) succeed) 4047 | ((== #f r) succeed))) 4048 | 4049 | `(tea cup)) 4050 | 4051 | (test-check "testc23.tex-16" 4052 | (run* (r) 4053 | (== #f r) 4054 | (conda 4055 | ((teacupo r) succeed) 4056 | ((== #f r) succeed))) 4057 | 4058 | `(#f)) 4059 | 4060 | (test-check "testc23.tex-17" 4061 | (run* (r) 4062 | (== #f r) 4063 | (condu 4064 | ((teacupo r) succeed) 4065 | ((== #f r) succeed))) 4066 | 4067 | `(#f)) 4068 | 4069 | (define bumpo 4070 | (lambda (n x) 4071 | (conde 4072 | ((== n x) succeed) 4073 | ((fresh (m) 4074 | (minuso n '(1) m) 4075 | (bumpo m x)))))) 4076 | 4077 | 4078 | (test-check "testc23.tex-18" 4079 | (run* (x) 4080 | (bumpo '(1 1 1) x)) 4081 | 4082 | 4083 | `((1 1 1) 4084 | (0 1 1) 4085 | (1 0 1) 4086 | (0 0 1) 4087 | (1 1) 4088 | (0 1) 4089 | (1) 4090 | ()) 4091 | ) 4092 | 4093 | (define gen&testo 4094 | (lambda (op i j k) 4095 | (onceo 4096 | (fresh (x y z) 4097 | (op x y z) 4098 | (== i x) 4099 | (== j y) 4100 | (== k z))))) 4101 | 4102 | 4103 | (test-check "testc23.tex-19" 4104 | (run* (q) 4105 | (gen&testo pluso '(0 0 1) '(1 1) '(1 1 1)) 4106 | (== #t q)) 4107 | 4108 | (list 4109 | #t 4110 | )) 4111 | (define e (make-engine (lambda () 4112 | (run1 (q) 4113 | (gen&testo pluso '(0 0 1) '(1 1) '(0 1 1))) 4114 | ))) 4115 | (printf "Testing testc23.tex-20 (engine with ~s ticks fuel)\n" max-ticks) 4116 | (e max-ticks 4117 | (lambda (t v) (error 'testc23.tex-20 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 4118 | (lambda (e^) (void))) 4119 | 4120 | (define e (make-engine (lambda () 4121 | (run1 (q) 4122 | (gen&testo pluso '(0 0 1) '(1 1) '(0 1 1))) 4123 | ))) 4124 | (printf "Testing testc23.tex-21 (engine with ~s ticks fuel)\n" max-ticks) 4125 | (e max-ticks 4126 | (lambda (t v) (error 'testc23.tex-21 "infinite loop returned ~s after ~s ticks" v (- max-ticks t))) 4127 | (lambda (e^) (void))) 4128 | 4129 | 4130 | (define enumerateo 4131 | (lambda (op r n) 4132 | (fresh (i j k) 4133 | (bumpo n i) 4134 | (bumpo n j) 4135 | (op i j k) 4136 | (gen&testo op i j k) 4137 | (== `(,i ,j ,k) r)))) 4138 | 4139 | 4140 | (test-check "testc23.tex-22" 4141 | (run* (s) 4142 | (enumerateo pluso s '(1 1))) 4143 | 4144 | 4145 | `(((1 1) (1 1) (0 1 1)) 4146 | ((1 1) (0 1) (1 0 1)) 4147 | ((1 1) () (1 1)) 4148 | ((0 1) (1 1) (1 0 1)) 4149 | ((1 1) (1) (0 0 1)) 4150 | ((1) (1 1) (0 0 1)) 4151 | ((0 1) (0 1) (0 0 1)) 4152 | (() (1 1) (1 1)) 4153 | ((0 1) () (0 1)) 4154 | ((0 1) (1) (1 1)) 4155 | ((1) (0 1) (1 1)) 4156 | ((1) (1) (0 1)) 4157 | ((1) () (1)) 4158 | (() (0 1) (0 1)) 4159 | (() (1) (1)) 4160 | (() () ())) 4161 | ) 4162 | 4163 | (run* (s) 4164 | (enumerateo pluso s '(1 1))) 4165 | 4166 | 4167 | '(test-check "testc23.tex-23" 4168 | (run1 (s) 4169 | (enumerateo pluso s '(1 1 1))) 4170 | 4171 | 4172 | `(((1 1 1) (1 1 1) (0 1 1 1))) 4173 | ) 4174 | 4175 | 4176 | 4177 | 4178 | 4179 | 4180 | 4181 | ;;; Will's toys: 4182 | 4183 | (define proof-that-fresh-needs-an-inc 4184 | (fresh () 4185 | proof-that-fresh-needs-an-inc)) 4186 | 4187 | (test-check 'proof-that-run-needs-an-inc 4188 | (run 1 (q) 4189 | (conde 4190 | (proof-that-fresh-needs-an-inc) 4191 | (succeed))) 4192 | '(_.0)) 4193 | 4194 | (define proof-that-fresh-needs-an-inc-with-conda 4195 | (conda 4196 | (proof-that-fresh-needs-an-inc))) 4197 | 4198 | (test-check 'proof-that-run-needs-an-inc-with-conde-and-conda 4199 | (run 1 (q) 4200 | (conde 4201 | (proof-that-fresh-needs-an-inc) 4202 | (succeed))) 4203 | '(_.0)) 4204 | 4205 | (define proof-that-fresh-needs-an-inc-with-conda 4206 | (fresh () 4207 | (conda 4208 | (proof-that-fresh-needs-an-inc succeed)))) 4209 | 4210 | (test-check 'proof-that-run-needs-an-inc-with-conde 4211 | (run 1 (q) 4212 | (conde 4213 | (proof-that-fresh-needs-an-inc succeed) 4214 | (succeed))) 4215 | '(_.0)) 4216 | 4217 | (test-check 'why-conde-must-also-have-an-inc 4218 | ((make-engine 4219 | (lambda () 4220 | (run 5 (q) 4221 | (letrec ((f (fresh () 4222 | (conde 4223 | (f (conde 4224 | (f) 4225 | (succeed))) 4226 | (succeed))))) 4227 | f)))) 4228 | 100000 4229 | (lambda (x y) y) 4230 | list) 4231 | '(_.0 _.0 _.0 _.0 _.0)) 4232 | 4233 | 4234 | ;;; Define 'test-check' once again, for the end-user. 4235 | (define-syntax test-check 4236 | (syntax-rules () 4237 | ((_ title tested-expression expected-result) 4238 | (begin 4239 | (cout "Testing " title nl) 4240 | (let* ((expected expected-result) 4241 | (produced tested-expression)) 4242 | (or (equal? expected produced) 4243 | (errorf 'test-check 4244 | "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 4245 | 'tested-expression expected produced))))))) 4246 | --------------------------------------------------------------------------------