suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial add of all schelog files

Browse Source
This commit is contained in:
John Clements 2010-04-22 09:31:30 -07:00
parent 946f5c54d3
commit c8d5f5cc12
22 changed files with 3491 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/schelog/COPYING Normal file
View File

@ -0,0 +1,7 @@
Copyright (c) 1993-2001, Dorai Sitaram.
All rights reserved.
Permission to distribute and use this work for any
purpose is hereby granted provided this copyright
notice is included in the copy. This work is provided
as is, with no warranty of any kind.

77
collects/schelog/INSTALL Normal file
View File

@ -0,0 +1,77 @@
Installing Schelog
-
First, obtain the Schelog distribution. This is
available at
http://www.ccs.neu.edu/~dorai/schelog/schelog.html
Gunzipping and untarring this file produces a directory
called "schelog". This directory contains, among other
subsidiary files:
the Schelog code file "schelog.scm";
the file INSTALL, which you are now reading.
-
The file schelog.scm in the distribution loads in
MzScheme (and some other Scheme dialects) without
configuration. If it does not load in your
dialect, you can configure Schelog for it using
the scmxlate package, which is available at
http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
Start your Scheme in the schelog directory, and load
the file scmxlate/scmxlate.scm , using the correct
relative or full pathname. You will be asked what your
Scheme dialect is. Answer appropriately. The
following symbols are used by the porting
mechanism to identify the corresponding Scheme
dialects: bigloo (Bigloo); gambit (Gambit); guile
(Guile); mitscheme (MIT Scheme); mzscheme (MzScheme);
petite (Petite Chez Scheme); pscheme (Pocket Scheme);
scm (SCM); stk (STk).
scmxlate will generate a file called
"my-schelog.scm", which you may rename to
"schelog.scm".
Load schelog.scm into your Scheme in order to use
Schelog.
The distribution comes with an "examples" subdirectory
containing some sample Schelog programs. In order to
try an example file, load it into your Scheme after
ensuring that "schelog.scm" has already been loaded.
Follow the instructions in the example file.
-
The file "schelog.tex" contains a tutorial on Schelog. Run it
through (plain) TeX to obtain viewable/printable
documentation. (You will need to run TeX twice to resolve
cross references.)
You can get a browsable version of the document by
calling
tex2page schelog.tex
This browsable version is also available for Web
viewing at
http://www.ccs.neu.edu/~dorai/schelog/schelog.html
tex2page is available at
http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html
-
Concise bug reports, questions, and suggestions
may be emailed to
ds26 at gte dot com

45
collects/schelog/README Normal file
View File

@ -0,0 +1,45 @@
README
Schelog
Dorai Sitaram
ds26@gte.com
...
Schelog is for you if you are interested in any or all
of the following: Scheme, Prolog, logic, logic
programming, AI, and expert systems.
Schelog is an embedding of logic programming a la
Prolog in Scheme. "Embedding" means you don't lose
Scheme: You can use Prolog-style and conventional
Scheme code fragments alongside each other. Schelog
contains the full repertoire of Prolog features,
including meta-logical and second-order ("set")
predicates, leaving out only those features that could
be more easily and more efficiently done with Scheme
subexpressions. The Schelog distribution includes
examples and comprehensive documentation.
Schelog has been tested successfully on the following
Scheme dialects:
Bigloo, Gambit, Guile, MIT Scheme, MzScheme, Petite
Chez Scheme, Pocket Scheme, SCM, and STk.
...
The Schelog distribution is available at the URL:
http://www.cs.rice.edu/CS/PLT/packages/schelog/
Unpacking (using gunzip and tar xf) the Schelog distribution
produces a directory called "schelog". In it is a file
called INSTALL which contains detailed installation
instructions. Read INSTALL now.
*** this package has been TAMPERED WITH in an unscrupulous and undisciplined
way by John Clements 2010-04-22 in order to see how difficult it would be to
get it to compile in PLT 4.2.5. The answer is "not hard", but it's certainly
not portable any more, and crucially the two macros that cause capture of
the ! symbol now require uses of the macro to supply the bang, thus making them
non-capturing.

16
collects/schelog/dialects/dialects-supported.scm Normal file
View File

@ -0,0 +1,16 @@
;last change: 2003-06-01
bigloo
gambit
gauche
guile
mitscheme
mzscheme
petite
pscheme
scheme48
scm
scsh
stk
sxm
umbscheme

