#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh 'Readme' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
XInstalling schelog:
X
Xschelog, the Prolog-in-Scheme provided here, is written in Ch*z
XScheme. The code is mostly RRRS-compatible. Deviations include the
Xuse of extend-syntax, the syntactic definition facility, which is
Xeasily obtained, the box (called ref in some Schemes) data structure
Xused for logic variables, and printf for formatted output. The form
Xrecur is Ch*z's named let. (I would suggest defining these as
Xutilities in your Scheme if they aren't already available.) A
Xreasonably competent Schemer should be able to fix those parts which
Xcause trouble in his/her particular brand of Scheme, even without
Xunderstanding what the code is doing. If you have problems, send me
Xemail at dorai@rice.edu. (You want to know my gripe about RRRS: it's
Xa standard all right, but it manages to be so by just plain refusing
Xto talk about several things, like macros. :-[)
X
XThe makefile assumes you have Ch*z Scheme. If so, perform a "make" to
Xget the compiled versions {schelog.so, bagof.so} of the files
X{schelog.ss, bagof.ss}. Otherwise, ignore the makefile; you're then
Xforced to use the uncompiled *.ss files, which should be fine, if
Xslow.
X
XYou are allowed to make any changes you want to this implementation.
XYou may want to drop me a note though!
X
XUsing schelog:
X
XLoading schelog.so (schelog.ss) followed by bagof.so (or bagof.ss) in
Xyour Scheme session gives you the Prolog embedding. Some details
Xabout syntax are given in the file called Usage.
X
XThe shell script "schelog" simply makes use of the command-line
Xloading facility of Ch*z. Insert the required change in the name of
Xthe directory in the sbin= line. If your Scheme doesn't have the
Xcommand-line loading ability, just ignore this script, and use schelog
Xas in previous paragraph.
X
XThe implementation consists of the files schelog.ss and bagof.ss
X(only). The other (code) files are example files, most of the
Xexamples coming from Shapiro and Sterling's book, _The Art of Prolog_.
XThe examples should give some clue about the writing and running of
XProlog programs in this implementation. Enjoy. If you encounter
Xproblems and/or bugs, send email.
X
XIt is beyond the scope of this documentation to tell you _how_ the
Ximplementation works. Reading the code may be useful (!?), but the
Xfollowing references should be a better guide to a big part of at
Xleast one of the implementation files.
X
XLiterature:
X
XChristopher Haynes, Logic Continuations. J. Logic Program. 4, 1987,
X157-176.
X
XMatthias Felleisen, Transliterating Prolog into Scheme, Tech. Rep.
X182, Indiana Univ. Comp. Sci. Dept., 1985.
END_OF_FILE
if test 2784 -ne `wc -c <'Readme'`; then
echo shar: \"'Readme'\" unpacked with wrong size!
fi
# end of 'Readme'
fi
if test -f 'Usage' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Usage'\"
else
echo shar: Extracting \"'Usage'\" \(3436 characters\)
sed "s/^X//" >'Usage' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
XThe syntax of the Prolog provided here may be unusual.
X
XThis note assumes you already know enough of Prolog and Scheme, at
Xleast syntax-wise. It will just show some examples whereby you can
Xfigure out how to transfer your knowledge of writing programs in
X"real" Prolog to writing in schelog.
X
XThe member predicate in "real" Prolog:
X
Xmember(X, [X|Xs]).
Xmember(X, [Y|Ys]) :- member(X,Ys).
X
XThe _same_ program in schelog:
X
X(define %member
X (rel (x xs y ys)
X [(x [cons x xs])]
X [(x [cons y ys]) (%member x ys)]))
X
XIt is a convention (which can be flouted) that all schelog predicates
Xare named with an inital %. This is solely to avoid confusion with
XScheme procedures of the same name. Use arbitrary naming systems as
Xyou please.
X
XRelations are defined using the form rel. rel is followed by a list of
Xidentifiers, these being the names of the logic variables used in the
Xdefinition of the relation. There is no naming convention involved here
X(as say initial-capital as in Prolog). cons is the constructor | of
XProlog. rel introduces the list of rules corresponding to the relation.
X
XFor another example, the if-then-else predicate in "real" Prolog:
X
Xif_then_else(P, Q, R) :- P, !, Q.
Xif_then_else(P, Q, R) :- R.
X
XThe _same_ in schelog reads:
X
X(define %ifthenelse
X (rel (p q r)
X [(p q r) p ! q]
X [(p q r) r]))
X
XThe cut is written !, as in Prolog.
XAnonymous variables are written (_), thus member could also be written:
X
X(define %member
X (rel (x xs)
X [(x [cons x (_)])]
X [(x [cons (_) xs]) (%member x xs)]))
X
Xwhich corresponds to:
X
Xmember(X, [X|_]).
Xmember(X, [_|Xs]) :- member(X, Xs).
X
XThis should give you a feel for the syntax. If not, read some of the
Xexample files provided for further exposure.
X
XThe interactive Prolog queries (?-) are handled with the form which:
X
X(which () (%member 1 '[1 2 3]))
X
Xcorresponds to ?- member(1, [1,2,3])
X
Xand returns
X
X#t ; more?
X
XTyping n or no after the more? prompt throws away all the other
Xanswers, as in Prolog. Typing anything other than n or no (e.g., y)
Xprovides alternate solutions. Here, there being no alternate
Xsolutions, typing y gives ().
X
X#t ; more? y
X()
X
Xwhich is followed by a list of logic variables whose bindings are
Xgiven as the solution. Thus
X
X(which (x) (%member x '[1 2 3])) gives
X x = 1
X#t ; more?
X
XProdding for more answers of course gives the following:
X
X x = 1
X#t ; more? y
X x = 2
X#t ; more? y
X x = 3
X#t ; more? y
X
XOne could also use the style (letref (x ...) (which (y ...) queries
X...)). Both letref and which introduce logic variables. However, in
Xthe solutions, only the which-variables are enumerated. E.g.,
X
X(letref (x) (which () (%member x '[1 2 3])))
X
Xsucceeds three times, without giving the values of x.
X
X#t ; more? y
X#t ; more? y
X#t ; more? y
X()
X
XSince schelog relations are just Scheme procedures, one can use
Xlexical scoping to define auxiliary relations, e.g., reverse using an
Xauxiliary that uses an accumulator (see toys.ss). One is also not
Xtied to the Prolog style--regular Scheme can be used too, treating the
XProlog relations as just another paradigm used for local convenience
Xand along with other paradigms, such as streams, coroutines and other
XScheme procedures and forms.
END_OF_FILE
if test 3436 -ne `wc -c <'Usage'`; then
echo shar: \"'Usage'\" unpacked with wrong size!
fi
# end of 'Usage'
fi
if test -f 'amsterdam.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'amsterdam.ss'\"
else
echo shar: Extracting \"'amsterdam.ss'\" \(699 characters\)
sed "s/^X//" >'amsterdam.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; this is a very trivial program, corresponds to the facts:
X;;; city(amsterdam).
X;;; city(brussels).
X;;; country(holland).
X;;; country(belgium).
X
X(define city
X (rel ()
X [('amsterdam)] [('brussels)]))
X
X(define country
X (rel ()
X [('holland)] [('belgium)]))
X
X;;; Typical easy queries:
X;;; (which (x) (city x)) succeeds twice
X;;; (which (x) (country x)) succeeds twice
X;;; (which () (city 'amsterdam)) succeeds
X;;; (which () (country 'amsterdam)) fails
END_OF_FILE
if test 699 -ne `wc -c <'amsterdam.ss'`; then
echo shar: \"'amsterdam.ss'\" unpacked with wrong size!
fi
# end of 'amsterdam.ss'
fi
if test -f 'bagof.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'bagof.ss'\"
else
echo shar: Extracting \"'bagof.ss'\" \(3026 characters\)
sed "s/^X//" >'bagof.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; set predicates
X
X(define %%copy-back
X (lambda (l r)
X (if (eq? l r) #t
X (cond [(unbound-box? l) (set-box! l (derefl r))]
X [(frozen-box? l) (error 'copy-back "")]
X [(box? l) (%%copy-back (unbox l) r)]
X [(pair? l)
X (if (pair? r)
X (begin (%%copy-back (car l) (car r))
X (%%copy-back (cdr l) (cdr r)))
X (error 'copy-back ""))]
X [else (error 'copy-back "")]))))
X
X(define %%set-back
X (lambda (l r)
X (cond [(eq? l r) #t]
X [(and (box? r) (not (frozen-box? r)))
X (%%set-back l (unbox r))]
X [else
X (cond [(unbound-box? l) (set-box! l r)]
X [(frozen-box? l) (error 'set-back "")]
X [(box? l) (set-box! l r)]
X [(pair? l) (if (pair? r)
X (begin (%%set-back (car l) (car r))
X (%%set-back (cdr l) (cdr r)))
X (error 'set-back ""))]
X [else (error 'set-back "")])])))
X
X(define *$bagof ; hacky? naaah!!
X (lambda (kons)
X (lambda (t f g s)
X (lambda (fk)
X (let* ([f (remq! t f)]
X [f-tmp (map %%copy f)]
X [fk^ #f]
X [f-prev (map derefl f)]
X [r (call/cc
X (lambda (k)
X (let* ([initial? #t] [s []]
X [fk* (lambda () (k (begin0 (reverse! s)
X (set! s []))))]
X [fk
X ((%and
X g (lambda (fk)
X (let ([f-curr (map derefl f)])
X (cond
X [initial?
X (set! initial? #f)
X (set! f-prev f-curr)
X fk]
X [(andmap equal? f-prev f-curr)
X fk]
X [else
X (call/cfc
X (lambda (fk-new)
X (when fk^ (error 'iio ""))
X (set! fk^ fk-new)
X (fk*)))
X (set! f-prev f-curr)
X fk])))) fk*)])
X (set! s (kons (derefl t) s))
X (fk))))])
X (for-each %%set-back f-tmp f-prev)
X (for-each %%set-back f f-tmp)
X ((%unify s r)
X (lambda ()
X (if fk^ ((begin0 fk^ (set! fk^ #f))) (fk)))))))))
X
X(define $bagof (*$bagof cons))
X
X(define set-cons (lambda (e s) (if (member e s) s (cons e s))))
X(define set-union
X (lambda (s1 s2)
X (if (null? s1) s2
X (set-union (cdr s1) (set-cons (car s1) s2)))))
X(define $setof (*$bagof set-cons))
X
X(define atoms-of
X (lambda (x)
X (recur L ([x x] [r ()] [s ()])
X (cond [(pair? x)
X (record-case x
X [quote (x) s]
X [lambda (vv . b) (L b (set-union (atoms-of vv) r) s)]
X [set! (x a) (L a r (L x r s))]
X [else (L (cdr x) r (L (car x) r s))])]
X [(symbol? x) (set-cons x s)]
X [else s]))))
X
X(define free-vars-among (lambda (s) (cull! %%var s)))
X
X(extend-syntax (%exists)
X [(%exists y g) (let ([y (%%copy y)]) g)])
X
X(extend-syntax (%bagof)
X [(%bagof x g s)
X (with ([atoms-of-g (cons 'list (atoms-of (expand 'g)))])
X ($bagof x (free-vars-among atoms-of-g) g s))])
X
X(extend-syntax (%setof)
X [(%setof x g s)
X (with ([atoms-of-g (cons 'list (atoms-of (expand 'g)))])
X ($setof x (free-vars-among atoms-of-g) g s))])
X
END_OF_FILE
if test 3026 -ne `wc -c <'bagof.ss'`; then
echo shar: \"'bagof.ss'\" unpacked with wrong size!
fi
# end of 'bagof.ss'
fi
if test -f 'bible.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'bible.ss'\"
else
echo shar: Extracting \"'bible.ss'\" \(1272 characters\)
sed "s/^X//" >'bible.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; "biblical" database from Sterling&Shapiro, p. 267,
X;;; Chap. 17, Second-order programming. Illustrates %bagof, %setof.
X
X(define %father
X (rel ()
X [('terach 'abraham)] [('terach 'nachor)] [('terach 'haran)]
X [('abraham 'isaac)] [('haran 'lot)] [('haran 'milcah)]
X [('haran 'yiscah)]))
X
X(define %mother
X (rel () [('sarah 'isaac)]))
X
X(define %male
X (rel ()
X [('terach)] [('abraham)] [('isaac)] [('lot)] [('haran)] [('nachor)]))
X
X(define %female
X (rel ()
X [('sarah)] [('milcah)] [('yiscah)]))
X
X'(define %children ; difficult to read and possibly problematic
X (letrec ([children-aux
X (rel (x a cc c)
X [(x a cc)
X (%father x c) (%not (%member c a)) !
X (children-aux x (cons c a) cc)]
X [(x cc cc)])])
X (rel (x cc)
X [(x cc) (children-aux x [] cc)])))
X
X(define %children
X (rel (x kids c)
X [(kids) (%bagof c (%exists x (%father x c)) kids)]))
X
X(define dad-kids-tst
X (lambda ()
X (letref (dad kids x)
X (which (dad-kids)
X (%setof [list dad kids]
X (%setof x (%father dad x) kids)
X dad-kids)))))
END_OF_FILE
if test 1272 -ne `wc -c <'bible.ss'`; then
echo shar: \"'bible.ss'\" unpacked with wrong size!
fi
# end of 'bible.ss'
fi
if test -f 'england.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'england.ss'\"
else
echo shar: Extracting \"'england.ss'\" \(1395 characters\)
sed "s/^X//" >'england.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; The following is a simple database about a certain family in England.
X;;; Should be a piece of cake, but given here so that you can hone
X;;; your ability to read the syntax.
X
X(define male
X (rel ()
X [('philip)] [('charles)] [('andrew)] [('edward)]
X [('mark)] [('william)] [('harry)] [('peter)]))
X
X(define female
X (rel ()
X [('elizabeth)] [('anne)] [('diana)] [('sarah)] [('zara)]))
X
X(define husbandof
X (rel ()
X [('philip 'elizabeth)] [('charles 'diana)]
X [('mark 'anne)] [('andrew 'sarah)]))
X
X(define wifeof
X (rel (w h)
X [(w h) (husbandof h w)]))
X
X(define marriedto
X (rel (x y)
X [(x y) (husbandof x y)]
X [(x y) (wifeof x y)]))
X
X(define fatherof
X (rel ()
X [('philip 'charles)] [('philip 'anne)] [('philip 'andrew)]
X [('philip 'edward)] [('charles 'william)] [('charles 'harry)]
X [('mark 'peter)] [('mark 'zara)]))
X
X(define motherof
X (rel (m c f)
X [(m c) (wifeof m f) (fatherof f c)]))
X
X(define childof
X (rel (c p)
X [(c p) (fatherof p c)]
X [(c p) (motherof p c)]))
X
X(define parentof
X (rel (p c)
X [(p c) (childof c p)]))
X
X(define brotherof
X (rel (b x f)
X [(b x) (male b) (fatherof f b) (fatherof f x) (%notunify b x)]))
END_OF_FILE
if test 1395 -ne `wc -c <'england.ss'`; then
echo shar: \"'england.ss'\" unpacked with wrong size!
fi
# end of 'england.ss'
fi
if test -f 'games.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'games.ss'\"
else
echo shar: Extracting \"'games.ss'\" \(2497 characters\)
sed "s/^X//" >'games.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; This example is from Sterling&Shapiro, page 214.
X
X;;; The problem reads:
X
X;;; Three friends came first, second and third in a competition.
X;;; Each had a different name, liked a different sport, and had a
X;;; different nationality.
X;;; Michael likes basketball, and did better than the American.
X;;; Simon, the Israeli, did better than the tennis player. The
X;;; cricket player came first.
X;;; Who's the Australian? What sport does Richard play?
X
X(define-functor person name country sport)
X
X(define %games
X (rel (clues queries solution the-men
X n1 n2 n3 c1 c2 c3 s1 s2 s3)
X [(clues queries solution)
X (%unify the-men
X [list [person n1 c1 s1] [person n2 c2 s2] [person n3 c3 s3]])
X (%games-clues the-men clues)
X (%games-queries the-men queries solution)]))
X
X(define %games-clues
X (rel (the-men clue1-man1 clue1-man2 clue2-man1 clue2-man2 clue3-man)
X [(the-men
X [list
X (%did-better clue1-man1 clue1-man2 the-men)
X (%name clue1-man1 'michael)
X (%sport clue1-man1 'basketball)
X (%country clue1-man2 'usa)
X
X (%did-better clue2-man1 clue2-man2 the-men)
X (%name clue2-man1 'simon)
X (%country clue2-man1 'israel)
X (%sport clue2-man2 'tennis)
X
X (%first the-men clue3-man)
X (%sport clue3-man 'cricket)])]))
X
X(define %games-queries
X (rel (the-men man1 man2 aussies-name dicks-sport)
X [(the-men
X [list
X (%member man1 the-men)
X (%country man1 'australia)
X (%name man1 aussies-name)
X
X (%member man2 the-men)
X (%name man2 'richard)
X (%sport man2 dicks-sport)]
X [list
X [list aussies-name 'is 'the 'australian]
X [list 'richard 'plays dicks-sport]])]))
X
X(define %did-better
X (rel (a b c)
X [(a b [list a b c])]
X [(a c [list a b c])]
X [(b c [list a b c])]))
X
X(define %name
X (rel (name country sport)
X [([person name country sport] name)]))
X
X(define %country
X (rel (name country sport)
X [([person name country sport] country)]))
X
X(define %sport
X (rel (name country sport)
X [([person name country sport] sport)]))
X
X(define %first
X (rel (car cdr)
X [([cons car cdr] car)]))
X
X;;; With the above as the database, and also loading the file
X;;; puzzle.ss containing the puzzle solver, we merely need to
X;;; ask (tst %games) to get the solution:
X;;; ((michael is the australian) (richard plays tennis))
END_OF_FILE
if test 2497 -ne `wc -c <'games.ss'`; then
echo shar: \"'games.ss'\" unpacked with wrong size!
fi
# end of 'games.ss'
fi
if test -f 'header' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'header'\"
else
echo shar: Extracting \"'header'\" \(219 characters\)
sed "s/^X//" >'header' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
END_OF_FILE
if test 219 -ne `wc -c <'header'`; then
echo shar: \"'header'\" unpacked with wrong size!
fi
# end of 'header'
fi
if test -f 'houses.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'houses.ss'\"
else
echo shar: Extracting \"'houses.ss'\" \(3275 characters\)
sed "s/^X//" >'houses.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; Exercise 14.1 (iv) from Sterling&Shapiro.
X
X(define-functor house hue nation pet drink cigarette)
X
X(define %hue (rel (h) [([house h (_) (_) (_) (_)] h)]))
X(define %nation (rel (n) [([house (_) n (_) (_) (_)] n)]))
X(define %pet (rel (p) [([house (_) (_) p (_) (_)] p)]))
X(define %drink (rel (d) [([house (_) (_) (_) d (_)] d)]))
X(define %cigarette (rel (c) [([house (_) (_) (_) (_) c] c)]))
X
X(define %adjacent
X (rel (a b)
X [(a b [list a b (_) (_) (_)])]
X [(a b [list (_) a b (_) (_)])]
X [(a b [list (_) (_) a b (_)])]
X [(a b [list (_) (_) (_) a b])]))
X
X(define %middle
X (rel (a)
X [(a [list (_) (_) a (_) (_)])]))
X
X(define %houses
X (rel (row-of-houses clues queries solution
X h1 h2 h3 h4 h5 n1 n2 n3 n4 n5 p1 p2 p3 p4 p5
X d1 d2 d3 d4 d5 c1 c2 c3 c4 c5)
X [(clues queries solution)
X (%unify row-of-houses
X [list
X [house h1 n1 p1 d1 c1]
X [house h2 n2 p2 d2 c2]
X [house h3 n3 p3 d3 c3]
X [house h4 n4 p4 d4 c4]
X [house h5 n5 p5 d5 c5]])
X (%houses-clues row-of-houses clues)
X (%houses-queries row-of-houses queries solution)]))
X
X(define %houses-clues
X (rel (row-of-houses abode1 abode2 abode3 abode4 abode5 abode6 abode7
X abode8 abode9 abode10 abode11 abode12 abode13 abode14 abode15)
X [(row-of-houses
X [list
X (%member abode1 row-of-houses)
X (%nation abode1 'english)
X (%hue abode1 'red)
X
X (%member abode2 row-of-houses)
X (%nation abode2 'spain)
X (%pet abode2 'dog)
X
X (%member abode3 row-of-houses)
X (%drink abode3 'coffee)
X (%hue abode3 'green)
X
X (%member abode4 row-of-houses)
X (%nation abode4 'ukraine)
X (%drink abode4 'tea)
X
X (%member abode5 row-of-houses)
X (%adjacent abode5 abode3 row-of-houses)
X (%hue abode5 'ivory)
X
X (%member abode6 row-of-houses)
X (%cigarette abode6 'winston)
X (%pet abode6 'snail)
X
X (%member abode7 row-of-houses)
X (%cigarette abode7 'kool)
X (%hue abode7 'yellow)
X
X (%unify [list (_) (_) abode8 (_) (_)] row-of-houses)
X (%drink abode8 'milk)
X
X (%unify [list abode9 (_) (_) (_) (_)] row-of-houses)
X (%nation abode9 'norway)
X
X (%member abode10 row-of-houses)
X (%member abode11 row-of-houses)
X (%or (%adjacent abode10 abode11) (%adjacent abode11 abode10))
X (%cigarette abode10 'chesterfield)
X (%pet abode11 'fox)
X
X (%member abode12 row-of-houses)
X (%or (%adjacent abode7 abode12) (%adjacent abode12 abode7))
X (%pet abode12 'horse)
X
X (%member abode13 row-of-houses)
X (%cigarette abode13 'lucky-strike)
X (%drink abode13 'oj)
X
X (%member abode14 row-of-houses)
X (%nation abode14 'japan)
X (%cigarette abode14 'parliament)
X
X (%member abode15 row-of-houses)
X (%or (%adjacent abode9 abode15) (%adjacent abode15 abode9))
X (%hue abode15 'blue)])]))
X
X(define %houses-queries
X (rel (row-of-houses abode1 abode2 zebra-owner water-drinker)
X [(row-of-houses
X [list
X (%member abode1 row-of-houses)
X (%pet abode1 'zebra)
X (%nation abode1 zebra-owner)
X
X (%member abode2 row-of-houses)
X (%drink abode2 'water)
X (%nation abode2 water-drinker)]
X
X [list [list zebra-owner 'owns 'the 'zebra]
X [list water-drinker 'drinks 'water]])]))
END_OF_FILE
if test 3275 -ne `wc -c <'houses.ss'`; then
echo shar: \"'houses.ss'\" unpacked with wrong size!
fi
# end of 'houses.ss'
fi
if test -f 'makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'makefile'\"
else
echo shar: Extracting \"'makefile'\" \(178 characters\)
sed "s/^X//" >'makefile' <<'END_OF_FILE'
Xall: schelog.so bagof.so
X
Xschelog.so: schelog.ss
X echo '(compile-file "schelog")' | chez
X
Xbagof.so: bagof.ss schelog.so
X echo '(load "schelog.so") (compile-file "bagof")' | chez
END_OF_FILE
if test 178 -ne `wc -c <'makefile'`; then
echo shar: \"'makefile'\" unpacked with wrong size!
fi
# end of 'makefile'
fi
if test -f 'mapcol.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'mapcol.ss'\"
else
echo shar: Extracting \"'mapcol.ss'\" \(2041 characters\)
sed "s/^X//" >'mapcol.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; Map coloring, example from Sterling&Shapiro, p. 212.
X
X(define %member
X (rel (X Xs Y Ys)
X [(X [cons X Xs])]
X [(X [cons Y Ys]) (%member X Ys)]))
X
X(define %members
X (rel (X Xs Ys)
X [([cons X Xs] Ys) (%member X Ys) (%members Xs Ys)]
X [([] Ys)]))
X
X(define %select
X (rel (X Xs Y Ys Zs)
X [(X [cons X Xs] Xs)]
X [(X [cons Y Ys] [cons Y Zs])
X (%select X Ys Zs)]))
X
X(define-functor region name color neighbors)
X
X(define %color-map
X (rel (Region Regions Colors)
X [([cons Region Regions] Colors)
X (%color-region Region Colors) (%color-map Regions Colors)]
X [([] Colors)]))
X
X(define %color-region
X (rel (Name Color Neighbors Colors Colors1)
X [([region Name Color Neighbors] Colors)
X (%select Color Colors Colors1)
X (%members Neighbors Colors1)]))
X
X(define %test-color
X (rel (Name Map Colors)
X [(Name Map)
X (%map Name Map)
X (%colors Colors)
X (%color-map Map Colors)]))
X
X(define %map
X (rel (A B C D E F P H WG L I S)
X [('test [list
X [region 'a A [list B C D]]
X [region 'b B [list A C E]]
X [region 'c C [list A B D E F]]
X [region 'd D [list A C F]]
X [region 'e E [list B C F]]
X [region 'f F [list C D E]]])]
X [('western-europe
X [list
X [region 'portugal P [list E]]
X [region 'spain E [list F P]]
X [region 'france F [list E I S B WG L]]
X [region 'belgium B [list F H L WG]]
X [region 'holland H [list B WG]]
X [region 'west-germany WG [list F A S H B L]]
X [region 'luxembourg L [list F B WG]]
X [region 'italy I [list F A S]]
X [region 'switzerland S [list F I A WG]]
X [region 'austria A [list I S WG]]])]))
X
X(define %colors
X (rel (X)
X [('[red yellow blue white])]))
X
X;;; ask (which (M) (%test-color 'test M)) or
X;;; ask (which (M) (%test-color 'western-europe M)) for the
X;;; respective (non-unique) colorings.
X
END_OF_FILE
if test 2041 -ne `wc -c <'mapcol.ss'`; then
echo shar: \"'mapcol.ss'\" unpacked with wrong size!
fi
# end of 'mapcol.ss'
fi
if test -f 'puzzle.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'puzzle.ss'\"
else
echo shar: Extracting \"'puzzle.ss'\" \(1174 characters\)
sed "s/^X//" >'puzzle.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; This is the puzzle solver described in Sterling&Shapiro, p. 214
X
X;;; It is a "trivial" (S&S's words, and I don't disagree) piece of code
X;;; that successively solves each clue and query, which are expressed
X;;; as Prolog goals and are executed with the meta-variable facility.
X
X;;; The code in "real" Prolog, for comparison, is:
X;;; solve_puzzle(Clues, Queries, Solution) :- solve(Clues), solve(Queries).
X
X;;; solve([Clue|Clues]) :- Clue, solve(Clues).
X;;; solve([]).
X
X
X(define %solve-puzzle
X (rel (Clues Queries Solution)
X [(Clues Queries Solution)
X (%solve Clues)
X (%solve Queries)]))
X
X(define %solve
X (rel (Clue Clues)
X [([cons Clue Clues])
X Clue
X (%solve Clues)]
X [([])]))
X
X;;; say (tst ) to get the solution to the puzzle.
X
X
X(define tst
X (lambda (puzzle)
X (letref (Clues Queries)
X (which (Solution)
X (puzzle Clues Queries Solution)
X (%solve-puzzle Clues Queries Solution)))))
END_OF_FILE
if test 1174 -ne `wc -c <'puzzle.ss'`; then
echo shar: \"'puzzle.ss'\" unpacked with wrong size!
fi
# end of 'puzzle.ss'
fi
if test -f 'schelog' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'schelog'\"
else
echo shar: Extracting \"'schelog'\" \(270 characters\)
sed "s/^X//" >'schelog' <<'END_OF_FILE'
X#! /bin/sh
X
X# Change *.so to *.ss if you can't compile-file your files.
X# Change the sbin= line to contain the appropriate directory (i.e.,
X# the one containing schelog.s[so] and bagof.s[so].
X
Xsbin=/titan/dorai/scm/logic/ftp
X
Xchez ${sbin}/schelog.so ${sbin}/bagof.so $*
END_OF_FILE
if test 270 -ne `wc -c <'schelog'`; then
echo shar: \"'schelog'\" unpacked with wrong size!
fi
chmod +x 'schelog'
# end of 'schelog'
fi
if test -f 'schelog.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'schelog.ss'\"
else
echo shar: Extracting \"'schelog.ss'\" \(8743 characters\)
sed "s/^X//" >'schelog.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; logic variables and their manipulation
X
X(define **unbound** (make-temp-symbol "_"))
X(define new-box (lambda () (box **unbound**)))
X(define unbind-box! (lambda (b) (set-box! b **unbound**) #f))
X(define unbound-box?
X (lambda (b) (and (box? b) (eq? (unbox b) **unbound**))))
X
X(define **frozen** (make-temp-symbol "@"))
X(define freeze-box (lambda (b) (box (cons **frozen** b))))
X(define thaw-box (lambda (b) (cdr (unbox b))))
X(define frozen-box?
X (lambda (b) (and (box? b)
X (let ([c (unbox b)])
X (and (pair? c) (eq? (car c) **frozen**))))))
X
X(define derefl
X (lambda (x)
X (cond [(unbound-box? x) (unbox x)]
X [(frozen-box? x) x]
X [(box? x) (derefl (unbox x))]
X [(pair? x) (let ([a (car x)] [d (cdr x)])
X (let ([a1 (derefl a)] [d1 (derefl d)])
X (if (and (eq? a a1) (eq? d d1)) x
X (cons a1 d1))))]
X [else x])))
X
X;;; letref introduces new logic-variables
X
X(extend-syntax (letref)
X [(letref (x ...) e ...) (let ([x (new-box)] ...) e ...)])
X
X;;; call/cfc is to command contns as call/cc is to expression contns
X
X(define call/cfc
X (lambda (f)
X (call/cc (lambda (k) (f (lambda () (k ')))))))
X
X;;; the unify predicate, called = in Prolog
X
X(define %unify
X (lambda (t1 t2)
X (lambda (fk)
X (letrec
X ([unify1 (lambda (t1 t2 s)
X (cond [(eqv? t1 t2) s]
X [(box? t1)
X (if (unbound-box? t1)
X (begin (set-box! t1 t2) (cons t1 s))
X (unify1 (unbox t1) t2 s))]
X [(box? t2) (unify1 t2 t1 s)]
X [(and (pair? t1) (pair? t2))
X (unify1 (cdr t1) (cdr t2)
X (unify1 (car t1) (car t2) s))]
X [else (for-each unbind-box! s) (fk)]))])
X (let ([s (unify1 t1 t2 [])])
X (lambda () (for-each unbind-box! s) (fk)))))))
X
X;;; rel introduces relations, which are bunches of related rules
X
X(extend-syntax (rel !)
X [(rel (b ...) [(a ...) p ...] ...)
X (lambda __fmls
X (lambda (__fk)
X (letref (b ...)
X (let ([! (lambda (fk1) __fk)])
X (call/cc
X (lambda (__sk)
X (call/cfc
X (lambda (__fk)
X (let* ([__fk ((%unify __fmls (list a ...)) __fk)]
X [__fk ((derefl p) __fk)] ...)
X (__sk __fk))))
X ...
X (__fk)))))))])
X
X;;; the fail and true predicates
X
X(define %fail (lambda (fk) (fk)))
X(define %true (lambda (fk) fk))
X
X;;; introduces new structure-builders; cons is built-in and is the same
X;;; as Scheme's cons
X
X(extend-syntax (define-functor)
X [(define-functor functor comp ...)
X (define functor (lambda (comp ...) (cons 'functor (list comp ...))))])
X
X;;; use (_) for creating anonymous variables a la Prolog's _
X
X(define _ new-box)
X
X;;; arithmetic, Prolog's is
X
X(extend-syntax (%is quote)
X [(%is[1] (quote x) fk) (quote x)]
X [(%is[1] (x ...) fk) ((%is[1] x fk) ...)]
X [(%is[1] x fk) (if (unbound-box? x) (fk) (derefl x))]
X [(%is v e) (lambda (__fk) ((%unify v (%is[1] e __fk)) __fk))])
X
X;;; defining arithmetic comparison operators
X
X(define *bin-arith-rel
X (lambda (f)
X (rel (x y) [(x y) (%is #t (f x y))])))
X
X(define %eq (*bin-arith-rel =))
X(define %gt (*bin-arith-rel >))
X(define %ge (*bin-arith-rel >=))
X(define %lt (*bin-arith-rel <))
X(define %le (*bin-arith-rel <=))
X(define %ne (*bin-arith-rel (lambda (m n) (not (= m n)))))
X
X;;; type predicates
X
X(define %%constant
X (lambda (x)
X (cond [(unbound-box? x) #f]
X [(frozen-box? x) #t]
X [(box? x) (%%constant (unbox x))]
X [(pair? x) #f]
X [else #t])))
X
X(define %%compound
X (lambda (x)
X (cond [(unbound-box? x) #f]
X [(frozen-box? x) #f]
X [(box? x) (%%compound (unbox x))]
X [(pair? x) #t]
X [else #f])))
X
X(define %constant
X (lambda (x)
X (lambda (fk) (if (%%constant x) fk (fk)))))
X
X(define %compound
X (lambda (x)
X (lambda (fk) (if (%%compound x) fk (fk)))))
X
X;;; metalogical type predicates
X
X(define %%var
X (lambda (x)
X (cond [(unbound-box? x) #t]
X [(frozen-box? x) #f]
X [(box? x) (%%var (unbox x))]
X [(pair? x) (or (%%var (car x)) (%%var (cdr x)))]
X [else #f])))
X
X(define %%nonvar (lambda (x) (not (%%var x))))
X
X(define %var
X (lambda (x)
X (lambda (fk) (if (%%var x) fk (fk)))))
X
X(define %nonvar
X (lambda (x)
X (lambda (fk) (if (%%var x) (fk) fk))))
X
X;;; %unify
X
X(define *negation ; basically inlined cut-fail
X (lambda (p)
X (lambda aa
X (lambda (fk)
X (if (call/cc
X (lambda (k)
X ((apply p aa) (lambda () (k #f))))) (fk) fk)))))
X
X(define %notunify (*negation %unify))
X
X(define %%ident
X (lambda (x y)
X (cond [(unbound-box? x)
X (cond [(unbound-box? y) (eq? x y)]
X [(frozen-box? y) #f]
X [(box? y) (%%ident x (unbox y))]
X [(pair? y) #f]
X [else #f])]
X [(frozen-box? x)
X (cond [(unbound-box? y) #f]
X [(frozen-box? y) (eq? x y)]
X [(box? y) (%%ident x (unbox y))]
X [(pair? y) #f]
X [else #f])]
X [(box? x) (%%ident (unbox x) y)]
X [(pair? x)
X (cond [(unbound-box? y) #f]
X [(frozen-box? y) #f]
X [(box? y) (%%ident x (unbox y))]
X [(pair? y) (and (%%ident (car x) (car y))
X (%%ident (cdr x) (cdr y)))]
X [else #f])]
X [else
X (cond [(unbound-box? y) #f]
X [(frozen-box? y) #f]
X [(box? y) (%%ident x (unbox y))]
X [(pair? y) #f]
X [else (eqv? x y)])])))
X
X(define %ident
X (lambda (x y)
X (lambda (fk) (if (%%ident x y) fk (fk)))))
X
X(define %notident
X (lambda (x y)
X (lambda (fk) (if (%%ident) (fk) fk))))
X
X;;; variables as objs
X
X(define %%freeze
X (lambda (t)
X (let ([dict []])
X (recur loop ([t t])
X (cond [(unbound-box? t)
X (let ([x (assq t dict)])
X (if x (cdr x)
X (let ([y (freeze-box t)])
X (set! dict (cons (cons t y) dict))
X y)))]
X [(frozen-box? t) t]
X [(box? t) (loop (unbox t))]
X [(pair? t) (cons (loop (car t)) (loop (cdr t)))]
X [else t])))))
X
X(define %%melt
X (lambda (f)
X (cond [(unbound-box? f) f]
X [(frozen-box? f) (thaw-box f)]
X [(box? f) (%%melt (unbox f))]
X [(pair? f) (cons (%%melt (car f)) (%%melt (cdr f)))]
X [else f])))
X
X
X(define %%melt-new
X (lambda (f)
X (let ([dict []])
X (recur loop ([f f])
X (cond [(unbound-box? f) f]
X [(frozen-box? f)
X (let ([x (assq f dict)])
X (if x (cdr x)
X (let ([y (new-box)])
X (set! dict (cons (cons f y) dict))
X y)))]
X [(box? f) (loop (unbox f))]
X [(pair? f) (cons (loop (car f)) (loop (cdr f)))]
X [else f])))))
X
X(define %%copy (lambda (t) (%%melt-new (%%freeze t))))
X
X(define %freeze
X (lambda (t f)
X (lambda (fk)
X ((%unify
X f (%%freeze t)) fk))))
X
X(define %melt
X (lambda (f t)
X (lambda (fk)
X ((%unify
X t (%%melt f)) fk))))
X
X(define %melt-new
X (lambda (f t)
X (lambda (fk)
X ((%unify
X t (%%melt-new f)) fk))))
X
X'(define %copy
X (rel (term copy frozen)
X [(term copy) (%freeze term frozen) (%melt-new frozen copy)]))
X
X(define %copy
X (lambda (t c)
X (lambda (fk)
X ((%unify c (%%copy t)) fk))))
X
X;;; negation as failure
X
X'(define %not (rel (x) [(x) x ! %fail] [(x)]))
X
X(define %not
X (lambda (g)
X (lambda (fk)
X (if (call/cc
X (lambda (k)
X ((derefl g) (lambda () (k #f))))) (fk) fk))))
X
X;;; metavariable facility
X
X(define %call ; for completeness, i guess?
X (lambda (g)
X (lambda (fk)
X ((recur loop ([g g])
X (cond [(unbound-box? g) (fk)]
X [(frozen-box? g) (error '%call "~a" g)]
X [(box? g) (loop (unbox g))]
X [(pair? g) (error '%call "~a" g)]
X [(procedure? g) g]
X [else (error '%call "~a" g)])) fk))))
X
X(define %or
X (lambda gg
X (lambda (fk)
X (call/cc
X (lambda (sk)
X (recur loop ([gg gg])
X (if (null? gg) (fk)
X (begin
X (call/cfc
X (lambda (fk)
X (sk ((derefl (car gg)) fk))))
X (loop (cdr gg))))))))))
X
X(define %and
X (lambda gg
X (lambda (fk)
X (recur loop ([gg gg] [fk fk])
X (if (null? gg) fk
X (loop (cdr gg) ((derefl (car gg)) fk)))))))
X
X;;; usual Prolog interface
X
X(define *prolog-more-prompt* " ; more? ")
X
X(extend-syntax (which)
X [(which (b ...) p ...)
X (letref (b ...)
X (call/cc
X (lambda (__k)
X (let* ([__fk (lambda () (__k #f))]
X [__fk ((derefl p) __fk)] ...)
X (for-each (lambda (var val)
X (printf " ~a = " var)
X (pretty-print (derefl val)))
X '(b ...) (list b ...))
X (display #t)
X (recur loop ([__fk __fk])
X (case (prompt-read *prolog-more-prompt*)
X [(n no) #f]
X [else (loop (__fk))]))))))])
X
X;;; side-effects: assert[az], retract? not put in. Use Scheme for
X;;; nicer side-effect interface
X
X;;; utilities, written in Prolog
X
X(define %member
X (rel (x x... y y...)
X [(x [cons x x...])]
X [(x [cons y y...]) (%member x y...)]))
X
X(define %ifthenelse
X (rel (p q r)
X [(p q r) p ! q]
X [(p q r) r]))
END_OF_FILE
if test 8743 -ne `wc -c <'schelog.ss'`; then
echo shar: \"'schelog.ss'\" unpacked with wrong size!
fi
# end of 'schelog.ss'
fi
if test -f 'toys.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'toys.ss'\"
else
echo shar: Extracting \"'toys.ss'\" \(1683 characters\)
sed "s/^X//" >'toys.ss' <<'END_OF_FILE'
X;;; schelog
X;;; An Embedding of Prolog in Scheme
X;;; Written by Dorai Sitaram, Rice University, 1989
X;;; Permission is granted for unrestricted non-commercial use
X
X;;; A list of trivial programs in Prolog, just so you can get used
X;;; to schelog syntax.
X
X(define %length
X (rel (h t n m)
X [([] 0)]
X [((cons h t) n) (%length t m) (%is n (1+ m))]))
X
X(define %delete
X (rel (x y z w)
X [(x [] [])]
X [(x (cons x w) y) (%delete x w y)]
X [(x (cons z w) (cons z y)) (non (eq x z)) (%delete x w y)]))
X
X(define %filter
X (rel (x y z w)
X [([] [])]
X [((cons x y) (cons x z)) (%delete x y w) (%filter w z)]))
X
X'(define %count
X (rel (x n y)
X [(x n) (%filter x y) (%length y n)]))
X
X(define %count
X (letrec ([countaux
X (rel (m n mm x y z)
X [([] m m)]
X [((cons x y) m n)
X (%delete x y z) (%is mm (1+ m)) (countaux z mm n)])])
X (rel (x n)
X [(x n) (countaux x 0 n)])))
X
X(define %append
X (rel (x y z w)
X [([] x x)]
X [((cons x y) z (cons x w)) (%append y z w)]))
X
X'(define %reverse
X (rel (x y z yy)
X [([] [])]
X [((cons x y) z) (%reverse y yy) (%append yy (list x) z)]))
X
X(define %reverse
X (letrec ([revaux
X (rel (x y z w)
X [([] y y)]
X [((cons x y) z w) (revaux y (cons x z) w)])])
X (rel (x y)
X [(x y) (revaux x [] y)])))
X
X'(define %fact
X (rel (n n! n-1 n-1!)
X [(0 1)]
X [(n n!) (%is n-1 (1- n)) (%fact n-1 n-1!) (%is n! (* n n-1!))]))
X
X(define %fact
X (letrec ([factaux
X (rel (n! m x m-1 xx)
X [(0 n! n!)]
X [(m x n!) (%is m-1 (1- m)) (%is xx (* x m))
X (factaux m-1 xx n!)])])
X (rel (n n!)
X [(n n!) (factaux n 1 n!)])))
END_OF_FILE
if test 1683 -ne `wc -c <'toys.ss'`; then
echo shar: \"'toys.ss'\" unpacked with wrong size!
fi
# end of 'toys.ss'
fi
echo shar: End of shell archive.
exit 0