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.005) (memory #(12582912 2562976 1048576)) (stdout "") (stderr ""))
test/=°: pass
(define (test/=° _) (⊦= '(α) (°->list/ground (=° 'z 'z))))
((eta 0.014) (memory #(12582912 2564120 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 2569928 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.015) (memory #(12582912 2573328 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.002) (memory #(12582912 2581896 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.001) (memory #(12582912 2569896 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 2586448 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.002) (memory #(12582912 2573712 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 2574208 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 2574864 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 2577208 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 2577872 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 2579168 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 2579816 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.009) (memory #(12582912 2580656 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.002) (memory #(12582912 2580880 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.001) (memory #(12582912 2587800 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 2583872 1048576)) (stdout "") (stderr ""))