├── .gitignore ├── LICENSE ├── README.md ├── full-interp.scm ├── helper.scm ├── mk-on-smt.scm ├── test-check.scm ├── test-full.scm ├── test-quines.scm └── tests.scm /.gitignore: -------------------------------------------------------------------------------- 1 | *.ss~ 2 | *.ss#* 3 | .#*.ss 4 | 5 | *.scm~ 6 | *.scm#* 7 | .#*.scm 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Nada Amin 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mk-on-smt 2 | miniKanren for search, SMT for solving 3 | -------------------------------------------------------------------------------- /full-interp.scm: -------------------------------------------------------------------------------- 1 | ;; The definition of 'letrec' is based based on Dan Friedman's code, 2 | ;; using the "half-closure" approach from Reynold's definitional 3 | ;; interpreters. 4 | 5 | (define (evalo expr val) 6 | (eval-expo expr initial-env val)) 7 | 8 | (define (eval-expo expr env val) 9 | (conde 10 | ((== `(quote ,val) expr) 11 | (not-closureo val) 12 | (not-primo val) 13 | (not-in-envo 'quote env)) 14 | 15 | ((numbero expr) (== expr val)) 16 | 17 | ((symbolo expr) (lookupo expr env val)) 18 | 19 | ((fresh (x body) 20 | (== `(lambda ,x ,body) expr) 21 | (== (make-closure x body env) val) 22 | (conde 23 | ;; Variadic 24 | ((symbolo x)) 25 | ;; Multi-argument 26 | ((list-of-symbolso x))) 27 | (not-in-envo 'lambda env))) 28 | 29 | ((fresh (rator x rands body env^ a* res) 30 | (== `(,rator . ,rands) expr) 31 | ;; variadic 32 | (symbolo x) 33 | (== `((,x . (val . ,a*)) . ,env^) res) 34 | (eval-expo rator env (make-closure x body env^)) 35 | (eval-expo body res val) 36 | (eval-listo rands env a*))) 37 | 38 | ((fresh (rator x* rands body env^ a* res) 39 | (== `(,rator . ,rands) expr) 40 | ;; Multi-argument 41 | (eval-expo rator env (make-closure x* body env^)) 42 | (eval-listo rands env a*) 43 | (ext-env*o x* a* env^ res) 44 | (eval-expo body res val))) 45 | 46 | ((fresh (rator x* rands a* prim-id) 47 | (== `(,rator . ,rands) expr) 48 | (eval-expo rator env (make-prim prim-id)) 49 | (eval-primo prim-id a* val) 50 | (eval-listo rands env a*))) 51 | 52 | ((handle-matcho expr env val)) 53 | 54 | ((fresh (p-name x body letrec-body) 55 | ;; single-function variadic letrec version 56 | (== `(letrec ((,p-name (lambda ,x ,body))) 57 | ,letrec-body) 58 | expr) 59 | (conde 60 | ; Variadic 61 | ((symbolo x)) 62 | ; Multiple argument 63 | ((list-of-symbolso x))) 64 | (not-in-envo 'letrec env) 65 | (eval-expo letrec-body 66 | `((,p-name . (rec . (lambda ,x ,body))) . ,env) 67 | val))) 68 | 69 | ((prim-expo expr env val)) 70 | 71 | )) 72 | 73 | (define empty-env '()) 74 | 75 | (define (lookupo x env t) 76 | (fresh (y b rest) 77 | (== `((,y . ,b) . ,rest) env) 78 | (conde 79 | ((== x y) 80 | (conde 81 | ((== `(val . ,t) b)) 82 | ((fresh (x body) 83 | (== `(rec . (lambda ,x ,body)) b) 84 | (== (make-closure x body env) t))))) 85 | ((=/= x y) 86 | (lookupo x rest t))))) 87 | 88 | (define (not-in-envo x env) 89 | (conde 90 | ((== empty-env env)) 91 | ((fresh (y b rest) 92 | (== `((,y . ,b) . ,rest) env) 93 | (=/= y x) 94 | (not-in-envo x rest))))) 95 | 96 | (define (eval-listo expr env val) 97 | (conde 98 | ((== '() expr) 99 | (== '() val)) 100 | ((fresh (a d v-a v-d) 101 | (== `(,a . ,d) expr) 102 | (== `(,v-a . ,v-d) val) 103 | (eval-expo a env v-a) 104 | (eval-listo d env v-d))))) 105 | 106 | ;; need to make sure lambdas are well formed. 107 | ;; grammar constraints would be useful here!!! 108 | (define (list-of-symbolso los) 109 | (conde 110 | ((== '() los)) 111 | ((fresh (a d) 112 | (== `(,a . ,d) los) 113 | (symbolo a) 114 | (list-of-symbolso d))))) 115 | 116 | (define (ext-env*o x* a* env out) 117 | (conde 118 | ((== '() x*) (== '() a*) (== env out)) 119 | ((fresh (x a dx* da* env2) 120 | (== `(,x . ,dx*) x*) 121 | (== `(,a . ,da*) a*) 122 | (== `((,x . (val . ,a)) . ,env) env2) 123 | (symbolo x) 124 | (ext-env*o dx* da* env2 out))))) 125 | 126 | (define (eval-primo prim-id a* val) 127 | (conde 128 | [(== prim-id 'cons) 129 | (fresh (a d) 130 | (== `(,a ,d) a*) 131 | (== `(,a . ,d) val))] 132 | [(== prim-id 'car) 133 | (fresh (d) 134 | (== `((,val . ,d)) a*) 135 | )] 136 | [(== prim-id 'cdr) 137 | (fresh (a) 138 | (== `((,a . ,val)) a*) 139 | )] 140 | [(== prim-id 'not) 141 | (fresh (b) 142 | (== `(,b) a*) 143 | (conde 144 | ((=/= #f b) (== #f val)) 145 | ((== #f b) (== #t val))))] 146 | [(== prim-id 'equal?) 147 | (fresh (v1 v2) 148 | (== `(,v1 ,v2) a*) 149 | (conde 150 | ((== v1 v2) (== #t val)) 151 | ((=/= v1 v2) (== #f val))))] 152 | [(== prim-id 'symbol?) 153 | (fresh (v) 154 | (== `(,v) a*) 155 | (conde 156 | ((symbolo v) (== #t val)) 157 | ((numbero v) (== #f val)) 158 | ((fresh (a d) 159 | (== `(,a . ,d) v) 160 | (== #f val)))))] 161 | [(== prim-id 'null?) 162 | (fresh (v) 163 | (== `(,v) a*) 164 | (conde 165 | ((== '() v) (== #t val)) 166 | ((=/= '() v) (== #f val))))])) 167 | 168 | (define (prim-expo expr env val) 169 | (conde 170 | ((boolean-primo expr env val)) 171 | ((and-primo expr env val)) 172 | ((or-primo expr env val)) 173 | ((if-primo expr env val)))) 174 | 175 | (define (boolean-primo expr env val) 176 | (conde 177 | ((== #t expr) (== #t val)) 178 | ((== #f expr) (== #f val)))) 179 | 180 | (define (and-primo expr env val) 181 | (fresh (e*) 182 | (== `(and . ,e*) expr) 183 | (not-in-envo 'and env) 184 | (ando e* env val))) 185 | 186 | (define (ando e* env val) 187 | (conde 188 | ((== '() e*) (== #t val)) 189 | ((fresh (e) 190 | (== `(,e) e*) 191 | (eval-expo e env val))) 192 | ((fresh (e1 e2 e-rest v) 193 | (== `(,e1 ,e2 . ,e-rest) e*) 194 | (conde 195 | ((== #f v) 196 | (== #f val) 197 | (eval-expo e1 env v)) 198 | ((=/= #f v) 199 | (eval-expo e1 env v) 200 | (ando `(,e2 . ,e-rest) env val))))))) 201 | 202 | (define (or-primo expr env val) 203 | (fresh (e*) 204 | (== `(or . ,e*) expr) 205 | (not-in-envo 'or env) 206 | (oro e* env val))) 207 | 208 | (define (oro e* env val) 209 | (conde 210 | ((== '() e*) (== #f val)) 211 | ((fresh (e) 212 | (== `(,e) e*) 213 | (eval-expo e env val))) 214 | ((fresh (e1 e2 e-rest v) 215 | (== `(,e1 ,e2 . ,e-rest) e*) 216 | (conde 217 | ((=/= #f v) 218 | (== v val) 219 | (eval-expo e1 env v)) 220 | ((== #f v) 221 | (eval-expo e1 env v) 222 | (oro `(,e2 . ,e-rest) env val))))))) 223 | 224 | (define (if-primo expr env val) 225 | (fresh (e1 e2 e3 t) 226 | (== `(if ,e1 ,e2 ,e3) expr) 227 | (not-in-envo 'if env) 228 | (eval-expo e1 env t) 229 | (conde 230 | ((=/= #f t) (eval-expo e2 env val)) 231 | ((== #f t) (eval-expo e3 env val))))) 232 | 233 | (define initial-env `((list . (val . ,(make-closure 'x 'x empty-env))) 234 | (not . (val . ,(make-prim 'not))) 235 | (equal? . (val . ,(make-prim 'equal?))) 236 | (symbol? . (val . ,(make-prim 'symbol?))) 237 | (cons . (val . ,(make-prim 'cons))) 238 | (null? . (val . ,(make-prim 'null?))) 239 | (car . (val . ,(make-prim 'car))) 240 | (cdr . (val . ,(make-prim 'cdr))) 241 | . ,empty-env)) 242 | 243 | (define handle-matcho 244 | (lambda (expr env val) 245 | (fresh (against-expr mval clause clauses) 246 | (== `(match ,against-expr ,clause . ,clauses) expr) 247 | (not-in-envo 'match env) 248 | (eval-expo against-expr env mval) 249 | (match-clauses mval `(,clause . ,clauses) env val)))) 250 | 251 | (define (not-symbolo t) 252 | (conde 253 | ((== #f t)) 254 | ((== #t t)) 255 | ((== '() t)) 256 | ((numbero t)) 257 | ((fresh (a d) 258 | (== `(,a . ,d) t))))) 259 | 260 | (define (not-numbero t) 261 | (conde 262 | ((== #f t)) 263 | ((== #t t)) 264 | ((== '() t)) 265 | ((symbolo t)) 266 | ((fresh (a d) 267 | (== `(,a . ,d) t))))) 268 | 269 | (define (self-eval-literalo t) 270 | (conde 271 | ((numbero t)) 272 | ((booleano t)))) 273 | 274 | (define (literalo t) 275 | (conde 276 | ((numbero t)) 277 | ((symbolo t)) 278 | ((booleano t)) 279 | ((== '() t)))) 280 | 281 | (define (booleano t) 282 | (conde 283 | ((== #f t)) 284 | ((== #t t)))) 285 | 286 | (define (regular-env-appendo env1 env2 env-out) 287 | (conde 288 | ((== empty-env env1) (== env2 env-out)) 289 | ((fresh (y v rest res) 290 | (== `((,y . (val . ,v)) . ,rest) env1) 291 | (== `((,y . (val . ,v)) . ,res) env-out) 292 | (regular-env-appendo rest env2 res))))) 293 | 294 | (define (match-clauses mval clauses env val) 295 | (fresh (p result-expr d penv) 296 | (== `((,p ,result-expr) . ,d) clauses) 297 | (conde 298 | ((fresh (env^) 299 | (p-match p mval '() penv) 300 | (regular-env-appendo penv env env^) 301 | (eval-expo result-expr env^ val))) 302 | ((p-no-match p mval '() penv) 303 | (match-clauses mval d env val))))) 304 | 305 | (define (var-p-match var mval penv penv-out) 306 | (fresh (val) 307 | (symbolo var) 308 | (conde 309 | ((== mval val) 310 | (== penv penv-out) 311 | (lookupo var penv val)) 312 | ((== `((,var . (val . ,mval)) . ,penv) penv-out) 313 | (not-in-envo var penv))))) 314 | 315 | (define (var-p-no-match var mval penv penv-out) 316 | (fresh (val) 317 | (symbolo var) 318 | (=/= mval val) 319 | (== penv penv-out) 320 | (lookupo var penv val))) 321 | 322 | (define (p-match p mval penv penv-out) 323 | (conde 324 | ((self-eval-literalo p) 325 | (== p mval) 326 | (== penv penv-out)) 327 | ((var-p-match p mval penv penv-out)) 328 | ((fresh (var pred val) 329 | (== `(? ,pred ,var) p) 330 | (conde 331 | ((== 'symbol? pred) 332 | (symbolo mval)) 333 | ((== 'number? pred) 334 | (numbero mval))) 335 | (var-p-match var mval penv penv-out))) 336 | ((fresh (quasi-p) 337 | (== (list 'quasiquote quasi-p) p) 338 | (quasi-p-match quasi-p mval penv penv-out))))) 339 | 340 | (define (p-no-match p mval penv penv-out) 341 | (conde 342 | ((self-eval-literalo p) 343 | (=/= p mval) 344 | (== penv penv-out)) 345 | ((var-p-no-match p mval penv penv-out)) 346 | ((fresh (var pred val) 347 | (== `(? ,pred ,var) p) 348 | (== penv penv-out) 349 | (symbolo var) 350 | (conde 351 | ((== 'symbol? pred) 352 | (conde 353 | ((not-symbolo mval)) 354 | ((symbolo mval) 355 | (var-p-no-match var mval penv penv-out)))) 356 | ((== 'number? pred) 357 | (conde 358 | ((not-numbero mval)) 359 | ((numbero mval) 360 | (var-p-no-match var mval penv penv-out))))))) 361 | ((fresh (quasi-p) 362 | (== (list 'quasiquote quasi-p) p) 363 | (quasi-p-no-match quasi-p mval penv penv-out))))) 364 | 365 | (define (quasi-p-match quasi-p mval penv penv-out) 366 | (conde 367 | ((== quasi-p mval) 368 | (== penv penv-out) 369 | (literalo quasi-p)) 370 | ((fresh (p) 371 | (== (list 'unquote p) quasi-p) 372 | (p-match p mval penv penv-out))) 373 | ((fresh (a d v1 v2 penv^) 374 | (== `(,a . ,d) quasi-p) 375 | (== `(,v1 . ,v2) mval) 376 | (=/= 'unquote a) 377 | (quasi-p-match a v1 penv penv^) 378 | (quasi-p-match d v2 penv^ penv-out))))) 379 | 380 | (define (quasi-p-no-match quasi-p mval penv penv-out) 381 | (conde 382 | ((=/= quasi-p mval) 383 | (== penv penv-out) 384 | (literalo quasi-p)) 385 | ((fresh (p) 386 | (== (list 'unquote p) quasi-p) 387 | (p-no-match p mval penv penv-out))) 388 | ((fresh (a d) 389 | (== `(,a . ,d) quasi-p) 390 | (=/= 'unquote a) 391 | (== penv penv-out) 392 | (literalo mval))) 393 | ((fresh (a d v1 v2 penv^) 394 | (== `(,a . ,d) quasi-p) 395 | (=/= 'unquote a) 396 | (== `(,v1 . ,v2) mval) 397 | (conde 398 | ((quasi-p-no-match a v1 penv penv^)) 399 | ((quasi-p-match a v1 penv penv^) 400 | (quasi-p-no-match d v2 penv^ penv-out))))))) 401 | -------------------------------------------------------------------------------- /helper.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | 6 | ; Trie implementation, due to Abdulaziz Ghuloum. Used for substitution 7 | ; and constraint store. 8 | 9 | ;;; subst ::= (empty) 10 | ;;; | (node even odd) 11 | ;;; | (data idx val) 12 | 13 | (define-record-type node (fields e o)) 14 | 15 | (define-record-type data (fields idx val)) 16 | 17 | (define shift (lambda (n) (fxsra n 1))) 18 | 19 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 20 | 21 | ;;; interface 22 | 23 | (define t:size 24 | (lambda (x) (t:aux:size x))) 25 | 26 | (define t:bind 27 | (lambda (xi v s) 28 | (unless (and (fixnum? xi) (>= xi 0)) 29 | (error 't:bind "index must be a fixnum, got ~s" xi)) 30 | (t:aux:bind xi v s))) 31 | 32 | (define t:unbind 33 | (lambda (xi s) 34 | (unless (and (fixnum? xi) (>= xi 0)) 35 | (error 't:unbind "index must be a fixnum, got ~s" xi)) 36 | (t:aux:unbind xi s))) 37 | 38 | (define t:lookup 39 | (lambda (xi s) 40 | (unless (and (fixnum? xi) (>= xi 0)) 41 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 42 | (t:aux:lookup xi s))) 43 | 44 | (define t:binding-value 45 | (lambda (s) 46 | (unless (data? s) 47 | (error 't:binding-value "not a binding ~s" s)) 48 | (data-val s))) 49 | 50 | ;;; helpers 51 | 52 | (define t:aux:push 53 | (lambda (xi vi xj vj) 54 | (if (fxeven? xi) 55 | (if (fxeven? xj) 56 | (make-node (t:aux:push (shift xi) vi (shift xj) vj) '()) 57 | (make-node (make-data (shift xi) vi) (make-data (shift xj) vj))) 58 | (if (fxeven? xj) 59 | (make-node (make-data (shift xj) vj) (make-data (shift xi) vi)) 60 | (make-node '() (t:aux:push (shift xi) vi (shift xj) vj)))))) 61 | 62 | (define t:aux:bind 63 | (lambda (xi vi s*) 64 | (cond 65 | [(node? s*) 66 | (if (fxeven? xi) 67 | (make-node (t:aux:bind (shift xi) vi (node-e s*)) (node-o s*)) 68 | (make-node (node-e s*) (t:aux:bind (shift xi) vi (node-o s*))))] 69 | [(data? s*) 70 | (let ([xj (data-idx s*)] [vj (data-val s*)]) 71 | (if (fx= xi xj) 72 | (make-data xi vi) 73 | (t:aux:push xi vi xj vj)))] 74 | [else (make-data xi vi)]))) 75 | 76 | (define t:aux:lookup 77 | (lambda (xi s*) 78 | (cond 79 | [(node? s*) 80 | (if (fxeven? xi) 81 | (t:aux:lookup (shift xi) (node-e s*)) 82 | (t:aux:lookup (shift xi) (node-o s*)))] 83 | [(data? s*) 84 | (if (fx= (data-idx s*) xi) 85 | s* 86 | #f)] 87 | [else #f]))) 88 | 89 | (define t:aux:size 90 | (lambda (s*) 91 | (cond 92 | [(node? s*) (fx+ (t:aux:size (node-e s*)) (t:aux:size (node-o s*)))] 93 | [(data? s*) 1] 94 | [else 0]))) 95 | 96 | (define t:aux:cons^ 97 | (lambda (e o) 98 | (cond 99 | [(or (node? e) (node? o)) (make-node e o)] 100 | [(data? e) 101 | (make-data (unshift (data-idx e) 0) (data-val e))] 102 | [(data? o) 103 | (make-data (unshift (data-idx o) 1) (data-val o))] 104 | [else '()]))) 105 | 106 | (define t:aux:unbind 107 | (lambda (xi s*) 108 | (cond 109 | [(node? s*) 110 | (if (fxeven? xi) 111 | (t:aux:cons^ (t:aux:unbind (shift xi) (node-e s*)) (node-o s*)) 112 | (t:aux:cons^ (node-e s*) (t:aux:unbind (shift xi) (node-o s*))))] 113 | [(and (data? s*) (fx= (data-idx s*) xi)) '()] 114 | [else s*]))) 115 | 116 | 117 | ; Misc. missing functions 118 | 119 | (define (remove-duplicates l) 120 | (cond ((null? l) 121 | '()) 122 | ((member (car l) (cdr l)) 123 | (remove-duplicates (cdr l))) 124 | (else 125 | (cons (car l) (remove-duplicates (cdr l)))))) 126 | 127 | (define (foldl f init seq) 128 | (if (null? seq) 129 | init 130 | (foldl f 131 | (f (car seq) init) 132 | (cdr seq)))) 133 | 134 | -------------------------------------------------------------------------------- /mk-on-smt.scm: -------------------------------------------------------------------------------- 1 | ;;(define smt-cmd "cvc4 --lang=smt2.6 -m --incremental --fmf-fun") 2 | (define smt-cmd "z3 -in") 3 | 4 | (define-values (smt-out smt-in smt-err smt-p) 5 | (open-process-ports smt-cmd 'block (native-transcoder))) 6 | (define (smt-reset!) 7 | (let-values (((out in err p) 8 | (open-process-ports smt-cmd 'block (native-transcoder)))) 9 | (set! smt-out out) 10 | (set! smt-in in) 11 | (set! smt-err err) 12 | (set! smt-p p))) 13 | 14 | (define (smt-read-sat) 15 | (let ([r (read smt-in)]) 16 | ;;(printf ">> ~a\n" r) 17 | (cond 18 | ((eq? r 'sat) 19 | #t) 20 | ((eq? r 'unsat) 21 | #f) 22 | ((eq? r 'unknown) 23 | (begin 24 | (printf "read-sat: unknown\n") 25 | #f)) 26 | (else (error 'read-sat (format "~a" r)))))) 27 | 28 | (define (smt-call xs) 29 | (for-each 30 | (lambda (x) 31 | ;;(printf "~s\n" x) 32 | (fprintf smt-out "~s\n" x)) 33 | xs) 34 | (flush-output-port smt-out)) 35 | 36 | (define empty-state '(0)) 37 | ;; a list of pairs of assumption variable id and z3 statements 38 | 39 | ;; a set of asserted assumption variable ids 40 | (define empty-seen-assumptions '()) 41 | (define seen-assumptions empty-seen-assumptions) 42 | (define (saw-assumption! id) 43 | (set! seen-assumptions (t:bind id #t seen-assumptions))) 44 | (define (seen-assumption? id) 45 | (t:lookup id seen-assumptions)) 46 | (define (assumption-id->symbol id) 47 | (string->symbol (format #f "_a~a" id))) 48 | (define assumption-count 0) 49 | (define (fresh-assumption-id!) 50 | (set! assumption-count (+ 1 assumption-count)) 51 | (smt-call `((declare-const ,(assumption-id->symbol assumption-count) Bool))) 52 | assumption-count) 53 | (define empty-child-assumptions '()) 54 | (define child-assumptions empty-child-assumptions) 55 | (define (get-child-assumptions! id) 56 | (let ((r (t:lookup id child-assumptions))) 57 | (if r 58 | (data-val r) 59 | (begin 60 | (let ((new-cs (cons (fresh-assumption-id!) (fresh-assumption-id!)))) 61 | (set! child-assumptions (t:bind id new-cs child-assumptions)) 62 | new-cs))))) 63 | (define left car) 64 | (define right cdr) 65 | 66 | (define-structure (closure id body env)) 67 | (define-structure (prim id)) 68 | 69 | (define (smt/add-if-new ctx stmt st) 70 | (unless (seen-assumption? ctx) 71 | (saw-assumption! ctx) 72 | (smt-call (list stmt))) 73 | (cons (car st) (cons (cons ctx stmt) (cdr st)))) 74 | 75 | (define (inc-counter st) 76 | (cons (+ 1 (car st)) (cdr st))) 77 | (define get-counter car) 78 | 79 | (define smt/check-sometimes 80 | (lambda (st) 81 | (let ((st (inc-counter st))) 82 | (if (= (remainder (get-counter st) 30) 0) 83 | (smt/check st) 84 | st)))) 85 | 86 | (define smt/check 87 | (lambda (st) 88 | (smt-call `((check-sat-assuming 89 | ,(map (lambda (x) (assumption-id->symbol (car x))) (cdr st))))) 90 | (if (smt-read-sat) 91 | st 92 | #f))) 93 | 94 | (define (smt/declare x) 95 | (lambda (ctx) 96 | (lambda (st) 97 | (smt/add-if-new ctx `(declare-const ,(var-name x) SExp) st)))) 98 | 99 | (define (smt/assert e) 100 | (lambda (ctx) 101 | (lambda (st) 102 | (smt/check-sometimes 103 | (smt/add-if-new ctx `(assert (= ,(assumption-id->symbol ctx) ,e)) st))))) 104 | 105 | (define smt/purge 106 | (lambda (ctx) 107 | smt/check)) 108 | 109 | (define (smt/reset!) 110 | (set! assumption-count 0) 111 | (set! seen-assumptions empty-seen-assumptions) 112 | (set! child-assumptions empty-child-assumptions) 113 | (smt-call '((reset))) 114 | (smt-call '((declare-datatypes 115 | ((SExp 0)) 116 | (((sbool (s-bool Bool)) 117 | (sint (s-int Int)) 118 | (sreal (s-real Real)) 119 | (ssymbol (s-symbol String)) 120 | (sclosure (s-clo-id SExp) (s-clo-body SExp) (s-clo-env SExp)) 121 | (sprim (sprim-id SExp)) 122 | (snil) 123 | (scons (s-car SExp) (s-cdr SExp))))))) 124 | #; 125 | (smt-call '((define-fun-rec closure-absent ((e SExp)) Bool ; 126 | (ite ((_ is sclosure) e) false ; 127 | (ite ((_ is scons) e) (and (closure-absent (s-car e)) (closure-absent (s-cdr e))) ; 128 | true))))) 129 | ) 130 | 131 | (define (reify q) 132 | (lambda (st) 133 | (smt/check st) 134 | (smt-call '((get-model))) 135 | (let ((ms (cdr (read smt-in)))) 136 | (let ((r (car (filter (lambda (x) (eq? (cadr x) (var-name q))) ms)))) 137 | (sinv (cadddr (cdr r)) '()))))) 138 | 139 | (define (var x id) 140 | (vector 141 | (string->symbol (format #f "_v_~a_~a" x id)))) 142 | 143 | (define (var? x) 144 | (vector? x)) 145 | 146 | (define (var-name v) 147 | (vector-ref v 0)) 148 | 149 | (define (s x) 150 | (cond 151 | ((eq? x #f) '(sbool false)) 152 | ((eq? x #t) '(sbool true)) 153 | ((number? x) 154 | (if (exact? x) 155 | `(sint ,x) 156 | `(sreal ,x))) 157 | ((null? x) 'snil) 158 | ((symbol? x) `(ssymbol ,(symbol->string x))) 159 | ((pair? x) `(scons ,(s (car x)) ,(s (cdr x)))) 160 | ((closure? x) `(sclosure ,(s (closure-id x)) ,(s (closure-body x)) ,(s (closure-env x)))) 161 | ((prim? x) `(sprim ,(s (prim-id x)))) 162 | ((var? x) (var-name x)) 163 | (else (error 's (format #f "not supported: ~a" x))))) 164 | 165 | (define (tagged-list? tag x) 166 | (and (pair? x) (eq? (car x) tag))) 167 | 168 | (define (simplify-real x) 169 | (cond ((number? x) x) 170 | ((tagged-list? '/ x) (/ (cadr x) (caddr x))) 171 | (else (error 'simplify-real (format #f "unexpected real: ~a" x))))) 172 | 173 | (define (sinv x env) 174 | (cond 175 | ((equal? x '(sbool false)) #f) 176 | ((equal? x '(sbool true)) #t) 177 | ((tagged-list? 'sint x) (cadr x)) 178 | ((tagged-list? 'sreal x) (simplify-real (cadr x))) 179 | ((equal? x 'snil) '()) 180 | ((tagged-list? 'ssymbol x) (string->symbol (cadr x))) 181 | ((tagged-list? 'scons x) `(,(sinv (cadr x) env) . ,(sinv (caddr x) env))) 182 | ((tagged-list? 'sclosure x) (make-closure (sinv (cadr x) env) (sinv (caddr x) env) (sinv (cadddr x) env))) 183 | ((tagged-list? 'sprim x) (make-prim (sinv (cadr x) env))) 184 | ((tagged-list? 'let x) 185 | (let* ((bindings (cadr x)) 186 | (lhss (map car bindings)) 187 | (rhss (map (lambda (x) (sinv (cadr x) env)) bindings)) 188 | (body (caddr x))) 189 | (sinv body (append (map cons lhss rhss) env)))) 190 | ((symbol? x) (let ((p (assq x env))) 191 | (if p 192 | (cdr p) 193 | (error 'sinv (format #f "unknown symbol: ~a" x))))) 194 | (else (error 'sinv (format #f "not supported: ~a" x))))) 195 | 196 | (define (symbolo x) 197 | (smt/assert `((_ is ssymbol) ,(s x)))) 198 | 199 | (define (numbero x) 200 | (smt/assert `(or ((_ is sint) ,(s x)) ((_ is sreal) ,(s x))))) 201 | 202 | #; 203 | (define (closure-absento x) 204 | (smt/assert `(closure-absent ,(s x)))) 205 | 206 | (define (not-closureo x) 207 | (smt/assert `(not ((_ is sclosure) ,(s x))))) 208 | 209 | (define (not-primo x) 210 | (smt/assert `(not ((_ is sprim) ,(s x))))) 211 | 212 | (define (=/= x y) 213 | (smt/assert `(not (= ,(s x) ,(s y))))) 214 | 215 | (define (== x y) 216 | (smt/assert `(= ,(s x) ,(s y)))) 217 | 218 | ;Search 219 | 220 | ; SearchStream: #f | Procedure | State | (Pair State (-> SearchStream)) 221 | 222 | ; SearchStream constructor types. Names inspired by the plus monad? 223 | 224 | ; -> SearchStream 225 | (define mzero (lambda () #f)) 226 | 227 | ; c: State 228 | ; -> SearchStream 229 | (define unit (lambda (c) c)) 230 | 231 | ; c: State 232 | ; f: (-> SearchStream) 233 | ; -> SearchStream 234 | ; 235 | ; f is a thunk to avoid unnecessary computation in the case that c is 236 | ; the last answer needed to satisfy the query. 237 | (define choice (lambda (c f) (cons c f))) 238 | 239 | ; e: SearchStream 240 | ; -> (-> SearchStream) 241 | (define-syntax inc 242 | (syntax-rules () 243 | ((_ e) (lambda () e)))) 244 | 245 | ; Goal: (State -> SearchStream) 246 | 247 | ; e: SearchStream 248 | ; -> Goal 249 | (define-syntax lambdag@ 250 | (syntax-rules () 251 | ((_ (st) e) (lambda (st) e)))) 252 | 253 | ; Match on search streams. The state type must not be a pair with a 254 | ; procedure in its cdr. 255 | ; 256 | ; (() e0) failure 257 | ; ((f) e1) inc for interleaving. separate from success or failure 258 | ; to ensure it goes all the way to the top of the tree. 259 | ; ((c) e2) single result. Used rather than (choice c (inc (mzero))) 260 | ; to avoid returning to search a part of the tree that 261 | ; will inevitably fail. 262 | ; ((c f) e3) multiple results. 263 | (define-syntax case-inf 264 | (syntax-rules () 265 | ((_ e (() e0) ((f^) e1) ((c^) e2) ((c f) e3)) 266 | (let ((c-inf e)) 267 | (cond 268 | ((not c-inf) e0) 269 | ((procedure? c-inf) (let ((f^ c-inf)) e1)) 270 | ((not (and (pair? c-inf) 271 | (procedure? (cdr c-inf)))) 272 | (let ((c^ c-inf)) e2)) 273 | (else (let ((c (car c-inf)) (f (cdr c-inf))) 274 | e3))))))) 275 | 276 | ; c-inf: SearchStream 277 | ; f: (-> SearchStream) 278 | ; -> SearchStream 279 | ; 280 | ; f is a thunk to avoid unnecesarry computation in the case that the 281 | ; first answer produced by c-inf is enough to satisfy the query. 282 | (define mplus 283 | (lambda (c-inf f) 284 | (case-inf c-inf 285 | (() (f)) 286 | ((f^) (inc (mplus (f) f^))) 287 | ((c) (choice c f)) 288 | ((c f^) (choice c (inc (mplus (f) f^))))))) 289 | 290 | ; c-inf: SearchStream 291 | ; g: Goal 292 | ; -> SearchStream 293 | (define bind 294 | (lambda (c-inf g) 295 | (case-inf c-inf 296 | (() (mzero)) 297 | ((f) (inc (bind (f) g))) 298 | ((c) (g c)) 299 | ((c f) (mplus (g c) (inc (bind (f) g))))))) 300 | 301 | ; Int, SearchStream -> (ListOf SearchResult) 302 | (define take 303 | (lambda (n f) 304 | (cond 305 | ((and n (zero? n)) '()) 306 | (else 307 | (case-inf (f) 308 | (() '()) 309 | ((f) (take n f)) 310 | ((c) (cons c '())) 311 | ((c f) (cons c 312 | (take (and n (- n 1)) f)))))))) 313 | 314 | ; -> SearchStream 315 | (define-syntax bind* 316 | (syntax-rules () 317 | ((_ e) e) 318 | ((_ e g0 g ...) (bind* (bind e g0) g ...)))) 319 | 320 | ; -> SearchStream 321 | (define-syntax mplus* 322 | (syntax-rules () 323 | ((_ e) e) 324 | ((_ e0 e ...) (mplus e0 325 | (inc (mplus* e ...)))))) 326 | 327 | ; -> Goal 328 | (define (conj2 ig1 ig2) 329 | (lambda (ctx) 330 | (let ((cs (get-child-assumptions! ctx))) 331 | (let ((ctx1 (left cs)) 332 | (ctx2 (right cs))) 333 | (let ((g1 (ig1 ctx1)) 334 | (g2 (ig2 ctx2))) 335 | (lambdag@ (st) 336 | (bind* 337 | st 338 | ((smt/assert `(and ,(assumption-id->symbol ctx1) 339 | ,(assumption-id->symbol ctx2))) 340 | ctx) 341 | g1 342 | g2))))))) 343 | 344 | (define-syntax conj* 345 | (syntax-rules () 346 | ((_ ig) ig) 347 | ((_ ig0 ig1 ig ...) (conj* (conj2 ig0 ig1) ig ...)))) 348 | 349 | (define-syntax fresh 350 | (syntax-rules () 351 | ((_ (x ...) ig0 ig ...) 352 | (lambda (ctx) 353 | (lambdag@ (st) 354 | (inc 355 | ;; this will break with macro-generated freshes 356 | (let ((x (var 'x ctx)) ...) 357 | (((conj* (smt/declare x) ... ig0 ig ...) ctx) st)))))))) 358 | #; 359 | (define-syntax fresh 360 | (syntax-rules () 361 | ((_ (x ...) g0 g ...) 362 | (lambdag@ (st) 363 | (inc 364 | (let ((x (var)) ...) 365 | (bind* st (smt/declare x) ... g0 g ...))))))) 366 | 367 | 368 | ; -> Goal 369 | (define (disj2 ig1 ig2) 370 | (lambda (ctx) 371 | (let ((cs (get-child-assumptions! ctx))) 372 | (let ((ctx1 (left cs)) 373 | (ctx2 (right cs))) 374 | (let ((g1 (ig1 ctx1)) 375 | (g2 (ig2 ctx2))) 376 | (lambdag@ (st) 377 | (inc 378 | (bind* 379 | (((smt/assert `(or ,(assumption-id->symbol ctx1) 380 | ,(assumption-id->symbol ctx2))) 381 | ctx) 382 | st) 383 | (lambdag@ (st) 384 | (mplus* 385 | (g1 st) 386 | (g2 st))))))))))) 387 | 388 | (define-syntax disj* 389 | (syntax-rules () 390 | ((_ ig) ig) 391 | ((_ ig0 ig ...) (disj2 ig0 (disj* ig ...))))) 392 | 393 | (define-syntax conde 394 | (syntax-rules () 395 | ((_ (ig0 ig ...) (ig1 ig^ ...) ...) 396 | (lambda (ctx) 397 | (lambdag@ (st) 398 | (inc 399 | (((disj* 400 | (conj* ig0 ig ...) 401 | (conj* ig1 ig^ ...) ...) 402 | ctx) 403 | st))))))) 404 | #; 405 | (define-syntax conde 406 | (syntax-rules () 407 | ((_ (g0 g ...) (g1 g^ ...) ...) 408 | (lambdag@ (st) 409 | (inc 410 | (mplus* 411 | (bind* (g0 st) g ...) 412 | (bind* (g1 st) g^ ...) ...)))))) 413 | 414 | (define-syntax run 415 | (syntax-rules () 416 | ((_ n (q) ig ...) 417 | (begin 418 | (smt/reset!) 419 | (let ((ctx (fresh-assumption-id!))) 420 | (let ((q (var 'q ctx))) 421 | (map (reify q) 422 | (take n 423 | (inc 424 | (((conj* (smt/declare q) ig ... smt/purge) ctx) 425 | 426 | empty-state)))))))))) 427 | #; 428 | (define-syntax run 429 | (syntax-rules () 430 | ((_ n (q) g0 g ...) 431 | (begin 432 | (smt/reset!) 433 | (take n 434 | (inc 435 | ((fresh (q) g0 g ... smt/purge 436 | (lambdag@ (st) 437 | (let ((z ((reify q) st))) 438 | (choice z (lambda () (lambda () #f)))))) 439 | empty-state))))) 440 | ((_ n (q0 q1 q ...) g0 g ...) 441 | (run n (x) 442 | (fresh (q0 q1 q ...) 443 | g0 g ... 444 | (== `(,q0 ,q1 ,q ...) x)))))) 445 | 446 | (define-syntax run* 447 | (syntax-rules () 448 | ((_ (q0 q ...) g0 g ...) (run #f (q0 q ...) g0 g ...)))) 449 | -------------------------------------------------------------------------------- /test-check.scm: -------------------------------------------------------------------------------- 1 | (define test-failed #f) 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | ((_ title tested-expression expected-result) 6 | (begin 7 | (printf "Testing ~s\n" title) 8 | (let* ((expected expected-result) 9 | (produced tested-expression)) 10 | (or (equal? expected produced) 11 | (begin 12 | (set! test-failed #t) 13 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 14 | 'tested-expression expected produced)))))))) 15 | 16 | (define-syntax time-test 17 | (syntax-rules () 18 | ((_ title tested-expression expected-result) 19 | (test title 20 | (time tested-expression) 21 | expected-result)))) 22 | 23 | (define-syntax todo 24 | (syntax-rules () 25 | ((_ title tested-expression expected-result) 26 | (printf "TODO ~s\n" title)))) 27 | -------------------------------------------------------------------------------- /test-full.scm: -------------------------------------------------------------------------------- 1 | (load "helper.scm") 2 | (load "mk-on-smt.scm") 3 | (load "test-check.scm") 4 | (load "full-interp.scm") 5 | 6 | 7 | (time-test "I love you 1" 8 | (run 3 (q) (evalo q '(I love you))) 9 | '('(I love you) ((lambda () '(I love you))) (list 'I 'love 'you))) 10 | 11 | ;(time (run 4 (q) (evalo q q))) 12 | 13 | (time 14 | (run 1 (q) 15 | (== q 'l1) 16 | (evalo 17 | `(letrec ([append (lambda (l1 l2) 18 | (if (null? ,q) 19 | l2 20 | (cons (car l1) (append (cdr l1) l2))))]) 21 | (list 22 | (append '() '()) 23 | (append '() '(4 5)) 24 | (append '(1) '(4 5)) 25 | (append '(1 2) '(4 5)) 26 | (append '(1 2 3) '(4 5)) 27 | )) 28 | '(() 29 | (4 5) 30 | (1 4 5) 31 | (1 2 4 5) 32 | (1 2 3 4 5))))) 33 | -------------------------------------------------------------------------------- /test-quines.scm: -------------------------------------------------------------------------------- 1 | (define eval-expo 2 | (lambda (exp env val) 3 | (conde 4 | ((fresh (v) 5 | (== `(quote ,v) exp) 6 | (not-in-envo 'quote env) 7 | ;;(closure-absento v) 8 | (not-closureo v) 9 | (== v val))) 10 | ((fresh (a*) 11 | (== `(list . ,a*) exp) 12 | (not-in-envo 'list env) 13 | ;;(closure-absento a*) 14 | (not-closureo a*) 15 | (proper-listo a* env val))) 16 | ((symbolo exp) (lookupo exp env val)) 17 | ((fresh (rator rand x body env^ a) 18 | (== `(,rator ,rand) exp) 19 | (eval-expo rator env (make-closure x body env^)) 20 | (eval-expo rand env a) 21 | (eval-expo body `((,x . ,a) . ,env^) val))) 22 | ((fresh (x body) 23 | (== `(lambda (,x) ,body) exp) 24 | (symbolo x) 25 | (not-in-envo 'lambda env) 26 | (== (make-closure x body env) val)))))) 27 | 28 | (define not-in-envo 29 | (lambda (x env) 30 | (conde 31 | ((fresh (y v rest) 32 | (== `((,y . ,v) . ,rest) env) 33 | (=/= y x) 34 | (not-in-envo x rest))) 35 | ((== '() env))))) 36 | 37 | (define proper-listo 38 | (lambda (exp env val) 39 | (conde 40 | ((== '() exp) 41 | (== '() val)) 42 | ((fresh (a d t-a t-d) 43 | (== `(,a . ,d) exp) 44 | (== `(,t-a . ,t-d) val) 45 | (eval-expo a env t-a) 46 | (proper-listo d env t-d)))))) 47 | 48 | (define lookupo 49 | (lambda (x env t) 50 | (fresh (rest y v) 51 | (== `((,y . ,v) . ,rest) env) 52 | (conde 53 | ((== y x) (== v t)) 54 | ((=/= y x) (lookupo x rest t)))))) 55 | 56 | (time-test "1 quine forward" 57 | (run 1 (q) 58 | (== q '((lambda (_.0) (list _.0 (list 'quote _.0))) 59 | '(lambda (_.0) (list _.0 (list 'quote _.0))))) 60 | (eval-expo q '() q)) 61 | '(((lambda (_.0) (list _.0 (list 'quote _.0))) 62 | '(lambda (_.0) (list _.0 (list 'quote _.0)))))) 63 | 64 | (time-test "1 quine" 65 | (run 1 (q) (eval-expo q '() q)) 66 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 67 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 68 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 69 | (sym _.0)))) 70 | 71 | (time-test "2 quines" 72 | (run 2 (q) (eval-expo q '() q)) 73 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 74 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 75 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 76 | (sym _.0)) 77 | (((lambda (_.0) 78 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))) 79 | '(lambda (_.0) 80 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 81 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 82 | ((_.0 quote)) ((_.1 closure))) 83 | (sym _.0 _.1) 84 | (absento (closure _.2))))) 85 | 86 | (time-test "3 quines" 87 | (run 3 (q) (eval-expo q '() q)) 88 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 89 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 90 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 91 | (sym _.0)) 92 | (((lambda (_.0) 93 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))) 94 | '(lambda (_.0) 95 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 96 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 97 | ((_.0 quote)) ((_.1 closure))) 98 | (sym _.0 _.1) 99 | (absento (closure _.2))) 100 | (((lambda (_.0) 101 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0))) 102 | '(lambda (_.0) 103 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0)))) 104 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 105 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 106 | (sym _.0 _.1) 107 | (absento (closure _.2))))) 108 | 109 | (time-test "5 quines" 110 | (run 5 (q) (eval-expo q '() q)) 111 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 112 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 113 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 114 | (sym _.0)) 115 | (((lambda (_.0) 116 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))) 117 | '(lambda (_.0) 118 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 119 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 120 | ((_.0 quote)) ((_.1 closure))) 121 | (sym _.0 _.1) 122 | (absento (closure _.2))) 123 | (((lambda (_.0) 124 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0))) 125 | '(lambda (_.0) 126 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0)))) 127 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 128 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 129 | (sym _.0 _.1) 130 | (absento (closure _.2))) 131 | (((lambda (_.0) 132 | (list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 133 | '(list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 134 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 135 | (sym _.0)) 136 | (((lambda (_.0) 137 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0))) 138 | '(lambda (_.0) 139 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0)))) 140 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 141 | ((_.0 quote)) ((_.1 closure))) 142 | (sym _.0 _.1)))) 143 | 144 | (time-test "10 quines" 145 | (run 10 (q) (eval-expo q '() q)) 146 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 147 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 148 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 149 | (sym _.0)) 150 | (((lambda (_.0) 151 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))) 152 | '(lambda (_.0) 153 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 154 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 155 | ((_.0 quote)) ((_.1 closure))) 156 | (sym _.0 _.1) 157 | (absento (closure _.2))) 158 | (((lambda (_.0) 159 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0))) 160 | '(lambda (_.0) 161 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0)))) 162 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 163 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 164 | (sym _.0 _.1) 165 | (absento (closure _.2))) 166 | (((lambda (_.0) 167 | (list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 168 | '(list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 169 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 170 | (sym _.0)) 171 | (((lambda (_.0) 172 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0))) 173 | '(lambda (_.0) 174 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0)))) 175 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 176 | ((_.0 quote)) ((_.1 closure))) 177 | (sym _.0 _.1)) 178 | (((lambda (_.0) 179 | ((lambda (_.1) (list _.0 (list 'quote _.0))) '_.2)) 180 | '(lambda (_.0) 181 | ((lambda (_.1) (list _.0 (list 'quote _.0))) '_.2))) 182 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 183 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 184 | (sym _.0 _.1) 185 | (absento (closure _.2))) 186 | (((lambda (_.0) 187 | (list _.0 ((lambda (_.1) (list 'quote _.0)) '_.2))) 188 | '(lambda (_.0) 189 | (list _.0 ((lambda (_.1) (list 'quote _.0)) '_.2)))) 190 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 191 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 192 | (sym _.0 _.1) 193 | (absento (closure _.2))) 194 | (((lambda (_.0) 195 | (list _.0 (list 'quote ((lambda (_.1) _.0) '_.2)))) 196 | '(lambda (_.0) 197 | (list _.0 (list 'quote ((lambda (_.1) _.0) '_.2))))) 198 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 199 | ((_.0 quote)) ((_.1 closure))) 200 | (sym _.0 _.1) 201 | (absento (closure _.2))) 202 | (((lambda (_.0) 203 | ((lambda (_.1) (list _.1 (list 'quote _.1))) _.0)) 204 | '(lambda (_.0) 205 | ((lambda (_.1) (list _.1 (list 'quote _.1))) _.0))) 206 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 207 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 208 | (sym _.0 _.1)) 209 | (((lambda (_.0) 210 | (list _.0 ((lambda (_.1) (list 'quote _.1)) _.0))) 211 | '(lambda (_.0) 212 | (list _.0 ((lambda (_.1) (list 'quote _.1)) _.0)))) 213 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 214 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 215 | (sym _.0 _.1)))) 216 | 217 | (time-test "40 quines" 218 | (run 40 (q) (eval-expo q '() q)) 219 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 220 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 221 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 222 | (sym _.0)) 223 | (((lambda (_.0) 224 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))) 225 | '(lambda (_.0) 226 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 227 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 228 | ((_.0 quote)) ((_.1 closure))) 229 | (sym _.0 _.1) 230 | (absento (closure _.2))) 231 | (((lambda (_.0) 232 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0))) 233 | '(lambda (_.0) 234 | (list _.0 (list ((lambda (_.1) 'quote) '_.2) _.0)))) 235 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 236 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 237 | (sym _.0 _.1) 238 | (absento (closure _.2))) 239 | (((lambda (_.0) 240 | (list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 241 | '(list (list 'lambda '(_.0) _.0) (list 'quote _.0))) 242 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 243 | (sym _.0)) 244 | (((lambda (_.0) 245 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0))) 246 | '(lambda (_.0) 247 | (list _.0 (list ((lambda (_.1) _.1) 'quote) _.0)))) 248 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 249 | ((_.0 quote)) ((_.1 closure))) 250 | (sym _.0 _.1)) 251 | (((lambda (_.0) 252 | ((lambda (_.1) (list _.0 (list 'quote _.0))) '_.2)) 253 | '(lambda (_.0) 254 | ((lambda (_.1) (list _.0 (list 'quote _.0))) '_.2))) 255 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 256 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 257 | (sym _.0 _.1) 258 | (absento (closure _.2))) 259 | (((lambda (_.0) 260 | (list _.0 ((lambda (_.1) (list 'quote _.0)) '_.2))) 261 | '(lambda (_.0) 262 | (list _.0 ((lambda (_.1) (list 'quote _.0)) '_.2)))) 263 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 264 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 265 | (sym _.0 _.1) 266 | (absento (closure _.2))) 267 | (((lambda (_.0) 268 | (list _.0 (list 'quote ((lambda (_.1) _.0) '_.2)))) 269 | '(lambda (_.0) 270 | (list _.0 (list 'quote ((lambda (_.1) _.0) '_.2))))) 271 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 272 | ((_.0 quote)) ((_.1 closure))) 273 | (sym _.0 _.1) 274 | (absento (closure _.2))) 275 | (((lambda (_.0) 276 | ((lambda (_.1) (list _.1 (list 'quote _.1))) _.0)) 277 | '(lambda (_.0) 278 | ((lambda (_.1) (list _.1 (list 'quote _.1))) _.0))) 279 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 280 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 281 | (sym _.0 _.1)) 282 | (((lambda (_.0) 283 | (list _.0 ((lambda (_.1) (list 'quote _.1)) _.0))) 284 | '(lambda (_.0) 285 | (list _.0 ((lambda (_.1) (list 'quote _.1)) _.0)))) 286 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 287 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 288 | (sym _.0 _.1)) 289 | (((lambda (_.0) 290 | ((lambda (_.1) (list _.0 (list _.1 _.0))) 'quote)) 291 | '(lambda (_.0) 292 | ((lambda (_.1) (list _.0 (list _.1 _.0))) 'quote))) 293 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 294 | ((_.0 quote)) ((_.1 closure)) ((_.1 list))) 295 | (sym _.0 _.1)) 296 | (((lambda (_.0) 297 | (list _.0 ((lambda (_.1) (list _.1 _.0)) 'quote))) 298 | '(lambda (_.0) 299 | (list _.0 ((lambda (_.1) (list _.1 _.0)) 'quote)))) 300 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 301 | ((_.0 quote)) ((_.1 closure)) ((_.1 list))) 302 | (sym _.0 _.1)) 303 | (((lambda (_.0) 304 | (list _.0 (list 'quote ((lambda (_.1) _.1) _.0)))) 305 | '(lambda (_.0) 306 | (list _.0 (list 'quote ((lambda (_.1) _.1) _.0))))) 307 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 308 | ((_.0 quote)) ((_.1 closure))) 309 | (sym _.0 _.1)) 310 | (((lambda (_.0) 311 | (list 312 | ((lambda (_.1) _.0) '_.2) 313 | (list ((lambda (_.3) 'quote) '_.4) _.0))) 314 | '(lambda (_.0) 315 | (list 316 | ((lambda (_.1) _.0) '_.2) 317 | (list ((lambda (_.3) 'quote) '_.4) _.0)))) 318 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 319 | ((_.0 quote)) ((_.1 closure)) ((_.3 closure)) ((_.3 quote))) 320 | (sym _.0 _.1 _.3) 321 | (absento (closure _.2) (closure _.4))) 322 | (((lambda (_.0) 323 | (list ((lambda (_.1) _.1) _.0) (list 'quote _.0))) 324 | '(lambda (_.0) 325 | (list ((lambda (_.1) _.1) _.0) (list 'quote _.0)))) 326 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 327 | ((_.0 quote)) ((_.1 closure))) 328 | (sym _.0 _.1)) 329 | (((lambda (_.0) 330 | (list _.0 (list 'quote ((lambda (_.1) _.0) _.0)))) 331 | '(lambda (_.0) 332 | (list _.0 (list 'quote ((lambda (_.1) _.0) _.0))))) 333 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 334 | ((_.0 quote)) ((_.1 closure))) 335 | (sym _.0 _.1)) 336 | (((lambda (_.0) 337 | (list _.0 ((lambda (_.1) (list 'quote _.0)) _.0))) 338 | '(lambda (_.0) 339 | (list _.0 ((lambda (_.1) (list 'quote _.0)) _.0)))) 340 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 341 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 342 | (sym _.0 _.1)) 343 | (((lambda (_.0) 344 | ((lambda (_.1) (list _.1 (list 'quote _.0))) _.0)) 345 | '(lambda (_.0) 346 | ((lambda (_.1) (list _.1 (list 'quote _.0))) _.0))) 347 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 348 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 349 | (sym _.0 _.1)) 350 | (((lambda (_.0) 351 | (list _.0 (list ((lambda (_.1) 'quote) _.0) _.0))) 352 | '(lambda (_.0) 353 | (list _.0 (list ((lambda (_.1) 'quote) _.0) _.0)))) 354 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 355 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 356 | (sym _.0 _.1)) 357 | (((lambda (_.0) 358 | (list 359 | ((lambda (_.1) _.0) '_.2) 360 | (list ((lambda (_.3) _.3) 'quote) _.0))) 361 | '(lambda (_.0) 362 | (list 363 | ((lambda (_.1) _.0) '_.2) 364 | (list ((lambda (_.3) _.3) 'quote) _.0)))) 365 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 366 | ((_.0 quote)) ((_.1 closure)) ((_.3 closure))) 367 | (sym _.0 _.1 _.3) 368 | (absento (closure _.2))) 369 | (((lambda (_.0) 370 | (list 371 | ((lambda (_.1) _.0) '_.2) 372 | ((lambda (_.3) (list 'quote _.0)) '_.4))) 373 | '(lambda (_.0) 374 | (list 375 | ((lambda (_.1) _.0) '_.2) 376 | ((lambda (_.3) (list 'quote _.0)) '_.4)))) 377 | (=/= ((_.0 _.1)) ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) 378 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.3 closure)) 379 | ((_.3 list)) ((_.3 quote))) 380 | (sym _.0 _.1 _.3) 381 | (absento (closure _.2) (closure _.4))) 382 | (((lambda (_.0) 383 | (list 384 | ((lambda (_.1) _.0) '_.2) 385 | (list 'quote ((lambda (_.3) _.0) '_.4)))) 386 | '(lambda (_.0) 387 | (list 388 | ((lambda (_.1) _.0) '_.2) 389 | (list 'quote ((lambda (_.3) _.0) '_.4))))) 390 | (=/= ((_.0 _.1)) ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) 391 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.3 closure))) 392 | (sym _.0 _.1 _.3) 393 | (absento (closure _.2) (closure _.4))) 394 | (((lambda (_.0) 395 | (list 396 | _.0 397 | (list 398 | ((lambda (_.1) 'quote) '_.2) 399 | ((lambda (_.3) _.0) '_.4)))) 400 | '(lambda (_.0) 401 | (list 402 | _.0 403 | (list 404 | ((lambda (_.1) 'quote) '_.2) 405 | ((lambda (_.3) _.0) '_.4))))) 406 | (=/= ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 407 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote)) ((_.3 closure))) 408 | (sym _.0 _.1 _.3) 409 | (absento (closure _.2) (closure _.4))) 410 | (((lambda (_.0) 411 | ((lambda (_.1) (list _.0 (list 'quote _.1))) _.0)) 412 | '(lambda (_.0) 413 | ((lambda (_.1) (list _.0 (list 'quote _.1))) _.0))) 414 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 415 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 416 | (sym _.0 _.1)) 417 | (((lambda (_.0) 418 | (list _.0 (list 'quote ((lambda (_.1) _.0) (list))))) 419 | '(lambda (_.0) 420 | (list _.0 (list 'quote ((lambda (_.1) _.0) (list)))))) 421 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 422 | ((_.0 quote)) ((_.1 closure))) 423 | (sym _.0 _.1)) 424 | (((lambda (_.0) 425 | (list 426 | (list 'lambda '(_.0) _.0) 427 | (list ((lambda (_.1) 'quote) '_.2) _.0))) 428 | '(list 429 | (list 'lambda '(_.0) _.0) 430 | (list ((lambda (_.1) 'quote) '_.2) _.0))) 431 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 432 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 433 | (sym _.0 _.1) 434 | (absento (closure _.2))) 435 | (((lambda (_.0) 436 | ((lambda (_.1) 437 | (list ((lambda (_.2) _.0) '_.3) (list 'quote _.0))) 438 | '_.4)) 439 | '(lambda (_.0) 440 | ((lambda (_.1) 441 | (list ((lambda (_.2) _.0) '_.3) (list 'quote _.0))) 442 | '_.4))) 443 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 closure)) ((_.0 lambda)) 444 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.1 lambda)) 445 | ((_.1 list)) ((_.1 quote)) ((_.2 closure))) 446 | (sym _.0 _.1 _.2) 447 | (absento (closure _.3) (closure _.4))) 448 | (((lambda (_.0) 449 | (list 450 | ((lambda (_.1) _.0) '_.2) 451 | ((lambda (_.3) (list 'quote _.3)) _.0))) 452 | '(lambda (_.0) 453 | (list 454 | ((lambda (_.1) _.0) '_.2) 455 | ((lambda (_.3) (list 'quote _.3)) _.0)))) 456 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 457 | ((_.0 quote)) ((_.1 closure)) ((_.3 closure)) ((_.3 list)) 458 | ((_.3 quote))) 459 | (sym _.0 _.1 _.3) 460 | (absento (closure _.2))) 461 | (((lambda (_.0) 462 | (list 463 | ((lambda (_.1) _.0) '_.2) 464 | ((lambda (_.3) (list _.3 _.0)) 'quote))) 465 | '(lambda (_.0) 466 | (list 467 | ((lambda (_.1) _.0) '_.2) 468 | ((lambda (_.3) (list _.3 _.0)) 'quote)))) 469 | (=/= ((_.0 _.1)) ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) 470 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.3 closure)) 471 | ((_.3 list))) 472 | (sym _.0 _.1 _.3) 473 | (absento (closure _.2))) 474 | (((lambda (_.0) 475 | (list 476 | ((lambda (_.1) _.0) '_.2) 477 | (list 'quote ((lambda (_.3) _.3) _.0)))) 478 | '(lambda (_.0) 479 | (list 480 | ((lambda (_.1) _.0) '_.2) 481 | (list 'quote ((lambda (_.3) _.3) _.0))))) 482 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 483 | ((_.0 quote)) ((_.1 closure)) ((_.3 closure))) 484 | (sym _.0 _.1 _.3) 485 | (absento (closure _.2))) 486 | (((lambda (_.0) 487 | (list _.0 ((lambda (_.1) (list 'quote _.0)) (list)))) 488 | '(lambda (_.0) 489 | (list _.0 ((lambda (_.1) (list 'quote _.0)) (list))))) 490 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 491 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 492 | (sym _.0 _.1)) 493 | (((lambda (_.0) 494 | (list 495 | _.0 496 | (list 497 | ((lambda (_.1) 'quote) '_.2) 498 | ((lambda (_.3) _.3) _.0)))) 499 | '(lambda (_.0) 500 | (list 501 | _.0 502 | (list 503 | ((lambda (_.1) 'quote) '_.2) 504 | ((lambda (_.3) _.3) _.0))))) 505 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 506 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote)) ((_.3 closure))) 507 | (sym _.0 _.1 _.3) 508 | (absento (closure _.2))) 509 | (((lambda (_.0) 510 | ((lambda (_.1) (list _.0 (list 'quote _.0))) (list))) 511 | '(lambda (_.0) 512 | ((lambda (_.1) (list _.0 (list 'quote _.0))) (list)))) 513 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 514 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 515 | (sym _.0 _.1)) 516 | (((lambda (_.0) 517 | (list ((lambda (_.1) _.0) _.0) (list 'quote _.0))) 518 | '(lambda (_.0) 519 | (list ((lambda (_.1) _.0) _.0) (list 'quote _.0)))) 520 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 521 | ((_.0 quote)) ((_.1 closure))) 522 | (sym _.0 _.1)) 523 | (((lambda (_.0) 524 | (list 525 | (list 'lambda '(_.0) _.0) 526 | (list ((lambda (_.1) _.1) 'quote) _.0))) 527 | '(list 528 | (list 'lambda '(_.0) _.0) 529 | (list ((lambda (_.1) _.1) 'quote) _.0))) 530 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 531 | ((_.0 quote)) ((_.1 closure))) 532 | (sym _.0 _.1)) 533 | (((lambda (_.0) 534 | ((lambda (_.1) (list _.0 (list 'quote _.0))) _.0)) 535 | '(lambda (_.0) 536 | ((lambda (_.1) (list _.0 (list 'quote _.0))) _.0))) 537 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 538 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 539 | (sym _.0 _.1)) 540 | (((lambda (_.0) 541 | (list 542 | (list 'lambda '(_.0) _.0) 543 | ((lambda (_.1) (list 'quote _.0)) '_.2))) 544 | '(list 545 | (list 'lambda '(_.0) _.0) 546 | ((lambda (_.1) (list 'quote _.0)) '_.2))) 547 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 548 | ((_.0 quote)) ((_.1 closure)) ((_.1 list)) ((_.1 quote))) 549 | (sym _.0 _.1) 550 | (absento (closure _.2))) 551 | (((lambda (_.0) 552 | (list 553 | ((lambda (_.1) _.0) '_.2) 554 | (list 'quote ((lambda (_.3) _.0) _.0)))) 555 | '(lambda (_.0) 556 | (list 557 | ((lambda (_.1) _.0) '_.2) 558 | (list 'quote ((lambda (_.3) _.0) _.0))))) 559 | (=/= ((_.0 _.1)) ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) 560 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.3 closure))) 561 | (sym _.0 _.1 _.3) 562 | (absento (closure _.2))) 563 | (((lambda (_.0) 564 | (list 565 | ((lambda (_.1) _.0) '_.2) 566 | ((lambda (_.3) (list 'quote _.0)) _.0))) 567 | '(lambda (_.0) 568 | (list 569 | ((lambda (_.1) _.0) '_.2) 570 | ((lambda (_.3) (list 'quote _.0)) _.0)))) 571 | (=/= ((_.0 _.1)) ((_.0 _.3)) ((_.0 closure)) ((_.0 lambda)) 572 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.3 closure)) 573 | ((_.3 list)) ((_.3 quote))) 574 | (sym _.0 _.1 _.3) 575 | (absento (closure _.2))) 576 | (((lambda (_.0) 577 | ((lambda (_.1) 578 | (list ((lambda (_.2) _.0) '_.3) (list _.1 _.0))) 579 | 'quote)) 580 | '(lambda (_.0) 581 | ((lambda (_.1) 582 | (list ((lambda (_.2) _.0) '_.3) (list _.1 _.0))) 583 | 'quote))) 584 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 closure)) ((_.0 lambda)) 585 | ((_.0 list)) ((_.0 quote)) ((_.1 closure)) ((_.1 lambda)) 586 | ((_.1 list)) ((_.1 quote)) ((_.2 closure))) 587 | (sym _.0 _.1 _.2) 588 | (absento (closure _.3))))) 589 | 590 | (time-test "2 twines" 591 | (run 2 (x) (fresh (p q) 592 | (=/= p q) 593 | (eval-expo p '() q) 594 | (eval-expo q '() p) 595 | (== `(,p ,q) x))) 596 | '((('((lambda (_.0) 597 | (list 'quote (list _.0 (list 'quote _.0)))) 598 | '(lambda (_.0) (list 'quote (list _.0 (list 'quote _.0))))) 599 | ((lambda (_.0) (list 'quote (list _.0 (list 'quote _.0)))) 600 | '(lambda (_.0) (list 'quote (list _.0 (list 'quote _.0)))))) 601 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 602 | (sym _.0)) 603 | (('((lambda (_.0) 604 | (list 605 | 'quote 606 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 607 | '(lambda (_.0) 608 | (list 609 | 'quote 610 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))))) 611 | ((lambda (_.0) 612 | (list 613 | 'quote 614 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))) 615 | '(lambda (_.0) 616 | (list 617 | 'quote 618 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))))) 619 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 620 | ((_.0 quote)) ((_.1 closure))) 621 | (sym _.0 _.1) 622 | (absento (closure _.2))))) 623 | 624 | (time-test "4 thrines" 625 | (run 4 (x) 626 | (fresh (p q r) 627 | (=/= p q) 628 | (=/= q r) 629 | (=/= r p) 630 | (eval-expo p '() q) 631 | (eval-expo q '() r) 632 | (eval-expo r '() p) 633 | (== `(,p ,q ,r) x))) 634 | '(((''((lambda (_.0) 635 | (list 'quote (list 'quote (list _.0 (list 'quote _.0))))) 636 | '(lambda (_.0) 637 | (list 'quote (list 'quote (list _.0 (list 'quote _.0)))))) 638 | '((lambda (_.0) 639 | (list 'quote (list 'quote (list _.0 (list 'quote _.0))))) 640 | '(lambda (_.0) 641 | (list 'quote (list 'quote (list _.0 (list 'quote _.0)))))) 642 | ((lambda (_.0) 643 | (list 'quote (list 'quote (list _.0 (list 'quote _.0))))) 644 | '(lambda (_.0) 645 | (list 'quote (list 'quote (list _.0 (list 'quote _.0))))))) 646 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 647 | (sym _.0)) 648 | ((''((lambda (_.0) 649 | (list 650 | 'quote 651 | (list 652 | 'quote 653 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))))) 654 | '(lambda (_.0) 655 | (list 656 | 'quote 657 | (list 658 | 'quote 659 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))))) 660 | '((lambda (_.0) 661 | (list 662 | 'quote 663 | (list 664 | 'quote 665 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))))) 666 | '(lambda (_.0) 667 | (list 668 | 'quote 669 | (list 670 | 'quote 671 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0)))))) 672 | ((lambda (_.0) 673 | (list 674 | 'quote 675 | (list 676 | 'quote 677 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))))) 678 | '(lambda (_.0) 679 | (list 680 | 'quote 681 | (list 682 | 'quote 683 | (list ((lambda (_.1) _.0) '_.2) (list 'quote _.0))))))) 684 | (=/= ((_.0 _.1)) ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 685 | ((_.0 quote)) ((_.1 closure))) 686 | (sym _.0 _.1) 687 | (absento (closure _.2))) 688 | (('(list 689 | '(lambda (_.0) 690 | (list 691 | 'quote 692 | (list 'list _.0 (list 'quote (list 'quote _.0))))) 693 | '''(lambda (_.0) 694 | (list 695 | 'quote 696 | (list 'list _.0 (list 'quote (list 'quote _.0)))))) 697 | (list 698 | '(lambda (_.0) 699 | (list 700 | 'quote 701 | (list 'list _.0 (list 'quote (list 'quote _.0))))) 702 | '''(lambda (_.0) 703 | (list 704 | 'quote 705 | (list 'list _.0 (list 'quote (list 'quote _.0)))))) 706 | ((lambda (_.0) 707 | (list 708 | 'quote 709 | (list 'list _.0 (list 'quote (list 'quote _.0))))) 710 | ''(lambda (_.0) 711 | (list 712 | 'quote 713 | (list 'list _.0 (list 'quote (list 'quote _.0))))))) 714 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 715 | (sym _.0)) 716 | ((''((lambda (_.0) 717 | (list 718 | ((lambda (_.1) 'quote) '_.2) 719 | (list 'quote (list _.0 (list 'quote _.0))))) 720 | '(lambda (_.0) 721 | (list 722 | ((lambda (_.1) 'quote) '_.2) 723 | (list 'quote (list _.0 (list 'quote _.0)))))) 724 | '((lambda (_.0) 725 | (list 726 | ((lambda (_.1) 'quote) '_.2) 727 | (list 'quote (list _.0 (list 'quote _.0))))) 728 | '(lambda (_.0) 729 | (list 730 | ((lambda (_.1) 'quote) '_.2) 731 | (list 'quote (list _.0 (list 'quote _.0)))))) 732 | ((lambda (_.0) 733 | (list 734 | ((lambda (_.1) 'quote) '_.2) 735 | (list 'quote (list _.0 (list 'quote _.0))))) 736 | '(lambda (_.0) 737 | (list 738 | ((lambda (_.1) 'quote) '_.2) 739 | (list 'quote (list _.0 (list 'quote _.0))))))) 740 | (=/= ((_.0 closure)) ((_.0 lambda)) ((_.0 list)) 741 | ((_.0 quote)) ((_.1 closure)) ((_.1 quote))) 742 | (sym _.0 _.1) 743 | (absento (closure _.2))))) 744 | -------------------------------------------------------------------------------- /tests.scm: -------------------------------------------------------------------------------- 1 | (load "helper.scm") 2 | (load "mk-on-smt.scm") 3 | (load "test-check.scm") 4 | 5 | (test "nil-1" 6 | (run* (q) (== q '())) 7 | '(())) 8 | 9 | (test "bool-1" 10 | (run* (q) (disj2 (== q #t) (== q #f))) 11 | '(#t #f)) 12 | 13 | (test "cons-1" 14 | (run* (q) (== q (cons 'a 'b))) 15 | '((a . b))) 16 | 17 | (test "closure-1" 18 | (run* (q) (== q (make-closure 'x 'x '()))) 19 | '(#(closure x x ()))) 20 | 21 | (test "int-1" 22 | (run* (q) (disj2 (== q 1) (== q 2))) 23 | '(1 2)) 24 | 25 | (test "real-1" 26 | (run* (q) (== q 2.5)) 27 | '(2.5)) 28 | 29 | (test "conj-1" 30 | (run* (q) (conj2 (numbero q) (== q 1))) 31 | '(1)) 32 | 33 | (test "conj-2" 34 | (run* (q) (conj2 (numbero q) (== q 'hello))) 35 | '()) 36 | 37 | (test "fresh-1" 38 | (run* (q) (fresh (x y) (== x q) (== y q) (== x 1))) 39 | '(1)) 40 | 41 | (test "conde-1" 42 | (run* (q) (conde ((== q 1)) ((== q 2)) ((== q 3)))) 43 | '(1 2 3)) 44 | 45 | (define (appendo l s out) 46 | (conde 47 | ((== l '()) (== s out)) 48 | ((fresh (a d res) 49 | (== l (cons a d)) 50 | (== out (cons a res)) 51 | (appendo d s res))))) 52 | 53 | (test "rec-1" 54 | (run 1 (q) (appendo '(a b) '(c d) q)) 55 | '((a b c d))) 56 | 57 | (test "rec-bwd-1" 58 | (run* (q) (fresh (x y) (appendo x y '(a b c d)) 59 | (== q (list x y)))) 60 | '((() (a b c d)) 61 | ((a) (b c d)) 62 | ((a b) (c d)) 63 | ((a b c) (d)) 64 | ((a b c d) ()))) 65 | 66 | #; 67 | (test "closure-absento-1" 68 | (run* (q) (closure-absento q) (== q 1)) 69 | '(1)) 70 | 71 | #; 72 | (test "closure-absento-2" 73 | (run* (q) (closure-absento q) (== q (make-closure 'x 'x '()))) 74 | '()) 75 | 76 | (define (anyo out) 77 | (conde 78 | ((== 1 out)) 79 | ((anyo out)))) 80 | 81 | (test "anyo-1" 82 | (run 1 (q) (anyo q)) 83 | '(1)) 84 | 85 | (test "cdcl-1" 86 | (run* (q) 87 | (fresh (x y) 88 | (conde 89 | ((== x 1)) 90 | ((== x 2))) 91 | (conde 92 | ((== y 1)) 93 | ((== y 2))) 94 | (== q (cons x y)))) 95 | '((1 . 1) (2 . 1) (1 . 2) (2 . 2))) 96 | 97 | (test "cdcl-2" 98 | (run* (q) 99 | (fresh (x) 100 | (conde 101 | ((== x 1)) 102 | ((== x 2))) 103 | (== q x))) 104 | '(1 2)) 105 | 106 | (test "cdcl-3" 107 | (run* (q) 108 | (fresh (x y) 109 | (== x 1) 110 | (anyo y) 111 | (== x 2))) 112 | '()) 113 | 114 | (test "cdcl-4" 115 | (run* (q) 116 | (fresh (x y) 117 | (== x 1) 118 | (anyo y) 119 | (conde 120 | ((== x 2)) 121 | ((== x 3))))) 122 | '()) 123 | 124 | (define (many1o x n) 125 | (if (<= n 0) 126 | (== x 1) 127 | (conde 128 | ((== x 1)) 129 | ((many1o x (- n 1)))))) 130 | 131 | (define (manyn1o x n) 132 | (if (<= n 0) 133 | (== x 2) 134 | (conde 135 | ((== x (+ n 10))) 136 | ((manyn1o x (- n 1)))))) 137 | 138 | #; 139 | (test "cdcl-5" 140 | (run 1 (q) 141 | (fresh (x) 142 | (many1o x 10000) 143 | (manyn1o x 10000))) 144 | '()) 145 | 146 | (test "cdcl-6" 147 | (run 1 (q) 148 | (fresh (x y z) 149 | (anyo x) 150 | (== y 1) 151 | (anyo z) 152 | (manyn1o y 1000))) ;; slow 153 | '()) 154 | 155 | (test "cdcl-7" 156 | (run 1 (q) 157 | (fresh (x y z) 158 | (anyo x) 159 | (== y 2) 160 | (anyo z) 161 | (many1o y 1000))) 162 | '()) 163 | --------------------------------------------------------------------------------