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

Rewrote documentation and working on cut

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-23 17:00:38 -06:00
parent 3653883b02
commit 1b4cd42d5c
18 changed files with 1842 additions and 2288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/schelog/INSTALL
View File

@ -1,85 +0,0 @@
Installing Schelog
*** JBC, 2010-04-22: I conjecture that (as a collection
within the PLT tree) installation directions are now
superfluous. The below is preserved for posterity.
-
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

55
collects/schelog/README
View File

@ -1,55 +0,0 @@
README
Schelog
Dorai Sitaram
ds26@gte.com
*** JBC 2010-04-22: 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.
TODO:
- pull some part of the docs across from their tex format
- figure out what to do with the makefile (delete it?)
- turn more of the implicit test cases into explicit test cases
- clean up this README file
- figure out whether there are copyright issues
...
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.

14
collects/schelog/examples/bible.rkt
View File

@ -9,7 +9,7 @@
;(%father X Y) :- X is the father of Y. ;(%father X Y) :- X is the father of Y.
(define %father (define %father
(%rel ! () (%rel ()
(('terach 'abraham)) (('terach 'nachor)) (('terach 'haran)) (('terach 'abraham)) (('terach 'nachor)) (('terach 'haran))
(('abraham 'isaac)) (('haran 'lot)) (('haran 'milcah)) (('abraham 'isaac)) (('haran 'lot)) (('haran 'milcah))
(('haran 'yiscah)))) (('haran 'yiscah))))
@ -17,14 +17,14 @@
;(%mother X Y) :- X is the mother of Y. ;(%mother X Y) :- X is the mother of Y.
(define %mother (define %mother
(%rel ! () (('sarah 'isaac)))) (%rel () (('sarah 'isaac))))
(define %male (define %male
(%rel ! () (%rel ()
(('terach)) (('abraham)) (('isaac)) (('lot)) (('haran)) (('nachor)))) (('terach)) (('abraham)) (('isaac)) (('lot)) (('haran)) (('nachor))))
(define %female (define %female
(%rel ! () (%rel ()
(('sarah)) (('milcah)) (('yiscah)))) (('sarah)) (('milcah)) (('yiscah))))
;AoP, ch. 17. Finding all the children of a particular ;AoP, ch. 17. Finding all the children of a particular
@ -36,13 +36,13 @@
(define %children-1 (define %children-1
(letrec ((children-aux (letrec ((children-aux
(%rel ! (x a cc c) (%rel (x a cc c)
((x a cc) ((x a cc)
(%father x c) (%not (%member c a)) ! (%father x c) (%not (%member c a)) !
(children-aux x (cons c a) cc)) (children-aux x (cons c a) cc))
((x cc cc))))) ((x cc cc)))))
(%rel ! (x cc) (%rel (x cc)
((x cc) (children-aux x '() cc))))) ((x cc) (children-aux x '() cc)))))
(define terachs-kids-test (define terachs-kids-test
@ -79,7 +79,7 @@
;Uses set predicate %bag-of ;Uses set predicate %bag-of
(define %children (define %children
(%rel ! (x kids c) (%rel (x kids c)
((kids) (%set-of c (%father x c) kids)))) ((kids) (%set-of c (%father x c) kids))))
(define dad-kids-test-2 (define dad-kids-test-2

20
collects/schelog/examples/england.rkt
View File

@ -11,47 +11,47 @@
;The file england2.scm uses a Scheme-like syntax. ;The file england2.scm uses a Scheme-like syntax.
(define %male (define %male
(%rel ! () (%rel ()
(('philip)) (('charles)) (('andrew)) (('edward)) (('philip)) (('charles)) (('andrew)) (('edward))
(('mark)) (('william)) (('harry)) (('peter)))) (('mark)) (('william)) (('harry)) (('peter))))
(define %female (define %female
(%rel ! () (%rel ()
(('elizabeth)) (('anne)) (('diana)) (('sarah)) (('zara)))) (('elizabeth)) (('anne)) (('diana)) (('sarah)) (('zara))))
(define %husband-of (define %husband-of
(%rel ! () (%rel ()
(('philip 'elizabeth)) (('charles 'diana)) (('philip 'elizabeth)) (('charles 'diana))
(('mark 'anne)) (('andrew 'sarah)))) (('mark 'anne)) (('andrew 'sarah))))
(define %wife-of (define %wife-of
(%rel ! (w h) (%rel (w h)
((w h) (%husband-of h w)))) ((w h) (%husband-of h w))))
(define %married-to (define %married-to
(%rel ! (x y) (%rel (x y)
((x y) (%husband-of x y)) ((x y) (%husband-of x y))
((x y) (%wife-of x y)))) ((x y) (%wife-of x y))))
(define %father-of (define %father-of
(%rel ! () (%rel ()
(('philip 'charles)) (('philip 'anne)) (('philip 'andrew)) (('philip 'charles)) (('philip 'anne)) (('philip 'andrew))
(('philip 'edward)) (('charles 'william)) (('charles 'harry)) (('philip 'edward)) (('charles 'william)) (('charles 'harry))
(('mark 'peter)) (('mark 'zara)))) (('mark 'peter)) (('mark 'zara))))
(define %mother-of (define %mother-of
(%rel ! (m c f) (%rel (m c f)
((m c) (%wife-of m f) (%father-of f c)))) ((m c) (%wife-of m f) (%father-of f c))))
(define %child-of (define %child-of
(%rel ! (c p) (%rel (c p)
((c p) (%father-of p c)) ((c p) (%father-of p c))
((c p) (%mother-of p c)))) ((c p) (%mother-of p c))))
(define %parent-of (define %parent-of
(%rel ! (p c) (%rel (p c)
((p c) (%child-of c p)))) ((p c) (%child-of c p))))
(define %brother-of (define %brother-of
(%rel ! (b x f) (%rel (b x f)
((b x) (%male b) (%father-of f b) (%father-of f x) (%/= b x)))) ((b x) (%male b) (%father-of f b) (%father-of f x) (%/= b x))))

16
collects/schelog/examples/games.rkt
View File

@ -20,7 +20,7 @@
(list 'person name country sport))) (list 'person name country sport)))
(define %games (define %games
(%rel ! (clues queries solution the-men (%rel (clues queries solution the-men
n1 n2 n3 c1 c2 c3 s1 s2 s3) n1 n2 n3 c1 c2 c3 s1 s2 s3)
((clues queries solution) ((clues queries solution)
(%= the-men (%= the-men
@ -29,7 +29,7 @@
(%games-queries the-men queries solution)))) (%games-queries the-men queries solution))))
(define %games-clues (define %games-clues
(%rel ! (the-men clue1-man1 clue1-man2 clue2-man1 clue2-man2 clue3-man) (%rel (the-men clue1-man1 clue1-man2 clue2-man1 clue2-man2 clue3-man)
((the-men ((the-men
(list (list
(%did-better clue1-man1 clue1-man2 the-men) (%did-better clue1-man1 clue1-man2 the-men)
@ -46,7 +46,7 @@
(%sport clue3-man 'cricket)))))) (%sport clue3-man 'cricket))))))
(define %games-queries (define %games-queries
(%rel ! (the-men man1 man2 aussies-name dicks-sport) (%rel (the-men man1 man2 aussies-name dicks-sport)
((the-men ((the-men
(list (list
(%member man1 the-men) (%member man1 the-men)
@ -61,25 +61,25 @@
(list 'richard 'plays dicks-sport)))))) (list 'richard 'plays dicks-sport))))))
(define %did-better (define %did-better
(%rel ! (a b c) (%rel (a b c)
((a b (list a b c))) ((a b (list a b c)))
((a c (list a b c))) ((a c (list a b c)))
((b c (list a b c))))) ((b c (list a b c)))))
(define %name (define %name
(%rel ! (name country sport) (%rel (name country sport)
(((person name country sport) name)))) (((person name country sport) name))))
(define %country (define %country
(%rel ! (name country sport) (%rel (name country sport)
(((person name country sport) country)))) (((person name country sport) country))))
(define %sport (define %sport
(%rel ! (name country sport) (%rel (name country sport)
(((person name country sport) sport)))) (((person name country sport) sport))))
(define %first (define %first
(%rel ! (car cdr) (%rel (car cdr)
(((cons car cdr) car)))) (((cons car cdr) car))))
;;With the above as the database, and also loading the file ;;With the above as the database, and also loading the file

20
collects/schelog/examples/houses.rkt
View File

@ -29,25 +29,25 @@
(lambda (hue nation pet drink cigarette) (lambda (hue nation pet drink cigarette)
(list 'house hue nation pet drink cigarette))) (list 'house hue nation pet drink cigarette)))
(define %hue (%rel ! (h) (((house h (_) (_) (_) (_)) h)))) (define %hue (%rel (h) (((house h (_) (_) (_) (_)) h))))
(define %nation (%rel ! (n) (((house (_) n (_) (_) (_)) n)))) (define %nation (%rel (n) (((house (_) n (_) (_) (_)) n))))
(define %pet (%rel ! (p) (((house (_) (_) p (_) (_)) p)))) (define %pet (%rel (p) (((house (_) (_) p (_) (_)) p))))
(define %drink (%rel ! (d) (((house (_) (_) (_) d (_)) d)))) (define %drink (%rel (d) (((house (_) (_) (_) d (_)) d))))
(define %cigarette (%rel ! (c) (((house (_) (_) (_) (_) c) c)))) (define %cigarette (%rel (c) (((house (_) (_) (_) (_) c) c))))
(define %adjacent (define %adjacent
(%rel ! (a b) (%rel (a b)
((a b (list a b (_) (_) (_)))) ((a b (list a b (_) (_) (_))))
((a b (list (_) a b (_) (_)))) ((a b (list (_) a b (_) (_))))
((a b (list (_) (_) a b (_)))) ((a b (list (_) (_) a b (_))))
((a b (list (_) (_) (_) a b))))) ((a b (list (_) (_) (_) a b)))))
(define %middle (define %middle
(%rel ! (a) (%rel (a)
((a (list (_) (_) a (_) (_)))))) ((a (list (_) (_) a (_) (_))))))
(define %houses (define %houses
(%rel ! (row-of-houses clues queries solution (%rel (row-of-houses clues queries solution
h1 h2 h3 h4 h5 n1 n2 n3 n4 n5 p1 p2 p3 p4 p5 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) d1 d2 d3 d4 d5 c1 c2 c3 c4 c5)
((clues queries solution) ((clues queries solution)
@ -62,7 +62,7 @@
(%houses-queries row-of-houses queries solution)))) (%houses-queries row-of-houses queries solution))))
(define %houses-clues (define %houses-clues
(%rel ! (row-of-houses abode1 abode2 abode3 abode4 abode5 abode6 abode7 (%rel (row-of-houses abode1 abode2 abode3 abode4 abode5 abode6 abode7
abode8 abode9 abode10 abode11 abode12 abode13 abode14 abode15) abode8 abode9 abode10 abode11 abode12 abode13 abode14 abode15)
((row-of-houses ((row-of-houses
(list (list
@ -126,7 +126,7 @@
(%hue abode15 'blue)))))) (%hue abode15 'blue))))))
(define %houses-queries (define %houses-queries
(%rel ! (row-of-houses abode1 abode2 zebra-owner water-drinker) (%rel (row-of-houses abode1 abode2 zebra-owner water-drinker)
((row-of-houses ((row-of-houses
(list (list
(%member abode1 row-of-houses) (%member abode1 row-of-houses)

16
collects/schelog/examples/mapcol.rkt
View File

@ -9,21 +9,21 @@
;; is this different from the %member provided by schelog? fencing that one out. ;; is this different from the %member provided by schelog? fencing that one out.
(define %member (define %member
(%rel ! (X Xs Y Ys) (%rel (X Xs Y Ys)
((X (cons X Xs))) ((X (cons X Xs)))
((X (cons Y Ys)) (%member X Ys)))) ((X (cons Y Ys)) (%member X Ys))))
;(%members x y) holds if x is a subset of y ;(%members x y) holds if x is a subset of y
(define %members (define %members
(%rel ! (X Xs Ys) (%rel (X Xs Ys)
(((cons X Xs) Ys) (%member X Ys) (%members Xs Ys)) (((cons X Xs) Ys) (%member X Ys) (%members Xs Ys))
(('() Ys)))) (('() Ys))))
;(%select x y z) holds if z is y with one less occurrence of x ;(%select x y z) holds if z is y with one less occurrence of x
(define %select (define %select
(%rel ! (X Xs Y Ys Zs) (%rel (X Xs Y Ys Zs)
((X (cons X Xs) Xs)) ((X (cons X Xs) Xs))
((X (cons Y Ys) (cons Y Zs)) ((X (cons Y Ys) (cons Y Zs))
(%select X Ys Zs)))) (%select X Ys Zs))))
@ -35,26 +35,26 @@
(list 'region name color neighbors))) (list 'region name color neighbors)))
(define %color-map (define %color-map
(%rel ! (Region Regions Colors) (%rel (Region Regions Colors)
(((cons Region Regions) Colors) (((cons Region Regions) Colors)
(%color-region Region Colors) (%color-map Regions Colors)) (%color-region Region Colors) (%color-map Regions Colors))
(('() Colors)))) (('() Colors))))
(define %color-region (define %color-region
(%rel ! (Name Color Neighbors Colors Colors1) (%rel (Name Color Neighbors Colors Colors1)
(((region Name Color Neighbors) Colors) (((region Name Color Neighbors) Colors)
(%select Color Colors Colors1) (%select Color Colors Colors1)
(%members Neighbors Colors1)))) (%members Neighbors Colors1))))
(define %test-color (define %test-color
(%rel ! (Name Map Colors) (%rel (Name Map Colors)
((Name Map) ((Name Map)
(%map Name Map) (%map Name Map)
(%colors Colors) (%colors Colors)
(%color-map Map Colors)))) (%color-map Map Colors))))
(define %map (define %map
(%rel ! (A B C D E F G H I L P S) (%rel (A B C D E F G H I L P S)
(('test (list (('test (list
(region 'a A (list B C D)) (region 'a A (list B C D))
(region 'b B (list A C E)) (region 'b B (list A C E))
@ -76,7 +76,7 @@
(region 'austria A (list I S G))))))) (region 'austria A (list I S G)))))))
(define %colors (define %colors
(%rel ! () (%rel ()
(('(red yellow blue white))))) (('(red yellow blue white)))))
;ask (%which (M) (%test-color 'test M)) or ;ask (%which (M) (%test-color 'test M)) or

4
collects/schelog/examples/puzzle.rkt
View File

@ -19,13 +19,13 @@
; solve([]). ; solve([]).
(define %solve-puzzle (define %solve-puzzle
(%rel ! (clues queries solution) (%rel (clues queries solution)
((clues queries solution) ((clues queries solution)
(%solve clues) (%solve clues)
(%solve queries)))) (%solve queries))))
(define %solve (define %solve
(%rel ! (clue clues) (%rel (clue clues)
(((cons clue clues)) (((cons clue clues))
clue clue
(%solve clues)) (%solve clues))

26
collects/schelog/examples/toys.rkt
View File

@ -8,14 +8,14 @@
;(%length l n) holds if length(l) = n ;(%length l n) holds if length(l) = n
(define %length (define %length
(%rel ! (h t n m) (%rel (h t n m)
(('() 0)) (('() 0))
(((cons h t) n) (%length t m) (%is n (+ m 1))))) (((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 ;(%delete x y z) holds if z is y with all x's removed
(define %delete (define %delete
(%rel ! (x y z w) (%rel (x y z w)
((x '() '())) ((x '() '()))
((x (cons x w) y) (%delete x w y)) ((x (cons x w) y) (%delete x w y))
((x (cons z w) (cons z y)) (%not (%= x z)) (%delete x w y)))) ((x (cons z w) (cons z y)) (%not (%= x z)) (%delete x w y))))
@ -23,7 +23,7 @@
;(%remdup x y) holds if y is x without duplicates ;(%remdup x y) holds if y is x without duplicates
(define %remdup (define %remdup
(%rel ! (x y z w) (%rel (x y z w)
(('() '())) (('() '()))
(((cons x y) (cons x z)) (%delete x y w) (%remdup w z)))) (((cons x y) (cons x z)) (%delete x y w) (%remdup w z))))
@ -31,31 +31,31 @@
;counting duplicates ;counting duplicates
'(define %count '(define %count
(%rel ! (x n y) (%rel (x n y)
((x n) (%remdup x y) (%length y n)))) ((x n) (%remdup x y) (%length y n))))
;same thing ;same thing
(define %count (define %count
(letrec ((countaux (letrec ((countaux
(%rel ! (m n m+1 x y z) (%rel (m n m+1 x y z)
(('() m m)) (('() m m))
(((cons x y) m n) (((cons x y) m n)
(%delete x y z) (%is m+1 (+ m 1)) (countaux z m+1 n))))) (%delete x y z) (%is m+1 (+ m 1)) (countaux z m+1 n)))))
(%rel ! (x n) (%rel (x n)
((x n) (countaux x 0 n))))) ((x n) (countaux x 0 n)))))
;(%append x y z) holds if z is the concatenation of x and y ;(%append x y z) holds if z is the concatenation of x and y
(define %append (define %append
(%rel ! (x y z w) (%rel (x y z w)
(('() x x)) (('() x x))
(((cons x y) z (cons x w)) (%append y z w)))) (((cons x y) z (cons x w)) (%append y z w))))
;(%reverse x y) holds if the y is the reversal of x ;(%reverse x y) holds if the y is the reversal of x
'(define %reverse '(define %reverse
(%rel ! (x y z yy) (%rel (x y z yy)
(('() '())) (('() '()))
(((cons x y) z) (%reverse y yy) (%append yy (list x) z)))) (((cons x y) z) (%reverse y yy) (%append yy (list x) z))))
@ -63,16 +63,16 @@
(define %reverse (define %reverse
(letrec ((revaux (letrec ((revaux
(%rel ! (x y z w) (%rel (x y z w)
(('() y y)) (('() y y))
(((cons x y) z w) (revaux y (cons x z) w))))) (((cons x y) z w) (revaux y (cons x z) w)))))
(%rel ! (x y) (%rel (x y)
((x y) (revaux x '() y))))) ((x y) (revaux x '() y)))))
;(%fact n m) holds if m = n! ;(%fact n m) holds if m = n!
'(define %fact '(define %fact
(%rel ! (n n! n-1 n-1!) (%rel (n n! n-1 n-1!)
((0 1)) ((0 1))
((n n!) (%is n-1 (- n 1)) (%fact n-1 n-1!) (%is n! (* n n-1!))))) ((n n!) (%is n-1 (- n 1)) (%fact n-1 n-1!) (%is n! (* n n-1!)))))
@ -80,9 +80,9 @@
(define %fact (define %fact
(letrec ((factaux (letrec ((factaux
(%rel ! (n! m x m-1 xx) (%rel (n! m x m-1 xx)
((0 n! n!)) ((0 n! n!))
((m x n!) (%is m-1 (- m 1)) (%is xx (* x m)) ((m x n!) (%is m-1 (- m 1)) (%is xx (* x m))
(factaux m-1 xx n!))))) (factaux m-1 xx n!)))))
(%rel ! (n n!) (%rel (n n!)
((n n!) (factaux n 1 n!))))) ((n n!) (factaux n 1 n!)))))

2
collects/schelog/info.ss
View File

@ -1,2 +1,4 @@
#lang setup/infotab #lang setup/infotab
(define scribblings
'(("schelog.scrbl" (multi-page) (tool))))

3
collects/schelog/main.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket
(require "schelog.rkt")
(provide (all-from-out "schelog.rkt"))

48
collects/schelog/makefile
View File

@ -1,48 +0,0 @@
# JBC, 2010-04-22:
# this makefile could probably be usefully rendered in scheme... but
# I'm not going to try.
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
View File

@ -1,20 +0,0 @@
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
View File

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

95
collects/schelog/schelog.bib
View File

@ -1,95 +0,0 @@
@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,
}

711
collects/schelog/schelog.rkt
View File

@ -41,15 +41,15 @@
;;unbound refs point to themselves ;;unbound refs point to themselves
(lambda opt (lambda opt
(vector schelog:*ref* (vector schelog:*ref*
(if (null? opt) schelog:*unbound* (if (null? opt) schelog:*unbound*
(car opt))))) (car opt)))))
(define _ schelog:make-ref) (define _ schelog:make-ref)
(define schelog:ref? (define schelog:ref?
(lambda (r) (lambda (r)
(and (vector? r) (and (vector? r)
(eq? (vector-ref r 0) schelog:*ref*)))) (eq? (vector-ref r 0) schelog:*ref*))))
(define schelog:deref (define schelog:deref
(lambda (r) (lambda (r)
@ -83,41 +83,41 @@
(lambda (r) (lambda (r)
(let ((r2 (schelog:deref r))) (let ((r2 (schelog:deref r)))
(and (vector? r2) (and (vector? r2)
(eq? (vector-ref r2 0) schelog:*frozen*))))) (eq? (vector-ref r2 0) schelog:*frozen*)))))
;deref a structure completely (except the frozen ones, i.e.) ;deref a structure completely (except the frozen ones, i.e.)
(define schelog:deref* (define schelog:deref*
(lambda (s) (lambda (s)
(cond ((schelog:ref? s) (cond ((schelog:ref? s)
(if (schelog:frozen-ref? s) s (if (schelog:frozen-ref? s) s
(schelog:deref* (schelog:deref s)))) (schelog:deref* (schelog:deref s))))
((pair? s) (cons (schelog:deref* (car s)) ((pair? s) (cons (schelog:deref* (car s))
(schelog:deref* (cdr s)))) (schelog:deref* (cdr s))))
((vector? s) ((vector? s)
(list->vector (map schelog:deref* (vector->list s)))) (list->vector (map schelog:deref* (vector->list s))))
(else s)))) (else s))))
;%let introduces new logic variables ;%let introduces new logic variables
(define-syntax %let (define-syntax %let
(syntax-rules () (syntax-rules ()
((%let (x ...) . e) ((%let (x ...) . e)
(let ((x (schelog:make-ref)) ...) (let ((x (schelog:make-ref)) ...)
. e)))) . e))))
#;(define-macro %let #;(define-macro %let
(lambda (xx . ee) (lambda (xx . ee)
`(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx) `(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx)
,@ee))) ,@ee)))
;the unify predicate ;the unify predicate
(define *schelog-use-occurs-check?* #f) (define schelog-use-occurs-check? (make-parameter #f))
(define schelog:occurs-in? (define schelog:occurs-in?
(lambda (var term) (lambda (var term)
(and *schelog-use-occurs-check?* (and (schelog-use-occurs-check?)
(let loop ((term term)) (let loop ((term term))
(cond ((eqv? var term) #t) (cond ((eqv? var term) #t)
((schelog:ref? term) ((schelog:ref? term)
@ -134,45 +134,45 @@
(lambda (t1 t2) (lambda (t1 t2)
(lambda (fk) (lambda (fk)
(letrec (letrec
((cleanup-n-fail ((cleanup-n-fail
(lambda (s) (lambda (s)
(for-each schelog:unbind-ref! s) (for-each schelog:unbind-ref! s)
(fk 'fail))) (fk 'fail)))
(unify1 (unify1
(lambda (t1 t2 s) (lambda (t1 t2 s)
;(printf "unify1 ~s ~s~%" t1 t2) ;(printf "unify1 ~s ~s~%" t1 t2)
(cond ((eqv? t1 t2) s) (cond ((eqv? t1 t2) s)
((schelog:ref? t1) ((schelog:ref? t1)
(cond ((schelog:unbound-ref? t1) (cond ((schelog:unbound-ref? t1)
(cond ((schelog:occurs-in? t1 t2) (cond ((schelog:occurs-in? t1 t2)
(cleanup-n-fail s)) (cleanup-n-fail s))
(else (else
(schelog:set-ref! t1 t2) (schelog:set-ref! t1 t2)
(cons t1 s)))) (cons t1 s))))
((schelog:frozen-ref? t1) ((schelog:frozen-ref? t1)
(cond ((schelog:ref? t2) (cond ((schelog:ref? t2)
(cond ((schelog:unbound-ref? t2) (cond ((schelog:unbound-ref? t2)
;(printf "t2 is unbound~%") ;(printf "t2 is unbound~%")
(unify1 t2 t1 s)) (unify1 t2 t1 s))
((schelog:frozen-ref? t2) ((schelog:frozen-ref? t2)
(cleanup-n-fail s)) (cleanup-n-fail s))
(else (else
(unify1 t1 (schelog:deref t2) s)))) (unify1 t1 (schelog:deref t2) s))))
(else (cleanup-n-fail s)))) (else (cleanup-n-fail s))))
(else (else
;(printf "derefing t1~%") ;(printf "derefing t1~%")
(unify1 (schelog:deref t1) t2 s)))) (unify1 (schelog:deref t1) t2 s))))
((schelog:ref? t2) (unify1 t2 t1 s)) ((schelog:ref? t2) (unify1 t2 t1 s))
((and (pair? t1) (pair? t2)) ((and (pair? t1) (pair? t2))
(unify1 (cdr t1) (cdr t2) (unify1 (cdr t1) (cdr t2)
(unify1 (car t1) (car t2) s))) (unify1 (car t1) (car t2) s)))
((and (string? t1) (string? t2)) ((and (string? t1) (string? t2))
(if (string=? t1 t2) s (if (string=? t1 t2) s
(cleanup-n-fail s))) (cleanup-n-fail s)))
((and (vector? t1) (vector? t2)) ((and (vector? t1) (vector? t2))
(unify1 (vector->list t1) (unify1 (vector->list t1)
(vector->list t2) s)) (vector->list t2) s))
(else (else
(for-each schelog:unbind-ref! s) (for-each schelog:unbind-ref! s)
(fk 'fail)))))) (fk 'fail))))))
(let ((s (unify1 t1 t2 '()))) (let ((s (unify1 t1 t2 '())))
@ -188,24 +188,24 @@
((%or g ...) ((%or g ...)
(lambda (__fk) (lambda (__fk)
(call-with-current-continuation (call-with-current-continuation
(lambda (__sk) (lambda (__sk)
(call-with-current-continuation (call-with-current-continuation
(lambda (__fk) (lambda (__fk)
(__sk ((schelog:deref* g) __fk)))) (__sk ((schelog:deref* g) __fk))))
... ...
(__fk 'fail))))))) (__fk 'fail)))))))
#;(define-macro %or #;(define-macro %or
(lambda gg (lambda gg
`(lambda (__fk) `(lambda (__fk)
(call-with-current-continuation (call-with-current-continuation
(lambda (__sk) (lambda (__sk)
,@(map (lambda (g) ,@(map (lambda (g)
`(call-with-current-continuation `(call-with-current-continuation
(lambda (__fk) (lambda (__fk)
(__sk ((schelog:deref* ,g) __fk))))) (__sk ((schelog:deref* ,g) __fk)))))
gg) gg)
(__fk 'fail)))))) (__fk 'fail))))))
;conjunction ;conjunction
@ -214,73 +214,76 @@
((%and g ...) ((%and g ...)
(lambda (__fk) (lambda (__fk)
(let* ((__fk ((schelog:deref* g) __fk)) (let* ((__fk ((schelog:deref* g) __fk))
...) ...)
__fk))))) __fk)))))
#;(define-macro %and #;(define-macro %and
(lambda gg (lambda gg
`(lambda (__fk) `(lambda (__fk)
(let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg) (let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg)
__fk)))) __fk))))
(define (! fk) (error '! "May only be used inside goal expression."))
;cut ;cut
;; rather arbitrarily made this macro non- (define-syntax (%cut-delimiter stx)
;; capturing by requiring ! to be supplied at (syntax-case stx ()
;; macro use... not changing docs... -- JBC 2010 ((%cut-delimiter g)
(define-syntax %cut-delimiter (with-syntax ([! #'!])
(syntax-rules () (syntax/loc stx
((%cut-delimiter ! g) (lambda (__fk)
(lambda (__fk) (let ((! (lambda (__fk2) __fk)))
(let ((! (lambda (__fk2) __fk))) ((schelog:deref* g) __fk))))))))
((schelog:deref* g) __fk))))))
#;(define-macro %cut-delimiter #;(define-macro %cut-delimiter
(lambda (g) (lambda (g)
`(lambda (__fk) `(lambda (__fk)
(let ((! (lambda (__fk2) __fk))) (let ((! (lambda (__fk2) __fk)))
((schelog:deref* ,g) __fk))))) ((schelog:deref* ,g) __fk)))))
;Prolog-like sugar ;Prolog-like sugar
(define-syntax %rel (define-syntax (%rel stx)
(syntax-rules () (syntax-case stx ()
((%rel ! (v ...) ((a ...) subgoal ...) ...) ((%rel (v ...) ((a ...) subgoal ...) ...)
(lambda __fmls (with-syntax ([! #'!])
(lambda (__fk) (syntax/loc stx
(call-with-current-continuation (lambda __fmls
(lambda (__sk) (lambda (__fk)
(let ((! (lambda (fk1) __fk))) (call-with-current-continuation
(%let (v ...) (lambda (__sk)
(call-with-current-continuation (let ((! (lambda (fk1) __fk)))
(lambda (__fk) (%let (v ...)
(let* ((__fk ((%= __fmls (list a ...)) __fk)) (call-with-current-continuation
(__fk ((schelog:deref* subgoal) __fk)) (lambda (__fk)
...) (let* ((__fk ((%= __fmls (list a ...)) __fk))
(__sk __fk)))) (__fk ((schelog:deref* subgoal) __fk))
... ...)
(__fk 'fail)))))))))) (__sk __fk))))
...
(__fk 'fail))))))))))))
#;(define-macro %rel #;(define-macro %rel
(lambda (vv . cc) (lambda (vv . cc)
`(lambda __fmls `(lambda __fmls
(lambda (__fk) (lambda (__fk)
(call-with-current-continuation (call-with-current-continuation
(lambda (__sk) (lambda (__sk)
(let ((! (lambda (fk1) __fk))) (let ((! (lambda (fk1) __fk)))
(%let ,vv (%let ,vv
,@(map (lambda (c) ,@(map (lambda (c)
`(call-with-current-continuation `(call-with-current-continuation
(lambda (__fk) (lambda (__fk)
(let* ((__fk ((%= __fmls (list ,@(car c))) (let* ((__fk ((%= __fmls (list ,@(car c)))
__fk)) __fk))
,@(map (lambda (sg) ,@(map (lambda (sg)
`(__fk ((schelog:deref* ,sg) `(__fk ((schelog:deref* ,sg)
__fk))) __fk)))
(cdr c))) (cdr c)))
(__sk __fk))))) (__sk __fk)))))
cc) cc)
(__fk 'fail))))))))) (__fk 'fail)))))))))
;the fail and true preds ;the fail and true preds
@ -300,28 +303,28 @@
((%is v e) ((%is v e)
(lambda (__fk) (lambda (__fk)
((%= v (%is (1) e __fk)) __fk))) ((%= v (%is (1) e __fk)) __fk)))
((%is (1) (quote x) fk) (quote x)) ((%is (1) (quote x) fk) (quote x))
((%is (1) (x ...) fk) ((%is (1) (x ...) fk)
((%is (1) x fk) ...)) ((%is (1) x fk) ...))
((%is (1) x fk) ((%is (1) x fk)
(if (and (schelog:ref? x) (schelog:unbound-ref? x)) (if (and (schelog:ref? x) (schelog:unbound-ref? x))
(fk 'fail) (schelog:deref* x))))) (fk 'fail) (schelog:deref* x)))))
#;(define-macro %is #;(define-macro %is
(lambda (v e) (lambda (v e)
(letrec ((%is-help (lambda (e fk) (letrec ((%is-help (lambda (e fk)
(cond ((pair? e) (cond ((pair? e)
(cond ((eq? (car e) 'quote) e) (cond ((eq? (car e) 'quote) e)
(else (else
(map (lambda (e1) (map (lambda (e1)
(%is-help e1 fk)) e)))) (%is-help e1 fk)) e))))
(else (else
`(if (and (schelog:ref? ,e) `(if (and (schelog:ref? ,e)
(schelog:unbound-ref? ,e)) (schelog:unbound-ref? ,e))
(,fk 'fail) (schelog:deref* ,e))))))) (,fk 'fail) (schelog:deref* ,e)))))))
`(lambda (__fk) `(lambda (__fk)
((%= ,v ,(%is-help e '__fk)) __fk))))) ((%= ,v ,(%is-help e '__fk)) __fk)))))
;defining arithmetic comparison operators ;defining arithmetic comparison operators
@ -336,28 +339,28 @@
(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))))) (lambda (m n) (not (= m n)))))
;type predicates ;type predicates
(define schelog:constant? (define schelog:constant?
(lambda (x) (lambda (x)
(cond ((schelog:ref? x) (cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x) #f) (cond ((schelog:unbound-ref? x) #f)
((schelog:frozen-ref? x) #t) ((schelog:frozen-ref? x) #t)
(else (schelog:constant? (schelog:deref x))))) (else (schelog:constant? (schelog:deref x)))))
((pair? x) #f) ((pair? x) #f)
((vector? x) #f) ((vector? x) #f)
(else #t)))) (else #t))))
(define schelog:compound? (define schelog:compound?
(lambda (x) (lambda (x)
(cond ((schelog:ref? x) (cond ((schelog:unbound-ref? x) #f) (cond ((schelog:ref? x) (cond ((schelog:unbound-ref? x) #f)
((schelog:frozen-ref? x) #f) ((schelog:frozen-ref? x) #f)
(else (schelog:compound? (schelog:deref x))))) (else (schelog:compound? (schelog:deref x)))))
((pair? x) #t) ((pair? x) #t)
((vector? x) #t) ((vector? x) #t)
(else #f)))) (else #f))))
(define %constant (define %constant
(lambda (x) (lambda (x)
@ -374,12 +377,12 @@
(define schelog:var? (define schelog:var?
(lambda (x) (lambda (x)
(cond ((schelog:ref? x) (cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x) #t) (cond ((schelog:unbound-ref? x) #t)
((schelog:frozen-ref? x) #f) ((schelog:frozen-ref? x) #f)
(else (schelog:var? (schelog:deref x))))) (else (schelog:var? (schelog:deref x)))))
((pair? x) (or (schelog:var? (car x)) (schelog:var? (cdr x)))) ((pair? x) (or (schelog:var? (car x)) (schelog:var? (cdr x))))
((vector? x) (schelog:var? (vector->list x))) ((vector? x) (schelog:var? (vector->list x)))
(else #f)))) (else #f))))
(define %var (define %var
(lambda (x) (lambda (x)
@ -395,11 +398,11 @@
(lambda (p) (lambda (p)
(lambda args (lambda args
(lambda (fk) (lambda (fk)
(if (call-with-current-continuation (if (call-with-current-continuation
(lambda (k) (lambda (k)
((apply p args) (lambda (d) (k #f))))) ((apply p args) (lambda (d) (k #f)))))
(fk 'fail) (fk 'fail)
fk))))) fk)))))
(define %/= (define %/=
(schelog:make-negation %=)) (schelog:make-negation %=))
@ -409,45 +412,45 @@
(define schelog:ident? (define schelog:ident?
(lambda (x y) (lambda (x y)
(cond ((schelog:ref? x) (cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x) (cond ((schelog:unbound-ref? x)
(cond ((schelog:ref? y) (cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) (eq? x y)) (cond ((schelog:unbound-ref? y) (eq? x y))
((schelog:frozen-ref? y) #f) ((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y))))) (else (schelog:ident? x (schelog:deref y)))))
(else #f))) (else #f)))
((schelog:frozen-ref? x) ((schelog:frozen-ref? x)
(cond ((schelog:ref? y) (cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f) (cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) (eq? x y)) ((schelog:frozen-ref? y) (eq? x y))
(else (schelog:ident? x (schelog:deref y))))) (else (schelog:ident? x (schelog:deref y)))))
(else #f))) (else #f)))
(else (schelog:ident? (schelog:deref x) y)))) (else (schelog:ident? (schelog:deref x) y))))
((pair? x) ((pair? x)
(cond ((schelog:ref? y) (cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f) (cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f) ((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y))))) (else (schelog:ident? x (schelog:deref y)))))
((pair? y) ((pair? y)
(and (schelog:ident? (car x) (car y)) (and (schelog:ident? (car x) (car y))
(schelog:ident? (cdr x) (cdr y)))) (schelog:ident? (cdr x) (cdr y))))
(else #f))) (else #f)))
((vector? x) ((vector? x)
(cond ((schelog:ref? y) (cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f) (cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f) ((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y))))) (else (schelog:ident? x (schelog:deref y)))))
((vector? y) ((vector? y)
(schelog:ident? (vector->list x) (schelog:ident? (vector->list x)
(vector->list y))) (vector->list y)))
(else #f))) (else #f)))
(else (else
(cond ((schelog:ref? y) (cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f) (cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f) ((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y))))) (else (schelog:ident? x (schelog:deref y)))))
((pair? y) #f) ((pair? y) #f)
((vector? y) #f) ((vector? y) #f)
(else (eqv? x y))))))) (else (eqv? x y)))))))
(define %== (define %==
(lambda (x y) (lambda (x y)
@ -463,49 +466,49 @@
(lambda (s) (lambda (s)
(let ((dict '())) (let ((dict '()))
(let loop ((s s)) (let loop ((s s))
(cond ((schelog:ref? s) (cond ((schelog:ref? s)
(cond ((or (schelog:unbound-ref? s) (schelog:frozen-ref? s)) (cond ((or (schelog:unbound-ref? s) (schelog:frozen-ref? s))
(let ((x (assq s dict))) (let ((x (assq s dict)))
(if x (cdr x) (if x (cdr x)
(let ((y (schelog:freeze-ref s))) (let ((y (schelog:freeze-ref s)))
(set! dict (cons (cons s y) dict)) (set! dict (cons (cons s y) dict))
y)))) y))))
;((schelog:frozen-ref? s) s) ;? ;((schelog:frozen-ref? s) s) ;?
(else (loop (schelog:deref s))))) (else (loop (schelog:deref s)))))
((pair? s) (cons (loop (car s)) (loop (cdr s)))) ((pair? s) (cons (loop (car s)) (loop (cdr s))))
((vector? s) ((vector? s)
(list->vector (map loop (vector->list s)))) (list->vector (map loop (vector->list s))))
(else s)))))) (else s))))))
(define schelog:melt (define schelog:melt
(lambda (f) (lambda (f)
(cond ((schelog:ref? f) (cond ((schelog:ref? f)
(cond ((schelog:unbound-ref? f) f) (cond ((schelog:unbound-ref? f) f)
((schelog:frozen-ref? f) (schelog:thaw-frozen-ref f)) ((schelog:frozen-ref? f) (schelog:thaw-frozen-ref f))
(else (schelog:melt (schelog:deref f))))) (else (schelog:melt (schelog:deref f)))))
((pair? f) ((pair? f)
(cons (schelog:melt (car f)) (schelog:melt (cdr f)))) (cons (schelog:melt (car f)) (schelog:melt (cdr f))))
((vector? f) ((vector? f)
(list->vector (map schelog:melt (vector->list f)))) (list->vector (map schelog:melt (vector->list f))))
(else f)))) (else f))))
(define schelog:melt-new (define schelog:melt-new
(lambda (f) (lambda (f)
(let ((dict '())) (let ((dict '()))
(let loop ((f f)) (let loop ((f f))
(cond ((schelog:ref? f) (cond ((schelog:ref? f)
(cond ((schelog:unbound-ref? f) f) (cond ((schelog:unbound-ref? f) f)
((schelog:frozen-ref? f) ((schelog:frozen-ref? f)
(let ((x (assq f dict))) (let ((x (assq f dict)))
(if x (cdr x) (if x (cdr x)
(let ((y (schelog:make-ref))) (let ((y (schelog:make-ref)))
(set! dict (cons (cons f y) dict)) (set! dict (cons (cons f y) dict))
y)))) y))))
(else (loop (schelog:deref f))))) (else (loop (schelog:deref f)))))
((pair? f) (cons (loop (car f)) (loop (cdr f)))) ((pair? f) (cons (loop (car f)) (loop (cdr f))))
((vector? f) ((vector? f)
(list->vector (map loop (vector->list f)))) (list->vector (map loop (vector->list f))))
(else f)))))) (else f))))))
(define schelog:copy (define schelog:copy
(lambda (s) (lambda (s)
@ -537,9 +540,9 @@
(lambda (g) (lambda (g)
(lambda (fk) (lambda (fk)
(if (call-with-current-continuation (if (call-with-current-continuation
(lambda (k) (lambda (k)
((schelog:deref* g) (lambda (d) (k #f))))) ((schelog:deref* g) (lambda (d) (k #f)))))
(fk 'fail) fk)))) (fk 'fail) fk))))
;assert, asserta ;assert, asserta
@ -548,42 +551,42 @@
%fail)) %fail))
(define-syntax %assert (define-syntax %assert
(syntax-rules (!) (syntax-rules ()
((%assert rel-name (v ...) ((a ...) subgoal ...) ...) ((%assert rel-name (v ...) ((a ...) subgoal ...) ...)
(set! rel-name (set! rel-name
(let ((__old-rel rel-name) (let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...))) (__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 (lambda __fmls
(%or (apply __old-rel __fmls) (%or (apply __old-rel __fmls)
(apply __new-addition __fmls))))))) (apply __new-addition __fmls))))))))
#;(define-macro %assert-a (define-syntax %assert-a
(lambda (rel-name vv . cc) (syntax-rules ()
`(set! ,rel-name ((%assert-a rel-name (v ...) ((a ...) subgoal ...) ...)
(let ((__old-rel ,rel-name) (set! rel-name
(__new-addition (%rel ,vv ,@cc))) (let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...)))
(lambda __fmls (lambda __fmls
(%or (apply __new-addition __fmls) (%or (apply __new-addition __fmls)
(apply __old-rel __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 ;set predicates
@ -594,13 +597,13 @@
(define-syntax %free-vars (define-syntax %free-vars
(syntax-rules () (syntax-rules ()
((%free-vars (v ...) g) ((%free-vars (v ...) g)
(cons 'schelog:goal-with-free-vars (cons 'schelog:goal-with-free-vars
(cons (list v ...) g))))) (cons (list v ...) g)))))
#;(define-macro %free-vars #;(define-macro %free-vars
(lambda (vv g) (lambda (vv g)
`(cons 'schelog:goal-with-free-vars `(cons 'schelog:goal-with-free-vars
(cons (list ,@vv) ,g)))) (cons (list ,@vv) ,g))))
(define schelog:goal-with-free-vars? (define schelog:goal-with-free-vars?
(lambda (x) (lambda (x)
@ -619,38 +622,38 @@
(lambda (kons fvv lv goal bag) (lambda (kons fvv lv goal bag)
(lambda (fk) (lambda (fk)
(call-with-current-continuation (call-with-current-continuation
(lambda (sk) (lambda (sk)
(let ((lv2 (cons fvv lv))) (let ((lv2 (cons fvv lv)))
(let* ((acc '()) (let* ((acc '())
(fk-final (fk-final
(lambda (d) (lambda (d)
;;(set! acc (reverse! acc)) ;;(set! acc (reverse! acc))
(sk ((schelog:separate-bags fvv bag acc) fk)))) (sk ((schelog:separate-bags fvv bag acc) fk))))
(fk-retry (goal fk-final))) (fk-retry (goal fk-final)))
(set! acc (kons (schelog:deref* lv2) acc)) (set! acc (kons (schelog:deref* lv2) acc))
(fk-retry 'retry)))))))) (fk-retry 'retry))))))))
(define schelog:separate-bags (define schelog:separate-bags
(lambda (fvv bag acc) (lambda (fvv bag acc)
;;(format #t "Accum: ~s~%" acc) ;;(format #t "Accum: ~s~%" acc)
(let ((bags (let loop ((acc acc) (let ((bags (let loop ((acc acc)
(current-fvv #f) (current-bag '()) (current-fvv #f) (current-bag '())
(bags '())) (bags '()))
(if (null? acc) (if (null? acc)
(cons (cons current-fvv current-bag) bags) (cons (cons current-fvv current-bag) bags)
(let ((x (car acc))) (let ((x (car acc)))
(let ((x-fvv (car x)) (x-lv (cdr x))) (let ((x-fvv (car x)) (x-lv (cdr x)))
(if (or (not current-fvv) (equal? x-fvv current-fvv)) (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 (cons x-lv current-bag) bags)
(loop (cdr acc) x-fvv (list x-lv) (loop (cdr acc) x-fvv (list x-lv)
(cons (cons current-fvv current-bag) bags))))))))) (cons (cons current-fvv current-bag) bags)))))))))
;;(format #t "Bags: ~a~%" bags) ;;(format #t "Bags: ~a~%" bags)
(if (null? bags) (%= bag '()) (if (null? bags) (%= bag '())
(let ((fvv-bag (cons fvv bag))) (let ((fvv-bag (cons fvv bag)))
(let loop ((bags bags)) (let loop ((bags bags))
(if (null? bags) %fail (if (null? bags) %fail
(%or (%= fvv-bag (car bags)) (%or (%= fvv-bag (car bags))
(loop (cdr bags)))))))))) (loop (cdr bags))))))))))
(define %bag-of (schelog:make-bag-of cons)) (define %bag-of (schelog:make-bag-of cons))
(define %set-of (schelog:make-bag-of schelog:set-cons)) (define %set-of (schelog:make-bag-of schelog:set-cons))
@ -660,12 +663,12 @@
(define %bag-of-1 (define %bag-of-1
(lambda (x g b) (lambda (x g b)
(%and (%bag-of x g b) (%and (%bag-of x g b)
(%= b (cons (_) (_)))))) (%= b (cons (_) (_))))))
(define %set-of-1 (define %set-of-1
(lambda (x g s) (lambda (x g s)
(%and (%set-of x g s) (%and (%set-of x g s)
(%= s (cons (_) (_)))))) (%= s (cons (_) (_))))))
;user interface ;user interface
@ -680,42 +683,42 @@
(syntax-rules () (syntax-rules ()
((%which (v ...) g) ((%which (v ...) g)
(%let (v ...) (%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 (call-with-current-continuation
(lambda (__qk) (lambda (__qk)
(set! schelog:*more-k* __qk) (set-box! schelog:*more-k* __qk)
(set! schelog:*more-fk* (set-box! schelog:*more-fk*
((schelog:deref* ,g) ((schelog:deref* g)
(lambda (d) (lambda (d)
(set! schelog:*more-fk* #f) (set-box! schelog:*more-fk* #f)
(schelog:*more-k* #f)))) ((unbox schelog:*more-k*) #f))))
(schelog:*more-k* ((unbox schelog:*more-k*)
(map (lambda (nam val) (list nam (schelog:deref* val))) (map (lambda (nam val) (list nam (schelog:deref* val)))
',vv '(v ...)
(list ,@vv)))))))) (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 (define %more
(lambda () (lambda ()
(call-with-current-continuation (call-with-current-continuation
(lambda (k) (lambda (k)
(set-box! schelog:*more-k* k) (set-box! schelog:*more-k* k)
(if (unbox schelog:*more-fk*) ((unbox schelog:*more-fk*) 'more) (if (unbox schelog:*more-fk*) ((unbox schelog:*more-fk*) 'more)
#f))))) #f)))))
;end of embedding code. The following are ;end of embedding code. The following are
;some utilities, written in Schelog ;some utilities, written in Schelog
@ -723,42 +726,42 @@
(define %member (define %member
(lambda (x y) (lambda (x y)
(%let (xs z zs) (%let (xs z zs)
(%or (%or
(%= y (cons x xs)) (%= y (cons x xs))
(%and (%= y (cons z zs)) (%and (%= y (cons z zs))
(%member x zs)))))) (%member x zs))))))
(define %if-then-else (define %if-then-else
(lambda (p q r) (lambda (p q r)
(%cut-delimiter ! (%cut-delimiter
(%or (%or
(%and p ! q) (%and p ! q)
r)))) r))))
;the above could also have been written in a more ;the above could also have been written in a more
;Prolog-like fashion, viz. ;Prolog-like fashion, viz.
#;'(define %member #;'(define %member
(%rel ! (x xs y ys) (%rel ! (x xs y ys)
((x (cons x xs))) ((x (cons x xs)))
((x (cons y ys)) (%member x ys)))) ((x (cons y ys)) (%member x ys))))
#;'(define %if-then-else #;'(define %if-then-else
(%rel ! (p q r) (%rel ! (p q r)
((p q r) p ! q) ((p q r) p ! q)
((p q r) r))) ((p q r) r)))
(define %append (define %append
(%rel ! (x xs ys zs) (%rel (x xs ys zs)
(('() ys ys)) (('() ys ys))
(((cons x xs) ys (cons x zs)) (((cons x xs) ys (cons x zs))
(%append xs ys zs)))) (%append xs ys zs))))
(define %repeat (define %repeat
;;failure-driven loop ;;failure-driven loop
(%rel ! () (%rel ()
(()) (())
(() (%repeat)))) (() (%repeat))))
; deprecated names -- retained here for backward-compatibility ; deprecated names -- retained here for backward-compatibility
@ -769,12 +772,12 @@
#;(define %notunify %/=) #;(define %notunify %/=)
#;(define-macro %cut #;(define-macro %cut
(lambda e (lambda e
`(%cur-delimiter ,@e))) `(%cur-delimiter ,@e)))
#;(define-macro rel #;(define-macro rel
(lambda e (lambda e
`(%rel ,@e))) `(%rel ,@e)))
(define %eq %=:=) (define %eq %=:=)
(define %gt %>) (define %gt %>)
(define %ge %>=) (define %ge %>=)
@ -788,8 +791,8 @@
#;(define-macro %exists (lambda (vv g) g)) #;(define-macro %exists (lambda (vv g) g))
#;(define-macro which #;(define-macro which
(lambda e (lambda e
`(%which ,@e))) `(%which ,@e)))
(define more %more) (define more %more)
;end of file ;end of file

1422
collects/schelog/schelog.scrbl Normal file
View File

File diff suppressed because it is too large Load Diff

1572
collects/schelog/schelog.tex
View File

File diff suppressed because it is too large Load Diff