Permalink
Browse files

Added code examples from Chapter 2: Teaching Old Toys New Tricks

  • Loading branch information...
1 parent 4810e9e commit d905ce5ab75fbd6fc300af82aba46f05dcb3560f @pkrumins committed Mar 28, 2010
Showing with 348 additions and 0 deletions.
  1. +348 −0 02-old-toys.ss
View
@@ -0,0 +1,348 @@
+;
+; Chapter 2 of The Reasoned Schemer:
+; Teaching Old Toys New Tricks
+;
+; Code examples assembled by Peteris Krumins (peter@catonmat.net).
+; His blog is at http://www.catonmat.net -- good coders code, great reuse.
+;
+; Get yourself this wonderful book at Amazon: http://bit.ly/89tulL
+;
+
+;
+; You'll have to get Oleg Kiselyov's implementation of this logic programming
+; system to run the examples in this file. The implementation is here:
+; http://sourceforge.net/projects/kanren/
+;
+(load "mk.scm")
+(load "mkextraforms.scm")
+
+; ---------------------------------------------------------------------------
+
+; This is from The Little Schemer
+;
+(let ((x (lambda (a) a))
+ (y 'c))
+ (x y)) ; 'c
+
+; x and y stay fresh and get reified
+;
+(run* (r)
+ (fresh (y x)
+ (== (cons x (cons y '())) r))) ; '((._0 ._1))
+
+; Same but with different syntax for constructing x y list of freshes
+;
+(run* (r)
+ (fresh (y x)
+ (== `(,x ,y) r))) ; '((._0 ._1))
+
+; x is v and y is w, v and w are fresh
+;
+(run* (r)
+ (fresh (v w)
+ (== (let
+ ((x v)
+ (y w))
+ (cons x (cons y '()))) r))) ; '((._0 ._1))
+
+; This is from The Little Schemer
+;
+(car '(grape raisin pear)) ; 'grape
+(car '(a c o r n)) ; 'a
+
+; caro is car in relational programming. It succeeds if it can (cons a d) to
+; produce p.
+;
+(define caro
+ (lambda (p a)
+ (fresh (d)
+ (== (cons a d) p))))
+
+; Let's try out caro.
+;
+(run* (r)
+ (caro '(a c o r n) r)) ; '(a) because 'a is car of '(a c o r n)
+
+(run* (r)
+ (caro '(a c o r n) 'a)
+ (== #t r)); ; '(#t) because caro succeeds
+
+; caro associates r with x, then assigns 'pear to x, making r equal to 'pear
+;
+(run* (r)
+ (fresh (x y)
+ (caro (cons r (cons y '())) x)
+ (== 'pear x))) ; '(pear)
+
+; This is from The Little Schemer
+;
+(cons
+ (car '(grape raisin pear))
+ (car '((a) (b) (c)))) ; '(grape a)
+
+(run* (r)
+ (fresh (x y)
+ (caro '(grape raisin pear) x)
+ (caro '((a) (b) (c)) y)
+ (== (cons x y) r))) ; '((grape a))
+
+; This is from The Little Schemer
+;
+(cdr '(grape raisin pear)) ; '(raisin pear)
+(car (cdr '(a c o r n))) ; 'c
+
+; cdro is cdr in relational programming. It succeeds if it can (cons a d) to
+; produce p.
+;
+(define cdro
+ (lambda (p d)
+ (fresh (a)
+ (== (cons a d) p))))
+
+; Let's try out cdro. The process of transforming (car (cdr l)) into
+; (cdro l v) and (caro v r) is called unnesting.
+;
+(run* (r)
+ (fresh (v)
+ (cdro '(a c o r n) v)
+ (caro v r))) ; '(c)
+
+; This is from The Little Schemer
+;
+(cons
+ (cdr '(grape raisin pear))
+ (car '((a) (b) (c)))) ; '((grape raisin) a)
+
+; Same with run
+;
+(run* (r)
+ (fresh (x y)
+ (cdro '(grape raisin pear) x)
+ (caro '((a) (b) (c)) y)
+ (== (cons x y) r))) ; '(((grape raisin) a))
+
+; This succeeds because '(c o r n) is cdr of '(a c o r n)
+;
+(run* (q)
+ (cdro '(a c o r n) '(c o r n))
+ (== #t q)) ; '(#t)
+
+; cdr of '(c o r n) is '(o r n) and that needs to match `(,x r n). That can
+; only happen if x is 'o.
+;
+(run* (x)
+ (cdro '(c o r n) `(,x r n))) ; '(o)
+
+; cdr of l is '(c o r n), so l must be '(? c o r n).
+; car of l is x is ?
+; 'a gets assigned to x, making ?='a and l '(a c o r n)
+;
+(run* (l)
+ (fresh (x)
+ (cdro l '(c o r n))
+ (caro l x)
+ (== 'a x))) ; '(a c o r n)
+
+; conso!
+;
+(define conso
+ (lambda (a d p)
+ (== (cons a d) p)))
+
+; conso is magnificent
+;
+(run* (l)
+ (conso '(a b c) '(d e) l)) ; '((a b c d e))
+
+; x is 'd because we need to find something that prepended to '(a b c) would
+; give '(d a b c). The only possibility is that x is 'd.
+;
+(run* (x)
+ (conso x '(a b c) '(d a b c))) ; '(d)
+
+; `(,y a ,z c) becomes r, so y is 'e, z is 'd and x is 'c.
+; Therefore r becomes '(e a d c)
+;
+(run* (r)
+ (fresh (x y z)
+ (== `(e a d ,x) r)
+ (conso y `(a ,z c) r))) ; '((e a d c))
+
+; What value can we associate with x so that `(,x a ,x c) is `(d a ,x c)?
+; Clearly it's 'd.
+;
+(run* (x)
+ (conso x `(a ,x c) `(d a ,x c))) ; '((d))
+
+; Same but different question
+;
+;
+(run* (l)
+ (fresh (x)
+ (== `(d a ,x c) l)
+ (conso x `(a ,x c) l))) ; '((d a d c))
+
+; Same but different question
+;
+;
+(run* (l)
+ (fresh (x)
+ (conso x `(a ,x c) l)
+ (== `(d a ,x c) l))) ; '((d a d c))
+
+; Great puzzle
+;
+(run* (l)
+ (fresh (d x y w s)
+ (conso w '(a n s) s)
+ (cdro l s)
+ (caro l x)
+ (== 'b x)
+ (cdro l d)
+ (caro d y)
+ (== 'e y))) ; '((b e a n s))
+
+; This is from The Little Schemer
+;
+(null? '(grape raisin pear)) ; #f
+(null? '()) ; #t
+
+; nullo!
+;
+(define nullo
+ (lambda (l)
+ (== '() l)))
+
+; Examples of nullo
+;
+(run* (q)
+ (nullo '(grape raisin pear))
+ (== #t q)) ; '() because nullo fails
+
+(run* (q)
+ (nullo '())
+ (== #t q)) ; '(#t) because nullo succeeds
+
+; nullo succeeds and associates '() with q
+;
+(run* (q)
+ (nullo q)) ; '(()) because nullo succeeds
+
+; This is from The Little Schemer
+;
+(eq? 'pear 'plum) ; #f
+(eq? 'plum 'plum) ; #t
+
+; eqo!
+;
+(define eqo
+ (lambda (x y)
+ (== x y)))
+
+; Examples of eqo
+;
+(run* (q)
+ (eqo 'pear 'plum)
+ (== #t q)) ; '() because eqo fails
+
+(run* (q)
+ (eqo 'plum 'plum)
+ (== #t q)) ; '(#t) because eqo succeeds
+
+; This is NOT from The Little Schemer
+;
+(cons 'split 'pea) ; `(split . pea)
+`(split pea) ; `(split . pea)
+(pair? `(split . pea)) ; #t
+(pair? `((split) . pea)) ; #t
+(pair? `()) ; #f
+(pair? `pair) ; #f
+(pair? `(pear)) ; #t because it's `(pear . ())
+(car `(pear)) ; 'pear
+(cdr `(pear)) ; '()
+(cons `(split) 'pea) ; `((split) . pea)
+
+; Now back to The Reasoned Schemer
+;
+(run* (r)
+ (fresh (x y)
+ (== (cons x (cons y 'salad)) r))) ; `(._0 ._1 . salad)
+
+; pairo!
+;
+(define pairo
+ (lambda (p)
+ (fresh (a d)
+ (conso a d p))))
+
+; Examples of pairo
+;
+(run* (q)
+ (pairo (cons q q))
+ (== #t q)) ; '(#t) because `(q . q) is a pair
+
+(run* (q)
+ (pairo '())
+ (== #t q)) ; '() because '() is not a pair
+
+(run* (q)
+ (pairo 'pair)
+ (== #t q)) ; '()
+
+; pairo finds that any two variables make up a pair but since they
+; stay fresh, run* reifies them.
+;
+(run* (x)
+ (pairo x)) ; '((._0 ._1))
+
+; pairo finds that anything in place of r makes a pair in (cons r 'pear)
+;
+(run* (r)
+ (pairo (cons r 'pear))) ; '(._0)
+
+; caro, cdro, pairo can be defined using conso
+;
+(define caro
+ (lambda (p a)
+ (fresh (d)
+ (conso a d p))))
+
+(define cdro
+ (lambda (p d)
+ (fresh (a)
+ (conso a d p))))
+
+; (define pairo ...) aleady did above
+
+; Test caro and cdro
+;
+(run* (l)
+ (fresh (d x y w s)
+ (conso w '(a n s) s)
+ (cdro l s)
+ (caro l x)
+ (== 'b x)
+ (cdro l d)
+ (caro d y)
+ (== 'e y))) ; '((b e a n s))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; ;
+; This space reserved for ;
+; ;
+; "Conso the Mangificento" ;
+; ;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;
+; Go get yourself this wonderful book and have fun with logic programming!
+;
+; Shortened URL to the book at Amazon.com: http://bit.ly/89tulL
+;
+; Sincerely,
+; Peteris Krumins
+; http://www.catonmat.net
+;
+

0 comments on commit d905ce5

Please sign in to comment.