1
collects/schelog/dialects/files-to-be-ported.scm Normal file
View File

@ -0,0 +1 @@
schelog.scm

6
collects/schelog/dialects/gambit-schelog.scm Normal file
View File

@ -0,0 +1,6 @@
(declare (standard-bindings) (extended-bindings) (block) (not safe))
;if all your arithmetic is going to be fixnum-only,
;you might want to
;(declare (fixnum))

119
collects/schelog/examples/bible.scm Normal file
View File

@ -0,0 +1,119 @@
;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))))
(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))))
(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)))))

52
collects/schelog/examples/england.scm Normal file
View File

@ -0,0 +1,52 @@
;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))))

74
collects/schelog/examples/england2.scm Normal file
View File

@ -0,0 +1,74 @@
;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)))))

87
collects/schelog/examples/games.scm Normal file
View File

@ -0,0 +1,87 @@
#lang scheme
(require "../schelog.scm" "./puzzle.scm")
;;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))

36
collects/schelog/examples/holland.scm Normal file
View File

@ -0,0 +1,36 @@
;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

148
collects/schelog/examples/houses.scm Normal file
View File

@ -0,0 +1,148 @@
;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.

79
collects/schelog/examples/mapcol.scm Normal file
View File

@ -0,0 +1,79 @@
;map coloring, example from Sterling & Shapiro, p. 212
;(%member x y) holds if x is in y
(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.

47
collects/schelog/examples/puzzle.scm Normal file
View File

@ -0,0 +1,47 @@
#lang scheme
(require "../schelog.scm")
(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=))))))

84
collects/schelog/examples/toys.scm Normal file
View File

@ -0,0 +1,84 @@
;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!)))))

109
collects/schelog/history Normal file
View File

@ -0,0 +1,109 @@
June 1, 2003
Include Gauche as a target dialect. Alex Shinn
provided Gauche recognition to scmxlate (q.v.).
3h5
Mar 25, 2003
%assert documentation bugfix. From Steve Pothier.
3h4
15 Jul 2001
Added optional Occurs Check, suggested by Brad Lucier.
Brad also points out that the examples/houses.scm
puzzle, as written, needs the Occurs Check. ("as
written"...? Well, Prolog doesn't have the Occurs
Check, and this famous puzzle is offered as an exercise
in the Prolog textbook _The Art of Prolog_ (Sterling &
Shapiro). So I'm thinking perhaps there is a
less naive solution that doesn't rely on the Occurs
Check.)
3h3
Feb 28, 2000
Gambit port improvement from Brad Lucier: eval
define-macro explicitly to make macros usable after
loading
Sep 20, 1999
3h
Ported to Pocket Scheme (Ben Goetter) and Petite Chez Scheme.
Jan 31, 1999
3g1
Minor bugfix for Gambit install
May 2, 1998
3g
Ported to STk
April 19, 1998
3f
Porting mechanism refined: ports to mzscheme, scm,
guile, gambit, mitscheme, bigloo.
April 1997
3e
Extensible mechanism added for porting to various
Scheme dialects
3d
maybeini4gambit.scm (Brad Lucier)
Corrected () in evaluable positions to '(), as Gambit
won't accept unquoted ()s. (Brad Lucier)
3c
maybeini4mzscheme.scm.
Equal strings unify (Paul Prescod).
HTML version of doc included.
v. 3b
Fixed bug in %and and %or. (Using macros for now -- these were
procedures in v. 3, 3a.)
v. 3a
Added maybeini4mitscheme.scm (for Tore Amble).
March 1997
v. 3
Added syntax for asserting additional clauses to an existing
relation.
Set-predicates rewritten. (Free variables given choice of
treatment as in Prolog. Previously they had all been
assumed to be existentially quantified.)
Improved tutorial documentation.
Feb 1993
Second release.
1989
First release.

44
collects/schelog/makefile Normal file
View File

