diff --git a/collects/tests/schelog/bible.rkt b/collects/tests/schelog/bible.rkt new file mode 100644 index 0000000000..d591defdb1 --- /dev/null +++ b/collects/tests/schelog/bible.rkt @@ -0,0 +1,130 @@ +#lang racket + +(require schelog + schemeunit) + +;The following is the "Biblical" database from "The Art of +;Prolog", Sterling & Shapiro, ch. 1. + +;(%father X Y) :- X is the father of Y. + +(define %father + (%rel () + (('terach 'abraham)) (('terach 'nachor)) (('terach 'haran)) + (('abraham 'isaac)) (('haran 'lot)) (('haran 'milcah)) + (('haran 'yiscah)))) + +;(%mother X Y) :- X is the mother of Y. + +(define %mother + (%rel () (('sarah 'isaac)))) + +(define %male + (%rel () + (('terach)) (('abraham)) (('isaac)) (('lot)) (('haran)) (('nachor)))) + +(define %female + (%rel () + (('sarah)) (('milcah)) (('yiscah)))) + +;AoP, ch. 17. Finding all the children of a particular +;father. (%children F CC) :- CC is the list of children +;whose father is F. First approach: %children-1 uses an +;auxiliary predicate %children-aux, which uses an +;accumulator. + +(define %children-1 + + (letrec ((children-aux + (%rel (x a cc c) + ((x a cc) + (%father x c) (%not (%member c a)) ! + (children-aux x (cons c a) cc)) + ((x cc cc))))) + + (%rel (x cc) + ((x cc) (children-aux x '() cc))))) + +(define terachs-kids-test + ;find all the children of Terach. Returns + ;cc = (abraham nachor haran) + (lambda () + (%which (cc) + (%children-1 'terach cc)))) + +(check-equal? (terachs-kids-test) + `((cc (haran nachor abraham)))) + +(define dad-kids-test + ;find a father and all his children. Returns + ;f = terach, cc = (haran nachor abraham). + ;(%more) fails, showing flaw in %children-1. + ;see AoP, ch. 17, p. 267 + (lambda () + (%which (f cc) + (%children-1 f cc)))) + +(check-equal? (dad-kids-test) + `((f terach) (cc (haran nachor abraham)))) + +(define terachs-kids-test-2 + ;find all the kids of Terach, using %set-of. + ;returns kk = (abraham nachor haran) + (lambda () + (%let (k) + (%which (kk) + (%set-of k (%father 'terach k) kk))))) + +;This is a better definition of the %children predicate. +;Uses set predicate %bag-of + +(define %children + (%rel (x kids c) + ((kids) (%set-of c (%father x c) kids)))) + +(define dad-kids-test-2 + ;find each dad-kids combo. + ;1st soln: dad = terach, kids = (abraham nachor haran) + ;(%more) gives additional solutions. + (lambda () + (%let (x) + (%which (dad kids) + (%set-of x (%free-vars (dad) + (%father dad x)) + kids))))) + +(define dad-kids-test-3 + ;looks like dad-kids-test-2, but dad is now + ;existentially quantified. returns a set of + ;kids (i.e., anything with a father) + (lambda () + (%let (x) + (%which (dad kids) + (%set-of x (%father dad x) + kids))))) + +(define dad-kids-test-4 + ;find the set of dad-kids. + ;since dad is existentially quantified, + ;this gives the wrong answer: it gives + ;one set containing all the kids + (lambda () + (%let (dad kids x) + (%which (dad-kids) + (%set-of (list dad kids) + (%set-of x (%father dad x) kids) + dad-kids))))) + +(define dad-kids-test-5 + ;the correct solution. dad is + ;identified as a free var. + ;returns a set of dad-kids, one for + ;each dad + (lambda () + (%let (dad kids x) + (%which (dad-kids) + (%set-of (list dad kids) + (%set-of x (%free-vars (dad) + (%father dad x)) + kids) + dad-kids))))) diff --git a/collects/tests/schelog/england.rkt b/collects/tests/schelog/england.rkt new file mode 100644 index 0000000000..7a4ae74535 --- /dev/null +++ b/collects/tests/schelog/england.rkt @@ -0,0 +1,57 @@ +#lang racket + +(require schelog + schemeunit) + +;The following is a simple database about a certain family in England. +;Should be a piece of cake, but given here so that you can hone +;your ability to read the syntax. + +;This file is written using `%rel' for a more Prolog-like syntax. +;The file england2.scm uses a Scheme-like syntax. + +(define %male + (%rel () + (('philip)) (('charles)) (('andrew)) (('edward)) + (('mark)) (('william)) (('harry)) (('peter)))) + +(define %female + (%rel () + (('elizabeth)) (('anne)) (('diana)) (('sarah)) (('zara)))) + +(define %husband-of + (%rel () + (('philip 'elizabeth)) (('charles 'diana)) + (('mark 'anne)) (('andrew 'sarah)))) + +(define %wife-of + (%rel (w h) + ((w h) (%husband-of h w)))) + +(define %married-to + (%rel (x y) + ((x y) (%husband-of x y)) + ((x y) (%wife-of x y)))) + +(define %father-of + (%rel () + (('philip 'charles)) (('philip 'anne)) (('philip 'andrew)) + (('philip 'edward)) (('charles 'william)) (('charles 'harry)) + (('mark 'peter)) (('mark 'zara)))) + +(define %mother-of + (%rel (m c f) + ((m c) (%wife-of m f) (%father-of f c)))) + +(define %child-of + (%rel (c p) + ((c p) (%father-of p c)) + ((c p) (%mother-of p c)))) + +(define %parent-of + (%rel (p c) + ((p c) (%child-of c p)))) + +(define %brother-of + (%rel (b x f) + ((b x) (%male b) (%father-of f b) (%father-of f x) (%/= b x)))) diff --git a/collects/tests/schelog/england2.rkt b/collects/tests/schelog/england2.rkt new file mode 100644 index 0000000000..ab1775b629 --- /dev/null +++ b/collects/tests/schelog/england2.rkt @@ -0,0 +1,78 @@ +#lang racket + +(require schelog) + +;The following is a simple database about a certain family in England. +;Should be a piece of cake, but given here so that you can hone +;your ability to read the syntax. + +;This file is written using goal combinations like %or, %and +;like you would use Scheme procedures. For a more Prolog-like +;syntax of the same program, see england.scm. + +(define %male + (lambda (x) + (%or (%= x 'philip) + (%= x 'charles) + (%= x 'andrew) + (%= x 'edward) + (%= x 'mark) + (%= x 'william) + (%= x 'harry) + (%= x 'peter)))) + +(define %female + (lambda (x) + (%or (%= x 'elizabeth) + (%= x 'anne) + (%= x 'diana) + (%= x 'sarah) + (%= x 'zara)))) + +(define %husband-of + (lambda (h w) + (%or (%and (%= h 'philip) (%= w 'elizabeth)) + (%and (%= h 'charles) (%= w 'diana)) + (%and (%= h 'mark) (%= w 'anne)) + (%and (%= h 'andrew) (%= w 'sarah))))) + +(define %wife-of + (lambda (w h) + (%husband-of h w))) + +(define %married-to + (lambda (x y) + (%or (%husband-of x y) (%wife-of x y)))) + +(define %father-of + (lambda (x y) + (%or (%and (%= x 'philip) (%= y 'charles)) + (%and (%= x 'philip) (%= y 'anne)) + (%and (%= x 'philip) (%= y 'andrew)) + (%and (%= x 'philip) (%= y 'edward)) + (%and (%= x 'charles) (%= y 'william)) + (%and (%= x 'charles) (%= y 'harry)) + (%and (%= x 'mark) (%= y 'peter)) + (%and (%= x 'mark) (%= y 'zara))))) + +(define %mother-of + (lambda (m c) + (%let (f) + (%and (%wife-of m f) (%father-of f c))))) + +(define %child-of + (lambda (c p) + (%or (%father-of p c) (%mother-of p c)))) + +(define %parent-of + (lambda (p c) + (%child-of c p))) + +(define %brother-of + (lambda (b x) + (%let (f) + (%and (%male b) + (%father-of f b) + (%father-of f x) + (%/= b x))))) + diff --git a/collects/tests/schelog/games.rkt b/collects/tests/schelog/games.rkt new file mode 100644 index 0000000000..52ce206abb --- /dev/null +++ b/collects/tests/schelog/games.rkt @@ -0,0 +1,92 @@ +#lang racket + +(require schelog + "./puzzle.rkt" + schemeunit) + +;;This example is from Sterling & Shapiro, p. 214. +;; +;;The problem reads: Three friends came first, second and +;;third in a competition. Each had a different name, liked a +;;different sport, and had a different nationality. Michael +;;likes basketball, and did better than the American. Simon, +;;the Israeli, did better than the tennis player. The +;;cricket player came first. Who's the Australian? What +;;sport does Richard play? + +(define person + ;;a structure-builder for persons + (lambda (name country sport) + (list 'person name country sport))) + +(define %games + (%rel (clues queries solution the-men + n1 n2 n3 c1 c2 c3 s1 s2 s3) + ((clues queries solution) + (%= the-men + (list (person n1 c1 s1) (person n2 c2 s2) (person n3 c3 s3))) + (%games-clues the-men clues) + (%games-queries the-men queries solution)))) + +(define %games-clues + (%rel (the-men clue1-man1 clue1-man2 clue2-man1 clue2-man2 clue3-man) + ((the-men + (list + (%did-better clue1-man1 clue1-man2 the-men) + (%name clue1-man1 'michael) + (%sport clue1-man1 'basketball) + (%country clue1-man2 'usa) + + (%did-better clue2-man1 clue2-man2 the-men) + (%name clue2-man1 'simon) + (%country clue2-man1 'israel) + (%sport clue2-man2 'tennis) + + (%first the-men clue3-man) + (%sport clue3-man 'cricket)))))) + +(define %games-queries + (%rel (the-men man1 man2 aussies-name dicks-sport) + ((the-men + (list + (%member man1 the-men) + (%country man1 'australia) + (%name man1 aussies-name) + + (%member man2 the-men) + (%name man2 'richard) + (%sport man2 dicks-sport)) + (list + (list aussies-name 'is 'the 'australian) + (list 'richard 'plays dicks-sport)))))) + +(define %did-better + (%rel (a b c) + ((a b (list a b c))) + ((a c (list a b c))) + ((b c (list a b c))))) + +(define %name + (%rel (name country sport) + (((person name country sport) name)))) + +(define %country + (%rel (name country sport) + (((person name country sport) country)))) + +(define %sport + (%rel (name country sport) + (((person name country sport) sport)))) + +(define %first + (%rel (car cdr) + (((cons car cdr) car)))) + +;;With the above as the database, and also loading the file +;;puzzle.scm containing the puzzle solver, we merely need to +;;ask (solve-puzzle %games) to get the solution, which is +;; +;;((michael is the australian) (richard plays tennis)) + +(check-equal? (solve-puzzle %games) + '((solution= ((michael is the australian) (richard plays tennis))))) diff --git a/collects/tests/schelog/holland.rkt b/collects/tests/schelog/holland.rkt new file mode 100644 index 0000000000..97049d22e6 --- /dev/null +++ b/collects/tests/schelog/holland.rkt @@ -0,0 +1,40 @@ +#lang racket + +(require schelog) + +;This is a very trivial program. In Prolog, it would be: +; +; city(amsterdam). +; city(brussels). +; country(holland). +; country(belgium). + +(define %city + (lambda (x) + (%or (%= x 'amsterdam) + (%= x 'brussels)))) + +(define %country + (lambda (x) + (%or (%= x 'holland) + (%= x 'belgium)))) + +;For a more Prolog-style syntax, you can rewrite the same thing, +;using the `%rel' macro, as the following: + +'(define %city + (%rel () + (('amsterdam)) + (('brussels)))) + +'(define %country + (%rel () + (('holland)) + (('belgium)))) + +;Typical easy queries: +; +; (%which (x) (%city x)) succeeds twice +; (%which (x) (%country x)) succeeds twice +; (%which () (%city 'amsterdam)) succeeds +; (%which () (%country 'amsterdam)) fails diff --git a/collects/tests/schelog/houses.rkt b/collects/tests/schelog/houses.rkt new file mode 100644 index 0000000000..cf91166066 --- /dev/null +++ b/collects/tests/schelog/houses.rkt @@ -0,0 +1,152 @@ +#lang racket + +(require schelog) + +;Exercise 14.1 (iv) from Sterling & Shapiro, p. 217-8 + +;There are 5 houses, each of a different color and inhabited +;by a man of a different nationality, with a different pet, +;drink and cigarette choice. +; +;1. The Englishman lives in the red house +;2. The Spaniard owns the dog +;3. Coffee is drunk in the green house +;4. The Ukrainian drinks tea +;5. The green house is to the immediate right of the ivory house +;6. The Winston smoker owns snails +;7. Kools are smoked in the yellow house +;8. Milk is drunk in the middle house +;9. The Norwegian lives in the first house on the left +;10. The Chesterfield smoker lives next to the man with the fox +;11. Kools are smoked in the house adjacent to the horse's place +;12. The Lucky Strike smoker drinks orange juice +;13. The Japanese smokes Parliaments +;14. The Norwegian lives next to the blue house + +;Who owns the zebra? Who drinks water? + +(define house + (lambda (hue nation pet drink cigarette) + (list 'house hue nation pet drink cigarette))) + +(define %hue (%rel (h) (((house h (_) (_) (_) (_)) h)))) +(define %nation (%rel (n) (((house (_) n (_) (_) (_)) n)))) +(define %pet (%rel (p) (((house (_) (_) p (_) (_)) p)))) +(define %drink (%rel (d) (((house (_) (_) (_) d (_)) d)))) +(define %cigarette (%rel (c) (((house (_) (_) (_) (_) c) c)))) + +(define %adjacent + (%rel (a b) + ((a b (list a b (_) (_) (_)))) + ((a b (list (_) a b (_) (_)))) + ((a b (list (_) (_) a b (_)))) + ((a b (list (_) (_) (_) a b))))) + +(define %middle + (%rel (a) + ((a (list (_) (_) a (_) (_)))))) + +(define %houses + (%rel (row-of-houses clues queries solution + h1 h2 h3 h4 h5 n1 n2 n3 n4 n5 p1 p2 p3 p4 p5 + d1 d2 d3 d4 d5 c1 c2 c3 c4 c5) + ((clues queries solution) + (%= row-of-houses + (list + (house h1 n1 p1 d1 c1) + (house h2 n2 p2 d2 c2) + (house h3 n3 p3 d3 c3) + (house h4 n4 p4 d4 c4) + (house h5 n5 p5 d5 c5))) + (%houses-clues row-of-houses clues) + (%houses-queries row-of-houses queries solution)))) + +(define %houses-clues + (%rel (row-of-houses abode1 abode2 abode3 abode4 abode5 abode6 abode7 + abode8 abode9 abode10 abode11 abode12 abode13 abode14 abode15) + ((row-of-houses + (list + (%member abode1 row-of-houses) + (%nation abode1 'english) + (%hue abode1 'red) + + (%member abode2 row-of-houses) + (%nation abode2 'spain) + (%pet abode2 'dog) + + (%member abode3 row-of-houses) + (%drink abode3 'coffee) + (%hue abode3 'green) + + (%member abode4 row-of-houses) + (%nation abode4 'ukraine) + (%drink abode4 'tea) + + (%member abode5 row-of-houses) + (%adjacent abode5 abode3 row-of-houses) + (%hue abode5 'ivory) + + (%member abode6 row-of-houses) + (%cigarette abode6 'winston) + (%pet abode6 'snail) + + (%member abode7 row-of-houses) + (%cigarette abode7 'kool) + (%hue abode7 'yellow) + + (%= (list (_) (_) abode8 (_) (_)) row-of-houses) + (%drink abode8 'milk) + + (%= (list abode9 (_) (_) (_) (_)) row-of-houses) + (%nation abode9 'norway) + + (%member abode10 row-of-houses) + (%member abode11 row-of-houses) + (%or (%adjacent abode10 abode11 row-of-houses) + (%adjacent abode11 abode10 row-of-houses)) + (%cigarette abode10 'chesterfield) + (%pet abode11 'fox) + + (%member abode12 row-of-houses) + (%or (%adjacent abode7 abode12 row-of-houses) + (%adjacent abode12 abode7 row-of-houses)) + (%pet abode12 'horse) + + (%member abode13 row-of-houses) + (%cigarette abode13 'lucky-strike) + (%drink abode13 'oj) + + (%member abode14 row-of-houses) + (%nation abode14 'japan) + (%cigarette abode14 'parliament) + + (%member abode15 row-of-houses) + (%or (%adjacent abode9 abode15 row-of-houses) + (%adjacent abode15 abode9 row-of-houses)) + (%hue abode15 'blue)))))) + +(define %houses-queries + (%rel (row-of-houses abode1 abode2 zebra-owner water-drinker) + ((row-of-houses + (list + (%member abode1 row-of-houses) + (%pet abode1 'zebra) + (%nation abode1 zebra-owner) + + (%member abode2 row-of-houses) + (%drink abode2 'water) + (%nation abode2 water-drinker)) + + (list (list zebra-owner 'owns 'the 'zebra) + (list water-drinker 'drinks 'water)))))) + +;Load puzzle.scm and type (solve-puzzle %houses) + +;Note: This program, as written, requires +;the occurs check. Make sure the global +;*schelog-use-occurs-check?* is set to #t before +;calling solve-puzzle. If not, you will get into +;an infinite loop. + +;Note 2: Perhaps there is a way to rewrite the +;program so that it doesn't rely on the occurs check. diff --git a/collects/tests/schelog/mapcol.rkt b/collects/tests/schelog/mapcol.rkt new file mode 100644 index 0000000000..c328b52871 --- /dev/null +++ b/collects/tests/schelog/mapcol.rkt @@ -0,0 +1,85 @@ +#lang racket + +(require (except-in schelog %member)) + +;map coloring, example from Sterling & Shapiro, p. 212 + +;(%member x y) holds if x is in y + +;; is this different from the %member provided by schelog? fencing that one out. + +(define %member + (%rel (X Xs Y Ys) + ((X (cons X Xs))) + ((X (cons Y Ys)) (%member X Ys)))) + +;(%members x y) holds if x is a subset of y + +(define %members + (%rel (X Xs Ys) + (((cons X Xs) Ys) (%member X Ys) (%members Xs Ys)) + (('() Ys)))) + +;(%select x y z) holds if z is y with one less occurrence of x + +(define %select + (%rel (X Xs Y Ys Zs) + ((X (cons X Xs) Xs)) + ((X (cons Y Ys) (cons Y Zs)) + (%select X Ys Zs)))) + +;region is a structure-builder + +(define region + (lambda (name color neighbors) + (list 'region name color neighbors))) + +(define %color-map + (%rel (Region Regions Colors) + (((cons Region Regions) Colors) + (%color-region Region Colors) (%color-map Regions Colors)) + (('() Colors)))) + +(define %color-region + (%rel (Name Color Neighbors Colors Colors1) + (((region Name Color Neighbors) Colors) + (%select Color Colors Colors1) + (%members Neighbors Colors1)))) + +(define %test-color + (%rel (Name Map Colors) + ((Name Map) + (%map Name Map) + (%colors Colors) + (%color-map Map Colors)))) + +(define %map + (%rel (A B C D E F G H I L P S) + (('test (list + (region 'a A (list B C D)) + (region 'b B (list A C E)) + (region 'c C (list A B D E F)) + (region 'd D (list A C F)) + (region 'e E (list B C F)) + (region 'f F (list C D E))))) + (('western-europe + (list + (region 'portugal P (list E)) + (region 'spain E (list F P)) + (region 'france F (list E I S B G L)) + (region 'belgium B (list F H L G)) + (region 'holland H (list B G)) + (region 'germany G (list F A S H B L)) + (region 'luxembourg L (list F B G)) + (region 'italy I (list F A S)) + (region 'switzerland S (list F I A G)) + (region 'austria A (list I S G))))))) + +(define %colors + (%rel () + (('(red yellow blue white))))) + +;ask (%which (M) (%test-color 'test M)) or +;ask (%which (M) (%test-color 'western-europe M)) for the +;respective (non-unique) colorings. + diff --git a/collects/tests/schelog/puzzle.rkt b/collects/tests/schelog/puzzle.rkt new file mode 100644 index 0000000000..6598f71b9a --- /dev/null +++ b/collects/tests/schelog/puzzle.rkt @@ -0,0 +1,47 @@ +#lang racket + +(require schelog) + +(provide (all-defined-out)) + +;This is the puzzle solver described in Sterling & Shapiro, p. 214 + +;As S & S say, it is a "trivial" piece of code +;that successively solves each clue and query, which are expressed +;as Prolog goals and are executed with the meta-variable facility. + +;The code in "real" Prolog, for comparison, is: +; +; solve_puzzle(Clues, Queries, Solution) +; :- solve(Clues), solve(Queries). +; +; solve([Clue|Clues]) :- Clue, solve(Clues). +; solve([]). + +(define %solve-puzzle + (%rel (clues queries solution) + ((clues queries solution) + (%solve clues) + (%solve queries)))) + +(define %solve + (%rel (clue clues) + (((cons clue clues)) + clue + (%solve clues)) + (('())))) + +;evaluate (solve-puzzle %puzzle) to get the solution to +;%puzzle. Here %puzzle is a relation that is defined to +;hold for the three arguments clues, queries and solution=, +;iff they satisfy the constraints imposed by the puzzle. +;solve-puzzle finds an (the?) instantiation for the solution= +;variable. + +(define solve-puzzle + (lambda (%puzzle) + (%let (clues queries) + (%which (solution=) + (%and + (%puzzle clues queries solution=) + (%solve-puzzle clues queries solution=)))))) diff --git a/collects/tests/schelog/run-all.rkt b/collects/tests/schelog/run-all.rkt new file mode 100644 index 0000000000..cda82cead4 --- /dev/null +++ b/collects/tests/schelog/run-all.rkt @@ -0,0 +1,2 @@ +#lang racket + diff --git a/collects/tests/schelog/toys.rkt b/collects/tests/schelog/toys.rkt new file mode 100644 index 0000000000..daa875659f --- /dev/null +++ b/collects/tests/schelog/toys.rkt @@ -0,0 +1,88 @@ +#lang racket + +(require (except-in schelog %append)) + +;A list of trivial programs in Prolog, just so you can get used +;to schelog syntax. + +;(%length l n) holds if length(l) = n + +(define %length + (%rel (h t n m) + (('() 0)) + (((cons h t) n) (%length t m) (%is n (+ m 1))))) + +;(%delete x y z) holds if z is y with all x's removed + +(define %delete + (%rel (x y z w) + ((x '() '())) + ((x (cons x w) y) (%delete x w y)) + ((x (cons z w) (cons z y)) (%not (%= x z)) (%delete x w y)))) + +;(%remdup x y) holds if y is x without duplicates + +(define %remdup + (%rel (x y z w) + (('() '())) + (((cons x y) (cons x z)) (%delete x y w) (%remdup w z)))) + +;(%count x n) holds if n is the number of elements in x without +;counting duplicates + +'(define %count + (%rel (x n y) + ((x n) (%remdup x y) (%length y n)))) + +;same thing + +(define %count + (letrec ((countaux + (%rel (m n m+1 x y z) + (('() m m)) + (((cons x y) m n) + (%delete x y z) (%is m+1 (+ m 1)) (countaux z m+1 n))))) + (%rel (x n) + ((x n) (countaux x 0 n))))) + +;(%append x y z) holds if z is the concatenation of x and y + +(define %append + (%rel (x y z w) + (('() x x)) + (((cons x y) z (cons x w)) (%append y z w)))) + +;(%reverse x y) holds if the y is the reversal of x + +'(define %reverse + (%rel (x y z yy) + (('() '())) + (((cons x y) z) (%reverse y yy) (%append yy (list x) z)))) + +;same thing, but tailcall optimizing + +(define %reverse + (letrec ((revaux + (%rel (x y z w) + (('() y y)) + (((cons x y) z w) (revaux y (cons x z) w))))) + (%rel (x y) + ((x y) (revaux x '() y))))) + +;(%fact n m) holds if m = n! + +'(define %fact + (%rel (n n! n-1 n-1!) + ((0 1)) + ((n n!) (%is n-1 (- n 1)) (%fact n-1 n-1!) (%is n! (* n n-1!))))) + +;same thing, but tailcall optimizing + +(define %fact + (letrec ((factaux + (%rel (n! m x m-1 xx) + ((0 n! n!)) + ((m x n!) (%is m-1 (- m 1)) (%is xx (* x m)) + (factaux m-1 xx n!))))) + (%rel (n n!) + ((n n!) (factaux n 1 n!)))))