Changing style
This commit is contained in:
Jay McCarthy
parent
ca987f9020
commit
e0b571618a
|
|
@ -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)))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
||||
|
|
@ -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=))))))
|
||||
|
|
@ -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!)))))
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user