Friedman, Daniel P. and Byrd, William E. and Kiselyov, Oleg and Hemann, Jason, 2018. The Reasoned Schemer. 2nd edition, The MIT Press,
Abstract: A new edition of a book, written in a humorous question-and-answer style, that shows how to implement and use an elegant little programming language for logic programming. The goal of this book is to show the beauty and elegance of relational programming, which captures the essence of logic programming. The book shows how to implement a relational programming language in Scheme, or in any other functional language, and demonstrates the remarkable flexibility of the resulting relational programs. As in the first edition, the pedagogical method is a series of questions and answers, which proceed with the characteristic humor that marked The Little Schemer and The Seasoned Schemer. Familiarity with a functional language or with the first five chapters of The Little Schemer is assumed. For this second edition, the authors have greatly simplified the programming language used in the book, as well as the implementation of the language. In addition to revising the text extensively, and simplifying and revising the Laws and Commandments, they have added explicit Translation rules to ease translation of Scheme functions into relations.
Tests
test/find: pass
(define (test/find _)
(let* ((v1 (make-μkanren-var 0))
(v2 (make-μkanren-var 1))
(s0 μkanren-state-empty)
(s1 (make-μkanren-state
1
(cons/sbral 'a (μkanren-state-S s0))
empty/sbral
empty/sbral
empty/sbral
'()))
(s2 (make-μkanren-state
2
(cons/sbral v1 (μkanren-state-S s1))
empty/sbral
empty/sbral
empty/sbral
'())))
(⊦= 5 (μkanren-state-find 5 s2))
(⊦= 'a (μkanren-state-find v1 s2))
(⊦= 'a (μkanren-state-find v2 s2))))
((eta 0.006) (memory #(12582912 2572064 1048576)) (stdout "") (stderr ""))
test/=°: pass
(define (test/=° _) (⊦= '(α) (°->list/ground (=° 'z 'z))))
((eta 0.014) (memory #(12582912 2573160 1048576)) (stdout "") (stderr ""))
test/sharing: pass
(define (test/sharing _)
(⊦= '(((α z) z (α β)))
(°->list/ground
(fresh°
r
(n q x)
(=° q 'z)
(fresh° (w r) (=° n (list w q)) (=° x (list w r)))))))
((eta 0.007) (memory #(12582912 2571760 1048576)) (stdout "") (stderr ""))
test/peano°: pass
(define (test/peano° _)
(define-relation
(peano° n)
(or° (=° n 'z) (fresh° (r) (=° n `(s ,r)) (peano° r))))
(define-relation
(church° n)
(fresh° (b) (=° n `(λ (s) (λ (z) ,b))) (peano° b)))
(⊦= '(z (s z)
(s (s z))
(s (s (s z)))
(s (s (s (s z))))
(s (s (s (s (s z)))))
(s (s (s (s (s (s z))))))
(s (s (s (s (s (s (s z)))))))
(s (s (s (s (s (s (s (s z))))))))
(s (s (s (s (s (s (s (s (s z))))))))))
(°->list/ground (take° 10 (fresh° (n) (peano° n)))))
(⊦= '((λ (s) (λ (z) z))
(λ (s) (λ (z) (s z)))
(λ (s) (λ (z) (s (s z))))
(λ (s) (λ (z) (s (s (s z)))))
(λ (s) (λ (z) (s (s (s (s z))))))
(λ (s) (λ (z) (s (s (s (s (s z)))))))
(λ (s) (λ (z) (s (s (s (s (s (s z))))))))
(λ (s) (λ (z) (s (s (s (s (s (s (s z)))))))))
(λ (s) (λ (z) (s (s (s (s (s (s (s (s z))))))))))
(λ (s) (λ (z) (s (s (s (s (s (s (s (s (s z))))))))))))
(°->list/ground (take° 10 (fresh° (n) (church° n))))))
((eta 0.016) (memory #(12582912 2583480 1048576)) (stdout "") (stderr ""))
test/append°: pass
(define (test/append° _)
(define-relation
(append° r s rs)
(cond°
((null° r) (=° s rs))
((fresh° (a d c) (cons° a d r) (append° d s c) (cons° a c rs)))))
(⊦ equal?
'((λ (α) α)
(λ (α β) (cons α β))
(λ (α β γ) (cons α (cons β γ)))
(λ (α β γ δ) (cons α (cons β (cons γ δ))))
(λ (α β γ δ ε) (cons α (cons β (cons γ (cons δ ε)))))
(λ (α β γ δ ε ζ)
(cons α (cons β (cons γ (cons δ (cons ε ζ))))))
(λ (α β γ δ ε ζ η)
(cons α (cons β (cons γ (cons δ (cons ε (cons ζ η)))))))
(λ (α β γ δ ε ζ η θ)
(cons α
(cons β
(cons γ
(cons δ (cons ε (cons ζ (cons η θ))))))))
(λ (α β γ δ ε ζ η θ ι)
(cons α
(cons β
(cons γ
(cons δ
(cons ε (cons ζ (cons η (cons θ ι)))))))))
(λ (α β γ δ ε ζ η θ ι κ)
(cons α
(cons β
(cons γ
(cons δ
(cons ε
(cons ζ (cons η (cons θ (cons ι κ)))))))))))
(μkanren-run (l 10 #f) (fresh° (a d) (append° a d l)))))
((eta 0.001) (memory #(12582912 2585800 1048576)) (stdout "") (stderr ""))
test/project°: pass
(define (test/project° _)
(⊦= '(4700 6500 5000 5700 5700 4400 4000 5500 5300 5300)
(°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(empsalary° d e s)
(project° ((s* s)) (=° r (+ s* 500))))))))
((eta 0.0) (memory #(12582912 2572432 1048576)) (stdout "") (stderr ""))
test/groupby°/empty: pass
The following table has been kept from the PostgreSQL documentation example on window functions [1]:
depname | empno | salary | avg
-----------+-------+--------+-----------------------
develop | 11 | 5200 | 5020.0000000000000000
develop | 7 | 4200 | 5020.0000000000000000
develop | 9 | 4500 | 5020.0000000000000000
develop | 8 | 6000 | 5020.0000000000000000
develop | 10 | 5200 | 5020.0000000000000000
personnel | 5 | 3500 | 3700.0000000000000000
personnel | 2 | 3900 | 3700.0000000000000000
sales | 3 | 4800 | 4866.6666666666666667
sales | 1 | 5000 | 4866.6666666666666667
sales | 4 | 4800 | 4866.6666666666666667
(10 rows)SELECT depname, empno, salary, avg(salary) OVER (PARTITION BY depname) FROM empsalary;(define (test/groupby°/empty _)
(⊦= '(47100)
(°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(groupby°
(((s* foldr/add) s))
over
()
from
(empsalary° d e s)
=>
(=° r s*)))))))
((eta 0.002) (memory #(12582912 2587232 1048576)) (stdout "") (stderr ""))
test/groupby°/one-column: pass
(define (test/groupby°/one-column _)
(⊦= '((personnel 7400) (sales 14600) (develop 25100))
(sort (°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(groupby°
(((s* foldr/add) s))
over
(d)
from
(empsalary° d e s)
=>
(=° r `(,d ,s*))))))
(λ (a b) (< (cadr a) (cadr b))))))
((eta 0.001) (memory #(12582912 2575792 1048576)) (stdout "") (stderr ""))
test/set°: pass
(define (test/set° _)
(⊦= '((personnel 2) (sales 3) (develop 5))
(sort (°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(set° (c (λ (k v) (add1 v)) 0)
over
((d* d))
from
(empsalary° d e s)
=>
(=° r `(,d* ,c))))))
(λ (a b) (< (cadr a) (cadr b))))))
((eta 0.001) (memory #(12582912 2576152 1048576)) (stdout "") (stderr ""))
test/enumerate°: pass
(define (test/enumerate° _)
(⊦= '(((0 (sales))
(1 (sales))
(2 (sales))
(3 (personnel))
(4 (personnel))
(5 (develop))
(6 (develop))
(7 (develop))
(8 (develop))
(9 (develop))))
(°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(enumerate°
(c (λ (i k) (list i (list k))))
over
(d)
from
(empsalary° d e s)
=>
(=° r c)))))))
((eta 0.002) (memory #(12582912 2591560 1048576)) (stdout "") (stderr ""))
test/window°: pass
(define (test/window° _)
(⊦= '((develop 7 4200 5020)
(develop 8 6000 5020)
(develop 9 4500 5020)
(develop 10 5200 5020)
(develop 11 5200 5020)
(personnel 2 3900 3700)
(personnel 5 3500 3700)
(sales 1 5000 14600/3)
(sales 3 4800 14600/3)
(sales 4 4800 14600/3))
(°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(window°
(((s* foldr/avg) s))
over
(d)
from
(empsalary° d e s)
=>
(=° r `(,d ,e ,s ,s*)))))))
(⊦= '((develop 7 4200 4710)
(develop 8 6000 4710)
(develop 9 4500 4710)
(develop 10 5200 4710)
(develop 11 5200 4710)
(personnel 2 3900 4710)
(personnel 5 3500 4710)
(sales 1 5000 4710)
(sales 3 4800 4710)
(sales 4 4800 4710))
(°->list/ground
(fresh°
(r)
(fresh°
(d e s)
(window°
(((s* foldr/avg) s))
over
()
from
(empsalary° d e s)
=>
(=° r `(,d ,e ,s ,s*))))))))
((eta 0.004) (memory #(12582912 2580152 1048576)) (stdout "") (stderr ""))
test/=°/structure: pass
(define (test/=°/structure _)
(define-record person name age)
(define p (make-person 'alice 30))
(⊦= #t (record-instance? p))
(⊦= `((record ,p))
(°->list/ground (fresh° (r) (=° r (list 'record p)))))
(⊦= `((record ,(make-person 'α 30)))
(°->list/ground
(fresh° (r a) (=° r (list 'record (make-person a 30)))))))
((eta 0.002) (memory #(12582912 2580712 1048576)) (stdout "") (stderr ""))
test/=°/structure/vector: pass
(define (test/=°/structure/vector _)
(define-record person name age)
(define p (make-person 'alice 30))
(⊦= #t (record-instance? p))
(⊦= #(person alice 30) (record->vector p))
(⊦= '((person alice 30))
(°->list/ground (fresh° r (t n a) (=° `#(,t ,n ,a) p)))))
((eta 0.002) (memory #(12582912 2582048 1048576)) (stdout "") (stderr ""))
test/symbol°: pass
(define (test/symbol° _)
(⊦= '((λ (α) (assert (every (μ v (symbol? v)) (list α))) α))
(°->list #f (fresh° (s) (symbol° s))))
(⊦= '((λ (α) α)) (°->list #f (fresh° (s r) (symbol° r)))))
((eta 0.005) (memory #(12582912 2582696 1048576)) (stdout "") (stderr ""))
test/≠°: pass
(define (test/≠° _)
(⊦= '() (°->list #f (fresh° (s) (≠° (+ 2 3) 5))))
(⊦= '((λ (α) α)) (°->list #f (fresh° (s) (≠° (* 2 3) 5))))
(⊦= '((λ (α)
(begin (deny (equal? α 5)))
(begin (deny (equal? α 6)))
α))
(°->list #f (fresh° (q x) (≠° 5 q) (=° x q) (≠° 6 x))))
(⊦= '((λ (α) α)) (°->list #f (fresh° (q y z) (≠° (cons y z) q))))
(⊦= '((λ (α β γ)
(begin (deny (equal? α (cons β γ))))
(cons α (cons β (cons γ '())))))
(°->list
#f
(fresh° (q x y z) (≠° (cons y z) x) (=° (list x y z) q))))
(⊦= '((λ (α)
(begin (deny (equal? α 6)))
(cons (cons 5 α) (cons 5 (cons α '())))))
(°->list
#f
(fresh°
(q x y z)
(=° (cons y z) x)
(≠° (cons 5 6) x)
(=° 5 y)
(=° (list x y z) q))))
(⊦= '((λ (α) (cons (cons 6 α) (cons 6 (cons α '())))))
(°->list
#f
(fresh°
(q x y z)
(=° (cons y z) x)
(≠° (cons 5 6) x)
(=° 6 y)
(=° (list x y z) q))))
(⊦= '((λ (α β γ)
(begin (deny (equal? α 5)))
(begin (deny (equal? α 6)))
(begin (deny (equal? β 2)) (deny (equal? γ 1)))
(cons α (cons β (cons γ '())))))
(°->list
#f
(fresh°
(q x y z)
(≠° 5 x)
(≠° 6 x)
(≠° (list y 1) (list 2 z))
(=° (list x y z) q))))
(⊦= '((λ (α) (begin (deny (equal? α 1))) α))
(°->list #f (fresh° (s) (≠° s 1))))
(⊦= '() (°->list #f (fresh° (s) (≠° s 1) (=° s 1))))
(⊦= '((λ (α) (begin (deny (equal? α (cons 'a (cons 'b '()))))) α))
(°->list #f (fresh° (s) (≠° s '(a b)))))
(⊦= '((λ (α β)
(begin (deny (equal? α 1)) (deny (equal? β 2)))
(cons α (cons β '()))))
(°->list
#f
(fresh° (q p r) (≠° (list p r) '(1 2)) (=° q (list p r)))))
(⊦= '((λ (α) (begin (deny (equal? α 2))) (cons 1 (cons α '()))))
(°->list
#f
(fresh°
(q p r)
(≠° (list p r) '(1 2))
(=° p 1)
(=° q (list p r)))))
(⊦= '()
(°->list
#f
(fresh°
(q p r)
(≠° (list p r) '(1 2))
(=° p 1)
(=° r 2)
(=° q (list p r))))))
((eta 0.008) (memory #(12582912 2583744 1048576)) (stdout "") (stderr ""))
test/rember°/naive: pass
(define (test/rember°/naive _)
(define-relation
(rember° x ls out)
(cond°
((=° '() ls) (=° '() out))
((fresh° (a d) (=° `(,a unquote d) ls) (=° a x) (=° d out)))
((fresh°
(a d res)
(=° `(,a unquote d) ls)
(=° `(,a unquote res) out)
(rember° x d res)))))
(⊦= '((a c b d)) (μkanren-run (q 1 #t) (rember° 'b '(a b c b d) q)))
(⊦= '((a b c)) (μkanren-run (q 1 #t) (rember° 'd '(a b c) q)))
(⊦= '((a c b d) (a b c d) (a b c b d))
(μkanren-run (q -1 #t) (rember° 'b '(a b c b d) q)))
(⊦= '(α) (μkanren-run (q -1 #t) (rember° 'b '(b) '(b)))))
((eta 0.003) (memory #(12582912 2586392 1048576)) (stdout "") (stderr ""))
test/rember°/fixed: pass
(define (test/rember°/fixed _)
(define-relation
(rember° x ls out)
(cond°
((=° '() ls) (=° '() out))
((fresh° (a d) (=° `(,a unquote d) ls) (=° a x) (=° d out)))
((fresh°
(a d res)
(=° `(,a unquote d) ls)
(≠° a x)
(=° `(,a unquote res) out)
(rember° x d res)))))
(⊦= '((a c b d)) (μkanren-run (q -1 #t) (rember° 'b '(a b c b d) q)))
(⊦= '() (μkanren-run (q -1 #t) (rember° 'b '(b) '(b))))
(⊦= '((λ () (cons 'a (cons (cons 'b (cons 'c '())) '())))
(λ () (cons 'b (cons (cons 'a (cons 'c '())) '())))
(λ () (cons 'c (cons (cons 'a (cons 'b '())) '())))
(λ (α)
(begin (deny (equal? α 'a)))
(begin (deny (equal? α 'b)))
(begin (deny (equal? α 'c)))
(cons α (cons (cons 'a (cons 'b (cons 'c '()))) '()))))
(°->list
#f
(fresh° (q x out) (rember° x '(a b c) out) (=° (list x out) q)))))
((eta 0.0) (memory #(12582912 2590344 1048576)) (stdout "") (stderr ""))
test/absent°: pass
(define (test/absent° _)
(⊦= '((λ (α β)
(assert (absent? 'panda α))
(assert (absent? 'panda β))
(cons 'jackal
(cons (cons α (cons 'leopard (cons β '()))) '()))))
(°->list
#f
(fresh°
(q x y)
(=° `(jackal (,y leopard ,x)) q)
(absent° 'panda q)))))
((eta 0.004) (memory #(12582912 2591424 1048576)) (stdout "") (stderr ""))
Categories: scheme