#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh 'prolog1.2/Interval/mult.ss' <<'END_OF_FILE'
X(define (mult i j k)
X ;;; i, j, k are intervals
X (let ((i- (intersect i -INFZERO>))
X (i0 (intersect i ZEROZERO ))
X (i+ (intersect i ))
X (j0 (intersect j ZEROZERO ))
X (j+ (intersect j ))
X (k0 (intersect k ZEROZERO ))
X (k+ (intersect k ))
X (i0 (intersect i ZEROZERO ))
X (i+ (intersect i > >) (> { <) (> } >) (> < <)
X ({ > >) ({ { {) ({ } }) ({ < <)
X (} > >) (} { {) (} } }) (} < <)
X (< > >) (< { <) (< } >) (< < <) ))
END_OF_FILE
if test 4797 -ne `wc -c <'prolog1.2/Interval/mult.ss'`; then
echo shar: \"'prolog1.2/Interval/mult.ss'\" unpacked with wrong size!
fi
# end of 'prolog1.2/Interval/mult.ss'
fi
if test -f 'prolog1.2/Interval/prim.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'prolog1.2/Interval/prim.ss'\"
else
echo shar: Extracting \"'prolog1.2/Interval/prim.ss'\" \(7583 characters\)
sed "s/^X//" >'prolog1.2/Interval/prim.ss' <<'END_OF_FILE'
X
X;;; predicates
X(define (is-inf? x) (equal? x INF- )) ;;; x is an internal real
X
X(define (isinf? x) (equal? x INF)) ;;; x is an internal real
X
X(define (lb-open? type-lb) (equal? type-lb LB-OPEN))
X ;;; type-lb is a lower bound bracket
X
X(define (lb-closed? type-lb) (equal? type-lb LB-CLOSED))
X ;;; type-lb is a lower bound bracket
X
X(define (ub-open? type-ub) (equal? type-ub UB-OPEN))
X ;;; type-ub is a lower bound bracket
X
X(define (ub-closed? type-ub) (equal? type-ub UB-CLOSED))
X ;;; type-ub is a lower bound bracket
X
X(define (lb-type? x) (or (lb-open? x) (lb-closed? x)))
X ;;; x could be anything!?
X
X(define (ub-type? x) (or (ub-open? x) (ub-closed? x)))
X ;;; x could be anything!?
X
X(define (arith-interval? x) ;;; x could be anything!?
X (and (proper-list? x) ;;; note (pair? '(a . b)) -> #t
X (= 4 (length x))
X (lb-type? (index@ x 1))
X (ub-type? (index@ x 4))))
X ;;; sufficeth for now!##
X ;;; needs to be stricter later
X
X(define (~** { } < ) )
X(define LB-OPEN '< )
X(define LB-CLOSED '{ )
X(define UB-OPEN '> )
X(define UB-CLOSED '} )
X(define UMIN-BRACKET '( (< >) ({ }) (> <) (} {) ) )
X(define INF 'w )
X(define INF- '-w )
X(define -INFINF (mk-interval '{ INF- INF '} ) )
X(define EMPTY (mk-interval '< 2.0 1.0 '> ) )
X ;;; empty interval = (2,1)
X(define ZEROZERO (mk-interval '{ 0.0 0.0 '} ) )
X ;;; (0,0)
X(define ZEROINF (mk-interval '{ 0.0 INF '} ))
X ;;; (0,w)
X(define (mk-interval '{ INF- 0.0 '> ))
X ;;; (-w,0)
X(define ONEONE (mk-interval '{ 1.0 1.0 '} ) )
X ;;; (1,1)
X(define FAIL 'fail)
X(define COMPLETE-SUCCESS 'succ)
X(define RETAIN 'keep)
X
END_OF_FILE
if test 7583 -ne `wc -c <'prolog1.2/Interval/prim.ss'`; then
echo shar: \"'prolog1.2/Interval/prim.ss'\" unpacked with wrong size!
fi
# end of 'prolog1.2/Interval/prim.ss'
fi
if test -f 'prolog1.2/Interval/unify.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'prolog1.2/Interval/unify.ss'\"
else
echo shar: Extracting \"'prolog1.2/Interval/unify.ss'\" \(4598 characters\)
sed "s/^X//" >'prolog1.2/Interval/unify.ss' <<'END_OF_FILE'
X;;; predicates
X(define (arith-unify? term1 term2)
X (or (arith-var? term1) (arith-var? term2)))
X
X(define (arith-var? x) ;;; x is any dereferenced term
X (and (term-var? x)
X (var-inst? x)
X (arith-interval? (var-val x))))
X
X;;; functions
X(define (arith-unify term1 term2 program s f)
X ;;; term1, term2 are dereferenced terms
X (arith-debug "in arith-unify() with term1:")
X (arith-debug (term-instantiate term1))
X (arith-debug "and term2:")
X (arith-debug (term-instantiate term2))
X (if (arith-var? term1)
X (arith-u term1 term2 program s f)
X (arith-u term2 term1 program s f)))
X
X(define (arith-u arith-var term program s f)
X ;;; arith-var is an arithmetic var
X ;;; term is any term
X ;;; in all the following, no reference
X ;;; is maintained to the unified!!##
X (arith-debug "in arith-u() with arith-var:")
X (arith-debug (term-instantiate arith-var))
X (arith-debug "and term:")
X (arith-debug (term-instantiate term))
X (cond ((and (term-var? term) (not (var-inst? term)))
X ;;; term is uninstantiated variable?
X (var-instantiate! term arith-var program s f))
X ((and (arith-var? term) (var=? arith-var term))
X ;;; same variable?
X (s f))
X ((arith-var? term)
X ;;; term is a different and bound
X ;;; arithmetic var?
X (aau arith-var term program s f))
X ((number? term) ;;; constant term?
X (acu arith-var term program s f))
X (else (f)))) ;;; unification fails if term is bound
X ;;; to anything else
X
X(define (acu avar c program s f)
X ;;; avar is a var instantiated to an
X ;;; interval
X ;;; c is a number
X (let* ((avar-val (var-val avar))
X (c-val (approx c))
X (int-new (intersect avar-val c-val)))
X (cond ((empty? int-new)
X (f))
X ((~***list delay-dlist)))
X (for-each
X (lambda (dlay)
X (var-add-constraint! dlay to-var 'REAR))
X ;;; REAR to preserve order
X delay-list)))
X
X(define (erase-delays! var) (vector-set! var 3 (make-dlist)))
X ;;; NON-PORTABLE
X ;;; *** test me ***
X
X(define (fill-delays! var dlays) (vector-set! var 3 dlays))
X ;;; NON-PORTABLE
X ;;; *** test me ***
X
X(define (transfer-delay! var var-set)
X (arith-debug "in transfer-delay!()")
X (let ((constraints (var-constraints var)))
X ;;; note copying essential??##@@
X ;;; but all vars get SAME copy?#
X (for-each
X (lambda (to-var)
X (xfer-all-delays! constraints to-var))
X var-set)
X (erase-delays! var)
X constraints))
X
X(define (purge-delays! delay-dlist from-var)
X (let ((delay-list (dlist->list delay-dlist)))
X (for-each
X (lambda (dlay)
X (var-del-constraint! dlay from-var))
X delay-list)))
X
X(define (restore-delay! constraints var var-set)
X (arith-debug "in restore-delay!()")
X (fill-delays! var constraints)
X (for-each
X (lambda (from-var)
X (purge-delays! constraints from-var))
X var-set))
X
X;;; avar is an arithmetic variable (instantiated to an interval).
X;;; value is an arithmetic interval.
X;;; _unifies_ value with avar; this is done to handle multiple occurrences
X;;; of the same variable in a call to an arithmetic primitive.
X(define (unite! avar value)
X (let* ((avar-val (var-val avar))
X (int-new (intersect avar-val value)))
X (if (**'prolog1.2/Manual' <<'END_OF_FILE'
X Description of Scheme Prolog 1.2
X --------------------------------
X
XScheme Prolog 1.2 is an interpreter for pure Prolog. It supports delayed
Xgoals (i.e., goals which are not executed until certain conditions are met,
Xsuch as certain variables being bound) and is extensible to include predicates
Xdefined in Scheme. An interval-arithmetic package is also loaded by default.
X
X Syntax and Startup Procedure for Scheme Prolog 1.2
X --------------------------------------------------
X
XThe interpreter is invoked by evaluating the following:
X (pro "file"...)
Xwhere "file"... is a sequence of names of Prolog source files. The interpreter
Ximplicitly loads "builtin.pro" (and "interval.pro" if interval arithmetic is
Xenabled) before loading the specified files. Queries pertaining to the loaded
Xfiles are then accepted. The interpreter is exited by typing "q" to the query
Xprompt.
X
XProlog definitions consist of two parts: a "when" part and a "what" or "how"
Xpart. The "when" part specifies conditions under which a goal can proceed,
Xand the "what" or "how" part specifies the meaning of the goal in terms of
Xeither Prolog (for "what" definitions) or Scheme (for "how" definitions).
X
XTypically, no "when" conditions would be specified, indicating that the goal
Xis never delayed. Such a declaration would have the following form:
X (when (my-func ?arg1 ?arg2))
XOne may also specify conditions of the following forms:
X (when (my-func ?arg1 ?arg2) (nonvar ?arg1) (nonvar ?arg2))
X (when (my-func ?arg1 ?arg2) (ground ?arg2))
XTaken together, these two declarations imply that my-func may be executed if
Xand only if (a) both of its arguments are instantiated, or (b) its second
Xargument is ground.
X
XA "what" definition has the following form:
X (what (my-func ?arg1 ?arg2) (foo ?arg1) (bar ?arg2) (etc ?arg2))
X (what (my-func fred ?arg))
XThis is equivalent to the following Edinburgh Prolog definition:
X my-func(Arg1,Arg2) :- foo(Arg1), bar(Arg2), etc(Arg2).
X my-func(fred,Arg).
X
XInstead of providing a set of "what" clauses, one may provide a single "how"
Xclause to define a predicate in Scheme, as follows:
X (how (my-func ?arg1 ?arg2)
X (lambda (goal program s f) (scheme-stuff ...)))
XOnly a single "how" clause is permitted. For further details, refer to the
Xfile "Impl".
X
XA typical Prolog session looks something like the following:
X
X% scheme
XScheme ...
X> (load "/prolog.ss")
X ...
X> (pro "" ...)
X ...
X?- q
Xbye
X> (exit)
X%
X
XRefer to "ex.pro" for examples of Prolog programs, and to "ex.out" for
Xtheir expected output.
X
X Primitives Offered by Scheme Prolog 1.2
X ---------------------------------------
X
X[1] (true)
X This succeeds unconditionally.
X[2] (fail)
X This fails unconditionally.
X[3] (findall )
X is either a single Prolog variable or
X a LIST of variable names,
X and is a single Prolog goal.
X This predicate unifies with a list of bindings for ;
X each of these bindings is generated as part of the solution to
X .
X[4] (not )
X is a single Prolog goal.
X The predicate succeeds if fails.
X[5] (debug)
X This toggles user-level debugging, i.e., which predicate is being
X executed/backtracked and its argument terms.
X
X Built-In Routines for Dealing with Intervals
X --------------------------------------------
X
X[1] (add )
X This implies the constraint that + = .
X[2] (mult )
X This implies the constraint that * = .
X[3] (square )
X This implies the constraint that * = .
X[4] (int )
X This implies the constraint that is an integer.
X[5] (gt )
X This implies the constraint that > .
X[6] (geq )
X This implies the constraint that >= .
X[7] (neq )
X This implies the constraint that =/= .
X[8] (split )
X (split-abs )
X (split-rel )
X (split-machine )
X These are control predicates which enable different alternatives
X to be explored by unifying to complementary ranges of
X values whenever possible. Termination of splitting is controlled
X by , or, in the case of split-machine or split (which
X is actually synonymous with split-machine), by the finest
X precision representable on the machine.
X[9] (interval
X )
X This delays until has been instantiated to an arithmetic
X interval. Following instantiation, it unifies
X with the lower bound bracket,
X with the lower bound value,
X with the upper bound value, and
X with the upper bound bracket of (the value of)
X .
X[10] (monitor )
X is a single Prolog variable.
X is "any" displayable Prolog expression.
X This goal prints out (the value of) followed by
X whenever has its value narrowed (squeezed), and hence
X can be used for ascertaining the sequence of bindings a Prolog
X variable goes through.
X
X Interpretation of Arithmetic Intervals as Displayed in the Answers
X ------------------------------------------------------------------
X An arithmetic interval is represented as a list of four elements:
X (
X )
X can take the following values:
X '{' to represent a closed lower bound, and
X '<' to represent an open lower bound.
X can take the following values:
X '}' to represent a closed upper bound, and
X '>' to represent an open upper bound.
X and are SPECIAL real
X numbers representing the values of the bounds--SPECIAL
X because they can additionally take the following values:
X 'w' denoting +infinity, and
X '-w' denoting -infinity.
X
X For example:
X ({ 0 w }) denotes the set of all non-negative real numbers,
X ({ 1 1 }) denotes the integer 1 since it is a point interval,
X ({ -w w }) denotes the set of all real numbers,
X (< -1.1 1.2 }) denotes the set
X S = { x: x is Real and -1.1 < x and x <= 1.2 },
X (< 1.3 1.3 >) denotes the set
X S = { x: x is Real and 1.3 < x and x < 1.3 },
X and hence is an empty interval.
END_OF_FILE
if test 6382 -ne `wc -c <'prolog1.2/Manual'`; then
echo shar: \"'prolog1.2/Manual'\" unpacked with wrong size!
fi
# end of 'prolog1.2/Manual'
fi
if test -f 'prolog1.2/interval.pro' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'prolog1.2/interval.pro'\"
else
echo shar: Extracting \"'prolog1.2/interval.pro'\" \(4342 characters\)
sed "s/^X//" >'prolog1.2/interval.pro' <<'END_OF_FILE'
X(when (add ?x ?y ?z))
X(how (add ?x ?y ?z) relax-squeeze)
X
X(when (mult ?x ?y ?z))
X(how (mult ?x ?y ?z) relax-squeeze)
X
X(when (square ?x ?y))
X(how (square ?x ?y) relax-squeeze)
X
X(when (int ?x))
X(how (int ?x) relax-squeeze)
X
X(when (gt ?x ?y))
X(how (gt ?x ?y) relax-squeeze)
X
X(when (geq ?x ?y))
X(how (geq ?x ?y) relax-squeeze)
X
X(when (neq ?x ?y))
X(how (neq ?x ?y) relax-squeeze)
X
X(when (zero-one2 ?x ?y)) ;;; for internal use
X(how (zero-one2 ?x ?y) relax-squeeze)
X
X(when (zero-one1 ?x)) ;;; for internal use
X(how (zero-one1 ?x) relax-squeeze)
X
X(when (zero1 ?x)) ;;; for internal use
X(how (zero1 ?x) relax-squeeze)
X
X(when (split-abs ?prec ?x))
X(how (split-abs ?prec ?x)
X (lambda (goal program s f)
X (arith-debug "in how-split() with goal:")
X (arith-debug (term-instantiate (goal-term goal)))
X (user-debug "just delaying goal")
X (let ((old-split-list (backup-split-list)))
X (flounder! goal)
X (dlist-insert-anywhere! goal SPLITTING-GOALS)
X (s (lambda ()
X (unflounder! goal)
X (restore-split-list! old-split-list)
X (f))))))
X
X(when (split-rel ?prec ?x))
X(how (split-rel ?prec ?x)
X (lambda (goal program s f)
X (arith-debug "in how-split() with goal:")
X (arith-debug (term-instantiate (goal-term goal)))
X (user-debug "just delaying goal")
X (let ((old-split-list (backup-split-list)))
X (flounder! goal)
X (dlist-insert-anywhere! goal SPLITTING-GOALS)
X (s (lambda ()
X (unflounder! goal)
X (restore-split-list! old-split-list)
X (f))))))
X
X(when (split-machine ?x))
X(how (split-machine ?x)
X (lambda (goal program s f)
X (arith-debug "in how-split() with goal:")
X (arith-debug (term-instantiate (goal-term goal)))
X (user-debug "just delaying goal")
X (let ((old-split-list (backup-split-list)))
X (flounder! goal)
X (dlist-insert-anywhere! goal SPLITTING-GOALS)
X (s (lambda ()
X (unflounder! goal)
X (restore-split-list! old-split-list)
X (f))))))
X
X(when (split ?x))
X(how (split ?x)
X (lambda (goal program s f)
X (arith-debug "in how-split() with goal:")
X (arith-debug (term-instantiate (goal-term goal)))
X (user-debug "just delaying goal")
X (let ((old-split-list (backup-split-list)))
X (flounder! goal)
X (dlist-insert-anywhere! goal SPLITTING-GOALS)
X (s (lambda ()
X (unflounder! goal)
X (restore-split-list! old-split-list)
X (f))))))
X
X(when (interval ?term ?lbt ?lb ?ub ?ubt))
X(how (interval ?term ?lbt ?lb ?ub ?ubt)
X (lambda (goal program s f)
X (let* ((g-term (goal-term goal))
X (inst-goal (term-instantiate g-term))
X (term (term-deref (comp-cadr g-term))))
X (arith-debug "in interval() with goal:")
X (arith-debug inst-goal)
X (if (and (term-var? term) (var-inst? term)
X (arith-interval? (var-val term)))
X (let* ((lbt (comp-caddr g-term))
X (lb (comp-cadddr g-term))
X (ub (comp-caddddr g-term))
X (ubt (comp-cadddddr g-term))
X (val (var-val term))
X (lbt-val (lb-type@ val))
X (lb-val (lb@ val))
X (ub-val (ub@ val))
X (ubt-val (ub-type@ val))
X (u-ub (lambda (f)
X (unify ub ub-val program s f)))
X (u-lb (lambda (f)
X (unify-quick lb lb-val program
X u-ub f)))
X (u-ubt (lambda (f)
X (unify-quick ubt ubt-val program
X u-lb f))))
X (unify-quick lbt lbt-val program
X u-ubt f))
X (begin (user-debug "just delaying goal")
X (flounder! goal)
X (var-add-constraint! goal term 'REAR)
X ;;; assumes var here!
X (s (lambda ()
X (var-del-constraint! goal term)
X (unflounder! goal)
X (f))))))))
X
X(when (monitor ?x ?item))
X(how (monitor ?x ?item)
X (lambda (goal program s f)
X (let* ((g-term (goal-term goal))
X (term (term-deref (comp-cadr g-term)))
X (inst-term (term-instantiate (comp-cadr g-term)))
X (item (term-instantiate (comp-caddr g-term)))
X (inst-goal (term-instantiate g-term)))
X (arith-debug "in monitor() with goal:")
X (arith-debug inst-goal)
X (if (term-not-var? term)
X (error 'monitor() "illegal term ~s" term))
X (display inst-term)
X (display item)
X (newline)
X (if (and (var-inst? term)
X (or (term-const? (var-val term))
X (and (arith-interval?
X (var-val term))
X (point? (var-val term)))))
X ;;; no more narrowing/squeezing possible
X (s f)
X (begin (var-add-constraint! goal term 'REAR)
X (flounder! goal)
X (s (lambda ()
X (unflounder! goal)
X (var-del-constraint! goal term)
X (f))))))))
END_OF_FILE
if test 4342 -ne `wc -c <'prolog1.2/interval.pro'`; then
echo shar: \"'prolog1.2/interval.pro'\" unpacked with wrong size!
fi
# end of 'prolog1.2/interval.pro'
fi
if test -f 'prolog1.2/search.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'prolog1.2/search.ss'\"
else
echo shar: Extracting \"'prolog1.2/search.ss'\" \(5014 characters\)
sed "s/^X//" >'prolog1.2/search.ss' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;
X;;; Search
X;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(define (unify term1 term2 program s f)
X (unify-quick term1 term2 program
X (lambda (fail)
X (scheduler program s fail))
X f))
X
X;;; unify-quick takes care of all aspects of unification with the exception
X;;; of invocation of the scheduler upon completion. It is used as the
X;;; recursive portion of the unification algorithm in order to avoid
X;;; invoking the scheduler each time a variable becomes bound. This
X;;; necessary step is performed by unify after the unification is complete,
X;;; in order to deal with any delayed goals which should possibly be woken
X;;; due to bindings performed during unification.
X
X(define (unify-quick term1 term2 program s f)
X (define (u term1 term2 s f)
X (if debug?
X (begin
X (display "u: ")
X (display (term-instantiate term1))
X (display (term-instantiate term2))
X (newline)))
X (cond ((and intervals? (arith-unify? term1 term2))
X (arith-unify term1 term2 program s f))
X ((term-var? term1)
X (cond ((var=? term1 term2)
X ;;; same variable?
X (s f))
X ((not (var-inst? term1))
X (var-instantiate! term1 term2
X program s f))
X ((not (term-var? term2))
X ;;; const? or comp? term2
X (unify-quick (var-val term1)
X term2
X program s f))
X ((not (var-inst? term2))
X (var-instantiate! term2 term1
X program s f))
X (else ;;; both are instantiated?
X (unify-quick (var-val term1)
X (var-val term2)
X program s f))))
X ((term-var? term2)
X (cond ((var-inst? term2)
X (unify-quick term1
X (var-val term2)
X program s f))
X (else (var-instantiate! term2 term1
X program s f))))
X ((term-const? term1)
X ;;; neither term is a variable
X (if (term-const? term2)
X (if (const=? term1 term2) (s f) (f))
X (f)))
X ((term-const? term2)
X (f))
X (else ;;; both must be term-comp?
X (unify-quick (comp-car term1)
X (comp-car term2)
X program
X (lambda (f)
X (unify-quick (comp-cdr term1)
X (comp-cdr term2)
X program
X s f))
X f))))
X (u (term-deref term1) (term-deref term2) s f))
X
X
X(define (or-branch clause goal program s f)
X (if debug?
X (begin
X (display "or-branch clause: ")
X (display (term-instantiate clause))
X (display " goal: ")
X (display (term-instantiate (goal-term goal)))
X (newline)))
X (unify
X (clause-head clause)
X (goal-term goal)
X program
X (lambda (f) (and-node (clause-body clause) program s f))
X f))
X
X(define (or-node clause-makers goal program s f)
X (if debug?
X (begin (display "or-node goal: ")
X (display (term-instantiate (goal-term goal)))
X (display " clause-makers: ")
X (display clause-makers)
X (newline)))
X (if (null? clause-makers)
X (f)
X (or-branch
X ((car clause-makers))
X goal
X program
X s (lambda ()
X (or-node (cdr clause-makers) goal
X program s f)))))
X
X(define (and-branch goal program s f)
X (define (success fail)
X (user-debug (list "continuing after" (goal-id goal) ":"))
X (user-debug (term-instantiate (goal-term goal)))
X (s fail))
X (define (fail)
X (user-debug (list "backtracking to" (goal-id goal) ":"))
X (user-debug (term-instantiate (goal-term goal)))
X (f))
X
X (let ((pred (goal-pred goal))
X (instantiated-goal (term-instantiate (goal-term goal))))
X (if debug?
X (begin (display "and-branch goal: ")
X (display instantiated-goal)
X (newline)))
X (user-debug
X (list (if (pred-how? pred) ;;; system predicate?
X "executing system predicate"
X "executing user-defined predicate")
X (goal-id goal)
X ":"))
X (user-debug instantiated-goal)
X (if (pred-how? pred) ;;; system predicate?
X ((pred-how pred) goal program success fail)
X (or-node (pred-what pred) goal program success fail))))
X
X(define (and-node terms program s f)
X (if debug?
X (begin (display "and-node terms: ")
X (display (term-instantiate terms))
X (newline)))
X (if (null? terms)
X ;;; end of normal Prolog execution?
X (if intervals?
X (relax-split program s f) ;;; relaxation followed by (s f)
X ;;; which is done within
X ;;; (relax-split ...)
X (s f))
X (let ((goal (make-goal (car terms) program)))
X (goal-first-try!
X goal
X (lambda (f) ;;; run continuation
X (and-branch
X goal
X program
X (lambda (f) (and-node (cdr terms) program s f))
X f))
X (lambda (f) ;;; delay continuation
X (and-node (cdr terms) program s f))
X f))))
X
X(define (all-solutions vars-template goal-term program)
X (if debug? (begin (display "in all-solutions()") (newline)))
X (and-branch (make-goal goal-term program) program
X (lambda (fail)
X (let ((soln (term-instantiate vars-template)))
X (cons soln (fail))))
X (lambda () '())))
END_OF_FILE
if test 5014 -ne `wc -c <'prolog1.2/search.ss'`; then
echo shar: \"'prolog1.2/search.ss'\" unpacked with wrong size!
fi
# end of 'prolog1.2/search.ss'
fi
if test -f 'prolog1.2/terms.ss' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'prolog1.2/terms.ss'\"
else
echo shar: Extracting \"'prolog1.2/terms.ss'\" \(13418 characters\)
sed "s/^X//" >'prolog1.2/terms.ss' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;
X;;; Terms -- There are three classes of terms:
X;;; 1. Variables: vectors with a type, name and value in them
X;;; 2. Constants: symbol or atom or character or string
X;;; 3. Composites: pairs of terms
X;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; returns true iff x is a term
X(define (term? x) (or (term-var? x) (term-const? x) (term-comp? x)))
X
X;;; returns true iff term is a variable
X(define term-var? vector?)
X
X
X(define (term-not-var? term)
X (not (term-var? term)))
X
X
X;;; returns true iff term is a constant
X(define (term-const? term)
X (or (symbol? term)
X (number? term)
X (char? term)
X (string? term)
X (boolean? term)
X (null? term)))
X
X;;; returns true iff term is a composite term
X(define term-comp? pair?)
X
X;;; returns true iff terms are equal
X(define term=? equal?)
X
X(define (term-ground? term)
X (cond ((term-var? term)
X (if (var-inst? term)
X (term-ground? (var-val term))
X #f))
X ((term-comp? term)
X (if (term-ground? (comp-car term))
X (term-ground? (comp-cdr term))
X #f))
X (else ; term is a constant
X #t)))
X
X
X;;; returns a pair - car indicates how many characters of the string were
X;;; not followed
X;;; - cdr is the subtree
X;;;
X;;; eg. (term-follow-path '(?a (?b ?c)) "ad") => (0 ?b ?c)
X;;; (term-follow-path '(?a (?b ?c)) "ddaaad") => (3 . ?b)
X;;;
X(define (term-follow-path term str)
X (define (term-follow-path-aux term i)
X; (display "term-follow-path-aux ") (display term) (display " ") (display i) (newline)
X (if (term-var? term)
X (if (var-inst? term)
X (term-follow-path-aux (var-val term) i) ; dereference
X (cons (1+ i) term))
X (if (negative? i)
X (cons (1+ i) term)
X (if (term-comp? term)
X (term-follow-path-aux
X (if (char=? (string-ref str i) '#\a) (car term) (cdr term))
X (1- i))
X (cons (1+ i) term)))))
X (term-follow-path-aux term (1- (string-length str))))
X
X;;; returns a path (represented by a string of a's and d's) to const in term
X;;; returns false if there is no such path
X;;;
X;;; eg (term-find-path '?x '(append ?x ?y ?z)) => "ad"
X(define (term-find-path const term)
X (define (term-find-path-aux term char-list)
X (if (term-const? term)
X (if (const=? const term)
X (list->string char-list)
X #f)
X (let ((res (term-find-path-aux
X (comp-car term) (cons #\a char-list))))
X (if res
X res
X (term-find-path-aux (comp-cdr term) (cons #\d char-list))))))
X (term-find-path-aux term '()))
X
X;;; treat ALL variables as capable of multiple instantiations;
X;;; therefore, instantiated vars are "equivalent" to ordinary vars.
X;;; returns the set of the variables in term (no duplicates).
X;;; should be rewritten to using ordered variable lists for efficiency.
X(define (term-list-deref term)
X (define (collect term vars)
X (cond ((term-const? term)
X vars)
X ((term-var? term)
X (if (or (not (var-inst? term))
X (term-shallow-ground? term))
X (if (memq term vars) vars
X (cons term vars))
X (collect (var-val term) vars)))
X ((term-comp? term)
X (collect (comp-car term)
X (collect (comp-cdr term) vars)))
X (else (error 'collect "illegal term ~s" term))))
X (collect term '()))
X
X(define (term-recursive-const? term)
X (cond ((term-const? term)
X '#t)
X ((term-comp? term)
X (and (term-recursive-const? (comp-car term))
X (term-recursive-const? (comp-cdr term))))
X (else '#f)))
X
X(define (term-shallow-ground? term)
X (cond ((term-const? term)
X '#t)
X ((term-var? term)
X (if (var-inst? term)
X (term-recursive-const? (var-val term))
X '#f))
X ((term-comp? term)
X (and (term-shallow-ground? (comp-car term))
X (term-shallow-ground? (comp-cdr term))))
X (else (error 'term-shallow-ground? "illegal term ~s" term))))
X
X;;; returns the functor of term
X;;; e.g. (TERM-FUNCTOR '(PLUS ?X ?Y ?Z)) => PLUS
X;;; (TERM-FUNCTOR '(P)) => P
X;;; (TERM-FUNCTOR 'X) => X
X;;; (TERM-FUNCTOR 1) => error
X;;; (TERM-FUNCTOR '?X) => !@$%^&*
X(define (term-functor term)
X (cond ((term-var? term) '!@$%^&*)
X ((term-const? term) (const-functor term))
X ((term-comp? term) (comp-functor term))))
X
X;;; returns the arity of term
X;;; egs. (TERM-ARITY '(PLUS ?X ?Y ?Z)) => 3
X;;; (TERM-ARITY '(P)) => 0
X;;; (TERM-ARITY 'X) => 0
X;;; (TERM-ARITY 1) => error
X;;; (TERM-ARITY '?X) => error
X(define (term-arity term)
X (cond ((term-var? term) 0)
X ((term-const? term) (const-arity term))
X ((term-comp? term) (comp-arity term))))
X
X;;; returns a symbol which is of the form functor/arity
X;;; egs. (TERM->FUNCTOR/ARITY '(PLUS ?X ?Y ?Z)) => PLUS/3
X;;; (TERM->FUNCTOR/ARITY '(P)) => P/0
X;;; (TERM->FUNCTOR/ARITY 'X) => X/0
X;;; (TERM->FUNCTOR/ARITY 1) => undefined
X;;; (TERM->FUNCTOR/ARITY '?X) => !@$%^&*/0
X(define (term->functor/arity term)
X (string->symbol
X (string-append
X (symbol->string
X (term-functor term)) "/" (number->string (term-arity term)))))
X
X;;; returns term converted to a string
X;;; eg (term->string '(f ?x 1 ?y)) => "(F ?X 1 ?Y)"
X;;; This won't work in most schemes, should be rewritten!
X(define (term->string term) (format '() "~o" term))
X
X;;; returns DEEPEST referred VARIABLES in term.
X;;; dereferences term.
X(define (term-deref term)
X (if (and (term-var? term) (var-inst? term))
X (let ((val (var-val term)))
X (if (term-var? val)
X (term-deref val)
X term))
X term)) ;;; for composites and constants
X
X;;; instantiates term by dereferencing all variables
X;;; Note: this used to be called de-prolog
X(define (term-instantiate term)
X (cond ((term-const? term) term)
X ((term-var? term)
X (if (var-inst? term)
X (term-instantiate (var-val term))
X (var-name term)))
X ((term-comp? term)
X (comp-cons (term-instantiate (comp-car term))
X (term-instantiate (comp-cdr term))))))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;
X;;; Variable term stuff, call only with terms for which term-var? is true
X;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; constructor: renames name so it provides a unique key for the variable
X;;; so variables can be ordered
X(define make-var
X (let ((n 0))
X (lambda (name)
X (set! n (1+ n))
X (vector
X 'uninst
X (string->symbol
X (string-append (symbol->string name) "#" (number->string n)))
X 'no-val
X (make-dlist)))))
X
X;;; accessors
X(define (var-state var)
X (vector-ref var 0))
X
X(define (var-name var)
X (vector-ref var 1))
X
X;;; call only if var is instantiated!
X(define (var-val var)
X (vector-ref var 2))
X
X;;;
X(define (var-constraints var)
X (vector-ref var 3))
X
X(define (var-add-constraint! goal var where)
X (if debug?
X (begin (display "var-add-constraint! var: ")
X (display (var-name var))
X (display " goal")
X (display (goal-id goal))
X (display ": ")
X (display (term-instantiate (goal-term goal)))
X (display " existing constraints: ")
X (display (map (lambda (g) (goal-id g))
X (dlist->list (var-constraints var))))
X (newline)))
X (var-del-constraint! goal var)
X (case where
X ((FRONT ANY)
X (dlist-insert-front! goal (var-constraints var)))
X ((REAR) (dlist-insert-back! goal (var-constraints var)))
X (else (error 'var-add-constraint! "illegal position"))))
X
X(define (var-del-constraint! goal var)
X (if debug?
X (begin
X (display "var-del-constraint! var: ")
X (display (var-name var))
X (display " goal")
X (display (goal-id goal))
X (display ": ")
X (display (term-instantiate (goal-term goal)))
X (display " old constraints: ")
X (display (map (lambda (g) (goal-id g))
X (dlist->list (var-constraints var))))
X (newline)))
X (dlist-delete! goal (var-constraints var))
X)
X
X;;; true iff var is instantiated
X(define (var-inst? var)
X (eq? (vector-ref var 0) 'inst))
X
X;;; instantiates var to TERM itself!! and then tries to wake all goals delayed
X;;; on var
X(define (var-instantiate! var term program s f)
X (let ((prev-inst? (var-inst? var))
X (prev-val (var-val var))) ;;; abuse of (var-val ...)
X (var-inst! var term)
X (var-wake-constraints
X var
X program
X s
X (if prev-inst?
X (lambda ()
X (var-inst! var prev-val)
X (f))
X (lambda ()
X (var-uninst! var)
X (f))))))
X
X;;; instantiates var to val
X(define (var-inst! var val)
X (if debug?
X (begin
X (display "var-inst! var: ")
X (display (var-name var))
X (display " val: ")
X (display (term-instantiate val))
X (newline)))
X (vector-set! var 0 'inst)
X (vector-set! var 2 val))
X
X;;; uninstantiates var
X(define (var-uninst! var)
X (if debug?
X (begin
X (display "var-uninst! var: ")
X (display (var-name var))
X (newline)))
X (vector-set! var 0 'uninst))
X
X;;; try to wake all constraints delayed on variable
X(define (var-wake-constraints var program s f)
X (define (wake-constraints goals s f)
X (if (null? goals)
X (begin
X (user-debug (list "woke" (var-name var) (term-instantiate var)))
X (s f))
X (goal-wake-try!
X (car goals)
X var
X (lambda (f) ; run continuation
X (awaken-goal!
X (car goals)
X program
X (lambda (f)
X (wake-constraints (cdr goals) s f))
X f))
X (lambda (f) ; delay continuation
X (wake-constraints (cdr goals) s f))
X f)))
X
X (user-debug (list "wake-constraints" (var-name var) (term-instantiate var)))
X (map (lambda (g) (user-debug (list (goal-id g)
X (term-instantiate (goal-term g)))))
X (dlist->list (var-constraints var)))
X (wake-constraints (dlist->list (var-constraints var)) s f))
X
X;;; true iff vars are equal. Note that checking for "eq?"litiy is
X;;; equivalent to checking for equality of name
X;;; (but probably faster)
X(define var=? eq?)
X
X;;; true iff var1 is before var2 in variable ordering
X(define (varstring (vector-ref var1 1))
X (symbol->string (vector-ref var2 1))))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;
X;;; Constant term stuff, call only with terms for which term-const? is true
X;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; return true iff const1 and const2 are equal
X(define (const=? const1 const2)
X (if (eqv? const1 const2) ; symbols, numbers, characters, boolean, ()
X #t
X (if (and (string? const1) (string? const2)) ; strings
X (string=? const1 const2)
X #f)))
X
X;;; returns a symbol which is the functor of const
X(define (const-functor const)
X (if (symbol? const)
X const
X (error 'const-functor "non-symbol argument ~s" const)))
X
X;;; returns a number which is the arity of const
X(define (const-arity const)
X (if (symbol? const)
X 0
X (error 'const-arity "non-symbol argument ~s" const)))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;
X;;; Composite term stuff -- they're just pairs
X;;; call only with terms for which term-comp? is true
X;;; Note: some of these functions assume the their arguments
X;;; are proper lists, beware!
X;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; constructor for composite terms
X(define comp-cons cons)
X
X;;; accessors for composite terms (add as many as you like!)
X(define comp-car car)
X(define comp-cdr cdr)
X(define comp-cadr cadr)
X(define comp-caddr caddr)
X(define comp-cadddr cadddr)
X(define (comp-caddddr L) (cadr (cdddr L)))
X(define (comp-cadddddr L) (caddr (cdddr L)))
X(define comp-map map)
X(define comp-ref list-ref)
X
X(define (proper-list? l)
X (if (null? l)
X '#t ;;; or #f ??##
X (and (pair? l) (null? (cdr (last-pair l))))))
X
X;;; proper comp, makes sense to take length of these
X(define comp-proper? proper-list?)
X
X
X;;; length of composite term, should only be called for proper comps
X(define comp-length length)
X
X;;; returns a symbol which is the functor of comp
X(define comp-functor comp-car)
X
X;;; returns a number which is the arity of comp
X(define (comp-arity comp)
X (if (comp-proper? comp)
X (comp-length (comp-cdr comp))
X -1))
X
X;;; treats arithmetic variables as capable of multiple instantiations;
X;;; therefore, instantiated vars are "equivalent" to ordinary vars.
X;;; returns the set of the variables in term (no duplicates).
X;;; should be rewritten to using ordered variable lists for efficiency
X(define (term-var-set term)
X (define (collect-vars term vars)
X (cond ((term-var? term)
X (if (var-inst? term)
X (if (arith-interval? (var-val term))
X (if (memq term vars) vars (cons term vars))
X ;;; arith vars are eternally
X ;;; vars!
X ;;; the DEEPEST referred VARS
X ;;; are being returned
X (collect-vars (var-val term) vars))
X ;;; dereference
X (if (memq term vars) vars (cons term vars))))
X ((term-const? term) vars)
X ((term-comp? term)
X (collect-vars (comp-cdr term)
X (collect-vars (comp-car term) vars)))))
X (collect-vars term '()))
X
END_OF_FILE
if test 13418 -ne `wc -c <'prolog1.2/terms.ss'`; then
echo shar: \"'prolog1.2/terms.ss'\" unpacked with wrong size!
fi
# end of 'prolog1.2/terms.ss'
fi
echo shar: End of archive 2 \(of 3\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 3 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
*