@ -0,0 +1,44 @@
TRIGGER_FILES = history manifest makefile version.tex \
schelog.scm schelog.tex
default:
@echo Please read the file INSTALL.
%.html: %.tex
tex2page $(@:%.html=%)
while grep -i "rerun: tex2page" $(@:%.html=%.hlog); do \
tex2page $(@:%.html=%); \
done
schelog.pdf: schelog.tex
pdftex $^
schelog.tar:
echo tar cf schelog.tar schelog/manifest > .tarscript
for f in `grep "^[^;]" manifest`; do \
echo tar uf schelog.tar schelog/$$f >> .tarscript; \
done
chmod +x .tarscript
cd ..; schelog/.tarscript
mv ../schelog.tar .
schelog.tar.bz2: $(TRIGGER_FILES)
make schelog.tar
bzip2 -f schelog.tar
schelog.tar.gz: $(TRIGGER_FILES)
make schelog.tar
gzip -f schelog.tar
html: schelog.html
pdf: schelog.pdf
dist: schelog.tar.bz2
webdist: schelog.tar.gz html
clean:
@rm -f *~ *.bak
cd dialects; rm -f *~ *.bak

20
collects/schelog/manifest Normal file
View File

@ -0,0 +1,20 @@
COPYING
README
manifest
makefile
schelog-version.tex
INSTALL
history
schelog.tex
schelog.scm
schelog.bib
dialects/*.scm
examples/bible.scm
examples/england.scm
examples/england2.scm
examples/games.scm
examples/holland.scm
examples/houses.scm
examples/mapcol.scm
examples/puzzle.scm
examples/toys.scm

1
collects/schelog/schelog-version.tex Normal file
View File

@ -0,0 +1 @@
2003-06-01% last change

95
collects/schelog/schelog.bib Normal file
View File

@ -0,0 +1,95 @@
@book{sicp,
author = "Harold Abelson and Gerald Jay {Sussman with Julie Sussman}",
title = "\urlp{Structure and Interpretation of
Computer Programs (``SICP'')}{http://mitpress.mit.edu/sicp/full-text/book/book.html}",
edition = "2nd",
publisher = "MIT Press",
year = 1996,
}
@book{aop,
author = "Leon Sterling and Ehud Shapiro",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262193388}{The Art
of Prolog}",
publisher = "MIT Press",
year = 1994,
edition = "2nd",
}
@book{tls,
author = "Daniel P Friedman and Matthias Felleisen",
title = "\urlh{http://www.ccs.neu.edu/~matthias/BTLS}{The Little Schemer}",
publisher = "MIT Press",
year = 1996,
edition = "4th",
}
@book{tss,
author = "Daniel P Friedman and Matthias Felleisen",
title = "\urlh{http://www.ccs.neu.edu/~matthias/BTSS}{The Seasoned Schemer}",
publisher = "MIT Press",
year = 1996,
}
@book{eopl,
author = "Daniel P Friedman and Mitchell Wand and Christopher T Haynes",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262061457}{Essentials
of Programming Languages}",
publisher = "MIT Press, McGraw-Hill",
year = 1992,
}
@book{bratko,
author = "Ivan Bratko",
title = "Prolog Programming for Artificial Intelligence",
publisher = "Addison-Wesley",
year = 1986,
}
@book{campbell,
editor = "J A Campbell",
title = "Implementations of Prolog",
publisher = "Ellis Horwood",
year = 1984,
}
@book{ok:prolog,
author = "Richard A O'Keefe",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262150395}{The
Craft of Prolog}",
publisher = "MIT Press",
year = 1990,
}
@inproceedings{logick,
author = "Christopher T Haynes",
title = "{Logic continuations}",
booktitle = "{J Logic Program}",
year = 1987,
note = "vol 4",
pages = "157--176",
}
@misc{r5rs,
author = "Richard Kelsey and William Clinger and
Jonathan {Rees (eds)}",
title = "\urlp{Revised\^{}5
Report on the Algorithmic Language Scheme
(``R5RS'')}{http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs.html}",
year = 1998,
}
@misc{t-y-scheme,
author = "Dorai Sitaram",
title = "\urlp{Teach Yourself Scheme
in Fixnum Days}{http://www.ccs.neu.edu/~dorai/t-y-scheme/t-y-scheme.html}",
}
@techreport{mf:prolog,
author = "Matthias Felleisen",
title = "{Transliterating Prolog into Scheme}",
institution = "{Indiana U Comp Sci Dept}",
year = 1985,
number = 182,
}

772
collects/schelog/schelog.scm Normal file
View File

@ -0,0 +1,772 @@
#lang scheme
(provide (all-defined-out))
;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 schelog:*ref* "ref")
(define schelog:*unbound* '_)
(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 _ schelog:make-ref)
(define schelog:ref?
(lambda (r)
(and (vector? r)
(eq? (vector-ref r 0) schelog:*ref*))))
(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*)))
;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*)))))
;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))))
;%let introduces new logic variables
(define-syntax %let
(syntax-rules ()
((%let (x ...) . e)
(let ((x (schelog:make-ref)) ...)
. e))))
#;(define-macro %let
(lambda (xx . ee)
`(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx)
,@ee)))
;the unify predicate
(define *schelog-use-occurs-check?* #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 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 %= schelog:unify)
;disjunction
(define-syntax %or
(syntax-rules ()
((%or g ...)
(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
(call-with-current-continuation
(lambda (__fk)
(__sk ((schelog:deref* g) __fk))))
...
(__fk 'fail)))))))
#;(define-macro %or
(lambda gg
`(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
,@(map (lambda (g)
`(call-with-current-continuation
(lambda (__fk)
(__sk ((schelog:deref* ,g) __fk)))))
gg)
(__fk 'fail))))))
;conjunction
(define-syntax %and
(syntax-rules ()
((%and g ...)
(lambda (__fk)
(let* ((__fk ((schelog:deref* g) __fk))
...)
__fk)))))
#;(define-macro %and
(lambda gg
`(lambda (__fk)
(let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg)
__fk))))
;cut
;; rather arbitrarily made this macro non-
;; capturing by requiring ! to be supplied at
;; macro use... not changing docs... -- JBC 2010
(define-syntax %cut-delimiter
(syntax-rules ()
((%cut-delimiter ! g)
(lambda (__fk)
(let ((! (lambda (__fk2) __fk)))
((schelog:deref* g) __fk))))))
#;(define-macro %cut-delimiter
(lambda (g)
`(lambda (__fk)
(let ((! (lambda (__fk2) __fk)))
((schelog:deref* ,g) __fk)))))
;Prolog-like sugar
(define-syntax %rel
(syntax-rules ()
((%rel ! (v ...) ((a ...) subgoal ...) ...)
(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))))))))))
#;(define-macro %rel
(lambda (vv . cc)
`(lambda __fmls
(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
(let ((! (lambda (fk1) __fk)))
(%let ,vv
,@(map (lambda (c)
`(call-with-current-continuation
(lambda (__fk)
(let* ((__fk ((%= __fmls (list ,@(car c)))
__fk))
,@(map (lambda (sg)
`(__fk ((schelog:deref* ,sg)
__fk)))
(cdr c)))
(__sk __fk)))))
cc)
(__fk 'fail)))))))))
;the fail and true preds
(define %fail
(lambda (fk) (fk 'fail)))
(define %true
(lambda (fk) fk))
;for structures ("functors"), use Scheme's list and vector
;functions and anything that's built using them.
;arithmetic
(define-syntax %is
(syntax-rules (quote)
((%is v e)
(lambda (__fk)
((%= v (%is (1) e __fk)) __fk)))
((%is (1) (quote x) fk) (quote x))
((%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)))))
#;(define-macro %is
(lambda (v e)
(letrec ((%is-help (lambda (e fk)
(cond ((pair? e)
(cond ((eq? (car e) 'quote) e)
(else
(map (lambda (e1)
(%is-help e1 fk)) e))))
(else
`(if (and (schelog:ref? ,e)
(schelog:unbound-ref? ,e))
(,fk 'fail) (schelog:deref* ,e)))))))
`(lambda (__fk)
((%= ,v ,(%is-help e '__fk)) __fk)))))
;defining arithmetic comparison operators
(define schelog:make-binary-arithmetic-relation
(lambda (f)
(lambda (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
(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 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 %constant
(lambda (x)
(lambda (fk)
(if (schelog:constant? x) fk (fk 'fail)))))
(define %compound
(lambda (x)
(lambda (fk)
(if (schelog: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
(lambda (x)
(lambda (fk) (if (schelog:var? x) fk (fk 'fail)))))
(define %nonvar
(lambda (x)
(lambda (fk) (if (schelog: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 %/=
(schelog: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 %==
(lambda (x y)
(lambda (fk) (if (schelog:ident? x y) fk (fk 'fail)))))
(define %/==
(lambda (x y)
(lambda (fk) (if (schelog: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 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 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 schelog:copy
(lambda (s)
(schelog:melt-new (schelog:freeze s))))
(define %freeze
(lambda (s f)
(lambda (fk)
((%= (schelog:freeze s) f) fk))))
(define %melt
(lambda (f s)
(lambda (fk)
((%= (schelog:melt f) s) fk))))
(define %melt-new
(lambda (f s)
(lambda (fk)
((%= (schelog:melt-new f) s) fk))))
(define %copy
(lambda (s c)
(lambda (fk)
((%= (schelog: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))))
;assert, asserta
(define %empty-rel
(lambda args
%fail))
(define-syntax %assert
(syntax-rules (!)
((%assert rel-name (v ...) ((a ...) subgoal ...) ...)
(set! rel-name
(let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...)))
(lambda __fmls
(%or (apply __old-rel __fmls)
(apply __new-addition __fmls))))))))
(define-syntax %assert-a
(syntax-rules (!)
((%assert-a rel-name (v ...) ((a ...) subgoal ...) ...)
(set! rel-name
(let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...)))
(lambda __fmls
(%or (apply __new-addition __fmls)
(apply __old-rel __fmls))))))))
#;(define-macro %assert
(lambda (rel-name vv . cc)
`(set! ,rel-name
(let ((__old-rel ,rel-name)
(__new-addition (%rel ,vv ,@cc)))
(lambda __fmls
(%or (apply __old-rel __fmls)
(apply __new-addition __fmls)))))))
#;(define-macro %assert-a
(lambda (rel-name vv . cc)
`(set! ,rel-name
(let ((__old-rel ,rel-name)
(__new-addition (%rel ,vv ,@cc)))
(lambda __fmls
(%or (apply __new-addition __fmls)
(apply __old-rel __fmls)))))))
;set predicates
(define schelog:set-cons
(lambda (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 (list v ...) g)))))
#;(define-macro %free-vars
(lambda (vv g)
`(cons 'schelog:goal-with-free-vars
(cons (list ,@vv) ,g))))
(define schelog:goal-with-free-vars?
(lambda (x)
(and (pair? x) (eq? (car x) 'schelog: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 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 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 %bag-of (schelog:make-bag-of cons))
(define %set-of (schelog:make-bag-of schelog: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 %set-of-1
(lambda (x g s)
(%and (%set-of x g s)
(%= s (cons (_) (_))))))
;user interface
;(%which (v ...) query) returns #f if query fails and instantiations
;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-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 ...)))))))))
#;(define-macro %which
(lambda (vv g)
`(%let ,vv
(call-with-current-continuation
(lambda (__qk)
(set! schelog:*more-k* __qk)
(set! schelog:*more-fk*
((schelog:deref* ,g)
(lambda (d)
(set! schelog:*more-fk* #f)
(schelog:*more-k* #f))))
(schelog:*more-k*
(map (lambda (nam val) (list nam (schelog:deref* val)))
',vv
(list ,@vv))))))))
(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)))))
;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 %if-then-else
(lambda (p q r)
(%cut-delimiter !
(%or
(%and p ! q)
r))))
;the above could also have been written in a more
;Prolog-like fashion, viz.
'(define %member
(%rel ! (x xs y ys)
((x (cons x xs)))
((x (cons y ys)) (%member x ys))))
'(define %if-then-else
(%rel ! (p q r)
((p q r) p ! q)
((p q r) r)))
(define %append
(%rel ! (x xs ys zs)
(('() ys ys))
(((cons x xs) ys (cons x zs))
(%append xs ys zs))))
(define %repeat
;;failure-driven loop
(%rel ! ()
(())
(() (%repeat))))
; deprecated names -- retained here for backward-compatibility
(define == %=)
(define %notunify %/=)
#;(define-macro %cut
(lambda e
`(%cur-delimiter ,@e)))
#;(define-macro rel
(lambda e
`(%rel ,@e)))
(define %eq %=:=)
(define %gt %>)
(define %ge %>=)
(define %lt %<)
(define %le %<=)
(define %ne %=/=)
(define %ident %==)
(define %notident %/==)
;(define-syntax %exists (syntax-rules () ((%exists vv g) g)))
#;(define-macro %exists (lambda (vv g) g))
#;(define-macro which
(lambda e
`(%which ,@e)))
(define more %more)
;end of file

1572
collects/schelog/schelog.tex Normal file
View File

File diff suppressed because it is too large Load Diff