├── .io.livecode.ch ├── _site │ └── index.html ├── defaults.json ├── footer.txt ├── header.txt ├── install └── run ├── ==-tests.scm ├── LICENSE ├── README.md ├── absento-closure-tests.scm ├── absento-tests.scm ├── abstract-interp-tagged.scm ├── abstract-interp.scm ├── bouncing.rkt ├── boxes.rkt ├── boxes.scm ├── clpset-tests.scm ├── clpset.scm ├── clpsmt-basic-tests.rkt ├── clpsmt-basic-tests.scm ├── clpsmt-tests.scm ├── cvc4-driver.scm ├── cvc4-server-robust.scm ├── cvc4-server.scm ├── cvc4-set-tests.scm ├── disequality-tests.scm ├── ex-model-unsat.smt ├── ex-model.smt ├── ex-sat.smt ├── ex-unsat.smt ├── exp.scm ├── exp2.scm ├── full-abstract-interp-extended-tests.scm ├── full-abstract-interp-extended.scm ├── full-interp-extended-memo-lambda-tests.scm ├── full-interp-extended-memo-lambda.scm ├── full-interp-extended-tests.scm ├── full-interp-extended-with-amb-tests.scm ├── full-interp-extended-with-amb.scm ├── full-interp-extended.scm ├── full-interp-mutation-apply-tests.scm ├── full-interp-mutation-apply.scm ├── full-interp-quine.scm ├── full-interp-with-let.scm ├── full-interp.scm ├── interp-program-synthesizer-blog-post.scm ├── kcoloring.scm ├── mk-streaming-interface.scm ├── mk.rkt ├── mk.scm ├── mkf.scm ├── music.scm ├── numbero-tests.scm ├── numbers.scm ├── old-twenty-four-puzzle.scm ├── program-synthesizer-blog-post.scm ├── property-based-synthesis-tests.scm ├── radi-tests.scm ├── radi.scm ├── radif-tests.scm ├── radif.scm ├── radiw-concrete-tests.scm ├── radiw-concrete.scm ├── radiw-tests.scm ├── radiw.scm ├── rai-clojure ├── .lein-repl-history ├── README.md ├── project.clj ├── src │ └── rai_clojure │ │ ├── core.clj │ │ └── rai.clj ├── target │ ├── classes │ │ └── META-INF │ │ │ └── maven │ │ │ └── rai-clojure │ │ │ └── rai-clojure │ │ │ └── pom.properties │ └── stale │ │ └── leiningen.core.classpath.extract-native-dependencies └── test │ └── rai_clojure │ └── test │ └── core.clj ├── rcd.scm ├── rcd.smt ├── reactive.rkt ├── reactive1.rkt ├── reactive2.rkt ├── reactive3.rkt ├── reactive4.rkt ├── recordsub.scm ├── rsa.scm ├── sign-domain-tests.scm ├── sign-domain.scm ├── simple-interp.scm ├── soft.smt ├── sudoku.rkt ├── symbolic-execution-tests.scm ├── symbolo-numbero-tests.scm ├── symbolo-tests.scm ├── synthesis.scm ├── tabling-tests.scm ├── tabling.scm ├── talk.rkt ├── talk.scm ├── tapl.scm ├── tapl.smt ├── tapl_cvc4.smt ├── test-all.scm ├── test-check.scm ├── test-full-suite.scm ├── test-header-with-tabling.scm ├── test-header.scm ├── test-numbers.scm ├── test-simple-interp.scm ├── test-suite-tabling.scm ├── twenty-four-puzzle-depth-limit.scm ├── twenty-four-puzzle-smart-transcript.scm ├── twenty-four-puzzle-smart.scm ├── twenty-four-puzzle.scm ├── while-abort-tests.scm ├── while-abort.scm ├── yices-server.scm ├── z3-driver.scm ├── z3-noserver.scm ├── z3-server-robust.scm ├── z3-server.rkt ├── z3-server.scm └── z3-tests.scm /.io.livecode.ch/_site/index.html: -------------------------------------------------------------------------------- 1 | {% extends "base_livecode.html" %} 2 | 3 | {% block title %}CLP(SMT) playground{% endblock %} 4 | 5 | {% block content %} 6 | 7 |
8 | #lang racket 9 | 10 | (require racket/system) 11 | 12 | (define rows 13 | (for/list ([i (in-range 1 10)]) 14 | (for/list ([j (in-range 1 10)]) 15 | (cons i j)))) 16 | (define cols 17 | (for/list ([i (in-range 1 10)]) 18 | (for/list ([j (in-range 1 10)]) 19 | (cons j i)))) 20 | (define squares 21 | (for*/list ([m (in-range 3)] [n (in-range 3)]) 22 | (for*/list ([i (in-range 3)] [j (in-range 3)]) 23 | (cons (+ i (* n 3) 1) (+ j (* m 3) 1))))) 24 | 25 | (define (name ij) 26 | (let ((i (car ij)) (j (cdr ij))) 27 | (string->symbol (string-append "x" (string-append (number->string i) (number->string j)))))) 28 | (define (model-assoc m) 29 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 30 | (define (model-get m ij) (cdr (assoc (name ij) m))) 31 | (define (model->puzzle m) 32 | (for/vector ([i (in-range 1 10)]) 33 | (for/vector ([j (in-range 1 10)]) 34 | (model-get m (cons i j))))) 35 | (define (print-puzzle puzzle) 36 | (printf "~a\n" "'#(") 37 | (for ([line puzzle]) 38 | (printf " ~a\n" line)) 39 | (printf " ~a\n" ")")) 40 | (define (puzzle-index puzzle i j) 41 | (vector-ref (vector-ref puzzle (- i 1)) (- j 1))) 42 | 43 | (define puzzle 44 | '#( 45 | #(4 0 0 0 0 0 8 0 5) 46 | #(0 3 0 0 0 0 0 0 0) 47 | #(0 0 0 7 0 0 0 0 0) 48 | #(0 2 0 0 0 0 0 6 0) 49 | #(0 0 0 0 8 0 4 0 0) 50 | #(0 0 0 0 1 0 0 0 0) 51 | #(0 0 0 6 0 3 0 7 0) 52 | #(5 0 0 2 0 0 0 0 0) 53 | #(1 0 4 0 0 0 0 0 0) 54 | )) 55 | 56 | (define (say msg) 57 | (printf "~a\n" msg)) 58 | 59 | (define (board-constraints say) 60 | (for ([i (in-range 1 10)]) 61 | (for ([j (in-range 1 10)]) 62 | (let ((x (name (cons i j)))) 63 | (say `(declare-const ,x Int)) 64 | (say `(assert (<= 1 ,x))) 65 | (say `(assert (<= ,x 9)))))) 66 | (for ([c (list rows cols squares)]) 67 | (for ([r c]) 68 | (say `(assert (distinct . ,(map name r))))))) 69 | 70 | (define (puzzle-constraints puzzle say) 71 | (for ([i (in-range 1 10)]) 72 | (for ([j (in-range 1 10)]) 73 | (let ((r (puzzle-index puzzle i j))) 74 | (when (not (= r 0)) 75 | (let ((x (name (cons i j)))) 76 | (say `(assert (= ,x ,r))))))))) 77 | 78 | (define (uniqueness-constraints puzzle solution say) 79 | (say 80 | `(assert (or . 81 | ,(for*/list ([i (in-range 1 10)] [j (in-range 1 10)] 82 | #:when (= 0 (puzzle-index puzzle i j))) 83 | (let ((x (name (cons i j)))) 84 | `(not (= ,x ,(puzzle-index solution i j))))))))) 85 | 86 | (define (solve-sudoku puzzle) 87 | (match (process "z3 -in") 88 | [(list p-in p-out _ p-err p-fun) 89 | (define (say msg) 90 | ;(printf "~a\n" msg) 91 | (fprintf p-out "~a\n" msg)) 92 | (define (check-sat) 93 | (say '(check-sat)) 94 | (flush-output p-out) 95 | (let ((r (read p-in))) 96 | (println r) 97 | (eq? r 'sat))) 98 | (define (get-model) 99 | (say '(get-model)) 100 | (flush-output p-out) 101 | (model-assoc (read p-in))) 102 | 103 | (board-constraints say) 104 | (puzzle-constraints puzzle say) 105 | (if (check-sat) 106 | (let ((solution (model->puzzle (get-model)))) 107 | (print-puzzle solution) 108 | 109 | (uniqueness-constraints puzzle solution say) 110 | 111 | (if (check-sat) 112 | (printf "~a\n" ";; solution is not unique!") 113 | (printf "~a\n" ";; solution is unique :)")) 114 | ) 115 | (printf "~a\n" ";; no solution :(")) 116 | 117 | (close-input-port p-in) 118 | (close-output-port p-out) 119 | (close-input-port p-err)])) 120 | 121 | (solve-sudoku puzzle) 122 |
123 | 124 |
125 | #!/bin/bash 126 | set -e -v 127 | 128 | racket $1 129 |
130 | 131 | {% endblock %} 132 | -------------------------------------------------------------------------------- /.io.livecode.ch/defaults.json: -------------------------------------------------------------------------------- 1 | { 2 | "language" : "scheme" 3 | } 4 | -------------------------------------------------------------------------------- /.io.livecode.ch/footer.txt: -------------------------------------------------------------------------------- 1 | )) 2 | (newline) 3 | (flush-output-port (current-output-port)) 4 | -------------------------------------------------------------------------------- /.io.livecode.ch/header.txt: -------------------------------------------------------------------------------- 1 | (display (let () 2 | -------------------------------------------------------------------------------- /.io.livecode.ch/install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | echo OK -------------------------------------------------------------------------------- /.io.livecode.ch/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e -v 3 | 4 | bash $1 $2 5 | -------------------------------------------------------------------------------- /==-tests.scm: -------------------------------------------------------------------------------- 1 | (test "1" 2 | (run 1 (q) (== 5 q)) 3 | '(5)) 4 | 5 | (test "2" 6 | (run* (q) 7 | (conde 8 | [(== 5 q)] 9 | [(== 6 q)])) 10 | '(5 6)) 11 | 12 | (test "3" 13 | (run* (q) 14 | (fresh (a d) 15 | (conde 16 | [(== 5 a)] 17 | [(== 6 d)]) 18 | (== `(,a . ,d) q))) 19 | '((5 . _.0) (_.0 . 6))) 20 | 21 | (define appendo 22 | (lambda (l s out) 23 | (conde 24 | [(== '() l) (== s out)] 25 | [(fresh (a d res) 26 | (== `(,a . ,d) l) 27 | (== `(,a . ,res) out) 28 | (appendo d s res))]))) 29 | 30 | (test "4" 31 | (run* (q) (appendo '(a b c) '(d e) q)) 32 | '((a b c d e))) 33 | 34 | (test "5" 35 | (run* (q) (appendo q '(d e) '(a b c d e))) 36 | '((a b c))) 37 | 38 | (test "6" 39 | (run* (q) (appendo '(a b c) q '(a b c d e))) 40 | '((d e))) 41 | 42 | (test "7" 43 | (run 5 (q) 44 | (fresh (l s out) 45 | (appendo l s out) 46 | (== `(,l ,s ,out) q))) 47 | '((() _.0 _.0) 48 | ((_.0) _.1 (_.0 . _.1)) 49 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 50 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 51 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 52 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Nada Amin, Daniel P. Friedman, Oleg Kiselyov, and William E. Byrd 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 | CLP(SMT)-miniKanren 2 | =================== 3 | 4 | Canonical miniKanren implementation, augmented with CLP(SMT). 5 | 6 | This repository adds SMT hooks: `z/assert` takes a boolean arithmetic expression with variables (integer by default), `z/` takes an SMT statement, `z/purge` manually purges the SMT constraints into an enumeration of models, `z/check` only fails if the constraints are unsatisfiable. 7 | 8 | See also: 9 | - (recommended version) https://github.com/chansey97/faster-minikanren/tree/smt-assumptions-full-integration 10 | - https://github.com/namin/faster-miniKanren/tree/smt-assumptions 11 | - https://github.com/webyrd/Barliman/blob/will-clpsmt/cocoa/Barliman/mk-and-rel-interp/test-interp.scm 12 | 13 | Background on miniKanren 14 | ------------------------ 15 | 16 | Starts with the language described in the paper: 17 | 18 | William E. Byrd, Eric Holk, and Daniel P. Friedman. 19 | miniKanren, Live and Untagged: Quine Generation via Relational Interpreters (Programming Pearl). 20 | To appear in the Proceedings of the 2012 Workshop on Scheme and Functional Programming, Copenhagen, Denmark, 2012. 21 | 22 | 23 | CORE LANGUAGE 24 | 25 | Logical operators: 26 | 27 | == 28 | fresh 29 | conde 30 | 31 | Interface operators: 32 | 33 | run 34 | run* 35 | 36 | 37 | EXTENDED LANGUAGE 38 | 39 | Constraint operators: 40 | 41 | =/= 42 | symbolo 43 | numbero 44 | absento 45 | -------------------------------------------------------------------------------- /absento-closure-tests.scm: -------------------------------------------------------------------------------- 1 | (test "absento 'closure-1a" 2 | (run* (q) (absento 'closure q) (== q 'closure)) 3 | '()) 4 | 5 | (test "absento 'closure-1b" 6 | (run* (q) (== q 'closure) (absento 'closure q)) 7 | '()) 8 | 9 | (test "absento 'closure-2a" 10 | (run* (q) (fresh (a d) (== q 'closure) (absento 'closure q))) 11 | '()) 12 | 13 | (test "absento 'closure-2b" 14 | (run* (q) (fresh (a d) (absento 'closure q) (== q 'closure))) 15 | '()) 16 | 17 | ;; (test "absento 'closure-3a" 18 | ;; (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q))) 19 | ;; '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 20 | 21 | ;; (test "absento 'closure-3b" 22 | ;; (run* (q) (fresh (a d) (== `(,a . ,d) q) (absento 'closure q))) 23 | ;; '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 24 | 25 | (test "absento 'closure-4a" 26 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure a))) 27 | '()) 28 | 29 | (test "absento 'closure-4b" 30 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure a) (== `(,a . ,d) q))) 31 | '()) 32 | 33 | (test "absento 'closure-4c" 34 | (run* (q) (fresh (a d) (== 'closure a) (absento 'closure q) (== `(,a . ,d) q))) 35 | '()) 36 | 37 | (test "absento 'closure-4d" 38 | (run* (q) (fresh (a d) (== 'closure a) (== `(,a . ,d) q) (absento 'closure q))) 39 | '()) 40 | 41 | (test "absento 'closure-5a" 42 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure d))) 43 | '()) 44 | 45 | (test "absento 'closure-5b" 46 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure d) (== `(,a . ,d) q))) 47 | '()) 48 | 49 | (test "absento 'closure-5c" 50 | (run* (q) (fresh (a d) (== 'closure d) (absento 'closure q) (== `(,a . ,d) q))) 51 | '()) 52 | 53 | (test "absento 'closure-5d" 54 | (run* (q) (fresh (a d) (== 'closure d) (== `(,a . ,d) q) (absento 'closure q))) 55 | '()) 56 | 57 | (test "absento 'closure-6" 58 | (run* (q) 59 | (== `(3 (closure x (x x) ((y . 7))) #t) q) 60 | (absento 'closure q)) 61 | '()) 62 | -------------------------------------------------------------------------------- /bouncing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "mk.rkt") 4 | (do-defer-smt-checks!) 5 | (require 2htdp/universe 2htdp/image) 6 | 7 | (provide (all-from-out "mk.rkt") 8 | (all-defined-out)) 9 | 10 | (define maxw 400) 11 | (define maxh 400) 12 | 13 | (define (is-boxo b x y w h) 14 | (fresh () 15 | (z/assert `(<= 0 ,x)) 16 | (z/assert `(<= 0 ,y)) 17 | (z/assert `(<= 1 ,w)) 18 | (z/assert `(<= 1 ,h)) 19 | (z/assert `(<= (+ ,x ,w) ,maxw)) 20 | (z/assert `(<= (+ ,x ,w) ,maxh)) 21 | (== b `(box ,x ,y ,w ,h)))) 22 | 23 | (define (make-boxo w h b) 24 | (fresh (x y) 25 | (is-boxo b x y w h))) 26 | 27 | (define box-x cadr) 28 | (define box-y caddr) 29 | (define box-w cadddr) 30 | (define (box-h x) (cadddr (cdr x))) 31 | (define (boxo-w b w) 32 | (fresh (x y h) 33 | (is-boxo b x y w h))) 34 | (define (boxo-x b x) 35 | (fresh (y w h) 36 | (is-boxo b x y w h))) 37 | (define (boxo-y b y) 38 | (fresh (x w h) 39 | (is-boxo b x y w h))) 40 | 41 | 42 | (define (draw-scene b) 43 | (place-image 44 | (rectangle (box-w b) (box-h b) "solid" "gray") 45 | (box-x b) (box-y b) 46 | (empty-scene maxw maxh "white"))) 47 | 48 | (define TICK-RATE 1) 49 | 50 | (define (ex1) 51 | (let ((r (run 10 (b) (make-boxo 40 40 b)))) 52 | (big-bang r 53 | (on-tick cdr TICK-RATE) 54 | (stop-when null?) 55 | (to-draw (lambda (x) (draw-scene (car x))))))) 56 | 57 | (define ((moveo t) b) 58 | (fresh (x) 59 | (make-boxo 40 40 b) 60 | (boxo-x b x) 61 | (z/assert `(<= (* ,t 20) ,x)) 62 | (z/assert `(>= (* (+ 1 ,t) 20) ,x)))) 63 | 64 | (define (move2 t) 65 | (run 1 (b) ((moveo t) b))) 66 | 67 | (define (ex2) 68 | (big-bang 0 69 | (on-tick (lambda (t) (+ t 1)) TICK-RATE) 70 | (stop-when (lambda (t) (null? (move2 t)))) 71 | (to-draw (lambda (t) (draw-scene (car (move2 t))))))) 72 | 73 | (define ((moveo3 t) b) 74 | (fresh (y) ((moveo t) b) (boxo-y b y) (z/assert `(= ,y 100)))) 75 | 76 | (define (move3 t) 77 | (run 1 (b) ((moveo3 t) b))) 78 | 79 | (define (ex3) 80 | (big-bang 0 81 | (on-tick (lambda (t) (+ t 1)) TICK-RATE) 82 | (stop-when (lambda (t) (null? (move3 t)))) 83 | (to-draw (lambda (t) (draw-scene (car (move3 t))))))) 84 | 85 | (define (ex4) 86 | (let ((r (run 10 (b) (fresh (t) ((moveo3 t) b))))) 87 | (big-bang r 88 | (on-tick cdr TICK-RATE) 89 | (stop-when null?) 90 | (to-draw (lambda (x) (draw-scene (car x))))))) 91 | 92 | (define (runt t tq g) 93 | (conde 94 | ((z/assert `(= ,tq ,t)) (g)) 95 | ((z/assert `(not (= ,tq ,t))) (runt (+ 1 t) tq g)))) 96 | 97 | (define (with-toggled-get-next-model?! t) 98 | (toggle-get-next-model?!) 99 | (let ((r (t))) 100 | (toggle-get-next-model?!) 101 | r)) 102 | 103 | (define (ex5) 104 | (let ((r (with-toggled-get-next-model?! (lambda () (run 10 (b) (fresh (t) (z/assert `(<= 0 ,t)) (runt 0 t (lambda () ((moveo3 t) b))))))))) 105 | (big-bang r 106 | (on-tick cdr TICK-RATE) 107 | (stop-when null?) 108 | (to-draw (lambda (x) (draw-scene (car x))))))) 109 | -------------------------------------------------------------------------------- /boxes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../faster-miniKanren/mk.rkt") 4 | ;;(do-defer-smt-checks!) 5 | (require graphics/graphics) 6 | 7 | (provide (all-from-out "../faster-miniKanren/mk.rkt") 8 | (all-defined-out)) 9 | 10 | (define (is-boxo b x y w h) 11 | (fresh () 12 | (z/assert `(<= 0 ,x)) 13 | (z/assert `(<= 0 ,y)) 14 | (z/assert `(<= 0 ,w)) 15 | (z/assert `(<= 0 ,h)) 16 | (== b `(box ,x ,y ,w ,h)))) 17 | 18 | (define (make-boxo w h b) 19 | (fresh (x y) 20 | (is-boxo b x y w h))) 21 | 22 | (define (withino ax aw bx bw) 23 | (fresh () 24 | (z/assert `(>= ,ax ,bx)) 25 | (z/assert `(<= (+ ,ax ,aw) (+ ,bx ,bw))))) 26 | 27 | (define (not-withino ax aw bx bw) 28 | (fresh () 29 | (conde 30 | ((z/assert `(< ,ax ,bx))) 31 | ((z/assert `(> (+ ,ax ,aw) (+ ,bx ,bw))))))) 32 | 33 | (define (contains-boxo a b) 34 | (fresh (ax ay aw ah bx by bw bh) 35 | (is-boxo a ax ay aw ah) 36 | (is-boxo b bx by bw bh) 37 | (withino ax aw bx bw) 38 | (withino ay ah by bh))) 39 | 40 | (define (overlaps-boxo a b) 41 | (fresh (ax ay aw ah bx by bw bh) 42 | (is-boxo a ax ay aw ah) 43 | (is-boxo b bx by bw bh) 44 | (z/assert `(not (= ,ax ,bx))) 45 | (z/assert `(not (= ,ay ,by))) 46 | (conde 47 | ((withino ax aw bx bw) 48 | (not-withino ay ah by bh)) 49 | ((withino ay ah by bh) 50 | (not-withino ax aw bx bw))))) 51 | 52 | (define (separated-boxo a b) 53 | (fresh (ax ay aw ah bx by bw bh) 54 | (is-boxo a ax ay aw ah) 55 | (is-boxo b bx by bw bh) 56 | (not-withino ax aw bx bw) 57 | (not-withino ay ah by bh))) 58 | 59 | (define (ex1) 60 | (define r 61 | (run 1 (q) 62 | (fresh (a b c) 63 | (== q (list a b c)) 64 | (make-boxo 2 2 a) 65 | (make-boxo 3 3 b) 66 | (make-boxo 4 4 c) 67 | (contains-boxo a b) 68 | (overlaps-boxo b c)))) 69 | (open-graphics) 70 | (define v (open-viewport "practice" 200 200)) 71 | (define (s x) (* x 20)) 72 | (define (draw-box b) 73 | ((draw-rectangle v) (make-posn (s (cadr b)) (s (caddr b))) (s (cadddr b)) (s (cadddr (cdr b))))) 74 | (map draw-box (car r))) 75 | -------------------------------------------------------------------------------- /boxes.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (set! defer-smt-checks #t) 6 | 7 | (define (is-boxo b x y w h) 8 | (fresh () 9 | (z/assert `(<= 0 ,x)) 10 | (z/assert `(<= 0 ,y)) 11 | (z/assert `(<= 0 ,w)) 12 | (z/assert `(<= 0 ,h)) 13 | (== b `(box ,x ,y ,w ,h)))) 14 | 15 | (define (make-boxo w h b) 16 | (fresh (x y) 17 | (is-boxo b x y w h))) 18 | 19 | (define (withino ax aw bx bw) 20 | (fresh () 21 | (z/assert `(>= ,ax ,bx)) 22 | (z/assert `(<= (+ ,ax ,aw) (+ ,bx ,bw))))) 23 | 24 | (define (not-withino ax aw bx bw) 25 | (fresh () 26 | (conde 27 | ((z/assert `(< ,ax ,bx))) 28 | ((z/assert `(> (+ ,ax ,aw) (+ ,bx ,bw))))))) 29 | 30 | (define (contains-boxo a b) 31 | (fresh (ax ay aw ah bx by bw bh) 32 | (is-boxo a ax ay aw ah) 33 | (is-boxo b bx by bw bh) 34 | (withino ax aw bx bw) 35 | (withino ay ah by bh))) 36 | 37 | (define (overlaps-boxo a b) 38 | (fresh (ax ay aw ah bx by bw bh) 39 | (is-boxo a ax ay aw ah) 40 | (is-boxo b bx by bw bh) 41 | (z/assert `(not (= ,ax ,bx))) 42 | (z/assert `(not (= ,ay ,by))) 43 | (conde 44 | ((withino ax aw bx bw) 45 | (not-withino ay ah by bh)) 46 | ((withino ay ah by bh) 47 | (not-withino ax aw bx bw))))) 48 | 49 | (define (separated-boxo a b) 50 | (fresh (ax ay aw ah bx by bw bh) 51 | (is-boxo a ax ay aw ah) 52 | (is-boxo b bx by bw bh) 53 | (not-withino ax aw bx bw) 54 | (not-withino ay ah by bh))) 55 | 56 | (test "impossible-boxes" 57 | (run* (q) 58 | (fresh (a b c) 59 | (== q (list a b c)) 60 | (make-boxo 2 2 a) 61 | (make-boxo 3 3 b) 62 | (contains-boxo b a))) 63 | '()) 64 | 65 | (test "possible-boxes" 66 | (run 1 (q) 67 | (fresh (a b c) 68 | (== q (list a b c)) 69 | (make-boxo 2 2 a) 70 | (make-boxo 3 3 b) 71 | (make-boxo 4 4 c) 72 | (contains-boxo a b) 73 | (overlaps-boxo b c))) 74 | '(((box 1 0 2 2) (box 1 0 3 3) (box 0 1 4 4)))) 75 | -------------------------------------------------------------------------------- /clpset-tests.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (define z/set 6 | (lambda (s) 7 | (z/ `(declare-fun ,s (Int) Bool)))) 8 | 9 | (define z/in 10 | (lambda (x s) 11 | (z/assert `(,s ,x)))) 12 | 13 | (define z/not-in 14 | (lambda (x s) 15 | (z/assert `(not (,s ,x))))) 16 | 17 | (test "1" 18 | (run 1 (q) 19 | (fresh (s a b) 20 | (z/set s) 21 | (z/in a s) 22 | (z/not-in b s) 23 | (== q `(,s ,a ,b)))) 24 | '(((lambda (x!0) 25 | (ite (= x!0 0) true (ite (= x!0 1) false true))) 26 | 0 27 | 1))) 28 | -------------------------------------------------------------------------------- /clpset.scm: -------------------------------------------------------------------------------- 1 | (define z/set 2 | (lambda (s) 3 | (z/ `(declare-fun ,s () (Set Int))))) 4 | 5 | (define subseto 6 | (lambda (r1 r2) 7 | (z/assert `(subset ,r1 ,r2)))) 8 | 9 | (define !subseto 10 | (lambda (r1 r2) 11 | (z/assert `(not (subset ,r1 ,r2))))) 12 | 13 | (define set 14 | (lambda (s . args) 15 | `(insert ,@args ,s))) 16 | 17 | (define ∅ '(as emptyset (Set Int))) 18 | 19 | (define ino 20 | (lambda (x s) 21 | (z/assert `(member ,x ,s)))) 22 | 23 | (define !ino 24 | (lambda (x s) 25 | (z/assert `(not (member ,x ,s))))) 26 | 27 | (define uniono 28 | (lambda (s1 s2 s3) 29 | (z/assert `(= (union ,s1 ,s2) ,s3)))) 30 | 31 | (define z/== 32 | (lambda (a b) 33 | (z/assert `(= ,a ,b)))) 34 | -------------------------------------------------------------------------------- /clpsmt-basic-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | (require "mk.rkt") 3 | (load "test-check.scm") 4 | (load "clpsmt-basic-tests.scm") 5 | 6 | -------------------------------------------------------------------------------- /clpsmt-basic-tests.scm: -------------------------------------------------------------------------------- 1 | (test "counters" 2 | (let ((c1 z3-counter-check-sat) 3 | (c2 z3-counter-get-model)) 4 | (run* (q) 5 | (z/assert `(= ,q 0))) 6 | (list 7 | (- z3-counter-check-sat c1) 8 | (- z3-counter-get-model c2))) 9 | '(4 1)) 10 | 11 | (test "declare-idempotent" 12 | (run* (q) 13 | (fresh (v1 v2) 14 | (z/ `(declare-const ,v1 Bool)) 15 | (z/ `(declare-const ,v2 Bool)) 16 | (== v1 v2) 17 | (== q v1))) 18 | '(_.0)) 19 | 20 | (test "inf-smt-ans-1" 21 | (run 1 (q) 22 | (z/assert `(>= ,q 0))) 23 | '(0)) 24 | 25 | (test "inf-smt-ans-2" 26 | (run 2 (q) 27 | (z/assert `(>= ,q 0))) 28 | '(0 1)) 29 | 30 | (test "1" 31 | (run* (q) 32 | (fresh (x) 33 | (z/assert `(= ,x 0)))) 34 | '(_.0)) 35 | 36 | (test "2" 37 | (run* (q) 38 | (fresh (x) 39 | (z/assert `(= ,x 0)) 40 | (z/assert `(= ,x 1)))) 41 | '()) 42 | 43 | (test "3" 44 | (run* (q) 45 | (fresh (x) 46 | (z/assert `(= ,x 0)) 47 | (== x q))) 48 | '(0)) 49 | 50 | (test "4" 51 | (run* (q) 52 | (z/assert `(= ,q 0))) 53 | '(0)) 54 | 55 | (test "5" 56 | (run 2 (f) 57 | (z/ `(declare-fun ,f (Int) Int)) 58 | (z/assert `(= 1 (,f 1))) 59 | (z/assert `(= 0 (,f 0)))) 60 | ;; TODO: 61 | ;; what do we really want here? syntax lambda or actual lambda? 62 | '((lambda (x!0) (ite (= x!0 1) 1 (ite (= x!0 0) 0 1))))) 63 | 64 | (test "6" 65 | (run 1 (q) 66 | (fresh (f x) 67 | (z/ `(declare-fun ,f (Int) Int)) 68 | (z/assert `(= ,x (,f ,x))) 69 | (== q x))) 70 | '(0)) 71 | -------------------------------------------------------------------------------- /clpsmt-tests.scm: -------------------------------------------------------------------------------- 1 | (define faco 2 | (lambda (n out) 3 | (conde ((z/assert `(= ,n 0)) 4 | (z/assert `(= ,out 1))) 5 | ((z/assert `(> ,n 0)) 6 | (fresh (n-1 r) 7 | (z/assert `(= (- ,n 1) ,n-1)) 8 | (z/assert `(= (* ,n ,r) ,out)) 9 | (faco n-1 r)))))) 10 | 11 | (test "faco-7" 12 | (run 7 (q) 13 | (fresh (n out) 14 | (faco n out) 15 | (== q `(,n ,out)))) 16 | '((0 1) (1 1) (2 2) (3 6) (4 24) (5 120) (6 720))) 17 | 18 | (test "faco-backwards-2" 19 | (run* (q) 20 | (faco q 2)) 21 | '(2)) 22 | 23 | (test "faco-backwards-720" 24 | (run* (q) 25 | (faco q 720)) 26 | '(6)) 27 | 28 | (load "full-interp.scm") 29 | 30 | (test "evalo-1" 31 | (run* (q) 32 | (evalo '(+ 1 2) q)) 33 | '(3)) 34 | 35 | (test "evalo-backwards-1" 36 | (run* (q) 37 | (evalo `(+ 0 ',q) 3)) 38 | '(3)) 39 | 40 | (test "evalo-bop-1" 41 | (run* (q) 42 | (evalo `((lambda (n) (< n 0)) 0) q)) 43 | '(#f)) 44 | 45 | (test "evalo-2" 46 | (run* (q) 47 | (evalo `(((lambda (f) 48 | (lambda (n) (if (< n 0) #f 49 | (if (= n 0) 1 50 | (* n (f (- n 1))))))) 51 | (lambda (x) 1)) 52 | 2) 53 | q)) 54 | '(2)) 55 | 56 | 57 | (test "evalo-fac-6" 58 | (run* (q) 59 | (evalo `(letrec ((fac 60 | (lambda (n) 61 | (if (< n 0) #f 62 | (if (= n 0) 1 63 | (* n (fac (- n 1)))))))) 64 | (fac 6)) 65 | q)) 66 | '(720)) 67 | 68 | ;; slowish 69 | (test "evalo-fac-9" 70 | (run* (q) 71 | (evalo `(letrec ((fac 72 | (lambda (n) 73 | (if (< n 0) #f 74 | (if (= n 0) 1 75 | (* n (fac (- n 1)))))))) 76 | (fac 9)) 77 | q)) 78 | '(362880)) 79 | 80 | (test "evalo-backwards-fac-6" 81 | (run 1 (q) 82 | (evalo `(letrec ((fac 83 | (lambda (n) 84 | (if (< n 0) #f 85 | (if (= n 0) 1 86 | (* n (fac (- n 1)))))))) 87 | (fac ,q)) 88 | 720)) 89 | '(6)) 90 | 91 | ;; remember the quote! 92 | (test "evalo-backwards-fac-quoted-6" 93 | (run* (q) 94 | (evalo `(letrec ((fac 95 | (lambda (n) 96 | (if (< n 0) #f 97 | (if (= n 0) 1 98 | (* n (fac (- n 1)))))))) 99 | (fac ',q)) 100 | 720)) 101 | '(6)) 102 | 103 | 104 | ;; slowish 105 | (test "evalo-backwards-fac-9" 106 | (run 1 (q) 107 | (evalo `(letrec ((fac 108 | (lambda (n) 109 | (if (< n 0) #f 110 | (if (= n 0) 1 111 | (* n (fac (- n 1)))))))) 112 | (fac ,q)) 113 | 362880)) 114 | '(9)) 115 | 116 | ;; remember the quote! 117 | (test "evalo-backwards-fac-quoted-9" 118 | (run* (q) 119 | (evalo `(letrec ((fac 120 | (lambda (n) 121 | (if (< n 0) #f 122 | (if (= n 0) 1 123 | (* n (fac (- n 1)))))))) 124 | (fac ',q)) 125 | 362880)) 126 | '(9)) 127 | 128 | 129 | ;; slowish 130 | (test "evalo-fac-table" 131 | (run* (q) 132 | (evalo `(letrec ((fac 133 | (lambda (n) 134 | (if (< n 0) #f 135 | (if (= n 0) 1 136 | (* n (fac (- n 1)))))))) 137 | (list 138 | (fac 0) 139 | (fac 1) 140 | (fac 2) 141 | (fac 3))) 142 | q)) 143 | '((1 1 2 6))) 144 | 145 | (test "evalo-fac-synthesis-hole-0" 146 | (run* (q) 147 | (evalo `(letrec ((fac 148 | (lambda (n) 149 | (if (< n 0) #f 150 | (if (= n 0) ',q 151 | (* n (fac (- n 1)))))))) 152 | (list 153 | (fac 0) 154 | (fac 1) 155 | (fac 2) 156 | (fac 3))) 157 | '(1 1 2 6))) 158 | '(1)) 159 | 160 | (test "evalo-fac-synthesis-hole-1" 161 | (run 1 (q) 162 | (evalo `(letrec ((fac 163 | (lambda (n) 164 | (if (< n 0) #f 165 | (if (= n 0) 1 166 | (* n (,q (- n 1)))))))) 167 | (list 168 | (fac 0) 169 | (fac 1) 170 | (fac 2) 171 | (fac 3))) 172 | '(1 1 2 6))) 173 | '(fac)) 174 | 175 | ;; takes a while 176 | (test "evalo-fac-synthesis-hole-1-reversed-examples" 177 | (run 1 (q) 178 | (evalo `(letrec ((fac 179 | (lambda (n) 180 | (if (< n 0) #f 181 | (if (= n 0) 1 182 | (* n (,q (- n 1)))))))) 183 | (list 184 | (fac 3) 185 | (fac 2) 186 | (fac 1) 187 | (fac 0))) 188 | '(6 2 1 1))) 189 | '(fac)) 190 | 191 | (test "evalo-fac-synthesis-hole-2" 192 | (run 1 (q) 193 | (evalo `(letrec ((fac 194 | (lambda (n) 195 | (if (< n 0) #f 196 | (if (= n 0) 1 197 | (* n (fac (- ,q 1)))))))) 198 | (list 199 | (fac 0) 200 | (fac 1) 201 | (fac 2) 202 | (fac 3))) 203 | '(1 1 2 6))) 204 | '(n)) 205 | 206 | (test "evalo-fac-synthesis-hole-3" 207 | (run 1 (q) 208 | (fresh (r s) 209 | (== (list r s) q) 210 | (evalo `(letrec ((fac 211 | (lambda (n) 212 | (if (< n 0) #f 213 | (if (= n 0) 1 214 | (* n (fac (- ,r ,s)))))))) 215 | (list 216 | (fac 0) 217 | (fac 1) 218 | (fac 2) 219 | (fac 3))) 220 | '(1 1 2 6)))) 221 | '((n 1))) 222 | 223 | ;; slow, even with the 'symbolo' constraint on 'q' 224 | (test "evalo-fac-synthesis-hole-4" 225 | (run 1 (q) 226 | (symbolo q) 227 | (evalo `(letrec ((fac 228 | (lambda (n) 229 | (if (< n 0) #f 230 | (if (= n 0) 1 231 | (* n (fac (,q n 1)))))))) 232 | (list 233 | (fac 0) 234 | (fac 1) 235 | (fac 2) 236 | (fac 3))) 237 | '(1 1 2 6))) 238 | '(-)) 239 | 240 | 241 | (test "evalo-division-using-multiplication-0" 242 | (run* (q) 243 | (evalo `(* 3 ',q) 6)) 244 | '(2)) 245 | 246 | (test "evalo-division-using-multiplication-1" 247 | (run* (q) 248 | (evalo `(* 4 ',q) 6)) 249 | '()) 250 | 251 | (test "evalo-division-using-multiplication-2" 252 | (run* (q) 253 | (evalo `(* 3 ',q) 18)) 254 | '(6)) 255 | 256 | (test "evalo-many-0" 257 | (run* (q) 258 | (fresh (x y) 259 | (evalo `(* ',x ',y) 6) 260 | (== q (list x y)))) 261 | '((6 1) (1 6) (-1 -6) (-2 -3) 262 | (-3 -2) (-6 -1) (2 3) (3 2))) 263 | 264 | (test "many-1" 265 | (run* (q) 266 | (fresh (x y) 267 | (evalo `(+ (* ',x ',y) (* ',x ',y)) 6) 268 | (== q (list x y)))) 269 | '((3 1) (1 3) (-1 -3) (-3 -1))) 270 | 271 | (test "many-2" 272 | (run* (q) 273 | (fresh (x y) 274 | (evalo `(* (* ',x ',y) 2) 6) 275 | (== q (list x y)))) 276 | '((3 1) (1 3) (-1 -3) (-3 -1))) 277 | -------------------------------------------------------------------------------- /cvc4-driver.scm: -------------------------------------------------------------------------------- 1 | (define cvc4-counter-check-sat 0) 2 | (define cvc4-counter-get-model 0) 3 | 4 | (define read-sat 5 | (lambda (fn) 6 | (let ([p (open-input-file fn)]) 7 | (let ([r (read p)]) 8 | (close-input-port p) 9 | (eq? r 'sat))))) 10 | 11 | (define call-cvc4 12 | (lambda (xs) 13 | (let ([p (open-output-file "out.smt" 'replace)]) 14 | (for-each (lambda (x) (fprintf p "~a\n" x)) 15 | (cons '(set-logic ALL_SUPPORTED) xs)) 16 | (close-output-port p) 17 | (system "perl -i -pe 's/#t/true/g' out.smt") 18 | (system "perl -i -pe 's/#f/false/g' out.smt") 19 | (system "perl -i -pe 's/bitvec-/#b/g' out.smt") 20 | (let ((r (system "cvc4 -m --lang smt out.smt >out.txt"))) 21 | (system "perl -i -pe 's/#b/bitvec-/g' out.txt") 22 | (when (not (= r 0)) 23 | (error 'call-cvc4 "error in cvc4 out.smt > out.txt")))))) 24 | 25 | (define check-sat 26 | (lambda (xs) 27 | (call-cvc4 (append xs '((check-sat) (exit)))) 28 | (set! cvc4-counter-check-sat (+ cvc4-counter-check-sat 1)) 29 | (read-sat "out.txt"))) 30 | 31 | (define read-model 32 | (lambda (fn) 33 | (let ([p (open-input-file fn)]) 34 | (let ([r (read p)]) 35 | (if (eq? r 'sat) 36 | (let ([m (read p)]) 37 | (close-input-port p) 38 | (map (lambda (x) 39 | (cons (cadr x) 40 | (if (null? (caddr x)) 41 | (let ([r (cadddr (cdr x))]) 42 | (cond 43 | ((eq? r 'false) #f) 44 | ((eq? r 'true) #t) 45 | ((number? r) r) 46 | (else r))) 47 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 48 | (filter (lambda (x) (not (declare-datatypes? x))) (cdr m)))) 49 | (begin 50 | (close-input-port p) 51 | #f)))))) 52 | 53 | (define get-model 54 | (lambda (xs) 55 | (call-cvc4 (append xs '((check-sat) (get-model) (exit)))) 56 | (set! cvc4-counter-get-model (+ cvc4-counter-get-model 1)) 57 | (read-model "out.txt"))) 58 | 59 | (define neg-model 60 | (lambda (model) 61 | (cons 62 | 'assert 63 | (list 64 | (cons 65 | 'or 66 | (map 67 | (lambda (xv) 68 | `(not (= ,(car xv) ,(cdr xv)))) 69 | model)))))) 70 | 71 | (define check-model-unique 72 | (lambda (xs model) 73 | (let ([r 74 | (check-sat 75 | (append xs (list (neg-model model))))]) 76 | (not r)))) 77 | 78 | (define get-all-models 79 | (lambda (xs ms) 80 | (let* ([ys (append xs (map neg-model ms))]) 81 | (if (not (check-sat ys)) 82 | (reverse ms) 83 | (get-all-models xs (cons (get-model ys) ms)))))) 84 | 85 | (define get-next-model 86 | (lambda (xs ms) 87 | (let ([ys (append xs (map neg-model ms))]) 88 | (and (check-sat ys) 89 | (get-model ys))))) 90 | -------------------------------------------------------------------------------- /cvc4-server-robust.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define log-all-calls #f) 5 | 6 | (define-values (z3-out z3-in z3-err z3-p) 7 | (open-process-ports "cvc4 -m --lang smt --quiet -" 'block (native-transcoder))) 8 | (define (z3-reset!) 9 | (let-values (((out in err p) 10 | (open-process-ports "cvc4 -m --lang smt --quiet -" 'block (native-transcoder)))) 11 | (set! z3-out out) 12 | (set! z3-in in) 13 | (set! z3-err err) 14 | (set! z3-p p))) 15 | (define (z3-check-in!) 16 | (if (eof-object? z3-in) 17 | (error 'z3-check-in "z3 input port") 18 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 19 | ;; (z3-reset!) 20 | ;; #t) 21 | #t)) 22 | 23 | (define read-sat 24 | (lambda () 25 | (z3-check-in!) 26 | (let ([r (read z3-in)]) 27 | (when log-all-calls (printf ";; ~a\n" r)) 28 | (if (eq? r 'sat) 29 | #t 30 | (if (eq? r 'unsat) 31 | #f 32 | (if (eq? r 'unknown) 33 | (begin 34 | (printf "read-sat: unknown\n") 35 | (call-z3 '((pop))) 36 | #f) 37 | (error 'read-sat (format "~a" r)))))))) 38 | 39 | (define call-z3 40 | (lambda (xs) 41 | (for-each (lambda (x) 42 | (when log-all-calls (printf "~a\n" x)) 43 | (when (and (pair? x) 44 | (eq? 'assert (car x)) 45 | (pair? (cadr x)) 46 | (eq? '=> (caadr x))) 47 | (fprintf z3-out "(push) ")) 48 | (fprintf z3-out "~a\n" x)) xs) 49 | (flush-output-port z3-out))) 50 | 51 | (define check-sat 52 | (lambda (xs) 53 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 54 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 55 | (read-sat))) 56 | 57 | (define read-model 58 | (lambda () 59 | (let ([m (read z3-in)]) 60 | (when log-all-calls (printf "~a\n" m)) 61 | (map (lambda (x) 62 | (cons (cadr x) 63 | (if (null? (caddr x)) 64 | (let ([r (cadddr (cdr x))]) 65 | (cond 66 | ((eq? r 'false) #f) 67 | ((eq? r 'true) #t) 68 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 69 | (else (eval r)))) 70 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 71 | (cdr m))))) 72 | 73 | (define get-model-inc 74 | (lambda () 75 | (call-z3 '((get-model))) 76 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 77 | (read-model))) 78 | 79 | (define get-model 80 | (lambda (xs) 81 | (and (check-sat xs) 82 | (get-model-inc)))) 83 | 84 | (define neg-model 85 | (lambda (model) 86 | (cons 87 | 'assert 88 | (list 89 | (cons 90 | 'or 91 | (map 92 | (lambda (xv) 93 | `(not (= ,(car xv) ,(cdr xv)))) 94 | model)))))) 95 | 96 | (define get-next-model 97 | (lambda (xs ms) 98 | (let* ([ms (map (lambda (m) 99 | (filter (lambda (x) ; ignoring functions 100 | (or (number? (cdr x)) 101 | (symbol? (cdr x)) ; for bitvectors 102 | )) m)) 103 | ms)]) 104 | (if (member '() ms) #f ; if we're skipping a model, let us stop 105 | (and (check-sat (append xs (map neg-model ms))) 106 | (get-model-inc)))))) 107 | -------------------------------------------------------------------------------- /cvc4-server.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define-values (z3-out z3-in z3-err z3-p) 5 | (open-process-ports "cvc4 -m --lang smt --quiet -" 'block (native-transcoder))) 6 | (define (z3-reset!) 7 | (let-values (((out in err p) 8 | (open-process-ports "cvc4 -m --lang smt --quiet -" 'block (native-transcoder)))) 9 | (set! z3-out out) 10 | (set! z3-in in) 11 | (set! z3-err err) 12 | (set! z3-p p))) 13 | (define (z3-check-in!) 14 | (if (eof-object? z3-in) 15 | (error 'z3-check-in "z3 input port") 16 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 17 | ;; (z3-reset!) 18 | ;; #t) 19 | #t)) 20 | 21 | (define read-sat 22 | (lambda () 23 | (z3-check-in!) 24 | (let ([r (read z3-in)]) 25 | (if (eq? r 'sat) 26 | #t 27 | (if (eq? r 'unsat) 28 | #f 29 | (if (eq? r 'unknown) 30 | (begin 31 | (printf "read-sat: unknown\n") 32 | ;;(call-z3 '((pop))) 33 | #f) 34 | (error 'read-sat (format "~a" r)))))))) 35 | 36 | (define call-z3 37 | (lambda (xs) 38 | (for-each (lambda (x) 39 | ;;(printf "~a\n" x) 40 | (fprintf z3-out "~a\n" x)) xs) 41 | (flush-output-port z3-out))) 42 | 43 | (define check-sat 44 | (lambda (xs) 45 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 46 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 47 | (read-sat))) 48 | 49 | (define read-model 50 | (lambda () 51 | (let ([m (read z3-in)]) 52 | (map (lambda (x) 53 | (cons (cadr x) 54 | (if (null? (caddr x)) 55 | (let ([r (cadddr (cdr x))]) 56 | (cond 57 | ((eq? r 'false) #f) 58 | ((eq? r 'true) #t) 59 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 60 | (else (eval r)))) 61 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 62 | (cdr m))))) 63 | 64 | (define get-model-inc 65 | (lambda () 66 | (call-z3 '((get-model))) 67 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 68 | (read-model))) 69 | 70 | (define get-model 71 | (lambda (xs) 72 | (and (check-sat xs) 73 | (get-model-inc)))) 74 | 75 | (define neg-model 76 | (lambda (model) 77 | (cons 78 | 'assert 79 | (list 80 | (cons 81 | 'or 82 | (map 83 | (lambda (xv) 84 | `(not (= ,(car xv) ,(cdr xv)))) 85 | model)))))) 86 | 87 | (define get-next-model 88 | (lambda (xs ms) 89 | (let* ([ms (map (lambda (m) 90 | (filter (lambda (x) ; ignoring functions 91 | (or (number? (cdr x)) 92 | (symbol? (cdr x)) ; for bitvectors 93 | )) m)) 94 | ms)]) 95 | (if (member '() ms) #f ; if we're skipping a model, let us stop 96 | (and (check-sat (append xs (map neg-model ms))) 97 | (get-model-inc)))))) 98 | -------------------------------------------------------------------------------- /cvc4-set-tests.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "cvc4-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (test "set-1" 6 | (run* (q) 7 | (z/ `(declare-fun ,q () (Set Int))) 8 | (z/assert `(= ,q (singleton 1)))) 9 | '((singleton 1))) 10 | 11 | (test "set-2" 12 | (run* (q) 13 | (z/ `(declare-fun ,q () (Set Int))) 14 | (z/assert `(subset ,q (insert 2 (singleton 1))))) 15 | '((as emptyset (Set Int)) 16 | (singleton 2) 17 | (singleton 1) 18 | (union [singleton 2] [singleton 1]))) 19 | 20 | (test "set-3" 21 | (run 4 (q) 22 | (z/ `(declare-fun ,q () (Set Int)))) 23 | '((as emptyset (Set Int)) 24 | (singleton 0) 25 | (singleton (- 1)) 26 | (singleton (- 2)))) 27 | 28 | (test "set-4" 29 | (run* (q) 30 | (z/ `(declare-fun ,q () (Set Int))) 31 | (z/assert 32 | `(= (insert 1 2 (singleton 3)) 33 | (union ,q (insert 1 (singleton 2)))))) 34 | '((singleton 3) 35 | (union [singleton 1] [singleton 3]) 36 | (union [singleton 2] [singleton 3]) 37 | (union [union (singleton 1) (singleton 2)] [singleton 3]))) 38 | 39 | (load "clpset.scm") 40 | 41 | (test "subseto-1" 42 | (run* (q) 43 | (subseto (set ∅ 1 2) (set ∅ 1 2 3))) 44 | '(_.0)) 45 | 46 | (test "subseto-1-not" 47 | (run* (q) 48 | (subseto (set ∅ 1 2 3) (set ∅ 1 2))) 49 | '()) 50 | 51 | (test "not-subseto-1" 52 | (run 1 (q) 53 | (!subseto (set ∅ 1 2 3) (set ∅ 1 2))) 54 | '(_.0)) 55 | 56 | (test "not-subseto-1-not" 57 | (run 1 (q) 58 | (!subseto (set ∅ 1 2) (set ∅ 1 2 3))) 59 | '()) 60 | -------------------------------------------------------------------------------- /ex-model-unsat.smt: -------------------------------------------------------------------------------- 1 | (declare-fun x0 () Int) 2 | (assert (= x0 0)) 3 | (assert (not (= x0 0))) 4 | (check-sat) 5 | (exit) 6 | -------------------------------------------------------------------------------- /ex-model.smt: -------------------------------------------------------------------------------- 1 | (declare-fun x0 () Int) 2 | (assert (= x0 0)) 3 | (check-sat) 4 | (get-model) 5 | (exit) 6 | -------------------------------------------------------------------------------- /ex-sat.smt: -------------------------------------------------------------------------------- 1 | (declare-fun x () Int) 2 | (declare-fun y () Int) 3 | (declare-fun z () Int) 4 | (assert (>= (* 2 x) (+ y z))) 5 | (check-sat) ; sat 6 | (exit) 7 | -------------------------------------------------------------------------------- /ex-unsat.smt: -------------------------------------------------------------------------------- 1 | (declare-fun x () Int) 2 | (declare-fun y () Int) 3 | (declare-fun z () Int) 4 | (assert (>= (* 2 x) (+ y z))) 5 | (assert (= x 0)) 6 | (assert (= y 1)) 7 | (assert (= z 1)) 8 | (check-sat) ; unsat 9 | (exit) 10 | -------------------------------------------------------------------------------- /exp.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "cvc4-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (define z/== 6 | (lambda (a b) 7 | (z/assert `(= ,a ,b)))) 8 | 9 | (define (L) 10 | (z/ 11 | `(declare-datatypes 12 | ((L 0)) 13 | (((zero) 14 | (succ (pred L)) 15 | (plus (a L) (b L)) 16 | (ifz (is_zero L) (yes L) (no L))))))) 17 | 18 | (define (L/dec x) 19 | (z/ `(declare-const ,x L))) 20 | 21 | (define (evalo l v) 22 | (conde 23 | ((z/== 'zero l) (z/== 0 v)) 24 | ((fresh (x i) 25 | (L/dec x) 26 | (z/== `(succ ,x) l) 27 | (z/== `(+ 1 ,i) v) 28 | (evalo x i))) 29 | ((fresh (x y i j) 30 | (L/dec x) 31 | (L/dec y) 32 | (z/== `(plus ,x ,y) l) 33 | (z/== `(+ ,i ,j) v) 34 | (evalo x i) 35 | (evalo y j))) 36 | ((fresh (x y z i) 37 | (L/dec x) 38 | (L/dec y) 39 | (L/dec z) 40 | (z/== `(ifz ,x ,y ,z) l) 41 | (conde 42 | ((z/== i 0) 43 | (evalo y v)) 44 | ((z/assert `(not (= ,i 0))) 45 | (evalo z v))) 46 | (evalo x i))))) 47 | 48 | (test "evalo-0" 49 | (run* (q) (L) (evalo 'zero q)) 50 | '(0)) 51 | 52 | (test "evalo-0-backwards" 53 | (run 2 (q) (L) (L/dec q) (evalo q 0)) 54 | '(zero (plus zero zero))) 55 | 56 | (test "evalo-1" 57 | (run* (q) (L) (evalo '(succ zero) q)) 58 | '(1)) 59 | 60 | (test "evalo-1-backwards" 61 | (run 2 (q) (L) (L/dec q) (evalo q 1)) 62 | '((succ zero) (succ (plus zero zero)))) 63 | 64 | (test "evalo-if" 65 | (run 1 (q) (L) (L/dec q) (evalo `(ifz ,q zero (succ zero)) 1)) 66 | '((succ zero))) 67 | 68 | 69 | -------------------------------------------------------------------------------- /exp2.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "cvc4-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (define z/== 6 | (lambda (a b) 7 | (z/assert `(= ,a ,b)))) 8 | 9 | (define (L) 10 | (z/ 11 | `(declare-datatypes 12 | ((L 0) (N 0)) 13 | (((zero) 14 | (succ (pred L)) 15 | (plus (a L) (b L)) 16 | (ifz (is_zero L) (yes L) (no L))) 17 | ((z) 18 | (s (p N))))))) 19 | 20 | (define (L/dec x) 21 | (z/ `(declare-const ,x L))) 22 | 23 | (define (N/dec x) 24 | (z/ `(declare-const ,x N))) 25 | 26 | (define (pluso n m o) 27 | (conde 28 | ((z/== 'z n) (z/== m o)) 29 | ((fresh (n-1 o-1) 30 | (N/dec n-1) 31 | (N/dec o-1) 32 | (z/== `(s ,n-1) n) 33 | (z/== `(s ,o-1) o) 34 | (pluso n-1 m o-1))))) 35 | 36 | (define (evalo l v) 37 | (conde 38 | ((z/== 'zero l) (z/== 'z v)) 39 | ((fresh (x i) 40 | (L/dec x) 41 | (N/dec i) 42 | (z/== `(succ ,x) l) 43 | (z/== `(s ,i) v) 44 | (evalo x i))) 45 | ((fresh (x y i j) 46 | (L/dec x) 47 | (L/dec y) 48 | (N/dec i) 49 | (N/dec j) 50 | (z/== `(plus ,x ,y) l) 51 | (pluso i j v) 52 | (evalo x i) 53 | (evalo y j))) 54 | ((fresh (x y z i) 55 | (L/dec x) 56 | (L/dec y) 57 | (L/dec z) 58 | (N/dec i) 59 | (z/== `(ifz ,x ,y ,z) l) 60 | (conde 61 | ((z/== i 'z) 62 | (evalo y v)) 63 | ((fresh (i-1) 64 | (N/dec i-1) 65 | (z/== `(s ,i-1) i) 66 | (evalo z v)))) 67 | (evalo x i))))) 68 | 69 | (test "evalo-0" 70 | (run* (q) (L) (N/dec q) (evalo 'zero q)) 71 | '(z)) 72 | 73 | (test "evalo-0-backwards" 74 | (run 3 (q) (L) (L/dec q) (evalo q 'z)) 75 | '(zero (plus zero zero) (ifz zero zero zero))) 76 | 77 | (test "evalo-1" 78 | (run* (q) (L) (N/dec q) (evalo '(succ zero) q)) 79 | '((s z))) 80 | 81 | (test "evalo-1-backwards" 82 | (run 2 (q) (L) (L/dec q) (evalo q '(s z))) 83 | '((succ zero) (succ (plus zero zero)))) 84 | 85 | (test "evalo-if" 86 | (run 1 (q) (L) (L/dec q) (evalo `(ifz ,q zero (succ zero)) '(s z))) 87 | '((succ zero))) 88 | 89 | 90 | -------------------------------------------------------------------------------- /kcoloring.scm: -------------------------------------------------------------------------------- 1 | ;; http://www.dmi.unipg.it/~formis/papers/JETAI07.pdf 2 | ;; p. 7 3 | ;; problem in CLP(FD) 4 | ;; (1) coloring(K, Vars) :- 5 | ;; (2) graph(Nodes, Edges),length(Nodes,N), 6 | ;; (3) length(Vars,N), 7 | ;; (4) domain(Vars, 1, K), 8 | ;; (5) constraints(Edges, Nodes, Vars), 9 | ;; (6) labeling([ff], Vars). 10 | ;; (7) constraints([],_,_). 11 | ;; (8) constraints([[A,B]|R], Nodes, Vars) :- 12 | ;; (9) nth(IdfA,Nodes,A),nth(IdfA,Vars,ColA), 13 | ;; (10) nth(IdfB,Nodes,B),nth(IdfB,Vars,ColB), 14 | ;; (11) ColA #\= ColB, 15 | ;; (12) constraints(R, Nodes, Vars). 16 | ;; 17 | ;; graph([1,2,3],[[1,2],[1,3],[2,3]]), 18 | 19 | (define (grapho nodes edges) 20 | (fresh () 21 | (== nodes '(1 2 3)) 22 | (== edges '((1 2) (1 3) (2 3))))) 23 | 24 | (define (coloringo k vars) 25 | (fresh (nodes edges n) 26 | (grapho nodes edges) 27 | (lengtho nodes n) 28 | (lengtho vars n) 29 | (for-eacho vars 30 | (lambda (v) 31 | (fresh () 32 | (z/assert `(<= 1 ,v)) 33 | (z/assert `(<= ,v ,k))))) 34 | (constraintso edges nodes vars) 35 | )) 36 | 37 | (define (constraintso edges nodes vars) 38 | (conde 39 | ((== edges '())) 40 | ((fresh (a b r idfa idfb cola colb) 41 | (== edges `((,a ,b) . ,r)) 42 | (=/= cola colb) (z/assert `(not (= ,cola ,colb))) 43 | (ntho idfa nodes a) (ntho idfa vars cola) 44 | (ntho idfb nodes b) (ntho idfb vars colb) 45 | (constraintso r nodes vars))))) 46 | 47 | (define (ntho i xs x) 48 | (fresh (y ys) 49 | (== `(,y . ,ys) xs) 50 | (conde 51 | ((== i 0) (z/assert `(= ,i 0)) 52 | (== y x)) 53 | ((=/= i 0) 54 | (fresh (i-1) 55 | (z/assert `(= ,i (+ ,i-1 1))) 56 | (ntho i-1 ys x)))))) 57 | 58 | (define (for-eacho vars ro) 59 | (conde 60 | ((== vars '())) 61 | ((fresh (x rest) 62 | (== `(,x . ,rest) vars) 63 | (ro x) 64 | (for-eacho rest ro))))) 65 | 66 | 67 | (define (lengtho xs n) 68 | (fresh () 69 | (z/assert `(>= ,n 0)) 70 | (conde 71 | ((== xs '()) (== n 0) (z/assert `(= ,n 0))) 72 | ((fresh (x rest n-1) 73 | (== `(,x . ,rest) xs) 74 | (z/assert `(= ,n (+ ,n-1 1))) 75 | (lengtho rest n-1)))))) 76 | 77 | ;; non-deterministic result :( 78 | #; 79 | (test "3coloring" 80 | (run* (q) (coloringo 3 q)) 81 | '((3 2 1) (3 1 2) (2 3 1) (1 3 2) (1 2 3) (2 1 3))) 82 | -------------------------------------------------------------------------------- /mk-streaming-interface.scm: -------------------------------------------------------------------------------- 1 | ;;; streaming run and run* interface 2 | ;;; 3 | ;;; prints the answers as they are generated, along with the current answer count, and total elapsed wall time 4 | ;;; 5 | ;;; also returns the final answer list, as usual 6 | 7 | (define-syntax streaming-run 8 | (syntax-rules () 9 | ((_ n (x) g0 g ...) 10 | (streaming-take n 0 (time-second (current-time)) 11 | (lambdaf@ () 12 | ((fresh (x) g0 g ... purge-M-inc-models 13 | (lambdag@ (final-c) 14 | (let ((z ((reify x) final-c))) 15 | (choice z empty-f)))) 16 | empty-c)))))) 17 | 18 | (define-syntax streaming-run* 19 | (syntax-rules () 20 | ((_ (x) g ...) (streaming-run #f (x) g ...)))) 21 | 22 | (define streaming-take 23 | (lambda (n answer-count start-time f) 24 | (cond 25 | ((and n (zero? n)) '()) 26 | (else 27 | (case-inf (f) 28 | (() '()) 29 | ((f) (streaming-take n answer-count start-time f)) 30 | ((c) 31 | (let ((total-elapsed-time (- (time-second (current-time)) start-time)) 32 | (answer-count (add1 answer-count))) 33 | (printf "~s [answer ~s, ~s seconds total elapsed (wall time)]\n" c answer-count total-elapsed-time) 34 | (cons c '()))) 35 | ((c f) 36 | (let ((total-elapsed-time (- (time-second (current-time)) start-time)) 37 | (answer-count (add1 answer-count))) 38 | (printf "~s [answer ~s, ~s seconds total elapsed (wall time)]\n" c answer-count total-elapsed-time) 39 | (cons c (streaming-take (and n (- n 1)) answer-count start-time f))))))))) 40 | -------------------------------------------------------------------------------- /mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list 4 | racket/system 5 | racket/include 6 | (rename-in racket/base (eval eval1)) 7 | (rename-in racket/base (open-output-file open-output-file1)) 8 | (rename-in racket/system (system system1))) 9 | 10 | (provide run run* 11 | == =/= 12 | fresh 13 | conde 14 | symbolo numbero 15 | absento 16 | succeed 17 | fail 18 | project 19 | z/assert 20 | z/ 21 | do-defer-smt-checks! 22 | get-next-model? 23 | toggle-get-next-model?! 24 | z3-counter-check-sat 25 | z3-counter-get-model) 26 | 27 | ;; extra stuff for racket 28 | (define ns (make-base-namespace)) 29 | 30 | (define (eval e) 31 | (eval1 e ns)) 32 | 33 | (define (open-output-file path options) 34 | (open-output-file1 path #:exists options)) 35 | 36 | (define (system command) 37 | (if (system1 command) 0 -1)) 38 | 39 | (include "z3-driver.scm") 40 | 41 | ;; extra stuff for racket 42 | ;; due mostly to samth 43 | (define (list-sort f l) (sort l f)) 44 | 45 | (define (remp f l) (filter-not f l)) 46 | 47 | (define (call-with-string-output-port f) 48 | (define p (open-output-string)) 49 | (f p) 50 | (get-output-string p)) 51 | 52 | (define (exists f l) (ormap f l)) 53 | 54 | (include "mk.scm") 55 | (define (do-defer-smt-checks!) 56 | (set! defer-smt-checks #t)) 57 | (define (toggle-get-next-model?!) 58 | (set! get-next-model? (not get-next-model?))) 59 | -------------------------------------------------------------------------------- /music.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | 5 | (define perfect-consonant '(0 5 7)) 6 | (define consonant '(0 3 4 5 7 8 9)) 7 | (define imperfect-consonant '(3 4 8 9)) 8 | 9 | (define harmony 10 | '((1 (3 6 2 4 5)) 11 | (2 (5 7)) 12 | (3 (6)) 13 | (4 (5 7)) 14 | (5 (1)) 15 | (6 (2 4)) 16 | (7 (1)))) 17 | 18 | (define (interval-ino ds note harmony) 19 | (fresh (d dr) 20 | (== (cons d dr) ds) 21 | (conde 22 | ((z/assert `(= (- ,note ,harmony) ,d))) 23 | ((z/assert `(not (= (- ,note ,harmony) ,d))) 24 | (interval-ino dr note harmony))))) 25 | 26 | (define (ino xs x) 27 | (fresh (y ys) 28 | (== (cons y ys) xs) 29 | (conde 30 | ((z/assert `(= ,x ,y))) 31 | ((z/assert `(not (= ,x ,y))) 32 | (ino ys x))))) 33 | 34 | (define (nexto harmony prev-harmony cur-harmony) 35 | (fresh (p hs cs) 36 | (== (cons `(,p ,cs) hs) harmony) 37 | (conde 38 | ((z/assert `(= ,p ,prev-harmony)) 39 | (ino cs cur-harmony)) 40 | ((z/assert `(not (= ,p ,prev-harmony))) 41 | (nexto hs prev-harmony cur-harmony))))) 42 | 43 | (define (zico measure phrase position prev-note cur-note prev-harmony cur-harmony) 44 | (fresh () 45 | (nexto harmony prev-harmony cur-harmony) 46 | (conde 47 | ((z/assert `(= 0 (mod ,position ,measure))) 48 | (== cur-harmony 1) 49 | (interval-ino perfect-consonant cur-note cur-harmony)) 50 | ((z/assert `(not (= 0 (mod ,position ,measure)))) 51 | (interval-ino imperfect-consonant cur-note cur-harmony))))) 52 | 53 | (define (musico measure phrase position prev-note prev-harmony m) 54 | (conde 55 | ((z/assert `(= ,position ,(* measure phrase))) 56 | (== m '())) 57 | ((z/assert `(< ,position ,(* measure phrase))) 58 | (fresh (position+1 cur-note cur-harmony rest-m) 59 | (== m (cons (list cur-note cur-harmony) rest-m)) 60 | (z/assert `(= ,position+1 (+ 1 ,position))) 61 | (zico measure phrase position prev-note cur-note prev-harmony cur-harmony) 62 | (musico measure phrase position+1 cur-note cur-harmony rest-m))))) 63 | 64 | (test "1" 65 | (run 1 (m) 66 | (musico 1 1 0 5 5 m)) 67 | '(((1 1)))) 68 | 69 | (test "5" ;; slow 70 | (run 1 (m) 71 | (musico 5 1 0 5 5 m)) 72 | '(((1 1) (6 3) (9 6) (5 2) (8 5)))) 73 | 74 | (test "4-2" ;; very slow 75 | (run 1 (m) 76 | (musico 4 2 0 5 5 m)) 77 | '(((1 1) (9 6) (5 2) (8 5) (1 1) (6 3) (9 6) (5 2)))) 78 | -------------------------------------------------------------------------------- /numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "numbero-1" 2 | (run* (q) (numbero q)) 3 | '((_.0 (num _.0)))) 4 | 5 | (test "numbero-2" 6 | (run* (q) (numbero q) (== 5 q)) 7 | '(5)) 8 | 9 | (test "numbero-3" 10 | (run* (q) (== 5 q) (numbero q)) 11 | '(5)) 12 | 13 | (test "numbero-4" 14 | (run* (q) (== 'x q) (numbero q)) 15 | '()) 16 | 17 | (test "numbero-5" 18 | (run* (q) (numbero q) (== 'x q)) 19 | '()) 20 | 21 | (test "numbero-6" 22 | (run* (q) (numbero q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "numbero-7" 26 | (run* (q) (== `(1 . 2) q) (numbero q)) 27 | '()) 28 | 29 | (test "numbero-8" 30 | (run* (q) (fresh (x) (numbero x))) 31 | '(_.0)) 32 | 33 | (test "numbero-9" 34 | (run* (q) (fresh (x) (numbero x))) 35 | '(_.0)) 36 | 37 | (test "numbero-10" 38 | (run* (q) (fresh (x) (numbero x) (== x q))) 39 | '((_.0 (num _.0)))) 40 | 41 | (test "numbero-11" 42 | (run* (q) (fresh (x) (numbero q) (== x q) (numbero x))) 43 | '((_.0 (num _.0)))) 44 | 45 | (test "numbero-12" 46 | (run* (q) (fresh (x) (numbero q) (numbero x) (== x q))) 47 | '((_.0 (num _.0)))) 48 | 49 | (test "numbero-13" 50 | (run* (q) (fresh (x) (== x q) (numbero q) (numbero x))) 51 | '((_.0 (num _.0)))) 52 | 53 | (test "numbero-14-a" 54 | (run* (q) (fresh (x) (numbero q) (== 5 x))) 55 | '((_.0 (num _.0)))) 56 | 57 | (test "numbero-14-b" 58 | (run* (q) (fresh (x) (numbero q) (== 5 x) (== x q))) 59 | '(5)) 60 | 61 | (test "numbero-15" 62 | (run* (q) (fresh (x) (== q x) (numbero q) (== 'y x))) 63 | '()) 64 | 65 | (test "numbero-16-a" 66 | (run* (q) (numbero q) (=/= 'y q)) 67 | '((_.0 (num _.0)))) 68 | 69 | (test "numbero-16-b" 70 | (run* (q) (=/= 'y q) (numbero q)) 71 | '((_.0 (num _.0)))) 72 | 73 | (test "numbero-17" 74 | (run* (q) (numbero q) (=/= `(1 . 2) q)) 75 | '((_.0 (num _.0)))) 76 | 77 | (test "numbero-18" 78 | (run* (q) (numbero q) (=/= 5 q)) 79 | '((_.0 (=/= ((_.0 5))) (num _.0)))) 80 | 81 | (test "numbero-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (numbero x) 85 | (numbero y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (num _.0 _.1)))) 88 | 89 | (test "numbero-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (numbero x) 94 | (numbero y))) 95 | '(((_.0 _.1) (num _.0 _.1)))) 96 | 97 | (test "numbero-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (numbero x) 102 | (numbero x))) 103 | '(((_.0 _.1) (num _.0)))) 104 | 105 | (test "numbero-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (numbero x) 109 | (numbero x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (num _.0)))) 112 | 113 | (test "numbero-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (numbero x) 117 | (== `(,x ,y) q) 118 | (numbero x))) 119 | '(((_.0 _.1) (num _.0)))) 120 | 121 | (test "numbero-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (numbero w) 126 | (numbero z))) 127 | '(_.0)) 128 | 129 | (test "numbero-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (numbero w) 134 | (numbero z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (num _.0 _.3)))) 139 | 140 | (test "numbero-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (numbero w) 145 | (numbero y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (num _.0 _.2)))) 150 | 151 | (test "numbero-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (numbero w) 156 | (numbero y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (num _.0)))) 162 | 163 | (test "numbero-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(a . b)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 a) (_.1 b)))))) 169 | 170 | (test "numbero-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(a . b)) 174 | (numbero w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (num _.0)))) 177 | 178 | (test "numbero-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (numbero w) 182 | (=/= `(,w . ,x) `(a . b)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (num _.0)))) 185 | 186 | (test "numbero-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (numbero w) 190 | (=/= `(a . b) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (num _.0)))) 193 | 194 | (test "numbero-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (numbero w) 198 | (=/= `(a . ,x) `(,w . b)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (num _.0)))) 201 | 202 | (test "numbero-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (numbero w) 206 | (=/= `(5 . ,x) `(,w . b)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 b))) (num _.0)))) 209 | 210 | (test "numbero-31" 211 | (run* (q) 212 | (fresh (x y z a b) 213 | (numbero x) 214 | (numbero y) 215 | (numbero z) 216 | (numbero a) 217 | (numbero b) 218 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 219 | (== q `(,x ,y ,z ,a ,b)))) 220 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 221 | 222 | (test "numbero-32" 223 | (run* (q) 224 | (fresh (x y z a b) 225 | (== q `(,x ,y ,z ,a ,b)) 226 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 227 | (numbero x) 228 | (numbero a))) 229 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 230 | -------------------------------------------------------------------------------- /numbers.scm: -------------------------------------------------------------------------------- 1 | (define appendo 2 | (lambda (l s out) 3 | (conde 4 | [(== '() l) (== s out)] 5 | [(fresh (a d res) 6 | (== `(,a . ,d) l) 7 | (== `(,a . ,res) out) 8 | (appendo d s res))]))) 9 | 10 | (define build-num 11 | (lambda (n) 12 | (cond 13 | ((odd? n) 14 | (cons 1 15 | (build-num (quotient (- n 1) 2)))) 16 | ((and (not (zero? n)) (even? n)) 17 | (cons 0 18 | (build-num (quotient n 2)))) 19 | ((zero? n) '())))) 20 | 21 | (define zeroo 22 | (lambda (n) 23 | (== '() n))) 24 | 25 | (define poso 26 | (lambda (n) 27 | (fresh (a d) 28 | (== `(,a . ,d) n)))) 29 | 30 | (define >1o 31 | (lambda (n) 32 | (fresh (a ad dd) 33 | (== `(,a ,ad . ,dd) n)))) 34 | 35 | (define full-addero 36 | (lambda (b x y r c) 37 | (conde 38 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 39 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 40 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 41 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 42 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 43 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 44 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 45 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c))))) 46 | 47 | (define addero 48 | (lambda (d n m r) 49 | (conde 50 | ((== 0 d) (== '() m) (== n r)) 51 | ((== 0 d) (== '() n) (== m r) 52 | (poso m)) 53 | ((== 1 d) (== '() m) 54 | (addero 0 n '(1) r)) 55 | ((== 1 d) (== '() n) (poso m) 56 | (addero 0 '(1) m r)) 57 | ((== '(1) n) (== '(1) m) 58 | (fresh (a c) 59 | (== `(,a ,c) r) 60 | (full-addero d 1 1 a c))) 61 | ((== '(1) n) (gen-addero d n m r)) 62 | ((== '(1) m) (>1o n) (>1o r) 63 | (addero d '(1) n r)) 64 | ((>1o n) (gen-addero d n m r))))) 65 | 66 | (define gen-addero 67 | (lambda (d n m r) 68 | (fresh (a b c e x y z) 69 | (== `(,a . ,x) n) 70 | (== `(,b . ,y) m) (poso y) 71 | (== `(,c . ,z) r) (poso z) 72 | (full-addero d a b c e) 73 | (addero e x y z)))) 74 | 75 | (define pluso 76 | (lambda (n m k) 77 | (addero 0 n m k))) 78 | 79 | (define minuso 80 | (lambda (n m k) 81 | (pluso m k n))) 82 | 83 | (define *o 84 | (lambda (n m p) 85 | (conde 86 | ((== '() n) (== '() p)) 87 | ((poso n) (== '() m) (== '() p)) 88 | ((== '(1) n) (poso m) (== m p)) 89 | ((>1o n) (== '(1) m) (== n p)) 90 | ((fresh (x z) 91 | (== `(0 . ,x) n) (poso x) 92 | (== `(0 . ,z) p) (poso z) 93 | (>1o m) 94 | (*o x m z))) 95 | ((fresh (x y) 96 | (== `(1 . ,x) n) (poso x) 97 | (== `(0 . ,y) m) (poso y) 98 | (*o m n p))) 99 | ((fresh (x y) 100 | (== `(1 . ,x) n) (poso x) 101 | (== `(1 . ,y) m) (poso y) 102 | (odd-*o x n m p)))))) 103 | 104 | (define odd-*o 105 | (lambda (x n m p) 106 | (fresh (q) 107 | (bound-*o q p n m) 108 | (*o x m q) 109 | (pluso `(0 . ,q) m p)))) 110 | 111 | (define bound-*o 112 | (lambda (q p n m) 113 | (conde 114 | ((== '() q) (poso p)) 115 | ((fresh (a0 a1 a2 a3 x y z) 116 | (== `(,a0 . ,x) q) 117 | (== `(,a1 . ,y) p) 118 | (conde 119 | ((== '() n) 120 | (== `(,a2 . ,z) m) 121 | (bound-*o x y z '())) 122 | ((== `(,a3 . ,z) n) 123 | (bound-*o x y z m)))))))) 124 | 125 | (define =lo 126 | (lambda (n m) 127 | (conde 128 | ((== '() n) (== '() m)) 129 | ((== '(1) n) (== '(1) m)) 130 | ((fresh (a x b y) 131 | (== `(,a . ,x) n) (poso x) 132 | (== `(,b . ,y) m) (poso y) 133 | (=lo x y)))))) 134 | 135 | (define 1o m)) 140 | ((fresh (a x b y) 141 | (== `(,a . ,x) n) (poso x) 142 | (== `(,b . ,y) m) (poso y) 143 | (1o b) (=lo n b) (pluso r b n)) 227 | ((== '(1) b) (poso q) (pluso r '(1) n)) 228 | ((== '() b) (poso q) (== r n)) 229 | ((== '(0 1) b) 230 | (fresh (a ad dd) 231 | (poso dd) 232 | (== `(,a ,ad . ,dd) n) 233 | (exp2 n '() q) 234 | (fresh (s) 235 | (splito n dd r s)))) 236 | ((fresh (a ad add ddd) 237 | (conde 238 | ((== '(1 1) b)) 239 | ((== `(,a ,ad ,add . ,ddd) b)))) 240 | (1o n) (== '(1) q) 272 | (fresh (s) 273 | (splito n b s '(1)))) 274 | ((fresh (q1 b2) 275 | (== `(0 . ,q1) q) 276 | (poso q1) 277 | (1o q) 294 | (fresh (q1 nq1) 295 | (pluso q1 '(1) q) 296 | (repeated-mul n q1 nq1) 297 | (*o nq1 n nq)))))) 298 | 299 | (define expo 300 | (lambda (b q n) 301 | (logo n b q '()))) 302 | 303 | -------------------------------------------------------------------------------- /radiw-concrete-tests.scm: -------------------------------------------------------------------------------- 1 | (load "../clpsmt-miniKanren/radiw-concrete.scm") 2 | ;(load "test-check.scm") 3 | 4 | ;; WEB todo 5 | ;; 6 | ;; Port CLP(SMT) to faster mk 7 | ;; 8 | ;; Change radiw abstract interp to allow for any integer, rather than just -1, 0, 1 9 | ;; 10 | ;; Combine concrete and abstract interps for synthesis (perhaps with type inferencer). 11 | ;; 12 | ;; Can I combine abstract and concrete interp for RSA synthesis? 13 | 14 | (define fact 15 | `(lam self n 16 | (if0 (var n) 17 | (int 1) 18 | (times (var n) 19 | (app (var self) 20 | (plus (var n) (int -1))))))) 21 | 22 | (define efact 23 | `(app ,fact (int 5))) 24 | 25 | 26 | (define fib 27 | `(lam self n 28 | (if0 (var n) 29 | (int 0) 30 | (if0 (plus (var n) (int -1)) 31 | (int 1) 32 | (plus (app (var self) 33 | (plus (var n) (int -1))) 34 | (app (var self) 35 | (plus (var n) (int -2)))))))) 36 | 37 | (define efib 38 | `(app ,fib (int 6))) 39 | 40 | (time-test "fact-5" 41 | (run* (q) 42 | (evalo efact q)) 43 | '((int 120))) 44 | 45 | (time-test "fib-6" 46 | (run* (q) 47 | (evalo efib q)) 48 | '((int 8))) 49 | 50 | (time-test "fib-synthesis-1" 51 | (run 1 (fib) 52 | (fresh (r) 53 | (== `(lam self n 54 | (if0 (var n) 55 | (int 0) 56 | (if0 (plus (var n) (int -1)) 57 | ,r 58 | (plus (app (var self) 59 | (plus (var n) (int -1))) 60 | (app (var self) 61 | (plus (var n) (int -2))))))) 62 | fib)) 63 | (evalo `(app ,fib (int 6)) '(int 8))) 64 | '((lam self 65 | n 66 | (if0 (var n) 67 | (int 0) 68 | (if0 (plus (var n) (int -1)) 69 | (int 1) 70 | (plus 71 | (app (var self) (plus (var n) (int -1))) 72 | (app (var self) (plus (var n) (int -2))))))))) 73 | 74 | (time-test "fib-synthesis-2" 75 | (run 1 (fib) 76 | (fresh (r r1 r2) 77 | (== `(lam self n 78 | (if0 (var n) 79 | (int 0) 80 | (if0 (plus (var n) (int -1)) 81 | ,r 82 | (plus (app (var self) 83 | (plus (var n) ,r1)) 84 | (app (var self) 85 | (plus (var n) ,r2)))))) 86 | fib)) 87 | (evalo `(app ,fib (int 0)) '(int 0)) 88 | (evalo `(app ,fib (int 2)) '(int 1)) 89 | (evalo `(app ,fib (int 3)) '(int 2)) 90 | (evalo `(app ,fib (int 4)) '(int 3))) 91 | '((lam self 92 | n 93 | (if0 (var n) 94 | (int 0) 95 | (if0 (plus (var n) (int -1)) 96 | (int 1) 97 | (plus 98 | (app (var self) (plus (var n) (int -2))) 99 | (app (var self) (plus (var n) (int -1))))))))) 100 | 101 | -------------------------------------------------------------------------------- /radiw-concrete.scm: -------------------------------------------------------------------------------- 1 | ;(load "mk.scm") 2 | ;(load "z3-driver.scm") 3 | 4 | (define (lookupo x env val) 5 | (fresh (y v rest) 6 | (== `((,y . ,v) . ,rest) env) 7 | (conde 8 | [(== x y) (== v val)] 9 | [(=/= x y) (lookupo x rest val)]))) 10 | 11 | (define (evalo expr val) 12 | (eval-expro expr '() val)) 13 | 14 | (define (eval-expro expr env val) 15 | (conde 16 | [(fresh (x) 17 | (== `(var ,x) expr) 18 | (symbolo x) 19 | (lookupo x env val))] 20 | [(fresh (i) 21 | (== `(int ,i) expr) 22 | (== `(int ,i) val) 23 | (numbero i))] 24 | [(fresh (e1 e2 n1 n2 n3) 25 | (== `(plus ,e1 ,e2) expr) 26 | (numbero n1) 27 | (numbero n2) 28 | (numbero n3) 29 | (== `(int ,n3) val) 30 | (z/assert `(= ,n3 (+ ,n1 ,n2))) 31 | (eval-expro e1 env `(int ,n1)) 32 | (eval-expro e2 env `(int ,n2)))] 33 | [(fresh (e1 e2 n1 n2 n3) 34 | (== `(times ,e1 ,e2) expr) 35 | (numbero n1) 36 | (numbero n2) 37 | (numbero n3) 38 | (== `(int ,n3) val) 39 | (z/assert `(= ,n3 (* ,n1 ,n2))) 40 | (eval-expro e1 env `(int ,n1)) 41 | (eval-expro e2 env `(int ,n2)))] 42 | [(fresh (x y body) 43 | (== `(lam ,x ,y ,body) expr) 44 | (== `(clos ,x ,y ,body ,env) val) 45 | (symbolo x) 46 | (symbolo y))] 47 | [(fresh (e1 e2 x y body env^ arg) 48 | (== `(app ,e1 ,e2) expr) 49 | (eval-expro e1 env `(clos ,x ,y ,body ,env^)) 50 | (symbolo x) 51 | (symbolo y) 52 | (eval-expro e2 env arg) 53 | ;; WEB is this right??? 54 | (eval-expro body `((,y . ,arg) (,x . (clos ,x ,y ,body ,env^)) . ,env^) val))] 55 | [(fresh (e1 e2 e3 n) 56 | (== `(if0 ,e1 ,e2 ,e3) expr) 57 | (numbero n) 58 | (eval-expro e1 env `(int ,n)) 59 | (conde 60 | [(z/assert `(= ,n 0)) 61 | (eval-expro e2 env val)] 62 | [(z/assert `(not (= ,n 0))) 63 | (eval-expro e3 env val)]))])) 64 | -------------------------------------------------------------------------------- /rai-clojure/.lein-repl-history: -------------------------------------------------------------------------------- 1 | (require 'clojure.core.logic) 2 | (load "rai_clojure/rai") 3 | myappendo 4 | (in-ns 'rai_clojure.rai) 5 | myappendo 6 | appendo 7 | (require 'clojure.core.logic) 8 | appendo 9 | (in-ns 'rai_clojure.rai) 10 | (load "rai_clojure/rai") 11 | (require 'clojure.core.logic) 12 | (load "rai_clojure/rai") 13 | (in-ns 'rai_clojure.rai) 14 | (require 'clojure.core.logic) 15 | (load "rai_clojure/rai") 16 | (in-ns 'rai_clojure.rai) 17 | myappendo 18 | appendo 19 | (require 'clojure.core.logic) 20 | (load "rai_clojure/rai") 21 | (in-ns 'rai_clojure.rai) 22 | appendo 23 | (require 'clojure.core.logic) 24 | (load "rai_clojure/rai") 25 | (in-ns 'rai_clojure.rai) 26 | (require 'clojure.core.logic) 27 | (load "rai_clojure/rai") 28 | (in-ns 'rai-clojure.rai) 29 | appendo 30 | (require 'clojure.core.logic) 31 | (load "rai_clojure/rai") 32 | (in-ns 'rai-clojure.rai) 33 | appendo 34 | (require 'clojure.core.logic) 35 | (load "rai_clojure/rai") 36 | (in-ns 'rai-clojure.rai) 37 | appendo 38 | (require 'clojure.core.logic) 39 | (load "rai_clojure/rai") 40 | (in-ns 'rai-clojure.rai) 41 | appendo 42 | (run 1 [q] (appendo [1 2] [3 4] q)) 43 | (run* [q] (appendo [1 2] [3 4] q)) 44 | (run* [x y] (appendo x y [1 2 3 4])) 45 | (run* [x y] (myappendo x y [1 2 3 4])) 46 | (require 'clojure.core.logic) 47 | (load "rai_clojure/rai") 48 | (require 'clojure.core.logic) 49 | (load "rai_clojure/rai") 50 | (require 'clojure.core.logic) 51 | (load "rai_clojure/rai") 52 | (in-ns 'rai-clojure.rai) 53 | (run 1 [q] (lookupo 3 [[1 2] [3 4] q)) 54 | (run 1 [q] (lookupo 3 [[1 2] [3 4]] q)) 55 | (run 1 [q] (lookupo 5 [[1 2] [3 4]] q)) 56 | (run 1 [q] (lookupo w [[w 2] [v 4]] q)) 57 | (run 1 [q] (lookupo 'w [[w 2] [v 4]] q)) 58 | (run 1 [q] (lookupo 'z [[w 2] [v 4]] q)) 59 | (run 1 [q] (lookupo 'z [['w 2] ['v 4]] q)) 60 | (run 1 [q] (lookupo 'v [['w 2] ['v 4]] q)) 61 | (require 'clojure.core.logic) 62 | (load "rai_clojure/rai") 63 | (require 'clojure.core.logic) 64 | (load "rai_clojure/rai") 65 | (require 'clojure.core.logic) 66 | (run 1 [e v] (evalo e v)) 67 | run 68 | appendo 69 | (require 'clojure.core.logic) 70 | (load "rai_clojure/rai") 71 | (load "rai-clojure/rai") 72 | (in-ns 'rai-clojure.rai) 73 | (run 1 [e v] (evalo e v)) 74 | (run 2 [e v] (evalo e v)) 75 | (require 'clojure.core.logic) 76 | (load "rai-clojure/rai") 77 | (load "rai_clojure/rai") 78 | (in-ns 'rai-clojure.rai) 79 | (run 2 [e v] (evalo e v)) 80 | (run 3 [e v] (evalo e v)) 81 | (require 'clojure.core.logic) 82 | (load "rai_clojure/rai") 83 | (in-ns 'rai-clojure.rai) 84 | (require 'clojure.core.logic) 85 | (load "rai_clojure/rai") 86 | (in-ns 'rai-clojure.rai) 87 | (run 2 [e v] (evalo e v)) 88 | (require 'clojure.core.logic) 89 | (load "rai_clojure/rai") 90 | (in-ns 'rai-clojure.rai) 91 | (run 2 [e v] (evalo e v)) 92 | (run 10 [e v] (evalo e v)) 93 | (run 100 [e v] (evalo e v)) 94 | (require 'clojure.core.logic) 95 | (load "rai_clojure/rai") 96 | (in-ns 'rai-clojure.rai) 97 | (run 100 [e v] (evalo e v)) 98 | (in-ns 'rai-clojure.rai) 99 | (load "rai_clojure/rai") 100 | (require 'clojure.core.logic) 101 | (load "rai_clojure/rai") 102 | (in-ns 'rai-clojure.rai) 103 | (run 100 [e v] (evalo e v)) 104 | (run 100 [e v] (fresh [rest] (conso 'if0 rest e)) (evalo e v)) 105 | (run 100 [e v] (fresh [rest] (conso 'times rest e)) (evalo e v)) 106 | (run 1000 [e v] (fresh [rest] (conso 'times rest e)) (evalo e v)) 107 | -------------------------------------------------------------------------------- /rai-clojure/README.md: -------------------------------------------------------------------------------- 1 | Relational Abstract Interpretation in Clojure 2 | ==== 3 | 4 | Meow! 5 | 6 | webyrd:~/github/rai-clojure/rai-clojure$ lein repl 7 | nREPL server started on port 56364 on host 127.0.0.1 - nrepl://127.0.0.1:56364 8 | REPL-y 0.3.7, nREPL 0.2.12 9 | Clojure 1.9.0 10 | Java HotSpot(TM) 64-Bit Server VM 9.0.1+11 11 | Docs: (doc function-name-here) 12 | (find-doc "part-of-name-here") 13 | Source: (source function-name-here) 14 | Javadoc: (javadoc java-object-or-class-here) 15 | Exit: Control+D or (exit) or (quit) 16 | Results: Stored in vars *1, *2, *3, an exception in *e 17 | 18 | user=> (require 'clojure.core.logic) 19 | nil 20 | user=> (load "rai_clojure/rai") 21 | nil 22 | user=> (in-ns 'rai-clojure.rai) 23 | #object[clojure.lang.Namespace 0x330a5dea "rai-clojure.rai"] 24 | rai-clojure.rai=> (run 100 [e v] (evalo e v)) 25 | 26 | 27 | 28 | 29 | webyrd:~/github/rai-clojure/rai-clojure$ lein repl 30 | nREPL server started on port 56058 on host 127.0.0.1 - nrepl://127.0.0.1:56058 31 | REPL-y 0.3.7, nREPL 0.2.12 32 | Clojure 1.9.0 33 | Java HotSpot(TM) 64-Bit Server VM 9.0.1+11 34 | Docs: (doc function-name-here) 35 | (find-doc "part-of-name-here") 36 | Source: (source function-name-here) 37 | Javadoc: (javadoc java-object-or-class-here) 38 | Exit: Control+D or (exit) or (quit) 39 | Results: Stored in vars *1, *2, *3, an exception in *e 40 | 41 | user=> (require 'clojure.core.logic) 42 | nil 43 | user=> (load "rai_clojure/rai") 44 | nil 45 | user=> (in-ns 'rai-clojure.rai) 46 | #object[clojure.lang.Namespace 0x11dd7c82 "rai-clojure.rai"] 47 | rai-clojure.rai=> (run 1 [q] (lookupo 3 [[1 2] [3 4] q)) 48 | 49 | RuntimeException Unmatched delimiter: ) clojure.lang.Util.runtimeException (Util.java:221) 50 | RuntimeException Unmatched delimiter: ) clojure.lang.Util.runtimeException (Util.java:221) 51 | rai-clojure.rai=> (run 1 [q] (lookupo 3 [[1 2] [3 4] q)) 52 | 53 | RuntimeException Unmatched delimiter: ) clojure.lang.Util.runtimeException (Util.java:221) 54 | RuntimeException Unmatched delimiter: ) clojure.lang.Util.runtimeException (Util.java:221) 55 | rai-clojure.rai=> (run 1 [q] (lookupo 3 [[1 2] [3 4]] q)) 56 | (4) 57 | rai-clojure.rai=> (run 1 [q] (lookupo 5 [[1 2] [3 4]] q)) 58 | () 59 | rai-clojure.rai=> (run 1 [q] (lookupo w [[w 2] [v 4]] q)) 60 | 61 | CompilerException java.lang.RuntimeException: Unable to resolve symbol: w in this context, compiling:(/private/var/folders/wm/4zr1t8m911lcrz9z7c54n4nm0000gn/T/form-init11060800822347525331.clj:1:12) 62 | rai-clojure.rai=> (run 1 [q] (lookupo 'w [[w 2] [v 4]] q)) 63 | 64 | CompilerException java.lang.RuntimeException: Unable to resolve symbol: w in this context, compiling:(/private/var/folders/wm/4zr1t8m911lcrz9z7c54n4nm0000gn/T/form-init11060800822347525331.clj:1:12) 65 | rai-clojure.rai=> (run 1 [q] (lookupo 'z [[w 2] [v 4]] q)) 66 | 67 | CompilerException java.lang.RuntimeException: Unable to resolve symbol: w in this context, compiling:(/private/var/folders/wm/4zr1t8m911lcrz9z7c54n4nm0000gn/T/form-init11060800822347525331.clj:1:12) 68 | rai-clojure.rai=> (run 1 [q] (lookupo 'z [['w 2] ['v 4]] q)) 69 | () 70 | rai-clojure.rai=> (run 1 [q] (lookupo 'v [['w 2] ['v 4]] q)) 71 | (4) 72 | rai-clojure.rai=> 73 | 74 | 75 | -------------------------------------------------------------------------------- /rai-clojure/project.clj: -------------------------------------------------------------------------------- 1 | (defproject rai-clojure "0.0.1" 2 | :description "RAI in Clojure" 3 | :dependencies [[org.clojure/clojure "1.9.0"] 4 | [org.clojure/core.logic "0.8.11"]]) 5 | -------------------------------------------------------------------------------- /rai-clojure/src/rai_clojure/core.clj: -------------------------------------------------------------------------------- 1 | (ns rai-clojure.core) 2 | -------------------------------------------------------------------------------- /rai-clojure/src/rai_clojure/rai.clj: -------------------------------------------------------------------------------- 1 | (ns rai-clojure.rai 2 | (:refer-clojure :exclude [==]) 3 | (:use [clojure.core.logic]) 4 | (:require [clojure.core.logic.fd :as fd])) 5 | 6 | 7 | ;; concrete interp 8 | (defn lookupo [x env val] 9 | (fresh [y v rest] 10 | (conso [y v] rest env) 11 | (conde 12 | ((== x y) (== v val)) 13 | ((!= x y) (lookupo x rest val))))) 14 | 15 | (defn eval-expro [expr env val] 16 | (conde 17 | ((fresh [x] 18 | (== ['var x] expr) 19 | (lookupo x env val))) 20 | ((fresh [i] 21 | (== ['int i] expr) 22 | (== ['int i] val) 23 | (fd/in i (fd/interval -1000 1000)))) 24 | ((fresh [e1 e2 n1 n2 n3] 25 | (== ['plus e1 e2] expr) 26 | (== ['int n3] val) 27 | (fd/in n1 n2 n3 (fd/interval -1000 1000)) 28 | (fd/+ n1 n2 n3) 29 | (eval-expro e1 env ['int n1]) 30 | (eval-expro e2 env ['int n2]))) 31 | ((fresh [e1 e2 n1 n2 n3] 32 | (== ['times e1 e2] expr) 33 | (== ['int n3] val) 34 | (fd/in n1 n2 n3 (fd/interval -1000 1000)) 35 | (fd/* n1 n2 n3) 36 | (eval-expro e1 env ['int n1]) 37 | (eval-expro e2 env ['int n2]))) 38 | ((fresh [x y body] 39 | (== ['lam x y body] expr) 40 | (== ['clos x y body env] val))) 41 | ((fresh [e1 e2 x y body env1 env2 env3 arg] 42 | (== ['app e1 e2] expr) 43 | (eval-expro e1 env ['clos x y body env1]) 44 | (eval-expro e2 env arg) 45 | (conso [x ['clos x y body env1]] env1 env2) 46 | (conso [y arg] env2 env3) 47 | (eval-expro body env3 val))) 48 | ((fresh [e1 e2 e3 n] 49 | (== ['if0 e1 e2 e3] expr) 50 | (fd/in n (fd/interval -1000 1000)) 51 | (eval-expro e1 env ['int n]) 52 | (conde 53 | [(fd/== n 0) 54 | (eval-expro e2 env val)] 55 | [(fd/!= n 0) 56 | (eval-expro e3 env val)]))))) 57 | 58 | (defn evalo [expr val] 59 | (eval-expro expr [] val)) -------------------------------------------------------------------------------- /rai-clojure/target/classes/META-INF/maven/rai-clojure/rai-clojure/pom.properties: -------------------------------------------------------------------------------- 1 | #Leiningen 2 | #Wed Oct 24 09:25:31 CDT 2018 3 | groupId=rai-clojure 4 | artifactId=rai-clojure 5 | version=0.0.1 6 | -------------------------------------------------------------------------------- /rai-clojure/target/stale/leiningen.core.classpath.extract-native-dependencies: -------------------------------------------------------------------------------- 1 | [{:dependencies {org.clojure/clojure {:vsn "1.9.0", :native-prefix nil}, org.clojure/spec.alpha {:vsn "0.1.143", :native-prefix nil}, org.clojure/core.specs.alpha {:vsn "0.1.24", :native-prefix nil}, org.clojure/core.logic {:vsn "0.8.11", :native-prefix nil}, org.clojure/tools.nrepl {:vsn "0.2.12", :native-prefix nil}, clojure-complete {:vsn "0.2.4", :native-prefix nil}}, :native-path "target/native"} {:native-path "target/native", :dependencies {org.clojure/clojure {:vsn "1.9.0", :native-prefix nil, :native? false}, org.clojure/core.logic {:vsn "0.8.11", :native-prefix nil, :native? false}, org.clojure/tools.nrepl {:vsn "0.2.12", :native-prefix nil, :native? false}, clojure-complete {:vsn "0.2.4", :native-prefix nil, :native? false}, org.clojure/spec.alpha {:vsn "0.1.143", :native-prefix nil, :native? false}, org.clojure/core.specs.alpha {:vsn "0.1.24", :native-prefix nil, :native? false}}}] -------------------------------------------------------------------------------- /rai-clojure/test/rai_clojure/test/core.clj: -------------------------------------------------------------------------------- 1 | (ns rai-clojure.test.core 2 | (:use [rai-clojure.core]) 3 | (:use [clojure.test])) 4 | 5 | (deftest replace-me ;; FIXME: write 6 | (is false "No tests have been written.")) 7 | -------------------------------------------------------------------------------- /rcd.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "cvc4-driver.scm") 3 | (load "test-check.scm") 4 | ;;(load "cvc4-set-tests.scm") 5 | ;;(load "clpset.scm") 6 | 7 | (define (declare-datatypes) 8 | (fresh () 9 | (z/ '(declare-datatypes 10 | ((Ty 0) (listTy 0)) 11 | (((arr (arr_param Ty) (arr_return Ty)) 12 | (rcd (rcd_set listTy))) 13 | ((cons (head Ty) (tail listTy)) (nil))))))) 14 | 15 | (define typ 16 | (lambda (t) 17 | (z/ `(declare-const ,t Ty)))) 18 | 19 | (define tf 20 | (lambda (f) 21 | (z/ `(declare-const ,f ty)))) 22 | 23 | (define tfs 24 | (lambda (s) 25 | (z/ `(declare-const ,s listTy)))) 26 | 27 | (define sub 28 | (lambda (t1 t2) 29 | (conde 30 | ((z/== t1 t2)) 31 | ((z/assert `(not (= ,t1 ,t2))) 32 | (conde 33 | ((fresh (ta1 tb1 ta2 tb2) 34 | (typ ta1) (typ tb1) (typ ta2) (typ tb2) 35 | (z/== `(arr ,ta1 ,tb1) t1) 36 | (z/== `(arr ,ta2 ,tb2) t2) 37 | (sub ta2 ta1) 38 | (sub tb1 tb2))) 39 | ((fresh (r1 r2) 40 | (tfs r1) (tfs r2) 41 | (z/== `(rcd ,r1) t1) 42 | (z/== `(rcd ,r2) t2) 43 | (sub-rcd r1 r2)))))))) 44 | 45 | (define sub-rcd 46 | (lambda (r1 r2) 47 | (conde 48 | ((z/assert `(not (= ,r1 ,r2))) 49 | (conde 50 | ((z/== r2 'nil)) 51 | ((fresh (a2 d2 a1 d1) 52 | (z/== r2 `(cons ,a2 ,d2)) 53 | (z/== r1 `(cons ,a1 ,d1)) 54 | (z/== a1 a2) 55 | (sub-rcd d2 d1)))))))) 56 | 57 | (test "1" 58 | (run 10 (q) 59 | (declare-datatypes) 60 | (fresh (t1 t2) 61 | (typ t1) (typ t2) 62 | (== q (list t1 t2)) 63 | (sub t1 t2))) 64 | '(((rcd nil) (rcd nil)) ((arr (rcd nil) (rcd nil)) (arr (rcd nil) (rcd nil))) 65 | ((rcd (cons (rcd nil) nil)) (rcd (cons (rcd nil) nil))) 66 | ((arr (rcd nil) (arr (rcd nil) (rcd nil))) 67 | (arr (rcd nil) (arr (rcd nil) (rcd nil)))) 68 | ((arr (arr (rcd nil) (rcd nil)) (rcd nil)) 69 | (arr (arr (rcd nil) (rcd nil)) (rcd nil))) 70 | ((rcd (cons (rcd nil) (cons (rcd nil) nil))) 71 | (rcd (cons (rcd nil) (cons (rcd nil) nil)))) 72 | ((arr (rcd nil) (rcd (cons (rcd nil) nil))) 73 | (arr (rcd nil) (rcd (cons (rcd nil) nil)))) 74 | ((arr (arr (rcd nil) (rcd nil)) (arr (rcd nil) (rcd nil))) 75 | (arr (arr (rcd nil) (rcd nil)) (arr (rcd nil) (rcd nil)))) 76 | ((arr (rcd (cons (rcd nil) nil)) (rcd nil)) 77 | (arr (rcd (cons (rcd nil) nil)) (rcd nil))) 78 | ((rcd (cons (arr (rcd nil) (rcd nil)) nil)) 79 | (rcd (cons (arr (rcd nil) (rcd nil)) nil))))) 80 | -------------------------------------------------------------------------------- /rcd.smt: -------------------------------------------------------------------------------- 1 | (set-logic ALL_SUPPORTED) 2 | 3 | (declare-datatypes 4 | ((Pair 2)) 5 | ((par (A B) ((pair (fst A) (snd B)))))) 6 | 7 | (declare-datatypes 8 | ((Typ 0)) 9 | (((arr (arr_param Typ) (arr_return Typ)) 10 | (rcd (rcd_set (Set (Pair Int Typ))))))) 11 | -------------------------------------------------------------------------------- /reactive1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 2htdp/image) 4 | (require racket/system) 5 | 6 | (define (model-assoc m) 7 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 8 | (define (get x m) (cdr (assoc x m))) 9 | 10 | (define (ex-scene m) 11 | (place-image 12 | (rectangle 40 40 "solid" "gray") 13 | (get 'x m) 100 14 | (empty-scene 400 400 "white"))) 15 | (define (ex-constraints say) 16 | (say '(declare-const t Int)) 17 | (say '(declare-const x Int)) 18 | (say '(assert (= x (* 10 t)))) 19 | (say '(assert (<= 0 x))) 20 | (say '(assert (<= x 400)))) 21 | 22 | 23 | (define (run-world constraints scene) 24 | (match (process "z3 -in") 25 | [(list p-in p-out _ p-err p-fun) 26 | (define (say msg) 27 | (fprintf p-out "~a\n" msg)) 28 | (define (check-sat) 29 | (say '(check-sat)) 30 | (flush-output p-out) 31 | (let ((r (read p-in))) 32 | (println r) 33 | (eq? r 'sat))) 34 | (define (get-model) 35 | (say '(get-model)) 36 | (flush-output p-out) 37 | (model-assoc (read p-in))) 38 | 39 | (constraints say) 40 | (big-bang 0 41 | (on-tick (lambda (t) (+ t 1))) 42 | (stop-when (lambda (t) (= t 40))) 43 | (to-draw (lambda (t) 44 | (say '(push)) 45 | (say `(assert (= t ,t))) 46 | (check-sat) 47 | (let ((m (get-model))) 48 | (println m) 49 | (say '(pop)) 50 | (scene m))))) 51 | 52 | (close-input-port p-in) 53 | (close-output-port p-out) 54 | (close-input-port p-err)])) 55 | 56 | (run-world ex-constraints ex-scene) 57 | -------------------------------------------------------------------------------- /reactive2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 2htdp/image) 4 | (require racket/system) 5 | 6 | (define (model-assoc m) 7 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 8 | (define (get x m) (cdr (assoc x m))) 9 | 10 | (define (ex-scene m) 11 | (place-image 12 | (rectangle 40 40 "solid" "gray") 13 | (get 'x m) 100 14 | (empty-scene 400 400 "white"))) 15 | (define (ex-constraints say) 16 | (say '(declare-const t Int)) 17 | (say '(declare-const x Int)) 18 | (say '(assert (= x (* 10 t)))) 19 | (say '(assert (<= 0 x))) 20 | (say '(assert (<= x 400)))) 21 | 22 | 23 | (define (ex2-scene m) 24 | (place-image 25 | (circle 40 "solid" "red") 26 | (get 'cx m) (get 'cy m) 27 | (place-image 28 | (rectangle 40 40 "solid" "gray") 29 | (get 'rx m) (get 'ry m) 30 | (empty-scene 400 400 "white")))) 31 | (define (ex2-constraints say) 32 | (say '(declare-const t Int)) 33 | (say '(declare-const rx Int)) 34 | (say '(declare-const cx Int)) 35 | (say '(declare-const ry Int)) 36 | (say '(declare-const cy Int)) 37 | (say '(declare-const rv Int)) 38 | (say '(declare-const cv Int)) 39 | (say '(assert (= cx (* cv t)))) 40 | (say '(assert (= ry (* rv t)))) 41 | (for-each 42 | (lambda (v) 43 | (say `(assert (< 0 ,v))) 44 | (say `(assert (<= ,v 10)))) 45 | '(cv rv)) 46 | (for-each 47 | (lambda (x) 48 | (say `(assert (<= 0 ,x))) 49 | (say `(assert (<= ,x 400)))) 50 | '(rx cx ry cy)) 51 | (say `(assert (<= 0 (- cy ry)))) 52 | (say `(assert (>= 100 (- cy ry))))) 53 | 54 | 55 | (define (run-world constraints scene) 56 | (match (process "z3 -in") 57 | [(list p-in p-out _ p-err p-fun) 58 | (define (say msg) 59 | ;(printf "~a\n" msg) 60 | (fprintf p-out "~a\n" msg)) 61 | (define (check-sat) 62 | (say '(check-sat)) 63 | (flush-output p-out) 64 | (let ((r (read p-in))) 65 | (println r) 66 | (eq? r 'sat))) 67 | (define (get-model) 68 | (say '(get-model)) 69 | (flush-output p-out) 70 | (model-assoc (read p-in))) 71 | (define (get-current-model t m) 72 | (say '(push)) 73 | (say `(assert (= t ,t))) 74 | (for-each 75 | (lambda (kv) 76 | (say `(assert-soft (= ,(car kv) ,(cdr kv)) :weight 1))) 77 | m) 78 | (let* ((ok (check-sat)) 79 | (m (if ok (get-model) m))) 80 | (say '(pop)) 81 | (list ok m))) 82 | 83 | (constraints say) 84 | (big-bang (cons 0 (get-current-model 0 '())) 85 | (on-tick (lambda (tom) 86 | (let ((t (car tom)) 87 | (m (caddr tom))) 88 | (cons (+ t 1) (get-current-model t m))))) 89 | (stop-when (lambda (tom) (not (cadr tom)))) 90 | (to-draw (lambda (tom) (scene (caddr tom))))) 91 | 92 | (close-input-port p-in) 93 | (close-output-port p-out) 94 | (close-input-port p-err)])) 95 | 96 | 97 | (run-world ex2-constraints ex2-scene) 98 | -------------------------------------------------------------------------------- /reactive3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 2htdp/image) 4 | (require racket/system) 5 | 6 | (define (model-assoc m) 7 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 8 | (define (get x m) (cdr (assoc x m))) 9 | 10 | (define (ex-scene m s) 11 | (place-image 12 | (rectangle 40 40 "solid" "gray") 13 | (get 'x m) 100 s)) 14 | (define (ex-constraints say) 15 | (say '(declare-const t Int)) 16 | (say '(declare-const x Int)) 17 | (say '(assert (= x (* 10 t)))) 18 | (say '(assert (<= 0 x))) 19 | (say '(assert (<= x 400)))) 20 | 21 | 22 | (define (ex2-scene m s) 23 | (place-image 24 | (circle 40 "solid" "red") 25 | (get 'cx m) (get 'cy m) 26 | (place-image 27 | (rectangle 40 40 "solid" "gray") 28 | (get 'rx m) (get 'ry m) 29 | s))) 30 | (define (ex2-constraints say) 31 | (say '(declare-const t Int)) 32 | (say '(declare-const rx Int)) 33 | (say '(declare-const cx Int)) 34 | (say '(declare-const ry Int)) 35 | (say '(declare-const cy Int)) 36 | (say '(declare-const rv Int)) 37 | (say '(declare-const cv Int)) 38 | (say '(assert (= cx (* cv t)))) 39 | (say '(assert (= ry (* rv t)))) 40 | (for-each 41 | (lambda (v) 42 | (say `(assert (< 0 ,v))) 43 | (say `(assert (<= ,v 10)))) 44 | '(cv rv)) 45 | (for-each 46 | (lambda (x) 47 | (say `(assert (<= 0 ,x))) 48 | (say `(assert (<= ,x 400)))) 49 | '(rx cx ry cy)) 50 | (say `(assert (<= 0 (- cy ry)))) 51 | (say `(assert (>= 100 (- cy ry))))) 52 | 53 | 54 | (define (run-world constraints scene) 55 | (match (process "z3 -in") 56 | [(list p-in p-out _ p-err p-fun) 57 | (define (say msg) 58 | ;(printf "~a\n" msg) 59 | (fprintf p-out "~a\n" msg)) 60 | (define (check-sat) 61 | (say '(check-sat)) 62 | (flush-output p-out) 63 | (let ((r (read p-in))) 64 | (println r) 65 | (eq? r 'sat))) 66 | (define (get-model) 67 | (say '(get-model)) 68 | (flush-output p-out) 69 | (model-assoc (read p-in))) 70 | (define (get-current-model t m ms) 71 | ;(println m) 72 | (say '(push)) 73 | (say `(assert (= t ,t))) 74 | (for-each 75 | (lambda (kv) 76 | (say `(assert-soft (= ,(car kv) ,(cdr kv)) :weight 1))) 77 | m) 78 | (for-each 79 | (lambda (other-m) 80 | (say `(assert 81 | ,(cons 'or 82 | (map 83 | (lambda (kv) 84 | `(not (= ,(car kv) ,(cdr kv)))) 85 | other-m))))) 86 | ms) 87 | (let* ((ok (check-sat)) 88 | (m (if ok (get-model) m))) 89 | (say '(pop)) 90 | (list ok m))) 91 | (define (get-current-models t ms) 92 | (foldr (lambda (m ms) 93 | (match (get-current-model t m ms) 94 | [(list ok m) 95 | (if ok (cons m ms) ms)])) '() ms)) 96 | (define (spur-new-models t n ms) 97 | (if (= n 0) 98 | ms 99 | (match (get-current-model t '() ms) 100 | [(list ok m) 101 | (if ok (spur-new-models t (- n 1) (cons m ms)) ms)]))) 102 | 103 | (constraints say) 104 | (big-bang (cons 0 (spur-new-models 0 10 '())) 105 | (on-tick (lambda (tm) 106 | (let ((t (car tm)) 107 | (ms (cdr tm))) 108 | (cons (+ t 1) (get-current-models t ms))))) 109 | (stop-when (lambda (tm) (null? (cdr tm)))) 110 | (to-draw (lambda (tm) (foldr scene (empty-scene 400 400 "white") (cdr tm))))) 111 | 112 | (close-input-port p-in) 113 | (close-output-port p-out) 114 | (close-input-port p-err)])) 115 | 116 | 117 | (run-world ex2-constraints ex2-scene) 118 | -------------------------------------------------------------------------------- /reactive4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 2htdp/image) 4 | (require racket/system) 5 | 6 | (define (model-assoc m) 7 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 8 | (define (get x m) (cdr (assoc x m))) 9 | 10 | (define (ex-scene m s) 11 | (place-image 12 | (rectangle 40 40 "solid" "gray") 13 | (get 'x m) 100 s)) 14 | (define (ex-constraints say) 15 | (say '(declare-const t Int)) 16 | (say '(declare-const x Int)) 17 | (say '(assert (= x (* 10 t)))) 18 | (say '(assert (<= 0 x))) 19 | (say '(assert (<= x 400)))) 20 | 21 | 22 | (define (ex2-scene m s) 23 | (place-image 24 | (circle 40 "solid" "red") 25 | (get 'cx m) (get 'cy m) 26 | (place-image 27 | (rectangle 40 40 "solid" "gray") 28 | (get 'rx m) (get 'ry m) 29 | s))) 30 | (define (ex2-constraints say) 31 | (say '(declare-const t Int)) 32 | (say '(declare-const rx Int)) 33 | (say '(declare-const cx Int)) 34 | (say '(declare-const ry Int)) 35 | (say '(declare-const cy Int)) 36 | (say '(declare-const rv Int)) 37 | (say '(declare-const cv Int)) 38 | (say '(assert (= cx (* cv t)))) 39 | (say '(assert (= ry (* rv t)))) 40 | (for-each 41 | (lambda (v) 42 | (say `(assert (< 0 ,v))) 43 | (say `(assert (<= ,v 10)))) 44 | '(cv rv)) 45 | (for-each 46 | (lambda (x) 47 | (say `(assert (<= 0 ,x))) 48 | (say `(assert (<= ,x 400)))) 49 | '(rx cx ry cy)) 50 | (say `(assert (<= 0 (- cy ry)))) 51 | (say `(assert (>= 100 (- cy ry))))) 52 | 53 | 54 | (define (run-world constraints scene) 55 | (match (process "z3 -in") 56 | [(list p-in p-out _ p-err p-fun) 57 | (define (say msg) 58 | ;(printf "~a\n" msg) 59 | (fprintf p-out "~a\n" msg)) 60 | (define (check-sat) 61 | (say '(check-sat)) 62 | (flush-output p-out) 63 | (let ((r (read p-in))) 64 | (println r) 65 | (eq? r 'sat))) 66 | (define (get-model) 67 | (say '(get-model)) 68 | (flush-output p-out) 69 | (model-assoc (read p-in))) 70 | (define (get-current-model t m ms) 71 | ;(println m) 72 | (say '(push)) 73 | (say `(assert (= t ,t))) 74 | (for-each 75 | (lambda (kv) 76 | (say `(assert-soft (= ,(car kv) ,(cdr kv)) :weight 1))) 77 | m) 78 | (for-each 79 | (lambda (other-m) 80 | (say `(assert 81 | ,(cons 'or 82 | (map 83 | (lambda (kv) 84 | `(not (<= 50 (abs (- ,(car kv) ,(cdr kv)))))) 85 | other-m))))) 86 | ms) 87 | (let* ((ok (check-sat)) 88 | (m (if ok (get-model) m))) 89 | (say '(pop)) 90 | (list ok m))) 91 | (define (get-current-models t ms) 92 | (foldr (lambda (m ms) 93 | (match (get-current-model t m ms) 94 | [(list ok m) 95 | (if ok (cons m ms) ms)])) '() ms)) 96 | (define (spur-new-models t n ms) 97 | (if (= n 0) 98 | ms 99 | (match (get-current-model t '() ms) 100 | [(list ok m) 101 | (if ok (spur-new-models t (- n 1) (cons m ms)) ms)]))) 102 | 103 | (constraints say) 104 | (big-bang (cons 0 (spur-new-models 0 10 '())) 105 | (on-tick (lambda (tm) 106 | (let ((t (car tm)) 107 | (ms (cdr tm))) 108 | (cons (+ t 1) (get-current-models t ms))))) 109 | (stop-when (lambda (tm) (null? (cdr tm)))) 110 | (to-draw (lambda (tm) (foldr scene (empty-scene 400 400 "white") (cdr tm))))) 111 | 112 | (close-input-port p-in) 113 | (close-output-port p-out) 114 | (close-input-port p-err)])) 115 | 116 | 117 | (run-world ex2-constraints ex2-scene) 118 | -------------------------------------------------------------------------------- /recordsub.scm: -------------------------------------------------------------------------------- 1 | (define typ 2 | (lambda (ty) 3 | (conde 4 | ((fresh (ty1 ty2) 5 | (== `(arr ,ty1 ,ty2) ty) 6 | (typ ty1) 7 | (typ ty2))) 8 | ((fresh (s env) 9 | (z/set s) 10 | (== `(rcd ,s ,env) ty) 11 | (typ-rcd s env)))))) 12 | 13 | (define typ-rcd 14 | (lambda (s env) 15 | (conde 16 | ((z/assert `(= ,s ,∅))) 17 | ((fresh (l ft sr er) 18 | (z/set sr) 19 | (z/assert `(= ,s ,(set sr l))) 20 | (!ino l sr) 21 | (numbero l) 22 | (== (cons (cons l ft) er) env) 23 | (typ ft) 24 | (typ-rcd sr er)))))) 25 | 26 | '( 27 | (run 10 (q) 28 | (fresh (s env) 29 | (== q (list s env)) 30 | (z/set s) 31 | (typ-rcd s env))) 32 | ) 33 | 34 | (define sub 35 | (lambda (ty1 ty2) 36 | (conde 37 | ((== ty1 ty2)) 38 | ((=/= ty1 ty2) 39 | (conde 40 | ((fresh (tya1 tyb1 tya2 tyb2) 41 | (== `(arr ,tya1 ,tyb1) ty1) 42 | (== `(arr ,tya2 ,tyb2) ty2) 43 | (sub tya2 tya1) 44 | (sub tyb1 tyb2))) 45 | ((fresh (s1 s2 e1 e2) 46 | (z/set s1) 47 | (z/set s2) 48 | (== `(rcd ,s1 ,e1) ty1) 49 | (== `(rcd ,s2 ,e2) ty2) 50 | (sub-rcd s1 e1 s2 e2)))))))) 51 | 52 | (define sub-rcd 53 | (lambda (s1 e1 s2 e2) 54 | (subseto s1 s2) 55 | ;; TODO 56 | )) 57 | 58 | '( 59 | (run 10 (q) 60 | (fresh (ty1 ty2) 61 | (=/= ty1 ty2) 62 | (=/= ty2 `(rcd ,∅ ())) 63 | (== q `(,ty1 ,ty2)) 64 | (sub ty1 ty2))) 65 | ) 66 | 67 | ;; more to do... 68 | -------------------------------------------------------------------------------- /sign-domain.scm: -------------------------------------------------------------------------------- 1 | (define s/declare-bito 2 | (lambda (b) 3 | (z/ `(declare-const ,b Bool)))) 4 | 5 | (define s/declareo 6 | (lambda (s) 7 | (z/ `(declare-const ,s (_ BitVec 3))))) 8 | 9 | (define s/haso 10 | (lambda (p) 11 | (lambda (s b) 12 | (z/assert `(= ,s (ite ,b (bvor ,s ,p) (bvand ,s (bvnot ,p)))))))) 13 | 14 | (define s/hasnto 15 | (lambda (p) 16 | (lambda (s b) 17 | (z/assert `(= ,s (ite ,b (bvand ,s (bvnot ,p)) (bvor ,s ,p))))))) 18 | 19 | (define s/chaso 20 | (lambda (p) 21 | (lambda (s) 22 | (z/assert `(= ,s (bvor ,s ,p)))))) 23 | (define s/chasnto 24 | (lambda (p) 25 | (lambda (s) 26 | (z/assert `(= ,s (bvand ,s (bvnot ,p))))))) 27 | 28 | (define vec-neg 'bitvec-001) 29 | (define s/has-nego (s/haso vec-neg)) 30 | (define s/hasnt-nego (s/hasnto vec-neg)) 31 | (define s/chas-nego (s/chaso vec-neg)) 32 | (define s/chasnt-nego (s/chasnto vec-neg)) 33 | 34 | (define vec-zero 'bitvec-010) 35 | (define s/has-zeroo (s/haso vec-zero)) 36 | (define s/hasnt-zeroo (s/hasnto vec-zero)) 37 | (define s/chas-zeroo (s/chaso vec-zero)) 38 | (define s/chasnt-zeroo (s/chasnto vec-zero)) 39 | 40 | (define vec-pos 'bitvec-100) 41 | (define s/has-poso (s/haso vec-pos)) 42 | (define s/hasnt-poso (s/hasnto vec-pos)) 43 | (define s/chas-poso (s/chaso vec-pos)) 44 | (define s/chasnt-poso (s/chasnto vec-pos)) 45 | 46 | (define vecs (list vec-neg vec-zero vec-pos)) 47 | 48 | (define s/iso 49 | (lambda (p) 50 | (lambda (s) 51 | (z/assert `(= ,s ,p))))) 52 | (define s/is-nego 53 | (s/iso vec-neg)) 54 | (define s/is-zeroo 55 | (s/iso vec-zero)) 56 | (define s/is-poso 57 | (s/iso vec-pos)) 58 | 59 | (define s/uniono 60 | (lambda (s1 s2 so) 61 | (z/assert `(= (bvor ,s1 ,s2) ,so)))) 62 | 63 | (define s/is-bito 64 | (lambda (b) 65 | (conde 66 | ((z/assert `(= ,b ,vec-neg))) 67 | ((z/assert `(= ,b ,vec-zero))) 68 | ((z/assert `(= ,b ,vec-pos)))))) 69 | 70 | (define s/membero 71 | (lambda (s b) 72 | (fresh () 73 | (z/assert `(= (bvand ,s ,b) ,b)) 74 | (s/is-bito b)))) 75 | 76 | (define s/alphao 77 | (lambda (n s) 78 | (fresh () 79 | (conde 80 | ((z/assert `(< ,n 0)) 81 | (s/is-nego s)) 82 | ((z/assert `(= ,n 0)) 83 | (s/is-zeroo s)) 84 | ((z/assert `(> ,n 0)) 85 | (s/is-poso s)))))) 86 | 87 | (define s/z3-alphao 88 | (lambda (n s) 89 | (z/assert `(= ,s (ite (> ,n 0) ,vec-pos (ite (= ,n 0) ,vec-zero ,vec-neg)))))) 90 | 91 | ;; For example, 92 | ;; {−,0}⊕{−}={−} and {−}⊕{+}={−,0,+}. 93 | ;; {−}⊗{+,0}={−,0} and {−,+}⊗{0}={0} 94 | 95 | (define s/plus-alphao 96 | (lambda (s1 s2 so) 97 | (conde 98 | ((s/is-zeroo s1) 99 | (z/assert `(= ,so ,s2))) 100 | ((s/is-zeroo s2) 101 | (z/assert `(= ,so ,s1))) 102 | ((s/is-nego s1) 103 | (s/is-nego s2) 104 | (s/is-nego so)) 105 | ((s/is-poso s1) 106 | (s/is-poso s2) 107 | (s/is-poso so)) 108 | ((s/is-nego s1) 109 | (s/is-poso s2) 110 | (z/assert `(= ,so bitvec-111))) 111 | ((s/is-poso s1) 112 | (s/is-nego s2) 113 | (z/assert `(= ,so bitvec-111)))))) 114 | 115 | (define s/containso 116 | (lambda (s1 s2) 117 | (z/assert `(= (bvor ,s1 ,s2) ,s1)))) 118 | 119 | (define s/pluso 120 | (lambda (s1 s2 so) 121 | (fresh () 122 | (conde ((s/chas-zeroo s1) 123 | (s/containso so s2)) 124 | ((s/chasnt-zeroo s1))) 125 | (conde ((s/chas-zeroo s2) 126 | (s/containso so s1)) 127 | ((s/chasnt-zeroo s2))) 128 | (conde ((s/chas-nego s1) 129 | (s/chas-nego s2) 130 | (s/chas-nego so)) 131 | ((s/chasnt-nego s1)) 132 | ((s/chasnt-nego s2))) 133 | (conde ((s/chas-poso s1) 134 | (s/chas-poso s2) 135 | (s/chas-poso so)) 136 | ((s/chasnt-poso s1)) 137 | ((s/chasnt-poso s2))) 138 | (conde ((s/chas-nego s1) 139 | (s/chas-poso s2) 140 | (z/assert `(= ,so bitvec-111))) 141 | ((s/chasnt-nego s1)) 142 | ((s/chasnt-poso s2))) 143 | (conde ((s/chas-poso s1) 144 | (s/chas-nego s2) 145 | (z/assert `(= ,so bitvec-111))) 146 | ((s/chasnt-poso s1)) 147 | ((s/chasnt-nego s2)))))) 148 | 149 | (define (plus-alpha s1 s2) 150 | (define (from a b) 151 | (and (eq? a s1) (eq? b s2))) 152 | (define (set . xs) 153 | xs) 154 | (cond 155 | [(from '- '-) (set '-)] 156 | [(from '- 0) (set '-)] 157 | [(from '- '+) (set '- '0 '+)] 158 | [(from '0 s2) (set s2)] 159 | [(from '+ '-) (set '- '0 '+)] 160 | [(from '+ 0) (set '+)] 161 | [(from '+ '+) (set '+)])) 162 | 163 | (define (times-alpha s1 s2) 164 | (define (from a b) 165 | (and (eq? a s1) (eq? b s2))) 166 | (define (set . xs) 167 | xs) 168 | (cond 169 | [(from '- '-) (set '+)] 170 | [(from '- '0) (set '0)] 171 | [(from '- '+) (set '-)] 172 | [(from '0 s2) (set '0)] 173 | [(from '+ '-) (set '-)] 174 | [(from '+ 0) (set '0)] 175 | [(from '+ '+) (set '+)])) 176 | 177 | (define (sub1-alpha s1) 178 | (define (from a) 179 | (eq? a s1)) 180 | (define (set . xs) 181 | xs) 182 | (cond 183 | [(from '-) (set '-)] 184 | [(from '0) (set '0)] 185 | [(from '+) (set '0 '+)])) 186 | 187 | (define to-bitvec 188 | (lambda (s) 189 | (string->symbol 190 | (string-append 191 | "bitvec-" 192 | (if (memq '+ s) "1" "0") 193 | (if (memq '0 s) "1" "0") 194 | (if (memq '- s) "1" "0"))))) 195 | 196 | (define flatten 197 | (lambda (xs) 198 | (cond ((null? xs) xs) 199 | ((atom? xs) (list xs)) 200 | (else (append (flatten (car xs)) 201 | (flatten (cdr xs))))))) 202 | 203 | (define op-abstract 204 | (lambda (op) 205 | (lambda (s1 s2) 206 | (to-bitvec 207 | (flatten 208 | (map 209 | (lambda (b1) 210 | (map 211 | (lambda (b2) 212 | (op b1 b2)) 213 | s2)) 214 | s1)))))) 215 | 216 | (define plus-abstract (op-abstract plus-alpha)) 217 | (define times-abstract (op-abstract times-alpha)) 218 | 219 | (define op1-abstract 220 | (lambda (op) 221 | (lambda (s1) 222 | (to-bitvec 223 | (flatten 224 | (map (lambda (b1) (op b1)) s1)))))) 225 | 226 | (define sub1-abstract (op1-abstract sub1-alpha)) 227 | 228 | (define (comb xs) 229 | (if (null? xs) '(()) 230 | (let ((r (comb (cdr xs)))) 231 | (append r (map (lambda (s) (cons (car xs) s)) r))))) 232 | 233 | (define (op-table op) 234 | (let ((r (comb '(- 0 +)))) 235 | (apply 236 | append 237 | (map 238 | (lambda (s1) 239 | (map 240 | (lambda (s2) 241 | (list (to-bitvec s1) (to-bitvec s2) 242 | (op s1 s2))) 243 | r)) 244 | r)))) 245 | 246 | (define (op1-table op) 247 | (let ((r (comb '(- 0 +)))) 248 | (map 249 | (lambda (s1) 250 | (list (to-bitvec s1) 251 | (op s1))) 252 | r))) 253 | 254 | (define s/op-tableo 255 | (lambda (table) 256 | (lambda (s1 s2 so) 257 | (define itero 258 | (lambda (es) 259 | (if (null? es) 260 | fail 261 | (let ((e (car es))) 262 | (conde 263 | ((z/assert `(= ,(car e) ,s1)) 264 | (z/assert `(= ,(cadr e) ,s2)) 265 | (z/assert `(= ,(caddr e) ,so))) 266 | ((z/assert `(or (not (= ,(car e) ,s1)) 267 | (not (= ,(cadr e) ,s2)))) 268 | (itero (cdr es)))))))) 269 | (itero table)))) 270 | 271 | (define s/plus-tableo (s/op-tableo (op-table plus-abstract))) 272 | (define s/times-tableo (s/op-tableo (op-table times-abstract))) 273 | 274 | (define s/z3-op-tableo 275 | (lambda (table) 276 | (lambda (s1 s2 so) 277 | (define iter 278 | (lambda (es) 279 | (let ((e (car es))) 280 | (if (null? (cdr es)) 281 | (caddr e) 282 | `(ite (and (= ,(car e) ,s1) 283 | (= ,(cadr e) ,s2)) 284 | ,(caddr e) 285 | ,(iter (cdr es))))))) 286 | (z/assert `(= ,so ,(iter table)))))) 287 | 288 | (define s/z3-plus-tableo (s/z3-op-tableo (op-table plus-abstract))) 289 | (define s/z3-times-tableo (s/z3-op-tableo (op-table times-abstract))) 290 | 291 | (define s/z3-op1-tableo 292 | (lambda (table) 293 | (lambda (s1 so) 294 | (define iter 295 | (lambda (es) 296 | (let ((e (car es))) 297 | (if (null? (cdr es)) 298 | (cadr e) 299 | `(ite (= ,(car e) ,s1) 300 | ,(cadr e) 301 | ,(iter (cdr es))))))) 302 | (z/assert `(= ,so ,(iter table)))))) 303 | 304 | (define s/z3-sub1-tableo (s/z3-op1-tableo (op1-table sub1-abstract))) 305 | -------------------------------------------------------------------------------- /simple-interp.scm: -------------------------------------------------------------------------------- 1 | (define evalo 2 | (lambda (expr val) 3 | (eval-expro expr '() val))) 4 | 5 | (define eval-expro 6 | (lambda (expr env val) 7 | (conde 8 | ((fresh (rator rand x body env^ a) 9 | (== `(,rator ,rand) expr) 10 | (eval-expro rator env `(closure ,x ,body ,env^)) 11 | (eval-expro rand env a) 12 | (eval-expro body `((,x . ,a) . ,env^) val))) 13 | ((fresh (x body) 14 | (== `(lambda (,x) ,body) expr) 15 | (symbolo x) 16 | (== `(closure ,x ,body ,env) val) 17 | (not-in-envo 'lambda env))) 18 | ((symbolo expr) (lookupo expr env val))))) 19 | 20 | (define not-in-envo 21 | (lambda (x env) 22 | (conde 23 | ((== '() env)) 24 | ((fresh (y v rest) 25 | (== `((,y . ,v) . ,rest) env) 26 | (=/= y x) 27 | (not-in-envo x rest)))))) 28 | 29 | (define lookupo 30 | (lambda (x env t) 31 | (conde 32 | ((fresh (y v rest) 33 | (== `((,y . ,v) . ,rest) env) (== y x) 34 | (== v t))) 35 | ((fresh (y v rest) 36 | (== `((,y . ,v) . ,rest) env) (=/= y x) 37 | (lookupo x rest t)))))) 38 | -------------------------------------------------------------------------------- /soft.smt: -------------------------------------------------------------------------------- 1 | (declare-const x Int) 2 | (declare-const y Int) 3 | (declare-const z Int) 4 | (assert (= (+ x y z) 100)) 5 | (check-sat) 6 | (get-model) 7 | (assert (= x 75)) 8 | (assert-soft (= y 25) :weight 2) 9 | (assert-soft (= z 25) :weight 1) 10 | (check-sat) 11 | (get-model) 12 | -------------------------------------------------------------------------------- /sudoku.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/system) 4 | 5 | (define rows 6 | (for/list ([i (in-range 1 10)]) 7 | (for/list ([j (in-range 1 10)]) 8 | (cons i j)))) 9 | (define cols 10 | (for/list ([i (in-range 1 10)]) 11 | (for/list ([j (in-range 1 10)]) 12 | (cons j i)))) 13 | (define squares 14 | (for*/list ([m (in-range 3)] [n (in-range 3)]) 15 | (for*/list ([i (in-range 3)] [j (in-range 3)]) 16 | (cons (+ i (* n 3) 1) (+ j (* m 3) 1))))) 17 | 18 | (define (name ij) 19 | (let ((i (car ij)) (j (cdr ij))) 20 | (string->symbol (string-append "x" (string-append (number->string i) (number->string j)))))) 21 | (define (model-assoc m) 22 | (map (lambda (x) (match x [(list _ lhs _ _ rhs) (cons lhs rhs)])) (cdr m))) 23 | (define (model-get m ij) (cdr (assoc (name ij) m))) 24 | (define (model->puzzle m) 25 | (for/vector ([i (in-range 1 10)]) 26 | (for/vector ([j (in-range 1 10)]) 27 | (model-get m (cons i j))))) 28 | (define (print-puzzle puzzle) 29 | (printf "~a\n" "'#(") 30 | (for ([line puzzle]) 31 | (printf " ~a\n" line)) 32 | (printf " ~a\n" ")")) 33 | (define (puzzle-index puzzle i j) 34 | (vector-ref (vector-ref puzzle (- i 1)) (- j 1))) 35 | 36 | (define puzzle 37 | '#( 38 | #(4 0 0 0 0 0 8 0 5) 39 | #(0 3 0 0 0 0 0 0 0) 40 | #(0 0 0 7 0 0 0 0 0) 41 | #(0 2 0 0 0 0 0 6 0) 42 | #(0 0 0 0 8 0 4 0 0) 43 | #(0 0 0 0 1 0 0 0 0) 44 | #(0 0 0 6 0 3 0 7 0) 45 | #(5 0 0 2 0 0 0 0 0) 46 | #(1 0 4 0 0 0 0 0 0) 47 | )) 48 | 49 | (define (say msg) 50 | (printf "~a\n" msg)) 51 | 52 | (define (board-constraints say) 53 | (for ([i (in-range 1 10)]) 54 | (for ([j (in-range 1 10)]) 55 | (let ((x (name (cons i j)))) 56 | (say `(declare-const ,x Int)) 57 | (say `(assert (<= 1 ,x))) 58 | (say `(assert (<= ,x 9)))))) 59 | (for ([c (list rows cols squares)]) 60 | (for ([r c]) 61 | (say `(assert (distinct . ,(map name r))))))) 62 | 63 | (define (puzzle-constraints puzzle say) 64 | (for ([i (in-range 1 10)]) 65 | (for ([j (in-range 1 10)]) 66 | (let ((r (puzzle-index puzzle i j))) 67 | (when (not (= r 0)) 68 | (let ((x (name (cons i j)))) 69 | (say `(assert (= ,x ,r))))))))) 70 | 71 | (define (uniqueness-constraints puzzle solution say) 72 | (say 73 | `(assert (or . 74 | ,(for*/list ([i (in-range 1 10)] [j (in-range 1 10)] 75 | #:when (= 0 (puzzle-index puzzle i j))) 76 | (let ((x (name (cons i j)))) 77 | `(not (= ,x ,(puzzle-index solution i j))))))))) 78 | 79 | (define (solve-sudoku puzzle) 80 | (match (process "z3 -in") 81 | [(list p-in p-out _ p-err p-fun) 82 | (define (say msg) 83 | ;(printf "~a\n" msg) 84 | (fprintf p-out "~a\n" msg)) 85 | (define (check-sat) 86 | (say '(check-sat)) 87 | (flush-output p-out) 88 | (let ((r (read p-in))) 89 | (println r) 90 | (eq? r 'sat))) 91 | (define (get-model) 92 | (say '(get-model)) 93 | (flush-output p-out) 94 | (model-assoc (read p-in))) 95 | 96 | (board-constraints say) 97 | (puzzle-constraints puzzle say) 98 | (if (check-sat) 99 | (let ((solution (model->puzzle (get-model)))) 100 | (print-puzzle solution) 101 | 102 | (uniqueness-constraints puzzle solution say) 103 | 104 | (if (check-sat) 105 | (printf "~a\n" ";; solution is not unique!") 106 | (printf "~a\n" ";; solution is unique :)")) 107 | ) 108 | (printf "~a\n" ";; no solution :(")) 109 | 110 | (close-input-port p-in) 111 | (close-output-port p-out) 112 | (close-input-port p-err)])) 113 | 114 | (solve-sudoku puzzle) 115 | 116 | -------------------------------------------------------------------------------- /symbolic-execution-tests.scm: -------------------------------------------------------------------------------- 1 | ;(load "mk.scm") 2 | ;(load "z3-driver.scm") 3 | ;(load "test-check.scm") 4 | (load "../clpsmt-miniKanren/full-interp.scm") 5 | 6 | (test "symbolic-execution-1a" 7 | (run 10 (q) 8 | (evalo 9 | `((lambda (n) 10 | (if (= 137 n) 11 | 'foo 12 | 'bar)) 13 | ,q) 14 | 'foo)) 15 | '(137 16 | '137 17 | (((lambda _.0 137)) (sym _.0)) 18 | (((lambda _.0 137) _.1) (num _.1) (sym _.0)) 19 | (((lambda _.0 137) _.1 _.2) (num _.1 _.2) (sym _.0)) 20 | (((lambda _.0 137) _.1 _.2 _.3) (num _.1 _.2 _.3) (sym _.0)) 21 | (((lambda _.0 137) list) (sym _.0)) 22 | (((lambda _.0 137) list _.1) (num _.1) (sym _.0)) 23 | ((match _.0 (_.0 137) . _.1) (num _.0)) 24 | (((lambda _.0 137) _.1 _.2 _.3 _.4) (num _.1 _.2 _.3 _.4) (sym _.0)))) 25 | 26 | (test "symbolic-execution-1b" 27 | (run* (q) 28 | (evalo 29 | `((lambda (n) 30 | (if (= 137 n) 31 | 'foo 32 | 'bar)) 33 | ',q) 34 | 'foo)) 35 | '(137)) 36 | 37 | (test "symbolic-execution-2a" 38 | (run 10 (q) 39 | (evalo 40 | `((lambda (n) 41 | (if (= 137 n) 42 | 'foo 43 | 'bar)) 44 | ,q) 45 | 'bar)) 46 | '(138 139 140 141 142 143 144 145 146 147)) 47 | 48 | (test "symbolic-execution-2b" 49 | (run 10 (q) 50 | (fresh (a d) 51 | (== `(,a . ,d) q)) 52 | (evalo 53 | `((lambda (n) 54 | (if (= 137 n) 55 | 'foo 56 | 'bar)) 57 | ,q) 58 | 'bar)) 59 | '('138 '139 '140 '141 '142 '143 '144 '145 '146 '147)) 60 | 61 | (test "symbolic-execution-2c" 62 | (run 10 (q) 63 | (evalo 64 | `((lambda (n) 65 | (if (= 137 n) 66 | 'foo 67 | 'bar)) 68 | ',q) 69 | 'bar)) 70 | '(138 139 140 141 142 143 144 145 146 147)) 71 | 72 | (test "symbolic-execution-3a" 73 | (run* (q) 74 | (evalo 75 | `((lambda (n) 76 | (if (= (+ (* n 3) 5) 14359371734) 77 | 'foo 78 | 'bar)) 79 | ',q) 80 | 'foo)) 81 | '(4786457243)) 82 | 83 | (test "symbolic-execution-4a" 84 | (run* (q) 85 | (evalo 86 | `((lambda (n) 87 | (if (= (+ (* n 17) 5) 81369773136) 88 | 'foo 89 | 'bar)) 90 | ',q) 91 | 'foo)) 92 | '(4786457243)) 93 | 94 | (test "symbolic-execution-5a" 95 | (run* (q) 96 | (evalo 97 | `((lambda (n) 98 | (if (= (+ (* n 17) 5) 127142397731434) 99 | 'foo 100 | 'bar)) 101 | ',q) 102 | 'foo)) 103 | '(7478964572437)) 104 | 105 | 106 | 107 | 108 | (load "while-abort.scm") 109 | 110 | ;;; The following example is adapted from: 111 | ;;; 112 | ;;; https://github.com/webyrd/polyconf-2015/blob/master/talk-code/while-interpreter/while-abort-tests.scm 113 | 114 | ;;; symbolic execution example from slide 7 of Stephen Chong's slides 115 | ;;; on symbolic execution (contains contents from Jeff Foster's 116 | ;;; slides) 117 | ;;; 118 | ;;; http://www.seas.harvard.edu/courses/cs252/2011sp/slides/Lec13-SymExec.pdf 119 | 120 | ;;; 1. int a = α, b = β, c = γ 121 | ;;; 2. // symbolic 122 | ;;; 3. int x = 0, y = 0, z = 0; 123 | ;;; 4. if (a) { 124 | ;;; 5. x = -2; 125 | ;;; 6. } 126 | ;;; 7. if (b < 5) { 127 | ;;; 8. if (!a && c) { y = 1; } 128 | ;;; 9. z = 2; 129 | ;;; 10. } 130 | ;;; 11. assert(x+y+z!=3) 131 | 132 | ;;; we will model the 'assert' using 'if' and 'abort' 133 | 134 | ;;; Slightly modified version that we are actually modelling: 135 | 136 | ;;; 1. int a := α, b := β, c := γ 137 | ;;; 4. if (a != 0) { 138 | ;;; 5. x := -2; 139 | ;;; 6. } 140 | ;;; 7. if (b < 5) { 141 | ;;; 8. if ((a = 0) && (c != 0)) { y := 1; } 142 | ;;; 9. z := 2; 143 | ;;; 10. } 144 | ;;; 11. if (x+(y+z) != 3) { 145 | ;;; abort 146 | ;;; } 147 | 148 | 149 | (define symbolic-exec-prog 150 | `(seq 151 | (if (!= a 0) 152 | (:= x -2) 153 | (skip)) 154 | (seq 155 | (if (< b 5) 156 | (seq 157 | (if (and (= a 0) (!= c 0)) 158 | (:= y 1) 159 | (skip)) 160 | (:= z 2)) 161 | (skip)) 162 | (if (!= (+ x (+ y z)) 3) 163 | (skip) 164 | (abort))))) 165 | 166 | (test "symbolic-exec-prog-a" 167 | (run 8 (q) 168 | (fresh (alpha beta gamma s) 169 | (== (list alpha beta gamma s) q) 170 | (->o 171 | `(,symbolic-exec-prog 172 | ((a . ,alpha) 173 | (b . ,beta) 174 | (c . ,gamma))) 175 | `(abort ,s)))) 176 | '((0 4 1 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 1))) 177 | (0 0 -1 ((z . 2) (y . 1) (a . 0) (b . 0) (c . -1))) 178 | (0 -1 -2 ((z . 2) (y . 1) (a . 0) (b . -1) (c . -2))) 179 | (0 -2 -3 ((z . 2) (y . 1) (a . 0) (b . -2) (c . -3))) 180 | (0 -3 -4 ((z . 2) (y . 1) (a . 0) (b . -3) (c . -4))) 181 | (0 -4 -5 ((z . 2) (y . 1) (a . 0) (b . -4) (c . -5))) 182 | (0 -5 -6 ((z . 2) (y . 1) (a . 0) (b . -5) (c . -6))) 183 | (0 -6 -7 ((z . 2) (y . 1) (a . 0) (b . -6) (c . -7))))) 184 | 185 | (test "symbolic-exec-prog-b" 186 | (run 8 (q) 187 | (fresh (alpha beta gamma s) 188 | (== (list alpha beta gamma s) q) 189 | (z/assert `(<= 0 ,alpha)) 190 | (z/assert `(<= 0 ,beta)) 191 | (z/assert `(<= 0 ,gamma)) 192 | (->o 193 | `(,symbolic-exec-prog 194 | ((a . ,alpha) 195 | (b . ,beta) 196 | (c . ,gamma))) 197 | `(abort ,s)))) 198 | '((0 0 1 ((z . 2) (y . 1) (a . 0) (b . 0) (c . 1))) 199 | (0 1 2 ((z . 2) (y . 1) (a . 0) (b . 1) (c . 2))) 200 | (0 2 3 ((z . 2) (y . 1) (a . 0) (b . 2) (c . 3))) 201 | (0 3 4 ((z . 2) (y . 1) (a . 0) (b . 3) (c . 4))) 202 | (0 4 5 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 5))) 203 | (0 4 6 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 6))) 204 | (0 4 7 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 7))) 205 | (0 4 8 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 8))))) 206 | 207 | (test "symbolic-exec-prog-c" 208 | (run 1 (q) 209 | (fresh (alpha beta gamma s) 210 | (== (list alpha beta gamma s) q) 211 | (z/assert `(not (= 0 ,alpha))) 212 | (z/assert `(<= 0 ,beta)) 213 | (z/assert `(<= 0 ,gamma)) 214 | (->o 215 | `(,symbolic-exec-prog 216 | ((a . ,alpha) 217 | (b . ,beta) 218 | (c . ,gamma))) 219 | `(abort ,s)))) 220 | '()) 221 | 222 | (test "symbolic-exec-prog-d" 223 | (run 1 (q) 224 | (fresh (alpha beta gamma s) 225 | (== (list alpha beta gamma s) q) 226 | (z/assert `(not (= 0 ,alpha))) 227 | (->o 228 | `(,symbolic-exec-prog 229 | ((a . ,alpha) 230 | (b . ,beta) 231 | (c . ,gamma))) 232 | `(abort ,s)))) 233 | '()) 234 | 235 | (test "symbolic-exec-prog-e" 236 | (run 8 (q) 237 | (fresh (alpha beta gamma s) 238 | (== (list alpha beta gamma s) q) 239 | (z/assert `(not (= 0 ,beta))) 240 | (->o 241 | `(,symbolic-exec-prog 242 | ((a . ,alpha) 243 | (b . ,beta) 244 | (c . ,gamma))) 245 | `(abort ,s)))) 246 | '((0 1 1 ((z . 2) (y . 1) (a . 0) (b . 1) (c . 1))) 247 | (0 -1 -1 ((z . 2) (y . 1) (a . 0) (b . -1) (c . -1))) 248 | (0 -2 -2 ((z . 2) (y . 1) (a . 0) (b . -2) (c . -2))) 249 | (0 -3 -3 ((z . 2) (y . 1) (a . 0) (b . -3) (c . -3))) 250 | (0 -4 -4 ((z . 2) (y . 1) (a . 0) (b . -4) (c . -4))) 251 | (0 -5 -5 ((z . 2) (y . 1) (a . 0) (b . -5) (c . -5))) 252 | (0 -6 -6 ((z . 2) (y . 1) (a . 0) (b . -6) (c . -6))) 253 | (0 2 -7 ((z . 2) (y . 1) (a . 0) (b . 2) (c . -7))))) 254 | -------------------------------------------------------------------------------- /symbolo-numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-numbero-1" 2 | (run* (q) (symbolo q) (numbero q)) 3 | '()) 4 | 5 | (test "symbolo-numbero-2" 6 | (run* (q) (numbero q) (symbolo q)) 7 | '()) 8 | 9 | (test "symbolo-numbero-3" 10 | (run* (q) 11 | (fresh (x) 12 | (numbero x) 13 | (symbolo x))) 14 | '()) 15 | 16 | (test "symbolo-numbero-4" 17 | (run* (q) 18 | (fresh (x) 19 | (symbolo x) 20 | (numbero x))) 21 | '()) 22 | 23 | (test "symbolo-numbero-5" 24 | (run* (q) 25 | (numbero q) 26 | (fresh (x) 27 | (symbolo x) 28 | (== x q))) 29 | '()) 30 | 31 | (test "symbolo-numbero-6" 32 | (run* (q) 33 | (symbolo q) 34 | (fresh (x) 35 | (numbero x) 36 | (== x q))) 37 | '()) 38 | 39 | (test "symbolo-numbero-7" 40 | (run* (q) 41 | (fresh (x) 42 | (numbero x) 43 | (== x q)) 44 | (symbolo q)) 45 | '()) 46 | 47 | (test "symbolo-numbero-7" 48 | (run* (q) 49 | (fresh (x) 50 | (symbolo x) 51 | (== x q)) 52 | (numbero q)) 53 | '()) 54 | 55 | (test "symbolo-numbero-8" 56 | (run* (q) 57 | (fresh (x) 58 | (== x q) 59 | (symbolo x)) 60 | (numbero q)) 61 | '()) 62 | 63 | (test "symbolo-numbero-9" 64 | (run* (q) 65 | (fresh (x) 66 | (== x q) 67 | (numbero x)) 68 | (symbolo q)) 69 | '()) 70 | 71 | (test "symbolo-numbero-10" 72 | (run* (q) 73 | (symbolo q) 74 | (fresh (x) 75 | (numbero x))) 76 | '((_.0 (sym _.0)))) 77 | 78 | (test "symbolo-numbero-11" 79 | (run* (q) 80 | (numbero q) 81 | (fresh (x) 82 | (symbolo x))) 83 | '((_.0 (num _.0)))) 84 | 85 | (test "symbolo-numbero-12" 86 | (run* (q) 87 | (fresh (x y) 88 | (symbolo x) 89 | (== `(,x ,y) q))) 90 | '(((_.0 _.1) (sym _.0)))) 91 | 92 | (test "symbolo-numbero-13" 93 | (run* (q) 94 | (fresh (x y) 95 | (numbero x) 96 | (== `(,x ,y) q))) 97 | '(((_.0 _.1) (num _.0)))) 98 | 99 | (test "symbolo-numbero-14" 100 | (run* (q) 101 | (fresh (x y) 102 | (numbero x) 103 | (symbolo y) 104 | (== `(,x ,y) q))) 105 | '(((_.0 _.1) (num _.0) (sym _.1)))) 106 | 107 | (test "symbolo-numbero-15" 108 | (run* (q) 109 | (fresh (x y) 110 | (numbero x) 111 | (== `(,x ,y) q) 112 | (symbolo y))) 113 | '(((_.0 _.1) (num _.0) (sym _.1)))) 114 | 115 | (test "symbolo-numbero-16" 116 | (run* (q) 117 | (fresh (x y) 118 | (== `(,x ,y) q) 119 | (numbero x) 120 | (symbolo y))) 121 | '(((_.0 _.1) (num _.0) (sym _.1)))) 122 | 123 | (test "symbolo-numbero-17" 124 | (run* (q) 125 | (fresh (x y) 126 | (== `(,x ,y) q) 127 | (numbero x) 128 | (symbolo y)) 129 | (fresh (w z) 130 | (== `(,w ,z) q))) 131 | '(((_.0 _.1) (num _.0) (sym _.1)))) 132 | 133 | (test "symbolo-numbero-18" 134 | (run* (q) 135 | (fresh (x y) 136 | (== `(,x ,y) q) 137 | (numbero x) 138 | (symbolo y)) 139 | (fresh (w z) 140 | (== `(,w ,z) q) 141 | (== w 5))) 142 | '(((5 _.0) (sym _.0)))) 143 | 144 | (test "symbolo-numbero-19" 145 | (run* (q) 146 | (fresh (x y) 147 | (== `(,x ,y) q) 148 | (numbero x) 149 | (symbolo y)) 150 | (fresh (w z) 151 | (== 'a z) 152 | (== `(,w ,z) q))) 153 | '(((_.0 a) (num _.0)))) 154 | 155 | (test "symbolo-numbero-20" 156 | (run* (q) 157 | (fresh (x y) 158 | (== `(,x ,y) q) 159 | (numbero x) 160 | (symbolo y)) 161 | (fresh (w z) 162 | (== `(,w ,z) q) 163 | (== 'a z))) 164 | '(((_.0 a) (num _.0)))) 165 | 166 | (test "symbolo-numbero-21" 167 | (run* (q) 168 | (fresh (x y) 169 | (== `(,x ,y) q) 170 | (=/= `(5 a) q))) 171 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 a)))))) 172 | 173 | (test "symbolo-numbero-22" 174 | (run* (q) 175 | (fresh (x y) 176 | (== `(,x ,y) q) 177 | (=/= `(5 a) q) 178 | (symbolo x))) 179 | '(((_.0 _.1) (sym _.0)))) 180 | 181 | (test "symbolo-numbero-23" 182 | (run* (q) 183 | (fresh (x y) 184 | (== `(,x ,y) q) 185 | (symbolo x) 186 | (=/= `(5 a) q))) 187 | '(((_.0 _.1) (sym _.0)))) 188 | 189 | (test "symbolo-numbero-24" 190 | (run* (q) 191 | (fresh (x y) 192 | (symbolo x) 193 | (== `(,x ,y) q) 194 | (=/= `(5 a) q))) 195 | '(((_.0 _.1) (sym _.0)))) 196 | 197 | (test "symbolo-numbero-25" 198 | (run* (q) 199 | (fresh (x y) 200 | (=/= `(5 a) q) 201 | (symbolo x) 202 | (== `(,x ,y) q))) 203 | '(((_.0 _.1) (sym _.0)))) 204 | 205 | (test "symbolo-numbero-26" 206 | (run* (q) 207 | (fresh (x y) 208 | (=/= `(5 a) q) 209 | (== `(,x ,y) q) 210 | (symbolo x))) 211 | '(((_.0 _.1) (sym _.0)))) 212 | 213 | (test "symbolo-numbero-27" 214 | (run* (q) 215 | (fresh (x y) 216 | (== `(,x ,y) q) 217 | (=/= `(5 a) q) 218 | (numbero y))) 219 | '(((_.0 _.1) (num _.1)))) 220 | 221 | (test "symbolo-numbero-28" 222 | (run* (q) 223 | (fresh (x y) 224 | (== `(,x ,y) q) 225 | (numbero y) 226 | (=/= `(5 a) q))) 227 | '(((_.0 _.1) (num _.1)))) 228 | 229 | (test "symbolo-numbero-29" 230 | (run* (q) 231 | (fresh (x y) 232 | (numbero y) 233 | (== `(,x ,y) q) 234 | (=/= `(5 a) q))) 235 | '(((_.0 _.1) (num _.1)))) 236 | 237 | (test "symbolo-numbero-30" 238 | (run* (q) 239 | (fresh (x y) 240 | (=/= `(5 a) q) 241 | (numbero y) 242 | (== `(,x ,y) q))) 243 | '(((_.0 _.1) (num _.1)))) 244 | 245 | (test "symbolo-numbero-31" 246 | (run* (q) 247 | (fresh (x y) 248 | (=/= `(5 a) q) 249 | (== `(,x ,y) q) 250 | (numbero y))) 251 | '(((_.0 _.1) (num _.1)))) 252 | 253 | (test "symbolo-numbero-32" 254 | (run* (q) 255 | (fresh (x y) 256 | (=/= `(,x ,y) q) 257 | (numbero x) 258 | (symbolo y))) 259 | '(_.0)) 260 | 261 | (test "symbolo-numbero-33" 262 | (run* (q) 263 | (fresh (x y) 264 | (numbero x) 265 | (=/= `(,x ,y) q) 266 | (symbolo y))) 267 | '(_.0)) 268 | 269 | (test "symbolo-numbero-34" 270 | (run* (q) 271 | (fresh (x y) 272 | (numbero x) 273 | (symbolo y) 274 | (=/= `(,x ,y) q))) 275 | '(_.0)) 276 | -------------------------------------------------------------------------------- /symbolo-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-1" 2 | (run* (q) (symbolo q)) 3 | '((_.0 (sym _.0)))) 4 | 5 | (test "symbolo-2" 6 | (run* (q) (symbolo q) (== 'x q)) 7 | '(x)) 8 | 9 | (test "symbolo-3" 10 | (run* (q) (== 'x q) (symbolo q)) 11 | '(x)) 12 | 13 | (test "symbolo-4" 14 | (run* (q) (== 5 q) (symbolo q)) 15 | '()) 16 | 17 | (test "symbolo-5" 18 | (run* (q) (symbolo q) (== 5 q)) 19 | '()) 20 | 21 | (test "symbolo-6" 22 | (run* (q) (symbolo q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "symbolo-7" 26 | (run* (q) (== `(1 . 2) q) (symbolo q)) 27 | '()) 28 | 29 | (test "symbolo-8" 30 | (run* (q) (fresh (x) (symbolo x))) 31 | '(_.0)) 32 | 33 | (test "symbolo-9" 34 | (run* (q) (fresh (x) (symbolo x))) 35 | '(_.0)) 36 | 37 | (test "symbolo-10" 38 | (run* (q) (fresh (x) (symbolo x) (== x q))) 39 | '((_.0 (sym _.0)))) 40 | 41 | (test "symbolo-11" 42 | (run* (q) (fresh (x) (symbolo q) (== x q) (symbolo x))) 43 | '((_.0 (sym _.0)))) 44 | 45 | (test "symbolo-12" 46 | (run* (q) (fresh (x) (symbolo q) (symbolo x) (== x q))) 47 | '((_.0 (sym _.0)))) 48 | 49 | (test "symbolo-13" 50 | (run* (q) (fresh (x) (== x q) (symbolo q) (symbolo x))) 51 | '((_.0 (sym _.0)))) 52 | 53 | (test "symbolo-14-a" 54 | (run* (q) (fresh (x) (symbolo q) (== 'y x))) 55 | '((_.0 (sym _.0)))) 56 | 57 | (test "symbolo-14-b" 58 | (run* (q) (fresh (x) (symbolo q) (== 'y x) (== x q))) 59 | '(y)) 60 | 61 | (test "symbolo-15" 62 | (run* (q) (fresh (x) (== q x) (symbolo q) (== 5 x))) 63 | '()) 64 | 65 | (test "symbolo-16-a" 66 | (run* (q) (symbolo q) (=/= 5 q)) 67 | '((_.0 (sym _.0)))) 68 | 69 | (test "symbolo-16-b" 70 | (run* (q) (=/= 5 q) (symbolo q)) 71 | '((_.0 (sym _.0)))) 72 | 73 | (test "symbolo-17" 74 | (run* (q) (symbolo q) (=/= `(1 . 2) q)) 75 | '((_.0 (sym _.0)))) 76 | 77 | (test "symbolo-18" 78 | (run* (q) (symbolo q) (=/= 'y q)) 79 | '((_.0 (=/= ((_.0 y))) (sym _.0)))) 80 | 81 | (test "symbolo-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (symbolo x) 85 | (symbolo y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (sym _.0 _.1)))) 88 | 89 | (test "symbolo-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (symbolo x) 94 | (symbolo y))) 95 | '(((_.0 _.1) (sym _.0 _.1)))) 96 | 97 | (test "symbolo-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (symbolo x) 102 | (symbolo x))) 103 | '(((_.0 _.1) (sym _.0)))) 104 | 105 | (test "symbolo-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (symbolo x) 109 | (symbolo x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (sym _.0)))) 112 | 113 | (test "symbolo-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (symbolo x) 117 | (== `(,x ,y) q) 118 | (symbolo x))) 119 | '(((_.0 _.1) (sym _.0)))) 120 | 121 | (test "symbolo-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (symbolo w) 126 | (symbolo z))) 127 | '(_.0)) 128 | 129 | (test "symbolo-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (symbolo w) 134 | (symbolo z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (sym _.0 _.3)))) 139 | 140 | (test "symbolo-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (symbolo w) 145 | (symbolo y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (sym _.0 _.2)))) 150 | 151 | (test "symbolo-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (symbolo w) 156 | (symbolo y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (sym _.0)))) 162 | 163 | (test "symbolo-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(5 . 6)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 6)))))) 169 | 170 | (test "symbolo-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(5 . 6)) 174 | (symbolo w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (sym _.0)))) 177 | 178 | (test "symbolo-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (symbolo w) 182 | (=/= `(,w . ,x) `(5 . 6)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (sym _.0)))) 185 | 186 | (test "symbolo-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (symbolo w) 190 | (=/= `(5 . 6) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (sym _.0)))) 193 | 194 | (test "symbolo-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (symbolo w) 198 | (=/= `(5 . ,x) `(,w . 6)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (sym _.0)))) 201 | 202 | (test "symbolo-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (symbolo w) 206 | (=/= `(z . ,x) `(,w . 6)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 z) (_.1 6))) (sym _.0)))) 209 | 210 | (test "symbolo-31-a" 211 | (run* (q) 212 | (fresh (w x y z) 213 | (== x 5) 214 | (=/= `(,w ,y) `(,x ,z)) 215 | (== w 5) 216 | (== `(,w ,x ,y ,z) q))) 217 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 218 | 219 | (test "symbolo-31-b" 220 | (run* (q) 221 | (fresh (w x y z) 222 | (=/= `(,w ,y) `(,x ,z)) 223 | (== w 5) 224 | (== x 5) 225 | (== `(,w ,x ,y ,z) q))) 226 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 227 | 228 | (test "symbolo-31-c" 229 | (run* (q) 230 | (fresh (w x y z) 231 | (== w 5) 232 | (=/= `(,w ,y) `(,x ,z)) 233 | (== `(,w ,x ,y ,z) q) 234 | (== x 5))) 235 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 236 | 237 | (test "symbolo-31-d" 238 | (run* (q) 239 | (fresh (w x y z) 240 | (== w 5) 241 | (== x 5) 242 | (=/= `(,w ,y) `(,x ,z)) 243 | (== `(,w ,x ,y ,z) q))) 244 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 245 | 246 | 247 | (test "symbolo-32-a" 248 | (run* (q) 249 | (fresh (w x y z) 250 | (== x 'a) 251 | (=/= `(,w ,y) `(,x ,z)) 252 | (== w 'a) 253 | (== `(,w ,x ,y ,z) q))) 254 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 255 | 256 | (test "symbolo-32-b" 257 | (run* (q) 258 | (fresh (w x y z) 259 | (=/= `(,w ,y) `(,x ,z)) 260 | (== w 'a) 261 | (== x 'a) 262 | (== `(,w ,x ,y ,z) q))) 263 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 264 | 265 | (test "symbolo-32-c" 266 | (run* (q) 267 | (fresh (w x y z) 268 | (== w 'a) 269 | (=/= `(,w ,y) `(,x ,z)) 270 | (== `(,w ,x ,y ,z) q) 271 | (== x 'a))) 272 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 273 | 274 | (test "symbolo-32-d" 275 | (run* (q) 276 | (fresh (w x y z) 277 | (== w 'a) 278 | (== x 'a) 279 | (=/= `(,w ,y) `(,x ,z)) 280 | (== `(,w ,x ,y ,z) q))) 281 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 282 | -------------------------------------------------------------------------------- /synthesis.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "cvc4-driver.scm") 3 | (load "test-check.scm") 4 | 5 | ;; following https://barghouthi.github.io/2017/04/24/synthesis-primer/ 6 | 7 | (define (synthesize q exs) 8 | (fresh (a b) 9 | (let ((shape `(+ (* ,a x) ,b))) 10 | (fresh () 11 | (z/ `(declare-const ,a Int)) 12 | (z/ `(declare-const ,b Int)) 13 | (z/ `(assert (forall ((x Int) (y Int)) 14 | (=> (or ,@(map (lambda (ex) 15 | `(and (= x ,(car ex)) 16 | (= y ,(cdr ex)))) 17 | exs)) 18 | (= y ,shape))))) 19 | z/purge 20 | (fresh (ax axb) 21 | (conde ((== a 1) (== ax 'x)) 22 | ((== a 0) (== ax 0)) 23 | ((=/= a 1) (=/= a 0) (== ax `(* ,a x)))) 24 | (conde ((== ax 0) (== axb b)) 25 | ((=/= ax 0) (== b 0) (== axb ax)) 26 | ((=/= ax 0) (=/= b 0) (== axb `(+ ,ax ,b)))) 27 | (== q `(lambda (x) ,axb))))))) 28 | 29 | 30 | (test "syn-inc" 31 | (run* (q) (synthesize q '((1 . 2) (2 . 3)))) 32 | '((lambda (x) (+ x 1)))) 33 | 34 | (test "syn-double" 35 | (run* (q) (synthesize q '((1 . 2) (2 . 4)))) 36 | '((lambda (x) (* 2 x)))) 37 | 38 | (test "syn-const" 39 | (run* (q) (synthesize q '((1 . 2) (2 . 2)))) 40 | '((lambda (x) 2))) 41 | 42 | (test "syn-lin" 43 | (run* (q) (synthesize q '((1 . 3) (2 . 5)))) 44 | '((lambda (x) (+ (* 2 x) 1)))) 45 | 46 | (test "syn-no" 47 | (run* (q) (synthesize q '((2 . 3) (3 . 2) (4 . 3)))) 48 | '()) 49 | -------------------------------------------------------------------------------- /tabling-tests.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "tabling.scm") 3 | (load "z3-driver.scm") 4 | (load "test-check.scm") 5 | 6 | ;; some tests inspired by 7 | ;; https://github.com/webyrd/tabling 8 | 9 | (test "path-tabled" 10 | (letrec ((arc (lambda (x y) 11 | (conde 12 | ((== x 'a) (== y 'b)) 13 | ((== x 'b) (== y 'a)) 14 | ((== x 'b) (== y 'd))))) 15 | (path (tabled (x y) 16 | (conde 17 | ((arc x y)) 18 | ((fresh (z) 19 | (arc x z) 20 | (path z y))))))) 21 | (run* (q) 22 | (path 'a q))) 23 | '(b a d)) 24 | 25 | 26 | (test "facto-7" 27 | (letrec ((facto (tabled (n out) 28 | (conde 29 | ((z/assert `(= ,n 0)) 30 | (z/assert `(= ,out 1))) 31 | ((z/assert `(not (= ,n 0))) 32 | (fresh (n-1 r) 33 | (z/assert `(= (- ,n 1) ,n-1)) 34 | (z/assert `(= (* ,n ,r) ,out)) 35 | (facto n-1 r))))))) 36 | (run 7 (q) 37 | (fresh (n out) 38 | (facto n out) 39 | (== q `(,n ,out))))) 40 | '((0 1) (1 1) (2 2) (3 6) (4 24) (5 120) (6 720))) 41 | 42 | (test "facto-backwards-2" 43 | (letrec ((facto (tabled (n out) 44 | (conde 45 | ((z/assert `(= ,n 0)) 46 | (z/assert `(= ,out 1))) 47 | ((z/assert `(not (= ,n 0))) 48 | (fresh (n-1 r) 49 | (z/assert `(= (- ,n 1) ,n-1)) 50 | (z/assert `(= (* ,n ,r) ,out)) 51 | (facto n-1 r))))))) 52 | (run* (q) 53 | (facto q 2))) 54 | '(2)) 55 | 56 | (test "facto-backwards-720" 57 | (letrec ((facto (tabled (n out) 58 | (conde 59 | ((z/assert `(= ,n 0)) 60 | (z/assert `(= ,out 1))) 61 | ((z/assert `(not (= ,n 0))) 62 | (fresh (n-1 r) 63 | (z/assert `(= (- ,n 1) ,n-1)) 64 | (z/assert `(= (* ,n ,r) ,out)) 65 | (facto n-1 r))))))) 66 | (run* (q) 67 | (facto q 720))) 68 | '(6)) 69 | 70 | (test "fibo-1-non-tabled" 71 | (letrec ((fibo (lambda (n out) 72 | (conde 73 | ((z/assert `(= ,n 0)) 74 | (z/assert `(= ,out 0))) 75 | ((z/assert `(= ,n 1)) 76 | (z/assert `(= ,out 1))) 77 | ((z/assert `(> ,n 1)) 78 | (fresh (n-1 n-2 r1 r2) 79 | (z/assert `(= (- ,n 1) ,n-1)) 80 | (z/assert `(= (- ,n 2) ,n-2)) 81 | (z/assert `(= (+ ,r1 ,r2) ,out)) 82 | (fibo n-1 r1) 83 | (fibo n-2 r2))))))) 84 | (run 7 (q) 85 | (fresh (n out) 86 | (fibo n out) 87 | (== q `(,n ,out))))) 88 | '((0 0) (1 1) (2 1) (3 2) (4 3) (5 5) (6 8))) 89 | 90 | (test "fibo-1-tabled" 91 | (letrec ((fibo (tabled (n out) 92 | (conde 93 | ((z/assert `(= ,n 0)) 94 | (z/assert `(= ,out 0))) 95 | ((z/assert `(= ,n 1)) 96 | (z/assert `(= ,out 1))) 97 | ((z/assert `(> ,n 1)) 98 | (fresh (n-1 n-2 r1 r2) 99 | (z/assert `(= (- ,n 1) ,n-1)) 100 | (z/assert `(= (- ,n 2) ,n-2)) 101 | (fibo n-1 r1) 102 | (fibo n-2 r2) 103 | (z/assert `(= (+ ,r1 ,r2) ,out)))))))) 104 | (run 7 (q) 105 | (fresh (n out) 106 | (fibo n out) 107 | (== q `(,n ,out))))) 108 | '((0 0) (1 1) (2 1) (3 2) (4 3) (5 5) (6 8))) 109 | -------------------------------------------------------------------------------- /tabling.scm: -------------------------------------------------------------------------------- 1 | ;; starting point is miniKanren tabling code by Ramana Kumar 2 | ;; taken from webyrd/tabling 3 | 4 | (define ext-s-no-check 5 | (lambda (x v s) 6 | (cons `(,x . ,v) s))) 7 | 8 | (define new-s 9 | (lambda (c s) 10 | (cons s (cdr c)))) 11 | 12 | (define make-cache (lambda (ansv*) (vector 'cache ansv*))) 13 | (define cache-ansv* (lambda (v) (vector-ref v 1))) 14 | (define cache-ansv*-set! (lambda (v val) (vector-set! v 1 val))) 15 | 16 | (define make-ss (lambda (cache ansv* f) (vector 'ss cache ansv* f))) 17 | (define ss? (lambda (v) (and (vector? v) (eq? (vector-ref v 0) 'ss)))) 18 | (define ss-cache (lambda (v) (vector-ref v 1))) 19 | (define ss-ansv* (lambda (v) (vector-ref v 2))) 20 | (define ss-f (lambda (v) (vector-ref v 3))) 21 | 22 | (define subunify (lambda (arg ans s) (subsumed ans arg s))) 23 | 24 | (define subsumed 25 | (lambda (arg ans s) 26 | (let ((arg (walk arg s)) 27 | (ans (walk ans s))) 28 | (cond 29 | ((eq? arg ans) s) 30 | ((var? ans) (ext-s-no-check ans arg s)) 31 | ((and (pair? arg) (pair? ans)) 32 | (let ((s (subsumed (car arg) (car ans) s))) 33 | (and s (subsumed (cdr arg) (cdr ans) s)))) 34 | ((equal? arg ans) s) 35 | (else #f))))) 36 | 37 | (define reuse 38 | (lambda (argv cache s c) 39 | (let fix ((start (cache-ansv* cache)) (end '())) 40 | (let loop ((ansv* start)) 41 | (if (eq? ansv* end) 42 | (list (make-ss cache start (lambdaf@ () (fix (cache-ansv* cache) start)))) 43 | (choice (new-s c (subunify argv (reify-var (car ansv*) s) s)) 44 | (lambdaf@ () (loop (cdr ansv*))))))))) 45 | 46 | (define master 47 | (lambda (argv cache) 48 | (lambdag@ (c : S D A T M) 49 | (bind* 50 | (purge-M-inc-models c) 51 | (lambdag@ (c : S D A T M) 52 | (and 53 | (for-all 54 | (lambda (ansv) (not (subsumed argv ansv S))) 55 | (cache-ansv* cache)) 56 | (begin 57 | (cache-ansv*-set! cache 58 | (cons (reify-var argv S) 59 | (cache-ansv* cache))) 60 | c))))))) 61 | 62 | (define-syntax tabled 63 | (syntax-rules () 64 | ((_ (x ...) g g* ...) 65 | (let ((table '())) 66 | (lambda (x ...) 67 | (let ((argv (list x ...))) 68 | (lambdag@ (c : S D A T M) 69 | (let ((key ((reify argv) c))) 70 | (cond 71 | ((assoc key table) 72 | => (lambda (key.cache) (reuse argv (cdr key.cache) S c))) 73 | (else (let ((cache (make-cache '()))) 74 | (set! table (cons `(,key . ,cache) table)) 75 | ((fresh () g g* ... (master argv cache)) c)))))))))))) 76 | 77 | 78 | (define ss-ready? (lambda (ss) (not (eq? (cache-ansv* (ss-cache ss)) (ss-ansv* ss))))) 79 | (define w? (lambda (w) (and (pair? w) (ss? (car w))))) 80 | 81 | (define w-check 82 | (lambda (w sk fk) 83 | (let loop ((w w) (a '())) 84 | (cond 85 | ((null? w) (fk)) 86 | ((ss-ready? (car w)) 87 | (sk (lambdaf@ () 88 | (let ((f (ss-f (car w))) 89 | (w (append (reverse a) (cdr w)))) 90 | (if (null? w) (f) 91 | (mplus (f) (lambdaf@ () w))))))) 92 | (else (loop (cdr w) (cons (car w) a))))))) 93 | 94 | (define-syntax case-inf 95 | (syntax-rules () 96 | ((_ e (() e0) ((f^) e1) ((w) ew) ((c^) e2) ((c f) e3)) 97 | (let ((c-inf e)) 98 | (cond 99 | ((not c-inf) e0) 100 | ((procedure? c-inf) (let ((f^ c-inf)) e1)) 101 | ((w? c-inf) (w-check c-inf 102 | (lambda (f^) e1) 103 | (lambda () (let ((w c-inf)) ew)))) 104 | ((not (and (pair? c-inf) 105 | (procedure? (cdr c-inf)))) 106 | (let ((c^ c-inf)) e2)) 107 | (else (let ((c (car c-inf)) (f (cdr c-inf))) 108 | e3))))))) 109 | 110 | (define take 111 | (lambda (n f) 112 | (cond 113 | ((and n (zero? n)) '()) 114 | (else 115 | (case-inf (f) 116 | (() '()) 117 | ((f) (take n f)) 118 | ((w) '()) 119 | ((c) (cons c '())) 120 | ((c f) (cons c (take (and n (- n 1)) f)))))))) 121 | 122 | (define bind 123 | (lambda (c-inf g) 124 | (case-inf c-inf 125 | (() (mzero)) 126 | ((f) (inc (bind (f) g))) 127 | ((w) (map (lambda (ss) 128 | (make-ss (ss-cache ss) (ss-ansv* ss) 129 | (lambdaf@ () (bind ((ss-f ss)) g)))) 130 | w)) 131 | ((c) (g c)) 132 | ((c f) (mplus (g c) (lambdaf@ () (bind (f) g))))))) 133 | 134 | (define mplus 135 | (lambda (c-inf f) 136 | (case-inf c-inf 137 | (() (f)) 138 | ((f^) (inc (mplus (f) f^))) 139 | ((w) (lambdaf@ () (let ((c-inf (f))) 140 | (if (w? c-inf) 141 | (append c-inf w) 142 | (mplus c-inf (lambdaf@ () w)))))) ((c) (choice c f)) 143 | ((c f^) (choice c (lambdaf@ () (mplus (f) f^))))))) 144 | 145 | (define reify-v 146 | (lambda (n) 147 | (var n))) 148 | 149 | (define empty-S '()) 150 | 151 | (define make-reify 152 | (lambda (rep) 153 | (lambda (v s) 154 | (let ((v (walk* v s))) 155 | (walk* v (reify-s rep v empty-S)))))) 156 | 157 | (define reify-s 158 | (lambda (rep v s) 159 | (let ((v (walk v s))) 160 | (cond 161 | ((var? v) (ext-s-no-check v (rep (length s)) s)) 162 | ((pair? v) (reify-s rep (cdr v) (reify-s rep (car v) s))) 163 | (else s))))) 164 | 165 | (define reify-from-s (make-reify reify-name)) 166 | (define reify-var (make-reify reify-v)) 167 | -------------------------------------------------------------------------------- /tapl.scm: -------------------------------------------------------------------------------- 1 | (define ∅L '(as emptyset (Set L))) 2 | 3 | (define L 4 | (lambda () 5 | (z/ 6 | `(declare-datatypes 7 | ((L 0)) 8 | (((tru) (fls) (zero) (succ (s1 L)) (pred (p1 L)) (iszero (z1 L)))))))) 9 | 10 | (define fresh/L 11 | (lambda (t xs) 12 | (if (null? xs) succeed (fresh () (z/ `(declare-const ,(car xs) ,t)) (freshL t (cdr xs)))))) 13 | 14 | (define map-seto 15 | (lambda (fo s out) 16 | (conde 17 | ((z/== s ∅L) 18 | (z/== out ∅L)) 19 | ((fresh (se sr oe or) 20 | (fresh/L '(Set L) (list sr or)) 21 | (fresh/L 'L (list se oe)) 22 | (z/== s (set sr se)) 23 | (!ino se sr) 24 | (z/== out (set or oe)) 25 | (!ino oe or) 26 | (fo se oe) 27 | (map-seto fo sr or)))))) 28 | 29 | (define S 30 | (lambda (i s) 31 | (conde 32 | ((z/== i 0) (z/== s ∅L)) 33 | ((fresh (i-1 S-1 S-11 S-111 S-succ S-pred S-iszero s1 s2) 34 | (freshL '(Set L) (list S-1 S-succ S-pred S-iszero s1 s2)) 35 | (z/== i `(+ 1 ,i-1)) 36 | (S i-1 S-1) 37 | (map-seto (lambda (e o) (z/== o `(succ ,e))) S-1 S-succ) 38 | (map-seto (lambda (e o) (z/== o `(pred ,e))) S-1 S-pred) 39 | (map-seto (lambda (e o) (z/== o `(iszero ,e))) S-1 S-iszero) 40 | (uniono (set ∅L 'tru 'fls 'zero) S-succ s1) 41 | (uniono s1 S-pred s2) 42 | (uniono s2 S-iszero s)))))) 43 | 44 | (test "S0" 45 | (run* (q) (L) (freshL '(Set L) (list q)) 46 | (S 0 q)) 47 | `(,∅L)) 48 | 49 | (test "S1" 50 | (run* (q) (L) (freshL '(Set L) (list q)) 51 | (S 1 q)) 52 | '((union 53 | [union (singleton tru) (singleton fls)] 54 | [singleton zero]))) 55 | 56 | (ignore "S2" 57 | (run 1 (q) (L) (freshL '(Set L) (list q)) 58 | (S 2 q)) 59 | 'works-but-not-pretty) 60 | -------------------------------------------------------------------------------- /tapl.smt: -------------------------------------------------------------------------------- 1 | (set-logic ALL_SUPPORTED) 2 | 3 | (declare-datatypes 4 | ((L 0)) 5 | (((zero) 6 | (succ (pred L)) 7 | (plus (a L) (b L)) 8 | (ifz (is_zero L) (yes L) (no L))))) 9 | 10 | (declare-fun x () L) 11 | (declare-fun y () L) 12 | (declare-fun z () L) 13 | (assert (not (= (plus x y) z))) 14 | (check-sat) 15 | (get-model) 16 | -------------------------------------------------------------------------------- /tapl_cvc4.smt: -------------------------------------------------------------------------------- 1 | (set-logic QF_UFDTLIAFS) 2 | 3 | (declare-datatypes ((L 0)) 4 | (((zero) (succ (s1 L)) (plus (p1 L) (p2 L)) (ifz (i1 L) (i2 L) (i3 L))))) 5 | 6 | (declare-const s (Set L)) 7 | (assert (member zero s)) 8 | (assert (member (succ zero) s)) 9 | (assert (not (= s (union (singleton zero) (singleton (succ zero)))))) 10 | (check-sat) 11 | (get-model) 12 | 13 | -------------------------------------------------------------------------------- /test-all.scm: -------------------------------------------------------------------------------- 1 | (load "test-check.scm") 2 | 3 | (printf "==-tests\n") 4 | (load "==-tests.scm") 5 | 6 | (printf "symbolo-tests\n") 7 | (load "symbolo-tests.scm") 8 | 9 | (printf "numbero-tests\n") 10 | (load "numbero-tests.scm") 11 | 12 | (printf "symbolo-numbero-tests\n") 13 | (load "symbolo-numbero-tests.scm") 14 | 15 | (printf "disequality-tests\n") 16 | (load "disequality-tests.scm") 17 | 18 | (printf "absento-closure-tests\n") 19 | (load "absento-closure-tests.scm") 20 | 21 | (printf "absento-tests\n") 22 | (load "absento-tests.scm") 23 | 24 | ;; (printf "test-infer\n") 25 | ;; (load "test-infer.scm") 26 | 27 | (printf "test-simple-interp\n") 28 | (load "test-simple-interp.scm") 29 | 30 | ;; (printf "test-quines\n") 31 | ;; (load "test-quines.scm") 32 | 33 | (printf "test-numbers\n") 34 | (load "numbers.scm") 35 | (load "test-numbers.scm") 36 | -------------------------------------------------------------------------------- /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-suite.scm: -------------------------------------------------------------------------------- 1 | (load "test-header.scm") 2 | 3 | (load "z3-tests.scm") 4 | (load "clpsmt-basic-tests.scm") 5 | (load "clpsmt-tests.scm") 6 | (load "sign-domain-tests.scm") 7 | (load "symbolic-execution-tests.scm") 8 | (load "full-interp-extended-tests.scm") 9 | (load "abstract-interp.scm") 10 | (load "abstract-interp-tagged.scm") 11 | (load "twenty-four-puzzle.scm") 12 | (load "twenty-four-puzzle-smart.scm") 13 | -------------------------------------------------------------------------------- /test-header-with-tabling.scm: -------------------------------------------------------------------------------- 1 | (load "test-header.scm") 2 | (load "tabling.scm") 3 | -------------------------------------------------------------------------------- /test-header.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | -------------------------------------------------------------------------------- /test-numbers.scm: -------------------------------------------------------------------------------- 1 | (test "test 1" 2 | (run* (q) (*o (build-num 2) (build-num 3) q)) 3 | '((0 1 1))) 4 | 5 | (test "test 2" 6 | (run* (q) 7 | (fresh (n m) 8 | (*o n m (build-num 6)) 9 | (== `(,n ,m) q))) 10 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 11 | 12 | (test "sums" 13 | (run 5 (q) 14 | (fresh (x y z) 15 | (pluso x y z) 16 | (== `(,x ,y ,z) q))) 17 | '((_.0 () _.0) 18 | (() (_.0 . _.1) (_.0 . _.1)) 19 | ((1) (1) (0 1)) 20 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 21 | ((1) (1 1) (0 0 1)))) 22 | 23 | (test "factors" 24 | (run* (q) 25 | (fresh (x y) 26 | (*o x y (build-num 24)) 27 | (== `(,x ,y ,(build-num 24)) q))) 28 | '(((1) (0 0 0 1 1) (0 0 0 1 1)) 29 | ((0 0 0 1 1) (1) (0 0 0 1 1)) 30 | ((0 1) (0 0 1 1) (0 0 0 1 1)) 31 | ((0 0 1) (0 1 1) (0 0 0 1 1)) 32 | ((0 0 0 1) (1 1) (0 0 0 1 1)) 33 | ((1 1) (0 0 0 1) (0 0 0 1 1)) 34 | ((0 1 1) (0 0 1) (0 0 0 1 1)) 35 | ((0 0 1 1) (0 1) (0 0 0 1 1)))) 36 | 37 | (define number-primo 38 | (lambda (exp env val) 39 | (fresh (n) 40 | (== `(intexp ,n) exp) 41 | (== `(intval ,n) val) 42 | (not-in-envo 'numo env)))) 43 | 44 | (define sub1-primo 45 | (lambda (exp env val) 46 | (fresh (e n n-1) 47 | (== `(sub1 ,e) exp) 48 | (== `(intval ,n-1) val) 49 | (not-in-envo 'sub1 env) 50 | (eval-expo e env `(intval ,n)) 51 | (minuso n '(1) n-1)))) 52 | 53 | (define zero?-primo 54 | (lambda (exp env val) 55 | (fresh (e n) 56 | (== `(zero? ,e) exp) 57 | (conde 58 | ((zeroo n) (== #t val)) 59 | ((poso n) (== #f val))) 60 | (not-in-envo 'zero? env) 61 | (eval-expo e env `(intval ,n))))) 62 | 63 | (define *-primo 64 | (lambda (exp env val) 65 | (fresh (e1 e2 n1 n2 n3) 66 | (== `(* ,e1 ,e2) exp) 67 | (== `(intval ,n3) val) 68 | (not-in-envo '* env) 69 | (eval-expo e1 env `(intval ,n1)) 70 | (eval-expo e2 env `(intval ,n2)) 71 | (*o n1 n2 n3)))) 72 | 73 | (define if-primo 74 | (lambda (exp env val) 75 | (fresh (e1 e2 e3 t) 76 | (== `(if ,e1 ,e2 ,e3) exp) 77 | (not-in-envo 'if env) 78 | (eval-expo e1 env t) 79 | (conde 80 | ((== #t t) (eval-expo e2 env val)) 81 | ((== #f t) (eval-expo e3 env val)))))) 82 | 83 | (define boolean-primo 84 | (lambda (exp env val) 85 | (conde 86 | ((== #t exp) (== #t val)) 87 | ((== #f exp) (== #f val))))) 88 | 89 | (define eval-expo 90 | (lambda (exp env val) 91 | (conde 92 | ((boolean-primo exp env val)) 93 | ((number-primo exp env val)) 94 | ((sub1-primo exp env val)) 95 | ((zero?-primo exp env val)) 96 | ((*-primo exp env val)) 97 | ((if-primo exp env val)) 98 | ((symbolo exp) (lookupo exp env val)) 99 | ((fresh (rator rand x body env^ a) 100 | (== `(,rator ,rand) exp) 101 | (eval-expo rator env `(closure ,x ,body ,env^)) 102 | (eval-expo rand env a) 103 | (eval-expo body `((,x . ,a) . ,env^) val))) 104 | ((fresh (x body) 105 | (== `(lambda (,x) ,body) exp) 106 | (symbolo x) 107 | (== `(closure ,x ,body ,env) val) 108 | (not-in-envo 'lambda env)))))) 109 | 110 | (define not-in-envo 111 | (lambda (x env) 112 | (conde 113 | ((fresh (y v rest) 114 | (== `((,y . ,v) . ,rest) env) 115 | (=/= y x) 116 | (not-in-envo x rest))) 117 | ((== '() env))))) 118 | 119 | (define lookupo 120 | (lambda (x env t) 121 | (fresh (rest y v) 122 | (== `((,y . ,v) . ,rest) env) 123 | (conde 124 | ((== y x) (== v t)) 125 | ((=/= y x) (lookupo x rest t)))))) 126 | 127 | (test "push-down problems 2" 128 | (run* (q) 129 | (fresh (x a d) 130 | (absento 'intval x) 131 | (== 'intval a) 132 | (== `(,a . ,d) x))) 133 | '()) 134 | 135 | (test "push-down problems 3" 136 | (run* (q) 137 | (fresh (x a d) 138 | (== `(,a . ,d) x) 139 | (absento 'intval x) 140 | (== 'intval a))) 141 | '()) 142 | 143 | (test "push-down problems 4" 144 | (run* (q) 145 | (fresh (x a d) 146 | (== `(,a . ,d) x) 147 | (== 'intval a) 148 | (absento 'intval x))) 149 | '()) 150 | 151 | (test "push-down problems 6" 152 | (run* (q) 153 | (fresh (x a d) 154 | (== 'intval a) 155 | (== `(,a . ,d) x) 156 | (absento 'intval x))) 157 | '()) 158 | 159 | (test "push-down problems 1" 160 | (run* (q) 161 | (fresh (x a d) 162 | (absento 'intval x) 163 | (== `(,a . ,d) x) 164 | (== 'intval a))) 165 | '()) 166 | 167 | (test "push-down problems 5" 168 | (run* (q) 169 | (fresh (x a d) 170 | (== 'intval a) 171 | (absento 'intval x) 172 | (== `(,a . ,d) x))) 173 | '()) 174 | 175 | (test "zero?" 176 | (run 1 (q) 177 | (eval-expo `(zero? (sub1 (intexp ,(build-num 1)))) '() q)) 178 | '(#t)) 179 | 180 | (test "*" 181 | (run 1 (q) 182 | (eval-expo `(* (intexp ,(build-num 3)) (intexp ,(build-num 2))) '() `(intval ,(build-num 6)))) 183 | '(_.0)) 184 | 185 | (test "sub1" 186 | (run 1 (q) 187 | (eval-expo q '() `(intval ,(build-num 6))) (== `(sub1 (intexp ,(build-num 7))) q)) 188 | '((sub1 (intexp (1 1 1))))) 189 | 190 | (test "sub1 bigger WAIT a minute" 191 | (run 1 (q) 192 | (eval-expo q '() `(intval ,(build-num 6))) 193 | (== `(sub1 (sub1 (intexp ,(build-num 8)))) q)) 194 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 195 | 196 | (test "sub1 biggest WAIT a minute" 197 | (run 1 (q) 198 | (eval-expo q '() `(intval ,(build-num 6))) 199 | (== `(sub1 (sub1 (sub1 (intexp ,(build-num 9))))) q)) 200 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 201 | 202 | (test "lots of programs to make a 6" 203 | (run 12 (q) (eval-expo q '() `(intval ,(build-num 6)))) 204 | '((intexp (0 1 1)) (sub1 (intexp (1 1 1))) 205 | (* (intexp (1)) (intexp (0 1 1))) 206 | (* (intexp (0 1 1)) (intexp (1))) 207 | (if #t (intexp (0 1 1)) _.0) 208 | (* (intexp (0 1)) (intexp (1 1))) 209 | (if #f _.0 (intexp (0 1 1))) 210 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 211 | (((lambda (_.0) (intexp (0 1 1))) #t) 212 | (=/= ((_.0 numo))) 213 | (sym _.0)) 214 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 215 | (sub1 (sub1 (intexp (0 0 0 1)))) 216 | (sub1 (if #t (intexp (1 1 1)) _.0)))) 217 | 218 | (define rel-fact5 219 | `((lambda (f) 220 | ((f f) (intexp ,(build-num 5)))) 221 | (lambda (f) 222 | (lambda (n) 223 | (if (zero? n) 224 | (intexp ,(build-num 1)) 225 | (* n ((f f) (sub1 n)))))))) 226 | 227 | (test "rel-fact5" 228 | (run* (q) (eval-expo rel-fact5 '() q)) 229 | `((intval ,(build-num 120)))) 230 | 231 | (test "rel-fact5-backwards" 232 | (run 1 (q) 233 | (eval-expo 234 | `((lambda (f) 235 | ((f ,q) (intexp ,(build-num 5)))) 236 | (lambda (f) 237 | (lambda (n) 238 | (if (zero? n) 239 | (intexp ,(build-num 1)) 240 | (* n ((f f) (sub1 n))))))) 241 | '() 242 | `(intval ,(build-num 120)))) 243 | `(f)) 244 | -------------------------------------------------------------------------------- /test-simple-interp.scm: -------------------------------------------------------------------------------- 1 | (load "simple-interp.scm") 2 | 3 | (test "running backwards" 4 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 5 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 6 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 7 | (((lambda (x) (lambda (y) x)) 8 | ((lambda (_.0) _.0) (lambda (z) z))) 9 | (sym _.0)) 10 | (((lambda (_.0) _.0) 11 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 12 | (sym _.0)) 13 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 14 | (lambda (z) z)) 15 | (sym _.0)))) 16 | 17 | (define lookupo 18 | (lambda (x env t) 19 | (fresh (rest y v) 20 | (== `((,y . ,v) . ,rest) env) 21 | (conde 22 | ((== y x) (== v t)) 23 | ((=/= y x) (lookupo x rest t)))))) 24 | 25 | (test "eval-exp-lc 1" 26 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) (lambda (z) z)) (lambda (a) a)) q)) 27 | '((closure z z ()))) 28 | 29 | (test "eval-exp-lc 2" 30 | (run* (q) (evalo '((lambda (x) (lambda (y) x)) (lambda (z) z)) q)) 31 | '((closure y x ((x . (closure z z ())))))) 32 | 33 | (test "running backwards" 34 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 35 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 36 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 37 | (((lambda (x) (lambda (y) x)) 38 | ((lambda (_.0) _.0) (lambda (z) z))) 39 | (sym _.0)) 40 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 41 | (lambda (z) z)) 42 | (sym _.0)) 43 | (((lambda (_.0) _.0) 44 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 45 | (sym _.0)))) 46 | 47 | (test "fully-running-backwards" 48 | (run 5 (q) 49 | (fresh (e v) 50 | (evalo e v) 51 | (== `(,e ==> ,v) q))) 52 | '((((lambda (_.0) _.1) 53 | ==> (closure _.0 _.1 ())) (sym _.0)) 54 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 55 | ==> 56 | (closure _.1 _.2 ())) 57 | (sym _.0 _.1)) 58 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 59 | ==> 60 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1 _.3)) 63 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 64 | ==> 65 | (closure _.1 _.1 ())) 66 | (sym _.0 _.1)) 67 | ((((lambda (_.0) (_.0 _.0)) 68 | (lambda (_.1) (lambda (_.2) _.3))) 69 | ==> 70 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 71 | (=/= ((_.1 lambda))) 72 | (sym _.0 _.1 _.2)))) 73 | -------------------------------------------------------------------------------- /test-suite-tabling.scm: -------------------------------------------------------------------------------- 1 | (load "test-header.scm") 2 | 3 | (load "clpsmt-basic-tests.scm") 4 | 5 | (load "test-header-with-tabling.scm") 6 | 7 | (load "clpsmt-basic-tests.scm") 8 | (load "tabling-tests.scm") 9 | (load "test-all.scm") 10 | -------------------------------------------------------------------------------- /twenty-four-puzzle-depth-limit.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | 5 | ;;; Classic 24 math puzzle, as described at: 6 | ;;; 7 | ;;; https://www.mathsisfun.com/puzzles/24-from-8-8-3-3-solution.html 8 | ;;; 9 | ;;; and 10 | ;;; 11 | ;;; http://www.4nums.com/game/difficulties/ 12 | 13 | ;;; This version of code is restricted to integer values, which means solutions like 14 | ;;; 15 | ;;; 8/(3-(8/3)) 16 | ;;; = 8/(1/3) 17 | ;;; = 24 18 | ;;; 19 | ;;; do *not* work! 20 | 21 | #| 22 | ;;; Original defn of remove-one-elemento, using (== x a) rather than (z/assert `(= ,x ,a)). 23 | ;;; Which version is preferable? 24 | ;;; What are the tradeoffs? 25 | 26 | (define remove-one-elemento 27 | (lambda (x ls out) 28 | (fresh (a d) 29 | (== `(,a . ,d) ls) 30 | (conde 31 | ((== x a) (== d out)) 32 | ((=/= x a) 33 | (fresh (res) 34 | (== `(,a . ,res) out) 35 | (remove-one-elemento x d res))))))) 36 | |# 37 | 38 | ;;; optimized version, more in the spirit of 24: 39 | ;;; assumes that 'ls' is a list of integers in 40 | ;;; *non-decreasing* order. 41 | (define remove-one-elemento 42 | (lambda (x ls out) 43 | (fresh (a d) 44 | (== `(,a . ,d) ls) 45 | (numbero a) 46 | (conde 47 | ((z/assert `(= ,a ,x)) 48 | (== d out)) 49 | ((z/assert `(< ,a ,x)) 50 | (fresh (res) 51 | (== `(,a . ,res) out) 52 | (remove-one-elemento x d res))))))) 53 | 54 | (define puzzleo 55 | (lambda (expr num* max-ops val num*^ max-ops^) 56 | (conde 57 | 58 | [(numbero expr) 59 | ;; Originally used (== expr val). 60 | ;; Which version is preferable? 61 | ;; What are the tradeoffs? 62 | (z/assert `(and (= ,expr ,val) (= ,max-ops ,max-ops^))) 63 | (remove-one-elemento expr num* num*^)] 64 | 65 | [(fresh (a1 a2 n1 n2 num*^^ max-ops-1 max-ops^^) 66 | (== `(+ ,a1 ,a2) expr) 67 | (z/assert `(and (= ,val (+ ,n1 ,n2)) (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1))) 68 | (puzzleo a1 num* max-ops-1 n1 num*^^ max-ops^^) 69 | (puzzleo a2 num*^^ max-ops^^ n2 num*^ max-ops^))] 70 | 71 | [(fresh (a1 a2 n1 n2 num*^^ max-ops-1 max-ops^^) 72 | (== `(- ,a1 ,a2) expr) 73 | (z/assert `(and (= ,val (- ,n1 ,n2)) (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1))) 74 | (puzzleo a1 num* max-ops-1 n1 num*^^ max-ops^^) 75 | (puzzleo a2 num*^^ max-ops^^ n2 num*^ max-ops^))] 76 | 77 | [(fresh (a1 a2 n1 n2 num*^^ max-ops-1 max-ops^^) 78 | (== `(* ,a1 ,a2) expr) 79 | (z/assert `(and (= ,val (* ,n1 ,n2)) (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1))) 80 | (puzzleo a1 num* max-ops-1 n1 num*^^ max-ops^^) 81 | (puzzleo a2 num*^^ max-ops^^ n2 num*^ max-ops^))] 82 | 83 | [(fresh (a1 a2 n1 n2 num*^^ max-ops-1 max-ops^^) 84 | (== `(/ ,a1 ,a2) expr) 85 | (z/assert `(and (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1) (not (= ,n2 0)) (= ,val (div ,n1 ,n2)))) 86 | (puzzleo a1 num* max-ops-1 n1 num*^^ max-ops^^) 87 | (puzzleo a2 num*^^ max-ops^^ n2 num*^ max-ops^))] 88 | 89 | ))) 90 | 91 | (test "remove-one-elemento-a" 92 | (run* (q) 93 | (fresh (x out) 94 | (== (list x out) q) 95 | (remove-one-elemento x '(2 2 10 10) out))) 96 | '((2 (2 10 10)) 97 | (10 (2 2 10)))) 98 | 99 | ;; Keep track of minimum number of numbers that can be used in the search! 100 | ;; This query should terminate! 101 | #| 102 | (test "24-puzzle-refute-a" 103 | (run 1 (e) (puzzleo e '() 3 24 '() 0)) 104 | '()) 105 | 106 | (test "24-puzzle-refute-b" 107 | (run 1 (e) (puzzleo e '(0) 3 24 '() 0)) 108 | '()) 109 | 110 | (test "24-puzzle-refute-c" 111 | (run 1 (e) (puzzleo e '(1) 3 24 '() 0)) 112 | '()) 113 | |# 114 | 115 | (test "24-puzzle-a-check-answer-a" 116 | (run 1 (e) (== '(* 8 (+ 1 (+ 1 1))) e) (puzzleo e '(1 1 1 8) 3 24 '() 0)) 117 | '((* 8 (+ 1 (+ 1 1))))) 118 | 119 | (test "24-puzzle-a-check-answer-b" 120 | (run 1 (e) (== '(+ 8 (+ 1 (+ 1 1))) e) (puzzleo e '(1 1 1 8) 3 24 '() 0)) 121 | '()) 122 | 123 | 124 | ;; On Will's lappy--timings, according to Chez Scheme: 125 | ;; vast majority of the time spent in Z3. 126 | ;; 127 | ;; run 6: 3.2s CPU time, 103s real time 128 | (test "24-puzzle-h" 129 | (run 6 (e) (puzzleo e '(2 2 2 12) 3 24 '() 0)) 130 | '((+ (- 2 2) (* 2 12)) 131 | (+ (- 2 2) (* 12 2)) 132 | (/ (* 2 12) (/ 2 2)) 133 | (+ 2 (- (* 2 12) 2)) 134 | (+ 2 (- (* 12 2) 2)) 135 | (* 2 (+ 2 (- 12 2))))) 136 | 137 | #!eof 138 | 139 | 140 | ;; On Will's lappy--timings, according to Chez Scheme: 141 | ;; vast majority of the time spent in Z3. 142 | ;; 143 | ;; run 1: 2.6s CPU time, 85s real time 144 | ;; ((* 8 (+ 1 (+ 1 1)))) 145 | ;; 146 | ;; run 2: 3.5s CPU time, 118s real time 147 | ;; ((* 8 (+ 1 (+ 1 1))) 148 | ;; (* 8 (+ (+ 1 1) 1))) 149 | ;; 150 | ;; run 3: 9.4s CPU, 312s real time 151 | ;; ((* 8 (+ 1 (+ 1 1))) 152 | ;; (* 8 (+ (+ 1 1) 1)) 153 | ;; (* (+ 1 (+ 1 1)) 8)) 154 | (test "24-puzzle-a" 155 | (run 1 (e) (puzzleo e '(1 1 1 8) 3 24 '() 0)) 156 | '((* 8 (+ 1 (+ 1 1))))) 157 | 158 | (test "24-puzzle-g" 159 | (run 1 (e) (puzzleo e '(2 2 10 10) 3 24 '() 0)) 160 | '((+ 2 (+ 2 (+ 10 10))))) 161 | 162 | #!eof 163 | 164 | (test "24-puzzle-i" 165 | (run 1 (e) (puzzleo e '(4 6 7 7) 24 '())) 166 | '((+ 4 (+ 6 (+ 7 7))))) 167 | 168 | #!eof 169 | 170 | (test "24-puzzle-j" 171 | (run 1 (e) (puzzleo e '(1 2 5 10) 24 '())) 172 | '?) 173 | 174 | ;;; boring!! 175 | (test "24-puzzle-b" 176 | (run 1 (q) 177 | (fresh (e num* n1 n2 n3 n4) 178 | (== (list e num*) q) 179 | (== `(,n1 ,n2 ,n3 ,n4) num*) 180 | (puzzleo e num* 24 '()))) 181 | '(((+ 24 (+ 0 (+ 0 0))) (24 0 0 0)))) 182 | 183 | (test "24-puzzle-c" 184 | (run 20 (e) 185 | (fresh (num* n1 n2 n3 n4) 186 | (z/assert `(< 1 ,n1)) 187 | (z/assert `(< 1 ,n2)) 188 | (z/assert `(< 1 ,n3)) 189 | (z/assert `(< 1 ,n4)) 190 | (== `(,n1 ,n2 ,n3 ,n4) num*) 191 | (puzzleo e num* 24 '()))) 192 | '((+ 18 (+ 2 (+ 2 2))) 193 | (+ 15 (+ 3 (+ 3 3))) 194 | (+ 12 (+ 4 (+ 4 4))) 195 | (+ 9 (+ 5 (+ 5 5))) 196 | (+ 13 (+ 4 (+ 4 3))) 197 | (+ 11 (+ 6 (+ 4 3))) 198 | (+ 10 (+ 7 (+ 4 3))) 199 | (+ 12 (+ 4 (+ 5 3))) 200 | (+ 11 (+ 4 (+ 6 3))) 201 | (+ 10 (+ 6 (+ 5 3))) 202 | (+ 9 (+ 8 (+ 4 3))) 203 | (+ 8 (+ 9 (+ 4 3))) 204 | (+ 14 (+ 4 (+ 3 3))) 205 | (+ 10 (+ 5 (+ 6 3))) 206 | (+ 13 (+ 5 (+ 3 3))) 207 | (+ 12 (+ 5 (+ 4 3))) 208 | (+ 10 (+ 4 (+ 7 3))) 209 | (+ 10 (+ 8 (+ 3 3))) 210 | (+ 9 (+ 9 (+ 3 3))) 211 | (+ 7 (+ 10 (+ 4 3))))) 212 | 213 | (test "24-puzzle-d" 214 | (run 10 (e) 215 | (fresh (num* n1 n2 n3 n4 op1 op2 op3 e1 e2 e3 e4) 216 | (z/assert `(< 0 ,n1)) 217 | (z/assert `(< 0 ,n2)) 218 | (z/assert `(< 0 ,n3)) 219 | (z/assert `(< 0 ,n4)) 220 | (== `(,n1 ,n2 ,n3 ,n4) num*) 221 | (== `(,op1 (,op2 ,e1 ,e2) (,op3 ,e3 ,e4)) e) 222 | (puzzleo e num* 24 '()))) 223 | '((+ (+ 21 1) (+ 1 1)) 224 | (+ (+ 18 2) (+ 2 2)) 225 | (+ (+ 15 3) (+ 3 3)) 226 | (+ (+ 12 4) (+ 4 4)) 227 | (+ (+ 16 3) (+ 3 2)) 228 | (+ (+ 14 5) (+ 3 2)) 229 | (+ (+ 13 6) (+ 3 2)) 230 | (+ (+ 15 3) (+ 4 2)) 231 | (+ (+ 14 3) (+ 5 2)) 232 | (+ (+ 13 5) (+ 4 2)))) 233 | 234 | (test "24-puzzle-e" 235 | (run 10 (e) 236 | (fresh (num* n1 n2 n3 n4 op e1 e2) 237 | (z/assert `(< 0 ,n1)) 238 | (z/assert `(< 0 ,n2)) 239 | (z/assert `(< 0 ,n3)) 240 | (z/assert `(< 0 ,n4)) 241 | (== `(,n1 ,n2 ,n3 ,n4) num*) 242 | (=/= op '+) 243 | (== `(,op ,e1 ,e2) e) 244 | (puzzleo e num* 24 '()))) 245 | '((- 27 (+ 1 (+ 1 1))) 246 | (- 30 (+ 2 (+ 2 2))) 247 | (- 33 (+ 3 (+ 3 3))) 248 | (- 36 (+ 4 (+ 4 4))) 249 | (- 32 (+ 3 (+ 3 2))) 250 | (- 34 (+ 5 (+ 3 2))) 251 | (- 35 (+ 6 (+ 3 2))) 252 | (- 33 (+ 3 (+ 4 2))) 253 | (- 34 (+ 3 (+ 5 2))) 254 | (- 35 (+ 5 (+ 4 2))))) 255 | 256 | (test "24-puzzle-f" 257 | (run 10 (e) 258 | (fresh (num* n1 n2 n3 n4 op e1 e2) 259 | (z/assert `(< 0 ,n1)) 260 | (z/assert `(< 0 ,n2)) 261 | (z/assert `(< 0 ,n3)) 262 | (z/assert `(< 0 ,n4)) 263 | (== `(,n1 ,n2 ,n3 ,n4) num*) 264 | (== op '*) 265 | (== `(,op ,e1 ,e2) e) 266 | (puzzleo e num* 24 '()))) 267 | '((* 1 (+ 1 (+ 1 22))) 268 | (* 8 (+ 1 (+ 1 1))) 269 | (* 6 (+ 2 (+ 1 1))) 270 | (* 4 (+ 4 (+ 1 1))) 271 | (* 3 (+ 6 (+ 1 1))) 272 | (* 2 (+ 10 (+ 1 1))) 273 | (* 1 (+ 22 (+ 1 1))) 274 | (* 6 (+ 1 (+ 1 2))) 275 | (* 4 (+ 3 (+ 1 2))) 276 | (* 3 (+ 5 (+ 1 2))))) 277 | -------------------------------------------------------------------------------- /twenty-four-puzzle-smart.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "mk-streaming-interface.scm") 3 | (load "z3-driver.scm") 4 | (load "test-check.scm") 5 | 6 | ;;; Classic 24 math puzzle, as described at: 7 | ;;; 8 | ;;; https://www.mathsisfun.com/puzzles/24-from-8-8-3-3-solution.html 9 | ;;; 10 | ;;; and 11 | ;;; 12 | ;;; http://www.4nums.com/game/difficulties/ 13 | 14 | ;;; This version of code is restricted to integer values, which means solutions like 15 | ;;; 16 | ;;; 8/(3-(8/3)) 17 | ;;; = 8/(1/3) 18 | ;;; = 24 19 | ;;; 20 | ;;; do *not* work! 21 | 22 | #| 23 | ;;; Original defn of remove-one-elemento, using (== x a) rather than (z/assert `(= ,x ,a)). 24 | ;;; Which version is preferable? 25 | ;;; What are the tradeoffs? 26 | 27 | (define remove-one-elemento 28 | (lambda (x ls out) 29 | (fresh (a d) 30 | (== `(,a . ,d) ls) 31 | (conde 32 | ((== x a) (== d out)) 33 | ((=/= x a) 34 | (fresh (res) 35 | (== `(,a . ,res) out) 36 | (remove-one-elemento x d res))))))) 37 | |# 38 | 39 | ;;; optimized version, more in the spirit of 24: 40 | ;;; assumes that 'ls' is a list of integers in 41 | ;;; *non-decreasing* order. 42 | (define remove-one-elemento 43 | (lambda (x ls out) 44 | (fresh (a d) 45 | (== `(,a . ,d) ls) 46 | (numbero a) 47 | (conde 48 | ((z/assert `(= ,a ,x)) 49 | (== d out)) 50 | ((z/assert `(< ,a ,x)) 51 | (fresh (res) 52 | (== `(,a . ,res) out) 53 | (remove-one-elemento x d res))))))) 54 | 55 | (define puzzleo 56 | (lambda (expr num* max-ops val num*^ max-ops^) 57 | (conde 58 | 59 | [(numbero expr) 60 | ;; Originally used (== expr val). 61 | ;; Which version is preferable? 62 | ;; What are the tradeoffs? 63 | (z/assert `(and (= ,expr ,val) (= ,max-ops ,max-ops^))) 64 | (remove-one-elemento expr num* num*^)] 65 | 66 | [(fresh (op e1 e2 n1 n2 num*^^ max-ops-1 max-ops^^) 67 | (== `(,op ,e1 ,e2) expr) 68 | (conde 69 | [(conde 70 | [(== '+ op)] 71 | [(== '* op)]) 72 | (z/assert `(and (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1) (= ,val (,op ,n1 ,n2)))) 73 | (conde 74 | ;; break symmetry for commutative operators 75 | [(numbero e1) (numbero e2) 76 | (z/assert `(<= ,e1 ,e2))] 77 | [(numbero e1) 78 | (fresh (o2 a2 b2) 79 | (== `(,o2 ,a2 ,b2) e2))] 80 | [(fresh (o1 a1 b1) 81 | (== `(,o1 ,a1 ,b1) e1)) 82 | (fresh (o2 a2 b2) 83 | (== `(,o2 ,a2 ,b2) e2))])] 84 | [(== '- op) 85 | (z/assert `(and (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1) (= ,val (,op ,n1 ,n2))))] 86 | [(== '/ op) 87 | (z/assert `(and (< 0 ,max-ops) (= (- ,max-ops 1) ,max-ops-1) (not (= ,n2 0)) (= ,val (div ,n1 ,n2))))]) 88 | (puzzleo e1 num* max-ops-1 n1 num*^^ max-ops^^) 89 | (puzzleo e2 num*^^ max-ops^^ n2 num*^ max-ops^))] 90 | 91 | ))) 92 | 93 | (define puzzle-drivero 94 | (lambda (expr num*) 95 | (puzzleo expr num* 3 24 '() 0))) 96 | 97 | (test "remove-one-elemento-a" 98 | (run* (q) 99 | (fresh (x out) 100 | (== (list x out) q) 101 | (remove-one-elemento x '(2 2 10 10) out))) 102 | '((2 (2 10 10)) 103 | (10 (2 2 10)))) 104 | 105 | 106 | 107 | (test "24-puzzle-refute-a" 108 | (run* (e) (puzzleo e '() 0 24 '() 0)) 109 | '()) 110 | 111 | (test "24-puzzle-refute-b" 112 | (run* (e) (puzzleo e '(0) 1 24 '() 0)) 113 | '()) 114 | 115 | (test "24-puzzle-refute-c" 116 | (run* (e) (puzzleo e '(1) 1 24 '() 0)) 117 | '()) 118 | 119 | 120 | 121 | (test "24-puzzle-a-check-answer-a" 122 | (run* (e) (== '(* 8 (+ 1 (+ 1 1))) e) (puzzle-drivero e '(1 1 1 8))) 123 | '((* 8 (+ 1 (+ 1 1))))) 124 | 125 | (test "24-puzzle-a-check-answer-b" 126 | (run* (e) (== '(+ 8 (+ 1 (+ 1 1))) e) (puzzle-drivero e '(1 1 1 8))) 127 | '()) 128 | 129 | 130 | ;; *** z3-counter-check-sat count: 28203 131 | ;; *** z3-counter-get-model count: 41 132 | ;; (time (test "24-puzzle-i" ...)) 133 | ;; 214 collections 134 | ;; 20.592048386s elapsed cpu time, including 0.275569252s collecting 135 | ;; 718.830567000s elapsed real time, including 0.277166000s collecting 136 | ;; 1743521856 bytes allocated, including 1708956160 bytes reclaimed 137 | (time 138 | (test "24-puzzle-i" 139 | (let ((c1 z3-counter-check-sat) 140 | (c2 z3-counter-get-model)) 141 | (let ((ans (streaming-run* (e) (puzzle-drivero e '(4 6 7 7))))) 142 | (printf "*** z3-counter-check-sat count: ~s\n" (- z3-counter-check-sat c1)) 143 | (printf "*** z3-counter-get-model count: ~s\n" (- z3-counter-get-model c2)) 144 | ans)) 145 | '((- 7 (- 7 (* 4 6))) 146 | (+ 4 (+ 6 (+ 7 7))) 147 | (* 4 (- 6 (- 7 7))) 148 | (+ 4 (+ 7 (+ 6 7))) 149 | (* 4 (/ 6 (/ 7 7))) 150 | (+ 6 (+ 4 (+ 7 7))) 151 | (* 4 (- 7 (- 7 6))) 152 | (+ 6 (+ 7 (+ 4 7))) 153 | (* 4 (- 7 (/ 7 6))) 154 | (* 6 (- 4 (- 7 7))) 155 | (* 4 (+ 6 (- 7 7))) 156 | (* 4 (+ 7 (- 6 7))) 157 | (* 4 (- (+ 6 7) 7)) 158 | (* 4 (* 6 (/ 7 7))) 159 | (* 6 (/ 4 (/ 7 7))) 160 | (* 4 (/ (* 6 7) 7)) 161 | (+ 7 (+ 4 (+ 6 7))) 162 | (* 6 (- 7 (- 7 4))) 163 | (+ 7 (+ 6 (+ 4 7))) 164 | (+ 7 (+ 7 (+ 4 6))) 165 | (* 6 (+ 4 (- 7 7))) 166 | (+ 7 (- (* 4 6) 7)) 167 | (* 6 (+ 7 (- 4 7))) 168 | (* 6 (- (+ 4 7) 7)) 169 | (* 6 (* 4 (/ 7 7))) 170 | (* 6 (/ (* 4 7) 7)) 171 | (- (* 4 6) (- 7 7)) 172 | (/ (* 4 6) (/ 7 7)) 173 | (+ (+ 4 6) (+ 7 7)) 174 | (+ (+ 4 7) (+ 6 7)) 175 | (/ (* 7 7) (- 6 4)) 176 | (+ (- 7 7) (* 4 6)) 177 | (- (+ 7 (* 4 6)) 7) 178 | (/ (* 4 (* 6 7)) 7) 179 | (* (* 4 6) (/ 7 7)) 180 | (+ (+ 6 7) (+ 4 7)) 181 | (+ (* 4 6) (- 7 7)) 182 | (/ (* 6 (* 4 7)) 7) 183 | (* (/ 7 7) (* 4 6)) 184 | (/ (* 7 (* 4 6)) 7) 185 | (+ (+ 7 7) (+ 4 6))))) 186 | 187 | (time 188 | (test "24-puzzle-j" 189 | (streaming-run* (e) (puzzle-drivero e '(1 2 5 10))) 190 | '((- 5 (- 1 (* 2 10))) 191 | (+ 5 (- (* 2 10) 1)) 192 | (+ (- 5 1) (* 2 10)) 193 | (- (* 2 10) (- 1 5)) 194 | (- (+ 5 (* 2 10)) 1) 195 | (- (* 5 (/ 10 2)) 1) 196 | (- (/ (* 5 10) 2) 1) 197 | (/ (- (* 5 10) 1) 2) 198 | (+ (* 2 10) (- 5 1))))) 199 | 200 | (time 201 | (test "24-puzzle-k" 202 | (streaming-run* (e) (puzzle-drivero e '(3 7 8 9))) 203 | '((* 3 (- 7 (- 8 9))) 204 | (* 3 (- 8 (/ 7 9))) 205 | (* 3 (- 9 (- 8 7))) 206 | (* 3 (- 9 (/ 8 7))) 207 | (* 3 (/ 8 (/ 9 7))) 208 | (* 3 (+ 7 (- 9 8))) 209 | (* 3 (+ 7 (/ 9 8))) 210 | (* 3 (+ 8 (/ 7 9))) 211 | (* 3 (+ 9 (- 7 8))) 212 | (* 3 (- (+ 7 9) 8)) 213 | (* 3 (* 8 (/ 9 7))) 214 | (* 8 (- 3 (/ 7 9))) 215 | (* 8 (/ 3 (/ 9 7))) 216 | (* 8 (+ 3 (/ 7 9))) 217 | (* 8 (* 3 (/ 9 7))) 218 | (* 8 (/ (* 3 9) 7)) 219 | (- (* 3 8) (/ 7 9)) 220 | (/ (* 3 8) (/ 9 7)) 221 | (+ (/ 7 9) (* 3 8)) 222 | (* (* 3 8) (/ 9 7)) 223 | (+ (* 3 8) (/ 7 9)) 224 | (* (/ 9 7) (* 3 8))))) 225 | 226 | (time 227 | (test "24-puzzle-a-all-streaming" 228 | (streaming-run* (e) (puzzle-drivero e '(1 1 1 8))) 229 | '((* 8 (+ 1 (+ 1 1)))))) 230 | 231 | (time 232 | (test "24-puzzle-g-all-streaming" 233 | (streaming-run* (e) (puzzle-drivero e '(2 2 10 10))) 234 | '((+ 2 (+ 2 (+ 10 10))) 235 | (+ 2 (+ 10 (+ 2 10))) 236 | (+ 10 (+ 2 (+ 2 10))) 237 | (+ 10 (+ 10 (+ 2 2))) 238 | (+ 10 (+ 10 (* 2 2))) 239 | (+ (+ 2 2) (+ 10 10)) 240 | (+ (+ 2 10) (+ 2 10)) 241 | (+ (* 2 2) (+ 10 10)) 242 | (+ (+ 10 10) (+ 2 2)) 243 | (+ (+ 10 10) (* 2 2))))) 244 | 245 | (time 246 | (test "24-puzzle-h-all-streaming" 247 | (streaming-run* (e) (puzzle-drivero e '(2 2 2 12))) 248 | '((- 2 (- 2 (* 2 12))) 249 | (* 2 (- 2 (- 2 12))) 250 | (* 2 (- 12 (- 2 2))) 251 | (* 2 (/ 12 (/ 2 2))) 252 | (+ 2 (- (* 2 12) 2)) 253 | (* 2 (+ 2 (- 12 2))) 254 | (* 2 (- (+ 2 12) 2)) 255 | (* 2 (* 2 (/ 12 2))) 256 | (* 12 (- 2 (- 2 2))) 257 | (* 2 (+ 12 (- 2 2))) 258 | (* 2 (* 12 (/ 2 2))) 259 | (* 2 (/ (* 2 12) 2)) 260 | (* 12 (/ 2 (/ 2 2))) 261 | (* 12 (+ 2 (- 2 2))) 262 | (* 12 (- (+ 2 2) 2)) 263 | (+ (- 2 2) (* 2 12)) 264 | (* 12 (* 2 (/ 2 2))) 265 | (* 12 (- (* 2 2) 2)) 266 | (* 12 (/ (+ 2 2) 2)) 267 | (* 12 (/ (* 2 2) 2)) 268 | (* (/ 2 2) (* 2 12)) 269 | (- (* 2 12) (- 2 2)) 270 | (/ (* 2 12) (/ 2 2)) 271 | (* (+ 2 2) (/ 12 2)) 272 | (- (+ 2 (* 2 12)) 2) 273 | (* (* 2 2) (/ 12 2)) 274 | (/ (* 2 (* 2 12)) 2) 275 | (* (* 2 12) (/ 2 2)) 276 | (+ (* 2 12) (- 2 2)) 277 | (* (/ 12 2) (+ 2 2)) 278 | (* (/ 12 2) (* 2 2)) 279 | (/ (* 12 (+ 2 2)) 2) 280 | (/ (* 12 (* 2 2)) 2)))) 281 | -------------------------------------------------------------------------------- /twenty-four-puzzle.scm: -------------------------------------------------------------------------------- 1 | ;(load "mk.scm") 2 | ;(load "z3-driver.scm") 3 | ;(load "test-check.scm") 4 | 5 | ;;; Classic 24 math puzzle, as described at: 6 | ;;; 7 | ;;; https://www.mathsisfun.com/puzzles/24-from-8-8-3-3-solution.html 8 | ;;; 9 | ;;; and 10 | ;;; 11 | ;;; http://www.4nums.com/game/difficulties/ 12 | 13 | ;;; This version of code is restricted to integer values, which means solutions like 14 | ;;; 15 | ;;; 8/(3-(8/3)) 16 | ;;; = 8/(1/3) 17 | ;;; = 24 18 | ;;; 19 | ;;; do *not* work! 20 | 21 | #| 22 | ;;; Original defn of remove-one-elemento, using (== x a) rather than (z/assert `(= ,x ,a)). 23 | ;;; Which version is preferable? 24 | ;;; What are the tradeoffs? 25 | 26 | (define remove-one-elemento 27 | (lambda (x ls out) 28 | (fresh (a d) 29 | (== `(,a . ,d) ls) 30 | (conde 31 | ((== x a) (== d out)) 32 | ((=/= x a) 33 | (fresh (res) 34 | (== `(,a . ,res) out) 35 | (remove-one-elemento x d res))))))) 36 | |# 37 | 38 | ;;; optimized version, more in the spirit of 24: 39 | ;;; assumes that 'ls' is a list of integers in 40 | ;;; *non-decreasing* order. 41 | (define remove-one-elemento 42 | (lambda (x ls out) 43 | (fresh (a d) 44 | (== `(,a . ,d) ls) 45 | (numbero a) 46 | (conde 47 | ((z/assert `(= ,a ,x)) 48 | (== d out)) 49 | ((z/assert `(< ,a ,x)) 50 | (fresh (res) 51 | (== `(,a . ,res) out) 52 | (remove-one-elemento x d res))))))) 53 | 54 | (define puzzleo 55 | (lambda (expr num* val num*^) 56 | (conde 57 | 58 | [(numbero expr) 59 | ;; Originally used (== expr val). 60 | ;; Which version is preferable? 61 | ;; What are the tradeoffs? 62 | (z/assert `(= ,expr ,val)) 63 | (remove-one-elemento expr num* num*^)] 64 | 65 | [(fresh (a1 a2 n1 n2 num*^^) 66 | (== `(+ ,a1 ,a2) expr) 67 | (z/assert `(= ,val (+ ,n1 ,n2))) 68 | (puzzleo a1 num* n1 num*^^) 69 | (puzzleo a2 num*^^ n2 num*^))] 70 | 71 | [(fresh (a1 a2 n1 n2 num*^^) 72 | (== `(- ,a1 ,a2) expr) 73 | (z/assert `(= ,val (- ,n1 ,n2))) 74 | (puzzleo a1 num* n1 num*^^) 75 | (puzzleo a2 num*^^ n2 num*^))] 76 | 77 | [(fresh (a1 a2 n1 n2 num*^^) 78 | (== `(* ,a1 ,a2) expr) 79 | (z/assert `(= ,val (* ,n1 ,n2))) 80 | (puzzleo a1 num* n1 num*^^) 81 | (puzzleo a2 num*^^ n2 num*^))] 82 | 83 | [(fresh (a1 a2 n1 n2 num*^^) 84 | (== `(/ ,a1 ,a2) expr) 85 | (z/assert `(not (= ,n2 0))) 86 | (z/assert `(= ,val (div ,n1 ,n2))) 87 | (puzzleo a1 num* n1 num*^^) 88 | (puzzleo a2 num*^^ n2 num*^))] 89 | 90 | ))) 91 | 92 | (test "remove-one-elemento-a" 93 | (run* (q) 94 | (fresh (x out) 95 | (== (list x out) q) 96 | (remove-one-elemento x '(2 2 10 10) out))) 97 | '((2 (2 10 10)) 98 | (10 (2 2 10)))) 99 | 100 | 101 | ;; On Will's lappy--timings, according to Chez Scheme: 102 | ;; vast majority of the time spent in Z3. 103 | ;; 104 | ;; run 1: 2.6s CPU time, 85s real time 105 | ;; ((* 8 (+ 1 (+ 1 1)))) 106 | ;; 107 | ;; run 2: 3.5s CPU time, 118s real time 108 | ;; ((* 8 (+ 1 (+ 1 1))) 109 | ;; (* 8 (+ (+ 1 1) 1))) 110 | ;; 111 | ;; run 3: 9.4s CPU, 312s real time 112 | ;; ((* 8 (+ 1 (+ 1 1))) 113 | ;; (* 8 (+ (+ 1 1) 1)) 114 | ;; (* (+ 1 (+ 1 1)) 8)) 115 | (test "24-puzzle-a" 116 | (run 1 (e) (puzzleo e '(1 1 1 8) 24 '())) 117 | '((* 8 (+ 1 (+ 1 1))))) 118 | 119 | (test "24-puzzle-g" 120 | (run 1 (e) (puzzleo e '(2 2 10 10) 24 '())) 121 | '((+ 2 (+ 2 (+ 10 10))))) 122 | 123 | ;; On Will's lappy--timings, according to Chez Scheme: 124 | ;; vast majority of the time spent in Z3. 125 | ;; 126 | ;; run 1: 2.3s CPU time, 75s real time 127 | ;; ((/ (* 2 12) (/ 2 2))) 128 | ;; 129 | ;; run 2: 2.5s CPU time, 85s real time 130 | ;; ((/ (* 2 12) (/ 2 2)) 131 | ;; (+ (- 2 2) (* 2 12))) 132 | ;; 133 | ;; run 3: 4.6s CPU time, 156s real time 134 | ;; ((/ (* 2 12) (/ 2 2)) 135 | ;; (+ (- 2 2) (* 2 12)) 136 | ;; (- 2 (- 2 (* 2 12)))) 137 | (test "24-puzzle-h" 138 | (run 1 (e) (puzzleo e '(2 2 2 12) 24 '())) 139 | '((/ (* 2 12) (/ 2 2)))) 140 | 141 | (test "24-puzzle-i" 142 | (run 1 (e) (puzzleo e '(4 6 7 7) 24 '())) 143 | '((+ 4 (+ 6 (+ 7 7))))) 144 | 145 | ;;; boring!! 146 | (test "24-puzzle-b" 147 | (run 1 (q) 148 | (fresh (e num* n1 n2 n3 n4) 149 | (== (list e num*) q) 150 | (== `(,n1 ,n2 ,n3 ,n4) num*) 151 | (puzzleo e num* 24 '()))) 152 | '(((+ 24 (+ 0 (+ 0 0))) (24 0 0 0)))) 153 | 154 | (test "24-puzzle-c" 155 | (run 20 (e) 156 | (fresh (num* n1 n2 n3 n4) 157 | (z/assert `(< 1 ,n1)) 158 | (z/assert `(< 1 ,n2)) 159 | (z/assert `(< 1 ,n3)) 160 | (z/assert `(< 1 ,n4)) 161 | (== `(,n1 ,n2 ,n3 ,n4) num*) 162 | (puzzleo e num* 24 '()))) 163 | '((+ 18 (+ 2 (+ 2 2))) 164 | (+ 15 (+ 3 (+ 3 3))) 165 | (+ 12 (+ 4 (+ 4 4))) 166 | (+ 9 (+ 5 (+ 5 5))) 167 | (+ 13 (+ 4 (+ 4 3))) 168 | (+ 11 (+ 6 (+ 4 3))) 169 | (+ 10 (+ 7 (+ 4 3))) 170 | (+ 12 (+ 4 (+ 5 3))) 171 | (+ 11 (+ 4 (+ 6 3))) 172 | (+ 10 (+ 6 (+ 5 3))) 173 | (+ 9 (+ 8 (+ 4 3))) 174 | (+ 8 (+ 9 (+ 4 3))) 175 | (+ 14 (+ 4 (+ 3 3))) 176 | (+ 10 (+ 5 (+ 6 3))) 177 | (+ 13 (+ 5 (+ 3 3))) 178 | (+ 12 (+ 5 (+ 4 3))) 179 | (+ 10 (+ 4 (+ 7 3))) 180 | (+ 10 (+ 8 (+ 3 3))) 181 | (+ 9 (+ 9 (+ 3 3))) 182 | (+ 7 (+ 10 (+ 4 3))))) 183 | 184 | (test "24-puzzle-d" 185 | (run 10 (e) 186 | (fresh (num* n1 n2 n3 n4 op1 op2 op3 e1 e2 e3 e4) 187 | (z/assert `(< 0 ,n1)) 188 | (z/assert `(< 0 ,n2)) 189 | (z/assert `(< 0 ,n3)) 190 | (z/assert `(< 0 ,n4)) 191 | (== `(,n1 ,n2 ,n3 ,n4) num*) 192 | (== `(,op1 (,op2 ,e1 ,e2) (,op3 ,e3 ,e4)) e) 193 | (puzzleo e num* 24 '()))) 194 | '((+ (+ 21 1) (+ 1 1)) 195 | (+ (+ 18 2) (+ 2 2)) 196 | (+ (+ 15 3) (+ 3 3)) 197 | (+ (+ 12 4) (+ 4 4)) 198 | (+ (+ 16 3) (+ 3 2)) 199 | (+ (+ 14 5) (+ 3 2)) 200 | (+ (+ 13 6) (+ 3 2)) 201 | (+ (+ 15 3) (+ 4 2)) 202 | (+ (+ 14 3) (+ 5 2)) 203 | (+ (+ 13 5) (+ 4 2)))) 204 | 205 | (test "24-puzzle-e" 206 | (run 10 (e) 207 | (fresh (num* n1 n2 n3 n4 op e1 e2) 208 | (z/assert `(< 0 ,n1)) 209 | (z/assert `(< 0 ,n2)) 210 | (z/assert `(< 0 ,n3)) 211 | (z/assert `(< 0 ,n4)) 212 | (== `(,n1 ,n2 ,n3 ,n4) num*) 213 | (=/= op '+) 214 | (== `(,op ,e1 ,e2) e) 215 | (puzzleo e num* 24 '()))) 216 | '((- 27 (+ 1 (+ 1 1))) 217 | (- 30 (+ 2 (+ 2 2))) 218 | (- 33 (+ 3 (+ 3 3))) 219 | (- 36 (+ 4 (+ 4 4))) 220 | (- 32 (+ 3 (+ 3 2))) 221 | (- 34 (+ 5 (+ 3 2))) 222 | (- 35 (+ 6 (+ 3 2))) 223 | (- 33 (+ 3 (+ 4 2))) 224 | (- 34 (+ 3 (+ 5 2))) 225 | (- 35 (+ 5 (+ 4 2))))) 226 | 227 | (test "24-puzzle-f" 228 | (run 10 (e) 229 | (fresh (num* n1 n2 n3 n4 op e1 e2) 230 | (z/assert `(< 0 ,n1)) 231 | (z/assert `(< 0 ,n2)) 232 | (z/assert `(< 0 ,n3)) 233 | (z/assert `(< 0 ,n4)) 234 | (== `(,n1 ,n2 ,n3 ,n4) num*) 235 | (== op '*) 236 | (== `(,op ,e1 ,e2) e) 237 | (puzzleo e num* 24 '()))) 238 | '((* 2 (+ 2 (+ 4 6))) 239 | (* 1 (+ 8 (+ 12 4))) 240 | (* 3 (+ 1 (+ 4 3))) 241 | (* 6 (+ 2 (+ 1 1))) 242 | (* 1 (+ 16 (+ 1 7))) 243 | (* 1 (+ 16 (+ 5 3))) 244 | (* 1 (+ 2 (+ 16 6))) 245 | (* 1 (+ 16 (+ 4 4))) 246 | (* 2 (+ 3 (+ 8 1))) 247 | (* 1 (+ 16 (+ 2 6))))) 248 | -------------------------------------------------------------------------------- /while-abort-tests.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "z3-driver.scm") 3 | (load "test-check.scm") 4 | (load "while-abort.scm") 5 | 6 | ;;; Adapted from https://github.com/webyrd/polyconf-2015/blob/master/talk-code/while-interpreter/while-abort-tests.scm 7 | 8 | (test "abort-1" 9 | (run 1 (q) 10 | (->o 11 | `((abort) 12 | ()) 13 | q)) 14 | '((abort ()))) 15 | 16 | (test "abort-2" 17 | (run 1 (q) 18 | (->o 19 | `((seq 20 | (:= y 4) 21 | (seq 22 | (abort) 23 | (:= x 5))) 24 | ()) 25 | q)) 26 | '((abort ((y . 4))))) 27 | 28 | 29 | 30 | 31 | ;;; symbolic execution example from slide 7 of Stephen Chong's slides 32 | ;;; on symbolic execution (contains contents from Jeff Foster's 33 | ;;; slides) 34 | ;;; 35 | ;;; http://www.seas.harvard.edu/courses/cs252/2011sp/slides/Lec13-SymExec.pdf 36 | 37 | ;;; 1. int a = α, b = β, c = γ 38 | ;;; 2. // symbolic 39 | ;;; 3. int x = 0, y = 0, z = 0; 40 | ;;; 4. if (a) { 41 | ;;; 5. x = -2; 42 | ;;; 6. } 43 | ;;; 7. if (b < 5) { 44 | ;;; 8. if (!a && c) { y = 1; } 45 | ;;; 9. z = 2; 46 | ;;; 10. } 47 | ;;; 11. assert(x+y+z!=3) 48 | 49 | ;;; we will model the 'assert' using 'if' and 'abort' 50 | 51 | 52 | ;;; Slightly modified version that we are actually modelling: 53 | 54 | ;;; 1. int a := α, b := β, c := γ 55 | ;;; 4. if (a != 0) { 56 | ;;; 5. x := -2; 57 | ;;; 6. } 58 | ;;; 7. if (b < 5) { 59 | ;;; 8. if ((a = 0) && (c != 0)) { y := 1; } 60 | ;;; 9. z := 2; 61 | ;;; 10. } 62 | ;;; 11. if (x+(y+z) != 3) { 63 | ;;; abort 64 | ;;; } 65 | 66 | 67 | (define symbolic-exec-prog 68 | `(seq 69 | (if (!= a 0) 70 | (:= x -2) 71 | (skip)) 72 | (seq 73 | (if (< b 5) 74 | (seq 75 | (if (and (= a 0) (!= c 0)) 76 | (:= y 1) 77 | (skip)) 78 | (:= z 2)) 79 | (skip)) 80 | (if (!= (+ x (+ y z)) 3) 81 | (skip) 82 | (abort))))) 83 | 84 | (test "symbolic-exec-prog-a" 85 | (run 4 (q) 86 | (fresh (alpha beta gamma s) 87 | (== (list alpha beta gamma s) q) 88 | (->o 89 | `(,symbolic-exec-prog 90 | ((a . ,alpha) 91 | (b . ,beta) 92 | (c . ,gamma))) 93 | `(abort ,s)))) 94 | '((0 4 1 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 1))) 95 | (0 0 -1 ((z . 2) (y . 1) (a . 0) (b . 0) (c . -1))) 96 | (0 -1 -2 ((z . 2) (y . 1) (a . 0) (b . -1) (c . -2))) 97 | (0 -2 -3 ((z . 2) (y . 1) (a . 0) (b . -2) (c . -3))))) 98 | 99 | (test "symbolic-exec-prog-b" 100 | (run 8 (q) 101 | (fresh (alpha beta gamma s) 102 | (== (list alpha beta gamma s) q) 103 | (z/assert `(<= 0 ,alpha)) 104 | (z/assert `(<= 0 ,beta)) 105 | (z/assert `(<= 0 ,gamma)) 106 | (->o 107 | `(,symbolic-exec-prog 108 | ((a . ,alpha) 109 | (b . ,beta) 110 | (c . ,gamma))) 111 | `(abort ,s)))) 112 | '((0 0 1 ((z . 2) (y . 1) (a . 0) (b . 0) (c . 1))) 113 | (0 1 2 ((z . 2) (y . 1) (a . 0) (b . 1) (c . 2))) 114 | (0 2 3 ((z . 2) (y . 1) (a . 0) (b . 2) (c . 3))) 115 | (0 3 4 ((z . 2) (y . 1) (a . 0) (b . 3) (c . 4))) 116 | (0 4 5 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 5))) 117 | (0 4 6 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 6))) 118 | (0 4 7 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 7))) 119 | (0 4 8 ((z . 2) (y . 1) (a . 0) (b . 4) (c . 8))))) 120 | 121 | 122 | 123 | 124 | 125 | ;;; Slightly modified version that we are actually modelling: 126 | 127 | ;;; 1. int a = α, b = β, c = γ 128 | ;;; 2. // symbolic 129 | ;;; 3. int x = 0, y = 0, z = 0; 130 | ;;; 4. if (a) { 131 | ;;; 5. x = 5; 132 | ;;; 6. } 133 | ;;; 7. if (b <= 4) { 134 | ;;; 8. if (!a && c) { y = 1; } 135 | ;;; 9. z = 2; 136 | ;;; 10. } 137 | ;;; 11. assert(x+y+z!=3) 138 | 139 | ;;; 1. int a := α, b := β, c := γ 140 | ;;; 4. if !(a = 0) { 141 | ;;; 5. x := 5; 142 | ;;; 6. } 143 | ;;; 7. if (b <= 4) { 144 | ;;; 8. if ((a = 0) && !(c = 0)) { y := 1; } 145 | ;;; 9. z := 2; 146 | ;;; 10. } 147 | ;;; 11. if !(x+(y+z) = 3) { 148 | ;;; abort 149 | ;;; } 150 | 151 | 152 | (define symbolic-exec-prog-1 153 | `(seq 154 | (if (not (= 0 a)) 155 | (:= x 5) ;; lol negative numbers! 156 | (skip)) 157 | (seq 158 | (if (<= b 4) ;; might want to use numbero to automatically convert numbers to Oleg form 159 | (seq 160 | (if (and (= 0 a) 161 | (not 162 | (= 0 c))) 163 | (:= y 1) 164 | (skip)) 165 | (:= z 2)) 166 | (skip)) 167 | (if (= (+ x (+ y z)) 3) 168 | (abort) 169 | (skip))))) 170 | 171 | (test "symbolic-exec-prog-1a" 172 | (run 4 (q) 173 | (fresh (alpha beta gamma s) 174 | (== (list alpha beta gamma s) q) 175 | (->o 176 | `(,symbolic-exec-prog-1 177 | ((a . ,alpha) 178 | (b . ,beta) 179 | (c . ,gamma))) 180 | `(abort ,s)))) 181 | '((0 4 1 182 | ((z . 2) 183 | (y . 1) 184 | (a . 0) 185 | (b . 4) 186 | (c . 1))) 187 | (0 0 -1 188 | ((z . 2) 189 | (y . 1) 190 | (a . 0) 191 | (b . 0) 192 | (c . -1))) 193 | (0 -1 2 194 | ((z . 2) 195 | (y . 1) 196 | (a . 0) 197 | (b . -1) 198 | (c . 2))) 199 | (0 -2 -2 200 | ((z . 2) 201 | (y . 1) 202 | (a . 0) 203 | (b . -2) 204 | (c . -2))))) 205 | 206 | ;; simplified answer format 207 | (test "symbolic-exec-prog-1b" 208 | (run 4 (alpha beta gamma) 209 | (fresh (s) 210 | (->o 211 | `(,symbolic-exec-prog-1 212 | ((a . (num ,alpha)) 213 | (b . (num ,beta)) 214 | (c . (num ,gamma)))) 215 | `(abort ,s)))) 216 | '(((() ; a == 0 217 | (0 0 1) ; b == 4 218 | _.0) ; c != 0 219 | (=/= ((_.0 ()))) 220 | (absento (abort _.0))) 221 | ((() ; a == 0 222 | () ; b == 0 223 | _.0) ; c != 0 224 | (=/= ((_.0 ()))) 225 | (absento (abort _.0))) 226 | ((() ; a == 0 227 | (1) ; b == 1 228 | _.0) ; c != 0 229 | (=/= ((_.0 ()))) 230 | (absento (abort _.0))) 231 | ((() ; a == 0 232 | (_.0 1) ; b == 2 or 3 233 | _.1) ; c != 3 234 | (=/= ((_.1 ()))) 235 | (absento (abort _.0) (abort _.1))))) 236 | 237 | ;; very simplified answer format 238 | (test "symbolic-exec-prog-1c" 239 | (run 1 (alpha beta gamma) 240 | (fresh (s) 241 | (->o 242 | `(,symbolic-exec-prog-1 243 | ((a . (num ,alpha)) 244 | (b . (num ,beta)) 245 | (c . (num ,gamma)))) 246 | `(abort ,s)))) 247 | '(((() ; a == 0 248 | (0 0 1) ; b == 4 249 | _.0) ; c != 0 250 | (=/= ((_.0 ()))) 251 | (absento (abort _.0))))) 252 | 253 | (test "symbolic-exec-prog-1-subexpr-1" 254 | (run* (c-val val) 255 | (Bo 256 | `(and (= ,(num 0) a) 257 | (not 258 | (= ,(num 0) c))) 259 | `((a . (num ())) (c . (num ,c-val))) 260 | val)) 261 | '(((_.0 tt) (=/= ((_.0 ())))) 262 | (() ff))) 263 | 264 | 265 | #| 266 | 267 | ;;; Example 1 from Zvonimir Rakamaric's CS 6110 slides on symbolic 268 | ;;; testing: 269 | ;;; 270 | ;;; http://www.zvonimir.info/teaching/cs6110-2015-spring/cs6110_lecture_10.pdf 271 | ;; 272 | ;; int x, y; 273 | ;; if (x > y) { 274 | ;; x = x + y; 275 | ;; y = x – y; 276 | ;; x = x – y; 277 | ;; if (x > y) 278 | ;; assert false; 279 | ;; } 280 | 281 | ;;; Is this example broken? Supposedly x = 4, y = 3 works, but this 282 | ;;; doesn't seem to be the case. Is the assert even reachable? 283 | 284 | (define symbolic-exec-prog-2 285 | `(seq 286 | (if (< y x) 287 | (seq 288 | (:= x (+ x y)) 289 | (seq 290 | (:= y (- x y)) 291 | (seq 292 | (:= x (- x y)) 293 | (if (< y x) 294 | (abort) 295 | (skip))))) 296 | (skip)) 297 | (skip))) 298 | 299 | (test "symbolic-exec-prog-2b" 300 | (run 1 (x y) 301 | (== (build-num 4) x) 302 | (== (build-num 3) y) 303 | (fresh (s) 304 | (->o 305 | `(,symbolic-exec-prog-2 306 | ((x . (num ,x)) 307 | (y . (num ,y)))) 308 | s))) 309 | '???) 310 | 311 | 312 | (test "symbolic-exec-prog-2a" 313 | (run 1 (alpha beta) 314 | (fresh (s) 315 | (->o 316 | `(,symbolic-exec-prog-2 317 | ((x . (num ,alpha)) 318 | (y . (num ,beta)))) 319 | `(abort ,s)))) 320 | '(((() ; a == 0 321 | (0 0 1) ; b == 4 322 | _.0) ; c != 0 323 | (=/= ((_.0 ()))) 324 | (absento (abort _.0))))) 325 | 326 | |# 327 | -------------------------------------------------------------------------------- /while-abort.scm: -------------------------------------------------------------------------------- 1 | ;;; The following example is adapted from: 2 | ;;; 3 | ;;; https://github.com/webyrd/polyconf-2015/blob/master/talk-code/while-interpreter/while-abort.scm 4 | 5 | 6 | ;; Relational interpreter for the While language, extended with 'abort'. 7 | 8 | ;; Based on the While language description in 'Semantics with 9 | ;; Applications' by Nielson and Nielson. Here we use the 1999 revised 10 | ;; edition of the book, available online at http://www.daimi.au.dk/~hrn. 11 | ;; The original edition was published in 1992 by John Wiley & Sons. 12 | 13 | 14 | 15 | ;; Arithmetic expression language (Table 1.1 on p.13 of the book) 16 | 17 | 18 | ;;; Important: all variables are bound to zero by default 19 | (define store-lookupo 20 | (lambda (x s val) 21 | (fresh () 22 | (symbolo x) 23 | (conde 24 | [(== '() s) 25 | (== 0 val)] 26 | [(fresh (y v rest) 27 | (== `((,y . ,v) . ,rest) s) 28 | (conde 29 | [(== x y) (== v val)] 30 | [(=/= x y) (symbolo y) (store-lookupo x rest val)]))])))) 31 | 32 | (define not-in-storeo 33 | (lambda (x s) 34 | (fresh () 35 | (symbolo x) 36 | (conde 37 | [(== '() s)] 38 | [(fresh (y _ s^) 39 | (== `((,y . ,_) . ,s^) s) 40 | (=/= y x) 41 | (symbolo y) 42 | (not-in-storeo x s^))])))) 43 | 44 | (define update-storeo 45 | (lambda (x v s s-out) 46 | (fresh () 47 | (symbolo x) 48 | (conde 49 | [(replaceo x v s s-out)] 50 | [(== `((,x . ,v) . ,s) s-out) 51 | (not-in-storeo x s)])))) 52 | 53 | (define replaceo 54 | (lambda (x val s s-out) 55 | (fresh (y v rest s^) 56 | (== `((,y . ,v) . ,rest) s) 57 | (symbolo x) 58 | (conde 59 | [(== x y) 60 | (== `((,x . ,val) . ,rest) s-out)] 61 | [(=/= x y) 62 | (== (cons `(,y . ,v) s^) s-out) 63 | (symbolo y) 64 | (replaceo x val rest s^)])))) 65 | 66 | 67 | 68 | (define Ao 69 | (lambda (expr s num) 70 | (conde 71 | 72 | [(symbolo expr) (store-lookupo expr s num)] 73 | 74 | ;; Perhaps should use (z/assert `(= ,expr ,num)) instead of (== expr num) 75 | [(numbero expr) (== expr num)] 76 | 77 | [(fresh (a1 a2 n1 n2) 78 | (== `(+ ,a1 ,a2) expr) 79 | (z/assert `(= ,num (+ ,n1 ,n2))) 80 | (Ao a1 s n1) 81 | (Ao a2 s n2))] 82 | 83 | [(fresh (a1 a2 n1 n2) 84 | (== `(- ,a1 ,a2) expr) 85 | (z/assert `(= ,num (- ,n1 ,n2))) 86 | (Ao a1 s n1) 87 | (Ao a2 s n2))] 88 | 89 | [(fresh (a1 a2 n1 n2) 90 | (== `(* ,a1 ,a2) expr) 91 | (z/assert `(= ,num (* ,n1 ,n2))) 92 | (Ao a1 s n1) 93 | (Ao a2 s n2))] 94 | 95 | ))) 96 | 97 | ;; Boolean expression language (Table 1.2 on p.14 of the book) 98 | 99 | (define Bo 100 | (lambda (expr s val) 101 | (conde 102 | [(== 'true expr) 103 | (== 'tt val)] 104 | [(== 'false expr) 105 | (== 'ff val)] 106 | 107 | [(fresh (b v) 108 | (== `(not ,b) expr) 109 | (conde 110 | [(== 'tt val) (== 'ff v)] 111 | [(== 'ff val) (== 'tt v)]) 112 | (Bo b s v))] 113 | 114 | [(fresh (b1 b2 v1 v2) 115 | (== `(and ,b1 ,b2) expr) 116 | (Bo b1 s v1) 117 | (Bo b2 s v2) 118 | (conde 119 | [(== 'tt val) (== 'tt v1) (== 'tt v2)] 120 | [(== 'ff val) 121 | (conde 122 | [(== 'ff v1)] 123 | [(== 'tt v1) (== 'ff v2)])]))] 124 | 125 | [(fresh (a1 a2 n1 n2) 126 | (== `(= ,a1 ,a2) expr) 127 | (conde 128 | [(== 'tt val) (z/assert `(= ,n1 ,n2))] 129 | [(== 'ff val) (z/assert `(not (= ,n1 ,n2)))]) 130 | (Ao a1 s n1) 131 | (Ao a2 s n2))] 132 | 133 | [(fresh (a1 a2 n1 n2) 134 | (== `(!= ,a1 ,a2) expr) 135 | (conde 136 | [(== 'tt val) (z/assert `(not (= ,n1 ,n2)))] 137 | [(== 'ff val) (z/assert `(= ,n1 ,n2))]) 138 | (Ao a1 s n1) 139 | (Ao a2 s n2))] 140 | 141 | [(fresh (a1 a2 n1 n2) 142 | (== `(< ,a1 ,a2) expr) 143 | (conde 144 | [(== 'tt val) (z/assert `(< ,n1 ,n2))] 145 | [(== 'ff val) (z/assert `(<= ,n2 ,n1))]) 146 | (Ao a1 s n1) 147 | (Ao a2 s n2))] 148 | 149 | [(fresh (a1 a2 n1 n2) 150 | (== `(<= ,a1 ,a2) expr) 151 | (conde 152 | [(== 'tt val) (z/assert `(<= ,n1 ,n2))] 153 | [(== 'ff val) (z/assert `(< ,n2 ,n1))]) 154 | (Ao a1 s n1) 155 | (Ao a2 s n2))] 156 | 157 | ))) 158 | 159 | ;; Natural semantics for While (Table 2.1 on p.20 of the book) 160 | 161 | (define with-abort-g 162 | (lambda (in out g) 163 | (fresh () 164 | (conde 165 | [(absento 'abort in) 166 | (g in out)] 167 | [(fresh (s) 168 | (== `(abort ,s) in) 169 | (== in out))])))) 170 | 171 | (define-syntax with-abort 172 | (syntax-rules () 173 | [(_ in out body body* ...) 174 | (with-abort-g in out (lambda (in out) (fresh () body body* ...)))])) 175 | 176 | (define ->o 177 | (lambda (config out) 178 | (conde 179 | [(fresh (s) 180 | (== `((skip) ,s) config) 181 | (== s out))] 182 | 183 | [(fresh (s) 184 | (== `((abort) ,s) config) 185 | (== `(abort ,s) out))] 186 | 187 | [(fresh (x a v s s^) 188 | (== `((:= ,x ,a) ,s) config) 189 | (== s^ out) 190 | (symbolo x) 191 | (Ao a s v) 192 | (update-storeo x v s s^))] 193 | 194 | [(fresh (b bv S1 S2 s) 195 | (== `((if ,b ,S1 ,S2) ,s) config) 196 | (Bo b s bv) 197 | (conde 198 | [(== 'tt bv) 199 | (->o `(,S1 ,s) out)] 200 | [(== 'ff bv) 201 | (->o `(,S2 ,s) out)]))] 202 | 203 | [(fresh (S1 S2 s s^) 204 | (== `((seq ,S1 ,S2) ,s) config) 205 | (->o `(,S1 ,s) s^) 206 | (with-abort s^ out 207 | (->o `(,S2 ,s^) out)))] 208 | 209 | [(fresh (b bv S s) 210 | (== `((while ,b ,S) ,s) config) 211 | (Bo b s bv) 212 | (conde 213 | [(== 'ff bv) 214 | (== s out)] 215 | [(== 'tt bv) 216 | (fresh (s^) 217 | (->o `(,S ,s) s^) 218 | (with-abort s^ out 219 | (->o `((while ,b ,S) ,s^) out)))]))] 220 | 221 | ))) 222 | 223 | -------------------------------------------------------------------------------- /yices-server.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define-values (z3-out z3-in z3-err z3-p) 5 | (open-process-ports "yices-smt2 --incremental --smt2-model-format" 'block (native-transcoder))) 6 | (fprintf z3-out "~a\n" '(set-logic ALL)) 7 | (define (z3-reset!) 8 | (let-values (((out in err p) 9 | (open-process-ports "yices-smt2 --incremental --smt2-model-format" 'block (native-transcoder)))) 10 | (set! z3-out out) 11 | (set! z3-in in) 12 | (set! z3-err err) 13 | (set! z3-p p) 14 | (fprintf z3-out "~a\n" '(set-logic ALL)))) 15 | (define (z3-check-in!) 16 | (if (eof-object? z3-in) 17 | (error 'z3-check-in "z3 input port") 18 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 19 | ;; (z3-reset!) 20 | ;; #t) 21 | #t)) 22 | 23 | (define read-sat 24 | (lambda () 25 | (z3-check-in!) 26 | (let ([r (read z3-in)]) 27 | (if (eq? r 'sat) 28 | #t 29 | (if (eq? r 'unsat) 30 | #f 31 | (if (eq? r 'unknown) 32 | (begin 33 | (printf "read-sat: unknown\n") 34 | ;;(call-z3 '((pop))) 35 | #f) 36 | (error 'read-sat (format "~a" r)))))))) 37 | 38 | (define call-z3 39 | (lambda (xs) 40 | (for-each (lambda (x) 41 | ;;(printf "~a\n" x) 42 | (fprintf z3-out "~a\n" x)) xs) 43 | (flush-output-port z3-out))) 44 | 45 | (define check-sat 46 | (lambda (xs) 47 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 48 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 49 | (read-sat))) 50 | 51 | (define read-model 52 | (lambda () 53 | (let ([m (read z3-in)]) 54 | ;;(printf "model: ~a\n" m) 55 | (map (lambda (x) 56 | (cons (cadr x) 57 | (if (null? (caddr x)) 58 | (let ([r (cadddr (cdr x))]) 59 | (cond 60 | ((eq? r 'false) #f) 61 | ((eq? r 'true) #t) 62 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 63 | (else (eval r)))) 64 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 65 | (cdr m))))) 66 | 67 | (define get-model-inc 68 | (lambda () 69 | (call-z3 '((get-model))) 70 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 71 | (read-model))) 72 | 73 | (define get-model 74 | (lambda (xs) 75 | (and (check-sat xs) 76 | (get-model-inc)))) 77 | 78 | (define neg-model 79 | (lambda (model) 80 | (cons 81 | 'assert 82 | (list 83 | (cons 84 | 'or 85 | (map 86 | (lambda (xv) 87 | `(not (= ,(car xv) ,(cdr xv)))) 88 | model)))))) 89 | 90 | (define get-next-model 91 | (lambda (xs ms) 92 | (let* ([ms (map (lambda (m) 93 | (filter (lambda (x) ; ignoring functions 94 | (or (number? (cdr x)) 95 | (symbol? (cdr x)) ; for bitvectors 96 | )) m)) 97 | ms)]) 98 | (if (member '() ms) #f ; if we're skipping a model, let us stop 99 | (and (check-sat (append xs (map neg-model ms))) 100 | (get-model-inc)))))) 101 | -------------------------------------------------------------------------------- /z3-driver.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define log-all-calls #f) 5 | 6 | (define read-sat 7 | (lambda (fn) 8 | (let ([p (open-input-file fn)]) 9 | (let ([r (read p)]) 10 | (close-input-port p) 11 | (when (eq? r 'unknown) 12 | (printf "unknown\n")) 13 | (eq? r 'sat))))) 14 | 15 | (define call-z3 16 | (lambda (xs) 17 | (let ([p (open-output-file "out.smt" 'replace)]) 18 | (for-each (lambda (x) (fprintf p "~a\n" x)) xs) 19 | (close-output-port p) 20 | ;; WEB -- I think this is equivalent to, but faster than, the commented three calls to sed, below 21 | ;; see https://unix.stackexchange.com/questions/97428/sed-how-to-do-several-consecutive-substitutions-but-process-file-only-once#97437 22 | (system "perl -i -pe 's/#t/true/g; s/#f/false/g; s/bitvec-/#b/g' out.smt") 23 | ;; (system "perl -i -pe 's/#t/true/g' out.smt") 24 | ;; (system "perl -i -pe 's/#f/false/g' out.smt") 25 | ;; (system "perl -i -pe 's/bitvec-/#b/g' out.smt") 26 | 27 | (let ((r (system "z3 out.smt >out.txt"))) 28 | (when log-all-calls 29 | (system (format "cp out.smt out~d.smt" (+ z3-counter-check-sat z3-counter-get-model))) 30 | (system (format "cp out.txt out~d.txt" (+ z3-counter-check-sat z3-counter-get-model)))) 31 | (system "perl -i -pe 's/#b/bitvec-/g' out.txt") 32 | (when (not (= r 0)) 33 | (error 'call-z3 "error in z3 out.smt > out.txt")))))) 34 | 35 | (define check-sat 36 | (lambda (xs) 37 | (call-z3 (append xs '((check-sat) (exit)))) 38 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 39 | (read-sat "out.txt"))) 40 | 41 | (define read-model 42 | (lambda (fn) 43 | (let ([p (open-input-file fn)]) 44 | (let ([r (read p)]) 45 | (if (eq? r 'sat) 46 | (let ([m (read p)]) 47 | (close-input-port p) 48 | (map (lambda (x) 49 | (cons (cadr x) 50 | (if (null? (caddr x)) 51 | (let ([r (cadddr (cdr x))]) 52 | (cond 53 | ((eq? r 'false) #f) 54 | ((eq? r 'true) #t) 55 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 56 | (else (eval r)))) 57 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 58 | m)) 59 | (begin 60 | (close-input-port p) 61 | #f)))))) 62 | 63 | (define get-model 64 | (lambda (xs) 65 | (call-z3 (append xs '((check-sat) (get-model) (exit)))) 66 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 67 | (read-model "out.txt"))) 68 | 69 | (define neg-model 70 | (lambda (model) 71 | (cons 72 | 'assert 73 | (list 74 | (cons 75 | 'or 76 | (map 77 | (lambda (xv) 78 | `(not (= ,(car xv) ,(cdr xv)))) 79 | model)))))) 80 | 81 | (define check-model-unique 82 | (lambda (xs model) 83 | (let ([r 84 | (check-sat 85 | (append xs (list (neg-model model))))]) 86 | (not r)))) 87 | 88 | (define get-all-models 89 | (lambda (xs ms) 90 | (let* ([ys (append xs (map neg-model ms))]) 91 | (if (not (check-sat ys)) 92 | (reverse ms) 93 | (get-all-models xs (cons (get-model ys) ms)))))) 94 | 95 | (define get-next-model 96 | (lambda (xs ms) 97 | (let* ([ms (map (lambda (m) 98 | (filter (lambda (x) ; ignoring functions 99 | (or (number? (cdr x)) 100 | (symbol? (cdr x)) ; for bitvectors 101 | (boolean? (cdr x)) ; for booleans 102 | )) m)) 103 | ms)]) 104 | (if (member '() ms) #f ; if we're skipping a model, let us stop 105 | (let ([ys (append xs (map neg-model ms))]) 106 | (and (check-sat ys) 107 | (get-model ys))))))) 108 | -------------------------------------------------------------------------------- /z3-noserver.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define read-sat 5 | (lambda (fn) 6 | (let ([p (open-input-file fn)]) 7 | (let ([r (read p)]) 8 | (close-input-port p) 9 | (eq? r 'sat))))) 10 | 11 | (define call-z3 12 | (lambda (xs) 13 | (let ([p (open-output-file "out.smt" 'replace)]) 14 | (for-each (lambda (x) (fprintf p "~a\n" x)) xs) 15 | (close-output-port p) 16 | (system "perl -i -pe 's/#t/true/g' out.smt") 17 | (system "perl -i -pe 's/#f/false/g' out.smt") 18 | (system "perl -i -pe 's/bitvec-/#b/g' out.smt") 19 | (let ((r (system "z3 out.smt >out.txt"))) 20 | (system "perl -i -pe 's/#b/bitvec-/g' out.txt") 21 | (if (not (= r 0)) 22 | (error 'call-z3 "error in z3 out.smt > out.txt")))))) 23 | 24 | (define check-sat 25 | (lambda (xs) 26 | (call-z3 (append xs '((check-sat) (exit)))) 27 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 28 | (read-sat "out.txt"))) 29 | 30 | (define read-model 31 | (lambda (fn) 32 | (let ([p (open-input-file fn)]) 33 | (let ([r (read p)]) 34 | (if (eq? r 'sat) 35 | (let ([m (read p)]) 36 | (close-input-port p) 37 | (map (lambda (x) 38 | (cons (cadr x) 39 | (if (null? (caddr x)) 40 | (let ([r (cadddr (cdr x))]) 41 | (cond 42 | ((eq? r 'false) #f) 43 | ((eq? r 'true) #t) 44 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 45 | (else (eval r)))) 46 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 47 | (cdr m))) 48 | (begin 49 | (close-input-port p) 50 | #f)))))) 51 | 52 | (define get-model 53 | (lambda (xs) 54 | (call-z3 (append xs '((check-sat) (get-model) (exit)))) 55 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 56 | (read-model "out.txt"))) 57 | 58 | (define neg-model 59 | (lambda (model) 60 | (cons 61 | 'assert 62 | (list 63 | (cons 64 | 'or 65 | (map 66 | (lambda (xv) 67 | `(not (= ,(car xv) ,(cdr xv)))) 68 | model)))))) 69 | 70 | (define check-model-unique 71 | (lambda (xs model) 72 | (let ([r 73 | (check-sat 74 | (append xs (list (neg-model model))))]) 75 | (not r)))) 76 | 77 | (define get-all-models 78 | (lambda (xs ms) 79 | (let* ([ys (append xs (map neg-model ms))]) 80 | (if (not (check-sat ys)) 81 | (reverse ms) 82 | (get-all-models xs (cons (get-model ys) ms)))))) 83 | 84 | (define get-next-model 85 | (lambda (xs ms) 86 | (let* ([ms (map (lambda (m) 87 | (filter (lambda (x) ; ignoring functions 88 | (or (number? (cdr x)) 89 | (symbol? (cdr x)) ; for bitvectors 90 | )) m)) 91 | ms)]) 92 | (if (member '() ms) #f ; if we're skipping a model, let us stop 93 | (let ([ys (append xs (map neg-model ms))]) 94 | (and (check-sat ys) 95 | (get-model ys))))))) 96 | -------------------------------------------------------------------------------- /z3-server-robust.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define log-all-calls #f) 5 | 6 | (define-values (z3-out z3-in z3-err z3-p) 7 | (open-process-ports "z3 -in" 'block (native-transcoder))) 8 | (define (z3-reset!) 9 | (let-values (((out in err p) 10 | (open-process-ports "z3 -in" 'block (native-transcoder)))) 11 | (set! z3-out out) 12 | (set! z3-in in) 13 | (set! z3-err err) 14 | (set! z3-p p))) 15 | (define (z3-check-in!) 16 | (if (eof-object? z3-in) 17 | (error 'z3-check-in "z3 input port") 18 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 19 | ;; (z3-reset!) 20 | ;; #t) 21 | #t)) 22 | 23 | (define read-sat 24 | (lambda () 25 | (z3-check-in!) 26 | (let ([r (read z3-in)]) 27 | (when log-all-calls (printf ";; ~a\n" r)) 28 | (if (eq? r 'sat) 29 | #t 30 | (if (eq? r 'unsat) 31 | #f 32 | (if (eq? r 'unknown) 33 | (begin 34 | (printf "read-sat: unknown\n") 35 | (call-z3 '((pop))) 36 | #f) 37 | (error 'read-sat (format "~a" r)))))))) 38 | 39 | (define call-z3 40 | (lambda (xs) 41 | (for-each (lambda (x) 42 | (when log-all-calls (printf "~a\n" x)) 43 | (when (and (pair? x) 44 | (eq? 'assert (car x)) 45 | (pair? (cadr x)) 46 | (eq? '=> (caadr x))) 47 | (fprintf z3-out "(push) ")) 48 | (fprintf z3-out "~a\n" x)) xs) 49 | (flush-output-port z3-out))) 50 | 51 | (define check-sat 52 | (lambda (xs) 53 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 54 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 55 | (read-sat))) 56 | 57 | (define read-model 58 | (lambda () 59 | (let ([m (read z3-in)]) 60 | (when log-all-calls (printf "~a\n" m)) 61 | (map (lambda (x) 62 | (cons (cadr x) 63 | (if (null? (caddr x)) 64 | (let ([r (cadddr (cdr x))]) 65 | (cond 66 | ((eq? r 'false) #f) 67 | ((eq? r 'true) #t) 68 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 69 | (else (eval r)))) 70 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 71 | (cdr m))))) 72 | 73 | (define get-model-inc 74 | (lambda () 75 | (call-z3 '((get-model))) 76 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 77 | (read-model))) 78 | 79 | (define get-model 80 | (lambda (xs) 81 | (and (check-sat xs) 82 | (get-model-inc)))) 83 | 84 | (define neg-model 85 | (lambda (model) 86 | (cons 87 | 'assert 88 | (list 89 | (cons 90 | 'or 91 | (map 92 | (lambda (xv) 93 | `(not (= ,(car xv) ,(cdr xv)))) 94 | model)))))) 95 | 96 | (define get-next-model 97 | (lambda (xs ms) 98 | (let* ([ms (map (lambda (m) 99 | (filter (lambda (x) ; ignoring functions 100 | (or (number? (cdr x)) 101 | (symbol? (cdr x)) ; for bitvectors 102 | )) m)) 103 | ms)]) 104 | (if (member '() ms) #f ; if we're skipping a model, let us stop 105 | (and (check-sat (append xs (map neg-model ms))) 106 | (get-model-inc)))))) 107 | -------------------------------------------------------------------------------- /z3-server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/system) 4 | 5 | (provide (all-defined-out)) 6 | 7 | (define ns (make-base-namespace)) 8 | 9 | (define z3-counter-check-sat 0) 10 | (define z3-counter-get-model 0) 11 | 12 | (define z3-out #f) 13 | (define z3-in #f) 14 | (define z3-err #f) 15 | (define z3-p #f) 16 | (define (z3-reset!) 17 | (let ((r 18 | (process "z3 -in"))) 19 | (set! z3-in (car r)) 20 | (set! z3-out (cadr r)) 21 | (set! z3-p (caddr r)) 22 | (set! z3-err (cadddr r)))) 23 | (z3-reset!) 24 | (define (z3-check-in!) 25 | (if (eof-object? z3-in) 26 | (error 'z3-check-in "z3 input port") 27 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 28 | ;; (z3-reset!) 29 | ;; #t) 30 | #t)) 31 | 32 | (define read-sat 33 | (lambda () 34 | (z3-check-in!) 35 | (let ([r (read z3-in)]) 36 | (if (eq? r 'sat) 37 | #t 38 | (if (eq? r 'unsat) 39 | #f 40 | (if (eq? r 'unknown) 41 | (begin 42 | (printf "read-sat: unknown\n") 43 | ;;(call-z3 '((pop))) 44 | #f) 45 | (error 'read-sat (format "~a" r)))))))) 46 | 47 | (define call-z3 48 | (lambda (xs) 49 | (for-each (lambda (x) 50 | ;;(printf "~a\n" x) 51 | (fprintf z3-out "~a\n" x)) xs) 52 | (flush-output z3-out))) 53 | 54 | (define check-sat 55 | (lambda (xs) 56 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 57 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 58 | (read-sat))) 59 | 60 | (define read-model 61 | (lambda () 62 | (let ([m (read z3-in)]) 63 | ;;(display m) 64 | (map (lambda (x) 65 | (cons (cadr x) 66 | (if (null? (caddr x)) 67 | (let ([r (cadddr (cdr x))]) 68 | (cond 69 | ((eq? r 'false) #f) 70 | ((eq? r 'true) #t) 71 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 72 | (else (eval r ns)))) 73 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 74 | (cdr m))))) 75 | 76 | (define get-model-inc 77 | (lambda () 78 | (call-z3 '((get-model))) 79 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 80 | (read-model))) 81 | 82 | (define get-model 83 | (lambda (xs) 84 | (and (check-sat xs) 85 | (get-model-inc)))) 86 | 87 | (define neg-model 88 | (lambda (model) 89 | (cons 90 | 'assert 91 | (list 92 | (cons 93 | 'or 94 | (map 95 | (lambda (xv) 96 | `(not (= ,(car xv) ,(cdr xv)))) 97 | model)))))) 98 | 99 | (define get-next-model 100 | (lambda (xs ms) 101 | (let* ([ms (map (lambda (m) 102 | (filter (lambda (x) ; ignoring functions 103 | (or (number? (cdr x)) 104 | (symbol? (cdr x)) ; for bitvectors 105 | )) m)) 106 | ms)]) 107 | (if (member '() ms) #f ; if we're skipping a model, let us stop 108 | (and (check-sat (append xs (map neg-model ms))) 109 | (get-model-inc)))))) 110 | -------------------------------------------------------------------------------- /z3-server.scm: -------------------------------------------------------------------------------- 1 | (define z3-counter-check-sat 0) 2 | (define z3-counter-get-model 0) 3 | 4 | (define log-all-calls #f) 5 | 6 | (define-values (z3-out z3-in z3-err z3-p) 7 | (open-process-ports "z3 -in" 'block (native-transcoder))) 8 | (define (z3-reset!) 9 | (let-values (((out in err p) 10 | (open-process-ports "z3 -in" 'block (native-transcoder)))) 11 | (set! z3-out out) 12 | (set! z3-in in) 13 | (set! z3-err err) 14 | (set! z3-p p))) 15 | (define (z3-check-in!) 16 | (if (eof-object? z3-in) 17 | (error 'z3-check-in "z3 input port") 18 | ;; (if (= 0 (mod z3-counter-check-sat 300)) 19 | ;; (z3-reset!) 20 | ;; #t) 21 | #t)) 22 | 23 | (define read-sat 24 | (lambda () 25 | (z3-check-in!) 26 | (let ([r (read z3-in)]) 27 | (when log-all-calls (printf ";; ~a\n" r)) 28 | (if (eq? r 'sat) 29 | #t 30 | (if (eq? r 'unsat) 31 | #f 32 | (if (eq? r 'unknown) 33 | (begin 34 | (printf "read-sat: unknown\n") 35 | ;;(call-z3 '((pop))) 36 | #f) 37 | (error 'read-sat (format "~a" r)))))))) 38 | 39 | (define call-z3 40 | (lambda (xs) 41 | (for-each (lambda (x) 42 | (when log-all-calls (printf "~a\n" x)) 43 | (fprintf z3-out "~a\n" x)) xs) 44 | (flush-output-port z3-out))) 45 | 46 | (define check-sat 47 | (lambda (xs) 48 | (call-z3 (append (cons '(reset) xs) '((check-sat)))) 49 | (set! z3-counter-check-sat (+ z3-counter-check-sat 1)) 50 | (read-sat))) 51 | 52 | (define read-model 53 | (lambda () 54 | (let ([m (read z3-in)]) 55 | (when log-all-calls (printf "~a\n" m)) 56 | (map (lambda (x) 57 | (cons (cadr x) 58 | (if (null? (caddr x)) 59 | (let ([r (cadddr (cdr x))]) 60 | (cond 61 | ((eq? r 'false) #f) 62 | ((eq? r 'true) #t) 63 | ((and (pair? (cadddr x)) (eq? (cadr (cadddr x)) 'BitVec)) r) 64 | (else (eval r)))) 65 | `(lambda ,(map car (caddr x)) ,(cadddr (cdr x)))))) 66 | (cdr m))))) 67 | 68 | (define get-model-inc 69 | (lambda () 70 | (call-z3 '((get-model))) 71 | (set! z3-counter-get-model (+ z3-counter-get-model 1)) 72 | (read-model))) 73 | 74 | (define get-model 75 | (lambda (xs) 76 | (and (check-sat xs) 77 | (get-model-inc)))) 78 | 79 | (define neg-model 80 | (lambda (model) 81 | (cons 82 | 'assert 83 | (list 84 | (cons 85 | 'or 86 | (map 87 | (lambda (xv) 88 | `(not (= ,(car xv) ,(cdr xv)))) 89 | model)))))) 90 | 91 | (define get-next-model 92 | (lambda (xs ms) 93 | (let* ([ms (map (lambda (m) 94 | (filter (lambda (x) ; ignoring functions 95 | (or (number? (cdr x)) 96 | (symbol? (cdr x)) ; for bitvectors 97 | )) m)) 98 | ms)]) 99 | (if (member '() ms) #f ; if we're skipping a model, let us stop 100 | (and (check-sat (append xs (map neg-model ms))) 101 | (get-model-inc)))))) 102 | -------------------------------------------------------------------------------- /z3-tests.scm: -------------------------------------------------------------------------------- 1 | (load "z3-driver.scm") 2 | (load "test-check.scm") 3 | 4 | (test "1" 5 | (check-sat 6 | '((declare-fun x () Int) 7 | (assert (>= x 0)))) 8 | #t) 9 | 10 | (test "2" 11 | (check-sat 12 | '((declare-fun x () Int) 13 | (assert (= x 0)) 14 | (assert (= x 1)))) 15 | #f) 16 | 17 | (test "3" 18 | (get-model 19 | '((declare-fun x () Int) 20 | (assert (= x 0)))) 21 | '((x . 0))) 22 | 23 | --------------------------------------------------------------------------------