From e0b571618a37f410f68db30d4d8d0cfbf342a715 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 26 Apr 2010 12:26:16 -0600 Subject: [PATCH] Changing style --- collects/schelog/examples/bible.rkt | 130 ----- collects/schelog/examples/england.rkt | 57 -- collects/schelog/examples/england2.rkt | 78 --- collects/schelog/examples/games.rkt | 92 --- collects/schelog/examples/holland.rkt | 40 -- collects/schelog/examples/houses.rkt | 152 ----- collects/schelog/examples/mapcol.rkt | 85 --- collects/schelog/examples/puzzle.rkt | 47 -- collects/schelog/examples/toys.rkt | 88 --- collects/schelog/schelog.rkt | 769 +++++++++++-------------- 10 files changed, 348 insertions(+), 1190 deletions(-) delete mode 100644 collects/schelog/examples/bible.rkt delete mode 100644 collects/schelog/examples/england.rkt delete mode 100644 collects/schelog/examples/england2.rkt delete mode 100644 collects/schelog/examples/games.rkt delete mode 100644 collects/schelog/examples/holland.rkt delete mode 100644 collects/schelog/examples/houses.rkt delete mode 100644 collects/schelog/examples/mapcol.rkt delete mode 100644 collects/schelog/examples/puzzle.rkt delete mode 100644 collects/schelog/examples/toys.rkt diff --git a/collects/schelog/examples/bible.rkt b/collects/schelog/examples/bible.rkt deleted file mode 100644 index 242c48ae02..0000000000 --- a/collects/schelog/examples/bible.rkt +++ /dev/null @@ -1,130 +0,0 @@ -#lang racket - -(require "../schelog.rkt" - 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/schelog/examples/england.rkt b/collects/schelog/examples/england.rkt deleted file mode 100644 index 15fc6ee400..0000000000 --- a/collects/schelog/examples/england.rkt +++ /dev/null @@ -1,57 +0,0 @@ -#lang racket - -(require "../schelog.rkt" - 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/schelog/examples/england2.rkt b/collects/schelog/examples/england2.rkt deleted file mode 100644 index aecc98f3aa..0000000000 --- a/collects/schelog/examples/england2.rkt +++ /dev/null @@ -1,78 +0,0 @@ -#lang racket - -(require "../schelog.rkt") - -;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/schelog/examples/games.rkt b/collects/schelog/examples/games.rkt deleted file mode 100644 index 9a001b760d..0000000000 --- a/collects/schelog/examples/games.rkt +++ /dev/null @@ -1,92 +0,0 @@ -#lang scheme - -(require "../schelog.rkt" - "./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/schelog/examples/holland.rkt b/collects/schelog/examples/holland.rkt deleted file mode 100644 index c7aa0b8be1..0000000000 --- a/collects/schelog/examples/holland.rkt +++ /dev/null @@ -1,40 +0,0 @@ -#lang racket - -(require "../schelog.rkt") - -;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/schelog/examples/houses.rkt b/collects/schelog/examples/houses.rkt deleted file mode 100644 index fc25dcf75b..0000000000 --- a/collects/schelog/examples/houses.rkt +++ /dev/null @@ -1,152 +0,0 @@ -#lang racket - -(require "../schelog.rkt") - -;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/schelog/examples/mapcol.rkt b/collects/schelog/examples/mapcol.rkt deleted file mode 100644 index 4ed29869af..0000000000 --- a/collects/schelog/examples/mapcol.rkt +++ /dev/null @@ -1,85 +0,0 @@ -#lang racket - -(require (except-in "../schelog.rkt" %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/schelog/examples/puzzle.rkt b/collects/schelog/examples/puzzle.rkt deleted file mode 100644 index 08092a4eff..0000000000 --- a/collects/schelog/examples/puzzle.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang scheme - -(require "../schelog.rkt") - -(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/schelog/examples/toys.rkt b/collects/schelog/examples/toys.rkt deleted file mode 100644 index c90c8e49ba..0000000000 --- a/collects/schelog/examples/toys.rkt +++ /dev/null @@ -1,88 +0,0 @@ -#lang racket - -(require (except-in "../schelog.rkt" %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!))))) diff --git a/collects/schelog/schelog.rkt b/collects/schelog/schelog.rkt index 76247f9d95..4086b1975c 100644 --- a/collects/schelog/schelog.rkt +++ b/collects/schelog/schelog.rkt @@ -1,156 +1,125 @@ #lang racket -;MzScheme version of -;schelog.scm -;Schelog -;An embedding of Prolog in Scheme ;Dorai Sitaram ;1989, revised Feb. 1993, Mar. 1997 ;logic variables and their manipulation +(define-struct iref (val) #:mutable) -(define schelog:*ref* "ref") +(define *unbound* '_) -(define schelog:*unbound* '_) +;;makes a fresh unbound ref; +;;unbound refs point to themselves +(define (make-ref [val *unbound*]) + (make-iref val)) -(define schelog:make-ref - ;;makes a fresh unbound ref; - ;;unbound refs point to themselves - (lambda opt - (vector schelog:*ref* - (if (null? opt) schelog:*unbound* - (car opt))))) +(define _ make-ref) -(define _ schelog:make-ref) +(define ref? iref?) +(define deref iref-val) +(define set-ref! set-iref-val!) -(define schelog:ref? - (lambda (r) - (and (vector? r) - (eq? (vector-ref r 0) schelog:*ref*)))) +(define (unbound-ref? r) + (and (ref? r) (eq? (deref r) *unbound*))) -(define schelog:deref - (lambda (r) - (vector-ref r 1))) - -(define schelog:set-ref! - (lambda (r v) - (vector-set! r 1 v))) - -(define schelog:unbound-ref? - (lambda (r) - (eq? (schelog:deref r) schelog:*unbound*))) - -(define schelog:unbind-ref! - (lambda (r) - (schelog:set-ref! r schelog:*unbound*))) +(define (unbind-ref! r) + (set-ref! r *unbound*)) ;frozen logic vars - -(define schelog:*frozen* "frozen") - -(define schelog:freeze-ref - (lambda (r) - (schelog:make-ref (vector schelog:*frozen* r)))) - -(define schelog:thaw-frozen-ref - (lambda (r) - (vector-ref (schelog:deref r) 1))) - -(define schelog:frozen-ref? - (lambda (r) - (let ((r2 (schelog:deref r))) - (and (vector? r2) - (eq? (vector-ref r2 0) schelog:*frozen*))))) +(define-struct frozen (val)) +(define (freeze-ref r) + (make-ref (make-frozen r))) +(define (thaw-frozen-ref r) + (frozen-val (deref r))) +(define (frozen-ref? r) + (frozen? (deref r))) ;deref a structure completely (except the frozen ones, i.e.) -(define schelog:deref* - (lambda (s) - (cond ((schelog:ref? s) - (if (schelog:frozen-ref? s) s - (schelog:deref* (schelog:deref s)))) - ((pair? s) (cons (schelog:deref* (car s)) - (schelog:deref* (cdr s)))) - ((vector? s) - (list->vector (map schelog:deref* (vector->list s)))) - (else s)))) +(define (deref* s) + (cond ((ref? s) + (if (frozen-ref? s) s + (deref* (deref s)))) + ((pair? s) (cons (deref* (car s)) + (deref* (cdr s)))) + ((vector? s) + (vector-map deref* s)) + (else s))) ;%let introduces new logic variables (define-syntax %let (syntax-rules () ((%let (x ...) . e) - (let ((x (schelog:make-ref)) ...) + (let ((x (_)) ...) . e)))) ;the unify predicate (define schelog-use-occurs-check? (make-parameter #f)) -(define schelog:occurs-in? - (lambda (var term) - (and (schelog-use-occurs-check?) - (let loop ((term term)) - (cond ((eqv? var term) #t) - ((schelog:ref? term) - (cond ((schelog:unbound-ref? term) #f) - ((schelog:frozen-ref? term) #f) - (else (loop (schelog:deref term))))) - ((pair? term) - (or (loop (car term)) (loop (cdr term)))) - ((vector? term) - (loop (vector->list term))) - (else #f)))))) +(define (occurs-in? var term) + (and (schelog-use-occurs-check?) + (let loop ((term term)) + (cond ((eqv? var term) #t) + ((ref? term) + (cond ((unbound-ref? term) #f) + ((frozen-ref? term) #f) + (else (loop (deref term))))) + ((pair? term) + (or (loop (car term)) (loop (cdr term)))) + ((vector? term) + (loop (vector->list term))) + (else #f))))) -(define schelog:unify - (lambda (t1 t2) - (lambda (fk) - (letrec - ((cleanup-n-fail - (lambda (s) - (for-each schelog:unbind-ref! s) - (fk 'fail))) - (unify1 - (lambda (t1 t2 s) - ;(printf "unify1 ~s ~s~%" t1 t2) - (cond ((eqv? t1 t2) s) - ((schelog:ref? t1) - (cond ((schelog:unbound-ref? t1) - (cond ((schelog:occurs-in? t1 t2) - (cleanup-n-fail s)) - (else - (schelog:set-ref! t1 t2) - (cons t1 s)))) - ((schelog:frozen-ref? t1) - (cond ((schelog:ref? t2) - (cond ((schelog:unbound-ref? t2) - ;(printf "t2 is unbound~%") - (unify1 t2 t1 s)) - ((schelog:frozen-ref? t2) - (cleanup-n-fail s)) - (else - (unify1 t1 (schelog:deref t2) s)))) - (else (cleanup-n-fail s)))) - (else - ;(printf "derefing t1~%") - (unify1 (schelog:deref t1) t2 s)))) - ((schelog:ref? t2) (unify1 t2 t1 s)) - ((and (pair? t1) (pair? t2)) - (unify1 (cdr t1) (cdr t2) - (unify1 (car t1) (car t2) s))) - ((and (string? t1) (string? t2)) - (if (string=? t1 t2) s - (cleanup-n-fail s))) - ((and (vector? t1) (vector? t2)) - (unify1 (vector->list t1) - (vector->list t2) s)) - (else - (for-each schelog:unbind-ref! s) - (fk 'fail)))))) - (let ((s (unify1 t1 t2 '()))) - (lambda (d) - (cleanup-n-fail s))))))) +(define (unify t1 t2) + (lambda (fk) + (letrec + ((cleanup-n-fail + (lambda (s) + (for-each unbind-ref! s) + (fk 'fail))) + (unify1 + (lambda (t1 t2 s) + ;(printf "unify1 ~s ~s~%" t1 t2) + (cond ((eqv? t1 t2) s) + ((ref? t1) + (cond ((unbound-ref? t1) + (cond ((occurs-in? t1 t2) + (cleanup-n-fail s)) + (else + (set-ref! t1 t2) + (cons t1 s)))) + ((frozen-ref? t1) + (cond ((ref? t2) + (cond ((unbound-ref? t2) + ;(printf "t2 is unbound~%") + (unify1 t2 t1 s)) + ((frozen-ref? t2) + (cleanup-n-fail s)) + (else + (unify1 t1 (deref t2) s)))) + (else (cleanup-n-fail s)))) + (else + ;(printf "derefing t1~%") + (unify1 (deref t1) t2 s)))) + ((ref? t2) (unify1 t2 t1 s)) + ((and (pair? t1) (pair? t2)) + (unify1 (cdr t1) (cdr t2) + (unify1 (car t1) (car t2) s))) + ((and (string? t1) (string? t2)) + (if (string=? t1 t2) s + (cleanup-n-fail s))) + ((and (vector? t1) (vector? t2)) + (unify1 (vector->list t1) + (vector->list t2) s)) + (else + (for-each unbind-ref! s) + (fk 'fail)))))) + (let ((s (unify1 t1 t2 '()))) + (lambda (d) + (cleanup-n-fail s)))))) -(define %= schelog:unify) +(define %= unify) ;disjunction @@ -158,13 +127,11 @@ (syntax-rules () ((%or g ...) (lambda (__fk) - (call-with-current-continuation - (lambda (__sk) - (call-with-current-continuation - (lambda (__fk) - (__sk ((schelog:deref* g) __fk)))) + (let/cc __sk + (let/cc __fk + (__sk ((deref* g) __fk))) ... - (__fk 'fail))))))) + (__fk 'fail)))))) ;conjunction @@ -172,7 +139,7 @@ (syntax-rules () ((%and g ...) (lambda (__fk) - (let* ((__fk ((schelog:deref* g) __fk)) + (let* ((__fk ((deref* g) __fk)) ...) __fk))))) @@ -188,7 +155,7 @@ (syntax/loc stx (lambda (__fk) (let ((! (lambda (__fk2) __fk))) - ((schelog:deref* g) __fk)))))))) + ((deref* g) __fk)))))))) ;Prolog-like sugar @@ -199,18 +166,16 @@ (syntax/loc stx (lambda __fmls (lambda (__fk) - (call-with-current-continuation - (lambda (__sk) - (let ((! (lambda (fk1) __fk))) - (%let (v ...) - (call-with-current-continuation - (lambda (__fk) - (let* ((__fk ((%= __fmls (list a ...)) __fk)) - (__fk ((schelog:deref* subgoal) __fk)) - ...) - (__sk __fk)))) - ... - (__fk 'fail)))))))))))) + (let/cc __sk + (let ((! (lambda (fk1) __fk))) + (%let (v ...) + (let/cc __fk + (let* ((__fk ((%= __fmls (list a ...)) __fk)) + (__fk ((deref* subgoal) __fk)) + ...) + (__sk __fk))) + ... + (__fk 'fail))))))))))) ;the fail and true preds @@ -235,232 +200,208 @@ ((%is (1) (x ...) fk) ((%is (1) x fk) ...)) ((%is (1) x fk) - (if (and (schelog:ref? x) (schelog:unbound-ref? x)) - (fk 'fail) (schelog:deref* x))))) + (if (and (ref? x) (unbound-ref? x)) + (fk 'fail) (deref* x))))) ;defining arithmetic comparison operators -(define schelog:make-binary-arithmetic-relation - (lambda (f) - (lambda (x y) - (%is #t (f x y))))) +(define ((make-binary-arithmetic-relation f) x y) + (%is #t (f x y))) -(define %=:= (schelog:make-binary-arithmetic-relation =)) -(define %> (schelog:make-binary-arithmetic-relation >)) -(define %>= (schelog:make-binary-arithmetic-relation >=)) -(define %< (schelog:make-binary-arithmetic-relation <)) -(define %<= (schelog:make-binary-arithmetic-relation <=)) -(define %=/= (schelog:make-binary-arithmetic-relation +(define %=:= (make-binary-arithmetic-relation =)) +(define %> (make-binary-arithmetic-relation >)) +(define %>= (make-binary-arithmetic-relation >=)) +(define %< (make-binary-arithmetic-relation <)) +(define %<= (make-binary-arithmetic-relation <=)) +(define %=/= (make-binary-arithmetic-relation (lambda (m n) (not (= m n))))) ;type predicates -(define schelog:constant? - (lambda (x) - (cond ((schelog:ref? x) - (cond ((schelog:unbound-ref? x) #f) - ((schelog:frozen-ref? x) #t) - (else (schelog:constant? (schelog:deref x))))) - ((pair? x) #f) - ((vector? x) #f) - (else #t)))) +(define (constant? x) + (cond ((ref? x) + (cond ((unbound-ref? x) #f) + ((frozen-ref? x) #t) + (else (constant? (deref x))))) + ((pair? x) #f) + ((vector? x) #f) + (else #t))) -(define schelog:compound? - (lambda (x) - (cond ((schelog:ref? x) (cond ((schelog:unbound-ref? x) #f) - ((schelog:frozen-ref? x) #f) - (else (schelog:compound? (schelog:deref x))))) - ((pair? x) #t) - ((vector? x) #t) - (else #f)))) +(define (compound? x) + (cond ((ref? x) + (cond ((unbound-ref? x) #f) + ((frozen-ref? x) #f) + (else (compound? (deref x))))) + ((pair? x) #t) + ((vector? x) #t) + (else #f))) -(define %constant - (lambda (x) - (lambda (fk) - (if (schelog:constant? x) fk (fk 'fail))))) +(define (%constant x) + (lambda (fk) + (if (constant? x) fk (fk 'fail)))) -(define %compound - (lambda (x) - (lambda (fk) - (if (schelog:compound? x) fk (fk 'fail))))) +(define (%compound x) + (lambda (fk) + (if (compound? x) fk (fk 'fail)))) ;metalogical type predicates -(define schelog:var? - (lambda (x) - (cond ((schelog:ref? x) - (cond ((schelog:unbound-ref? x) #t) - ((schelog:frozen-ref? x) #f) - (else (schelog:var? (schelog:deref x))))) - ((pair? x) (or (schelog:var? (car x)) (schelog:var? (cdr x)))) - ((vector? x) (schelog:var? (vector->list x))) - (else #f)))) +(define (var? x) + (cond ((ref? x) + (cond ((unbound-ref? x) #t) + ((frozen-ref? x) #f) + (else (var? (deref x))))) + ((pair? x) (or (var? (car x)) (var? (cdr x)))) + ((vector? x) (var? (vector->list x))) + (else #f))) -(define %var - (lambda (x) - (lambda (fk) (if (schelog:var? x) fk (fk 'fail))))) +(define (%var x) + (lambda (fk) (if (var? x) fk (fk 'fail)))) -(define %nonvar - (lambda (x) - (lambda (fk) (if (schelog:var? x) (fk 'fail) fk)))) +(define (%nonvar x) + (lambda (fk) (if (var? x) (fk 'fail) fk))) ; negation of unify -(define schelog:make-negation ;basically inlined cut-fail - (lambda (p) - (lambda args - (lambda (fk) - (if (call-with-current-continuation - (lambda (k) - ((apply p args) (lambda (d) (k #f))))) - (fk 'fail) - fk))))) +(define ((make-negation p) . args) + ;basically inlined cut-fail + (lambda (fk) + (if (let/cc k + ((apply p args) (lambda (d) (k #f)))) + (fk 'fail) + fk))) (define %/= - (schelog:make-negation %=)) + (make-negation %=)) ;identical -(define schelog:ident? - (lambda (x y) - (cond ((schelog:ref? x) - (cond ((schelog:unbound-ref? x) - (cond ((schelog:ref? y) - (cond ((schelog:unbound-ref? y) (eq? x y)) - ((schelog:frozen-ref? y) #f) - (else (schelog:ident? x (schelog:deref y))))) - (else #f))) - ((schelog:frozen-ref? x) - (cond ((schelog:ref? y) - (cond ((schelog:unbound-ref? y) #f) - ((schelog:frozen-ref? y) (eq? x y)) - (else (schelog:ident? x (schelog:deref y))))) - (else #f))) - (else (schelog:ident? (schelog:deref x) y)))) - ((pair? x) - (cond ((schelog:ref? y) - (cond ((schelog:unbound-ref? y) #f) - ((schelog:frozen-ref? y) #f) - (else (schelog:ident? x (schelog:deref y))))) - ((pair? y) - (and (schelog:ident? (car x) (car y)) - (schelog:ident? (cdr x) (cdr y)))) - (else #f))) - ((vector? x) - (cond ((schelog:ref? y) - (cond ((schelog:unbound-ref? y) #f) - ((schelog:frozen-ref? y) #f) - (else (schelog:ident? x (schelog:deref y))))) - ((vector? y) - (schelog:ident? (vector->list x) - (vector->list y))) - (else #f))) - (else - (cond ((schelog:ref? y) - (cond ((schelog:unbound-ref? y) #f) - ((schelog:frozen-ref? y) #f) - (else (schelog:ident? x (schelog:deref y))))) - ((pair? y) #f) - ((vector? y) #f) - (else (eqv? x y))))))) +(define (ident? x y) + (cond ((ref? x) + (cond ((unbound-ref? x) + (cond ((ref? y) + (cond ((unbound-ref? y) (eq? x y)) + ((frozen-ref? y) #f) + (else (ident? x (deref y))))) + (else #f))) + ((frozen-ref? x) + (cond ((ref? y) + (cond ((unbound-ref? y) #f) + ((frozen-ref? y) (eq? x y)) + (else (ident? x (deref y))))) + (else #f))) + (else (ident? (deref x) y)))) + ((pair? x) + (cond ((ref? y) + (cond ((unbound-ref? y) #f) + ((frozen-ref? y) #f) + (else (ident? x (deref y))))) + ((pair? y) + (and (ident? (car x) (car y)) + (ident? (cdr x) (cdr y)))) + (else #f))) + ((vector? x) + (cond ((ref? y) + (cond ((unbound-ref? y) #f) + ((frozen-ref? y) #f) + (else (ident? x (deref y))))) + ((vector? y) + (ident? (vector->list x) + (vector->list y))) + (else #f))) + (else + (cond ((ref? y) + (cond ((unbound-ref? y) #f) + ((frozen-ref? y) #f) + (else (ident? x (deref y))))) + ((pair? y) #f) + ((vector? y) #f) + (else (eqv? x y)))))) -(define %== - (lambda (x y) - (lambda (fk) (if (schelog:ident? x y) fk (fk 'fail))))) +(define (%== x y) + (lambda (fk) (if (ident? x y) fk (fk 'fail)))) -(define %/== - (lambda (x y) - (lambda (fk) (if (schelog:ident? x y) (fk 'fail) fk)))) +(define (%/== x y) + (lambda (fk) (if (ident? x y) (fk 'fail) fk))) ;variables as objects -(define schelog:freeze - (lambda (s) - (let ((dict '())) - (let loop ((s s)) - (cond ((schelog:ref? s) - (cond ((or (schelog:unbound-ref? s) (schelog:frozen-ref? s)) - (let ((x (assq s dict))) - (if x (cdr x) - (let ((y (schelog:freeze-ref s))) - (set! dict (cons (cons s y) dict)) - y)))) - ;((schelog:frozen-ref? s) s) ;? - (else (loop (schelog:deref s))))) - ((pair? s) (cons (loop (car s)) (loop (cdr s)))) - ((vector? s) - (list->vector (map loop (vector->list s)))) - (else s)))))) +(define (freeze s) + (let ((dict '())) + (let loop ((s s)) + (cond ((ref? s) + (cond ((or (unbound-ref? s) (frozen-ref? s)) + (let ((x (assq s dict))) + (if x (cdr x) + (let ((y (freeze-ref s))) + (set! dict (cons (cons s y) dict)) + y)))) + ;((frozen-ref? s) s) ;? + (else (loop (deref s))))) + ((pair? s) (cons (loop (car s)) (loop (cdr s)))) + ((vector? s) + (list->vector (map loop (vector->list s)))) + (else s))))) -(define schelog:melt - (lambda (f) - (cond ((schelog:ref? f) - (cond ((schelog:unbound-ref? f) f) - ((schelog:frozen-ref? f) (schelog:thaw-frozen-ref f)) - (else (schelog:melt (schelog:deref f))))) - ((pair? f) - (cons (schelog:melt (car f)) (schelog:melt (cdr f)))) - ((vector? f) - (list->vector (map schelog:melt (vector->list f)))) - (else f)))) +(define (melt f) + (cond ((ref? f) + (cond ((unbound-ref? f) f) + ((frozen-ref? f) (thaw-frozen-ref f)) + (else (melt (deref f))))) + ((pair? f) + (cons (melt (car f)) (melt (cdr f)))) + ((vector? f) + (list->vector (map melt (vector->list f)))) + (else f))) -(define schelog:melt-new - (lambda (f) - (let ((dict '())) - (let loop ((f f)) - (cond ((schelog:ref? f) - (cond ((schelog:unbound-ref? f) f) - ((schelog:frozen-ref? f) - (let ((x (assq f dict))) - (if x (cdr x) - (let ((y (schelog:make-ref))) - (set! dict (cons (cons f y) dict)) - y)))) - (else (loop (schelog:deref f))))) - ((pair? f) (cons (loop (car f)) (loop (cdr f)))) - ((vector? f) - (list->vector (map loop (vector->list f)))) - (else f)))))) +(define (melt-new f) + (let ((dict '())) + (let loop ((f f)) + (cond ((ref? f) + (cond ((unbound-ref? f) f) + ((frozen-ref? f) + (let ((x (assq f dict))) + (if x (cdr x) + (let ((y (_))) + (set! dict (cons (cons f y) dict)) + y)))) + (else (loop (deref f))))) + ((pair? f) (cons (loop (car f)) (loop (cdr f)))) + ((vector? f) + (list->vector (map loop (vector->list f)))) + (else f))))) -(define schelog:copy - (lambda (s) - (schelog:melt-new (schelog:freeze s)))) +(define (copy s) + (melt-new (freeze s))) -(define %freeze - (lambda (s f) - (lambda (fk) - ((%= (schelog:freeze s) f) fk)))) +(define (%freeze s f) + (lambda (fk) + ((%= (freeze s) f) fk))) -(define %melt - (lambda (f s) - (lambda (fk) - ((%= (schelog:melt f) s) fk)))) +(define (%melt f s) + (lambda (fk) + ((%= (melt f) s) fk))) -(define %melt-new - (lambda (f s) - (lambda (fk) - ((%= (schelog:melt-new f) s) fk)))) +(define (%melt-new f s) + (lambda (fk) + ((%= (melt-new f) s) fk))) -(define %copy - (lambda (s c) - (lambda (fk) - ((%= (schelog:copy s) c) fk)))) +(define (%copy s c) + (lambda (fk) + ((%= (copy s) c) fk))) ;negation as failure -(define %not - (lambda (g) - (lambda (fk) - (if (call-with-current-continuation - (lambda (k) - ((schelog:deref* g) (lambda (d) (k #f))))) - (fk 'fail) fk)))) +(define (%not g) + (lambda (fk) + (if (let/cc k + ((deref* g) (lambda (d) (k #f)))) + (fk 'fail) fk))) ;assert, asserta -(define %empty-rel - (lambda args - %fail)) +(define (%empty-rel . args) + %fail) (define-syntax %assert (syntax-rules () @@ -484,80 +425,71 @@ ;set predicates -(define schelog:set-cons - (lambda (e s) - (if (member e s) s (cons e s)))) +(define (set-cons e s) + (if (member e s) s (cons e s))) (define-syntax %free-vars (syntax-rules () ((%free-vars (v ...) g) - (cons 'schelog:goal-with-free-vars + (cons 'goal-with-free-vars (cons (list v ...) g))))) -(define schelog:goal-with-free-vars? - (lambda (x) - (and (pair? x) (eq? (car x) 'schelog:goal-with-free-vars)))) +(define (goal-with-free-vars? x) + (and (pair? x) (eq? (car x) 'goal-with-free-vars))) -(define schelog:make-bag-of - (lambda (kons) - (lambda (lv goal bag) - (let ((fvv '())) - (when (schelog:goal-with-free-vars? goal) - (set! fvv (cadr goal)) - (set! goal (cddr goal))) - (schelog:make-bag-of-aux kons fvv lv goal bag))))) +(define ((make-bag-of kons) lv goal bag) + (let ((fvv '())) + (when (goal-with-free-vars? goal) + (set! fvv (cadr goal)) + (set! goal (cddr goal))) + (make-bag-of-aux kons fvv lv goal bag))) -(define schelog:make-bag-of-aux - (lambda (kons fvv lv goal bag) - (lambda (fk) - (call-with-current-continuation - (lambda (sk) - (let ((lv2 (cons fvv lv))) - (let* ((acc '()) - (fk-final - (lambda (d) - ;;(set! acc (reverse! acc)) - (sk ((schelog:separate-bags fvv bag acc) fk)))) - (fk-retry (goal fk-final))) - (set! acc (kons (schelog:deref* lv2) acc)) - (fk-retry 'retry)))))))) +(define (make-bag-of-aux kons fvv lv goal bag) + (lambda (fk) + (let/cc sk + (let ((lv2 (cons fvv lv))) + (let* ((acc '()) + (fk-final + (lambda (d) + ;;(set! acc (reverse! acc)) + (sk ((separate-bags fvv bag acc) fk)))) + (fk-retry (goal fk-final))) + (set! acc (kons (deref* lv2) acc)) + (fk-retry 'retry)))))) -(define schelog:separate-bags - (lambda (fvv bag acc) - ;;(format #t "Accum: ~s~%" acc) - (let ((bags (let loop ((acc acc) - (current-fvv #f) (current-bag '()) - (bags '())) - (if (null? acc) - (cons (cons current-fvv current-bag) bags) - (let ((x (car acc))) - (let ((x-fvv (car x)) (x-lv (cdr x))) - (if (or (not current-fvv) (equal? x-fvv current-fvv)) - (loop (cdr acc) x-fvv (cons x-lv current-bag) bags) - (loop (cdr acc) x-fvv (list x-lv) - (cons (cons current-fvv current-bag) bags))))))))) - ;;(format #t "Bags: ~a~%" bags) - (if (null? bags) (%= bag '()) - (let ((fvv-bag (cons fvv bag))) - (let loop ((bags bags)) - (if (null? bags) %fail - (%or (%= fvv-bag (car bags)) - (loop (cdr bags)))))))))) +(define (separate-bags fvv bag acc) + ;;(format #t "Accum: ~s~%" acc) + (let ((bags (let loop ((acc acc) + (current-fvv #f) (current-bag '()) + (bags '())) + (if (null? acc) + (cons (cons current-fvv current-bag) bags) + (let ((x (car acc))) + (let ((x-fvv (car x)) (x-lv (cdr x))) + (if (or (not current-fvv) (equal? x-fvv current-fvv)) + (loop (cdr acc) x-fvv (cons x-lv current-bag) bags) + (loop (cdr acc) x-fvv (list x-lv) + (cons (cons current-fvv current-bag) bags))))))))) + ;;(format #t "Bags: ~a~%" bags) + (if (null? bags) (%= bag '()) + (let ((fvv-bag (cons fvv bag))) + (let loop ((bags bags)) + (if (null? bags) %fail + (%or (%= fvv-bag (car bags)) + (loop (cdr bags))))))))) -(define %bag-of (schelog:make-bag-of cons)) -(define %set-of (schelog:make-bag-of schelog:set-cons)) +(define %bag-of (make-bag-of cons)) +(define %set-of (make-bag-of set-cons)) ;%bag-of-1, %set-of-1 hold if there's at least one solution -(define %bag-of-1 - (lambda (x g b) - (%and (%bag-of x g b) - (%= b (cons (_) (_)))))) +(define (%bag-of-1 x g b) + (%and (%bag-of x g b) + (%= b (cons (_) (_))))) -(define %set-of-1 - (lambda (x g s) - (%and (%set-of x g s) - (%= s (cons (_) (_)))))) +(define (%set-of-1 x g s) + (%and (%set-of x g s) + (%= s (cons (_) (_))))) ;user interface @@ -565,51 +497,46 @@ ;of v ... if query succeeds. In the latter case, type (%more) to ;retry query for more instantiations. -(define schelog:*more-k* (box 'forward)) -(define schelog:*more-fk* (box 'forward)) +(define *more-k* (box 'forward)) +(define *more-fk* (box 'forward)) (define-syntax %which (syntax-rules () ((%which (v ...) g) (%let (v ...) - (call-with-current-continuation - (lambda (__qk) - (set-box! schelog:*more-k* __qk) - (set-box! schelog:*more-fk* - ((schelog:deref* g) - (lambda (d) - (set-box! schelog:*more-fk* #f) - ((unbox schelog:*more-k*) #f)))) - ((unbox schelog:*more-k*) - (map (lambda (nam val) (list nam (schelog:deref* val))) - '(v ...) - (list v ...))))))))) + (let/cc __qk + (set-box! *more-k* __qk) + (set-box! *more-fk* + ((deref* g) + (lambda (d) + (set-box! *more-fk* #f) + ((unbox *more-k*) #f)))) + ((unbox *more-k*) + (list (list 'v (deref* v)) + ...))))))) -(define %more - (lambda () - (call-with-current-continuation - (lambda (k) - (set-box! schelog:*more-k* k) - (if (unbox schelog:*more-fk*) ((unbox schelog:*more-fk*) 'more) - #f))))) +(define (%more) + (let/cc k + (set-box! *more-k* k) + (if (unbox *more-fk*) + ((unbox *more-fk*) 'more) + #f))) ;end of embedding code. The following are ;some utilities, written in Schelog -(define %member - (lambda (x y) - (%let (xs z zs) - (%or - (%= y (cons x xs)) - (%and (%= y (cons z zs)) - (%member x zs)))))) +(define (%member x y) + (%let (xs z zs) + (%or + (%= y (cons x xs)) + (%and (%= y (cons z zs)) + (%member x zs))))) -(define %if-then-else - (lambda (p q r) - (%cut-delimiter - (%or - (%and p ! q) - r)))) +(define (%if-then-else p q r) + (%cut-delimiter + (%or + (%and p ! q) + r))) ;the above could also have been written in a more ;Prolog-like fashion, viz.