131 lines
3.2 KiB
Racket
131 lines
3.2 KiB
Racket
#lang racket
|
|
|
|
(require "../schelog.rkt"
|
|
schemeunit)
|
|
|
|
;The following is the "Biblical" database from "The Art of
|
|
;Prolog", Sterling & Shapiro, ch. 1.
|
|
|
|
;(%father X Y) :- X is the father of Y.
|
|
|
|
(define %father
|
|
(%rel ()
|
|
(('terach 'abraham)) (('terach 'nachor)) (('terach 'haran))
|
|
(('abraham 'isaac)) (('haran 'lot)) (('haran 'milcah))
|
|
(('haran 'yiscah))))
|
|
|
|
;(%mother X Y) :- X is the mother of Y.
|
|
|
|
(define %mother
|
|
(%rel () (('sarah 'isaac))))
|
|
|
|
(define %male
|
|
(%rel ()
|
|
(('terach)) (('abraham)) (('isaac)) (('lot)) (('haran)) (('nachor))))
|
|
|
|
(define %female
|
|
(%rel ()
|
|
(('sarah)) (('milcah)) (('yiscah))))
|
|
|
|
;AoP, ch. 17. Finding all the children of a particular
|
|
;father. (%children F CC) :- CC is the list of children
|
|
;whose father is F. First approach: %children-1 uses an
|
|
;auxiliary predicate %children-aux, which uses an
|
|
;accumulator.
|
|
|
|
(define %children-1
|
|
|
|
(letrec ((children-aux
|
|
(%rel (x a cc c)
|
|
((x a cc)
|
|
(%father x c) (%not (%member c a)) !
|
|
(children-aux x (cons c a) cc))
|
|
((x cc cc)))))
|
|
|
|
(%rel (x cc)
|
|
((x cc) (children-aux x '() cc)))))
|
|
|
|
(define terachs-kids-test
|
|
;find all the children of Terach. Returns
|
|
;cc = (abraham nachor haran)
|
|
(lambda ()
|
|
(%which (cc)
|
|
(%children-1 'terach cc))))
|
|
|
|
(check-equal? (terachs-kids-test)
|
|
`((cc (haran nachor abraham))))
|
|
|
|
(define dad-kids-test
|
|
;find a father and all his children. Returns
|
|
;f = terach, cc = (haran nachor abraham).
|
|
;(%more) fails, showing flaw in %children-1.
|
|
;see AoP, ch. 17, p. 267
|
|
(lambda ()
|
|
(%which (f cc)
|
|
(%children-1 f cc))))
|
|
|
|
(check-equal? (dad-kids-test)
|
|
`((f terach) (cc (haran nachor abraham))))
|
|
|
|
(define terachs-kids-test-2
|
|
;find all the kids of Terach, using %set-of.
|
|
;returns kk = (abraham nachor haran)
|
|
(lambda ()
|
|
(%let (k)
|
|
(%which (kk)
|
|
(%set-of k (%father 'terach k) kk)))))
|
|
|
|
;This is a better definition of the %children predicate.
|
|
;Uses set predicate %bag-of
|
|
|
|
(define %children
|
|
(%rel (x kids c)
|
|
((kids) (%set-of c (%father x c) kids))))
|
|
|
|
(define dad-kids-test-2
|
|
;find each dad-kids combo.
|
|
;1st soln: dad = terach, kids = (abraham nachor haran)
|
|
;(%more) gives additional solutions.
|
|
(lambda ()
|
|
(%let (x)
|
|
(%which (dad kids)
|
|
(%set-of x (%free-vars (dad)
|
|
(%father dad x))
|
|
kids)))))
|
|
|
|
(define dad-kids-test-3
|
|
;looks like dad-kids-test-2, but dad is now
|
|
;existentially quantified. returns a set of
|
|
;kids (i.e., anything with a father)
|
|
(lambda ()
|
|
(%let (x)
|
|
(%which (dad kids)
|
|
(%set-of x (%father dad x)
|
|
kids)))))
|
|
|
|
(define dad-kids-test-4
|
|
;find the set of dad-kids.
|
|
;since dad is existentially quantified,
|
|
;this gives the wrong answer: it gives
|
|
;one set containing all the kids
|
|
(lambda ()
|
|
(%let (dad kids x)
|
|
(%which (dad-kids)
|
|
(%set-of (list dad kids)
|
|
(%set-of x (%father dad x) kids)
|
|
dad-kids)))))
|
|
|
|
(define dad-kids-test-5
|
|
;the correct solution. dad is
|
|
;identified as a free var.
|
|
;returns a set of dad-kids, one for
|
|
;each dad
|
|
(lambda ()
|
|
(%let (dad kids x)
|
|
(%which (dad-kids)
|
|
(%set-of (list dad kids)
|
|
(%set-of x (%free-vars (dad)
|
|
(%father dad x))
|
|
kids)
|
|
dad-kids)))))
|