;; smashed into benchmark form by Matthew
(define errorf error)
; like cout << arguments << args
; where argument can be any Scheme object. If it's a procedure
; (without args) it's executed rather than printed (like newline)
(define (cout . args)
(for-each (lambda (x)
(if (procedure? x) (x) (display x)))
args))
(define cerr cout)
(define pntall (lambda v (write v) (newline)))
(define (_pretty-print v) (write v) (newline))
(define nl (string #\newline))
;; =========================================================================
;; term.scm
;; =========================================================================
; Terms, variables, substitutions, unification
;
; The appropriate prelude (e.g., chez-specific.scm) is assumed.
; Some terminology related to variables and substitutions
;
; A substitution subst is a finite map { xi -> ti ... }
; where xi is a logic variable.
; ti is a term ::= variable | Scheme-atom | (cons term term)
; We will sometimes call one `component' xi -> ti of a substitution
; a commitment, or a binding, of a variable xi to a term ti.
;
; A variable x is free in the substitution subst if x \not\in Dom(subst)
;
; Given a term t and a substitution subst, a weak reduction
; t -->w t'
; is defined as
; x -->w subst[x] if x is a var and x \in Dom(subst)
; t -->w t otherwise
;
; A strong reduction
; t -->s t'
; is defined as
; x -->s subst[x] if x is a var and x \in Dom(subst)
; (cons t1 t2) -->s (cons t1' t2')
; where t1 -->s t1' t2 -->s t2'
; t -->s t otherwise
;
; The notion of reduction can be extended to substitutions themselves:
; { xi -> ti ...} -->w { xi -> ti' } where ti -> ti'
; ditto for -->s.
; Let -->w* be a reflexive transitive closure of -->w, and
; let -->w! be a fixpoint of -->w. Ditto for -->s* and -->s!
; For acyclic substitutions, the fixpoints exist.
;
; The confluence of the reduction is guaranteed by the particular form
; of the substitution produced by the unifier (the unifier always
; deals with the weak normal forms of submitted terms).
;
; The similarity of the weak normalization with call-by-value and
; the strong normalization with the applicative-order reduction should
; be apparent.
;
; Variable x is called ultimately free if
; x -->w! x' and x' is free in the subtutution in question.
;
; Two ultimately free variables x and y belong to the same equivalence class
; if x -->w! u and y -->w! u
; The (free) variable u is the natural class representative.
; For the purpose of presentation, one may wish for a better representative.
; Given a set of equivalent variables xi -->w! u,
; a pretty representative is a member z of that set such that the
; string name of 'z' is lexicographically smaller than the string names
; of the other variables in that set.
;
; If a variable x is ultimately free in subst and x ->w! u,
; then there is a binding
; v1 -> v2 where both v1 and v2 are variables and v2 ->w! u. Furthermore,
; the set of all such v1 union {u} is the whole equivalence class of x.
; That property is guaranteed by the unifier. That property lets us
; build an inverse index to find the equivalence class of x.
;
; $Id: term.scm,v 4.50 2005/02/12 00:05:27 oleg Exp $
;----------------------------------------
; A few preliminaries
; LET*-AND: a simplified and streamlined AND-LET*.
; The latter is defined in SRFI-2
(define-syntax let*-and
(syntax-rules ()
((_ false-exp () body0 body1 ...) (begin body0 body1 ...))
((_ false-exp ((var0 exp0) (var1 exp1) ...) body0 body1 ...)
(let ((var0 exp0))
(if var0
(let*-and false-exp ((var1 exp1) ...) body0 body1 ...)
false-exp)))))
; Regression testing framework
; test-check TITLE TESTED-EXPRESSION EXPECTED-RESULT
; where TITLE is something printable (e.g., a symbol or a string)
; EXPECTED-RESULT and TESTED-EXPRESSION are both expressions.
; The expressions are evaluated and their results are cmpared
; by equal?
; If the results compare, we just print the TITLE.
; Otherwise, we print the TITLE, the TESTED-EXPRESSION, and
; the both results.
(define-syntax test-check
(syntax-rules ()
((_ title tested-expression expected-result)
(begin
(cout "Testing " title nl)
(let* ((expected expected-result)
(produced tested-expression))
(or (equal? expected produced)
(errorf 'test-check
"Failed: ~a~%Expected: ~a~%Computed: ~a~%"
'tested-expression expected produced)))
#f))))
(define symbol-append
(lambda symbs
(string->symbol
(apply string-append
(map symbol->string symbs)))))
;----------------------------------------
;; use SRFI-9 records
(define (make-logical-variable name)
(vector 'lv name))
(define (logical-variable? x)
(and (vector? x) (eq? 'lv (vector-ref x 0))))
(define (logical-variable-id x)
(vector-ref x 1))
(define logical-variable make-logical-variable)
(define var? logical-variable?)
; Introduction of a logical variable
(define-syntax let-lv
(syntax-rules ()
((_ (id ...) body)
(let ((id (logical-variable 'id)) ...) body))))
; The anonymous variable
(define __ (let-lv (_) _))
; Another way to introduce logical variables: via distinguished pairs
; (define logical-var-tag (list '*logical-var-tag*)) ; unique for eq?
; (define native-pair? pair?)
; (define logical-variable
; (lambda (id)
; (cons logical-var-tag id)))
; (define var?
; (lambda (x)
; (and (native-pair? x) (eq? (car x) logical-var-tag))))
; (define logical-variable-id
; (lambda (x)
; (if (var? x) (cdr x)
; (errorf 'logical-variable-id "Invalid Logic Variable: ~s" x))))
; (define pair?
; (lambda (x)
; (and (native-pair? x) (not (eq? (car x) logical-var-tag)))))
; Eigen-variables -- unique symbols that represent universally-quantified
; variables in a term
; For identification, we prefix the name of the eigen-variable with
; the exclamation mark. The mark makes sure the symbol stands out when
; printed.
(define counter 0)
(define (jensym s)
(set! counter (+ counter 1))
(string->symbol (string-append "!$gen$!" s (number->string counter))))
(define eigen-variable
(lambda (id)
(symbol-append '! id '_ (jensym "x"))))
(define eigen-var?
(lambda (x)
(and (symbol? x)
(let ((str (symbol->string x)))
(> (string-length str) 2)
(char=? (string-ref str 0) #\!)))))
; (eigen (id ...) body) -- evaluate body in the environment
; extended with the bindings of id ... to the corresponding
; eigen-variables
(define-syntax eigen
(syntax-rules ()
((_ (id ...) body)
(let ((id (eigen-variable 'id)) ...) body))))
(define (eigen-test)
(test-check 'eigen
(and
(eigen () #t)
(eigen (x) (eigen-var? x))
(eigen (x y)
(begin (display "eigens: ") (display (list x y))
(newline) #t)))
#t))
;;; ------------------------------------------------------
(define commitment cons)
(define commitment->term cdr)
(define commitment->var car)
(define empty-subst '())
(define empty-subst? null?)
(define extend-subst
(lambda (v t subst)
(cons (commitment v t) subst)))
; get the free vars of a term (a list without duplicates)
(define vars-of
(lambda (term)
(let loop ((term term) (fv '()))
(cond
((var? term) (if (memq term fv) fv (cons term fv)))
((pair? term) (loop (cdr term) (loop (car term) fv)))
(else fv)))))
; Check to see if a var occurs in a term
(define occurs?
(lambda (var term)
(cond
((var? term) (eq? term var))
((pair? term) (or (occurs? var (car term)) (occurs? var (cdr term))))
(else #f))))
; A ground term contains no variables
(define ground?
(lambda (t)
(cond
((var? t) #f)
((pair? t) (and (ground? (car t)) (ground? (cdr t))))
(else #t))))
; Given a term v and a subst s, return v', the weak normal form of v:
; v -->w! v' with respect to s
(define subst-in-weak
(lambda (v s)
(cond
((var? v)
(cond
((assq v s) =>
(lambda (b) (subst-in-weak (commitment->term b) s)))
(else v)))
(else v))))
; Given a term v and a subst s, return v', the strong normal form of v:
; v -->s! v' with respect to s
(define subst-in
(lambda (t subst)
(cond
((var? t)
(let ((c (assq t subst)))
(if c (subst-in (commitment->term c) subst) t)))
((pair? t)
(cons
(subst-in (car t) subst)
(subst-in (cdr t) subst)))
(else t))))
; ; Given a term v and a subst s, return v', the strong normal form of v:
; ; v -->s! v' with respect to s
; (define subst-vars-recursively
; (lambda (t subst)
; (cond
; ((var? t)
; (cond
; ((assq t subst) =>
; (lambda (c)
; (subst-vars-recursively
; (commitment->term c) (remq c subst))))
; (else t)))
; ((pair? t)
; (cons
; (subst-vars-recursively (car t) subst)
; (subst-vars-recursively (cdr t) subst)))
; (else t))))
; (define normalize-subst
; (lambda (subst)
; (map (lambda (c)
; (commitment (commitment->var c)
; (subst-vars-recursively (commitment->term c) subst)))
; subst)))
; Sooner or later, we will need to print out a term or do something
; else with it. We have to decide what to do with free variables that
; may be in that term.
; The long experience with Kanren and miniKanren and long discussions
; convinced us that it's best to `display' free variables as
; _.n where n is a number. BTW, we can't just display
; logical-variable-id, because distinct logical variables may have the same
; logical-variable-id.
; reify:: term -> reified-term
; where reified-term is identical to term if it is ground.
; Otherwise, we replace all free variables in term with _.n symbols
; The 'reverse' in (reverse (vars-of t))
; just makes the output look as it used to look before. Consider it
(define reify
(lambda (term)
(let ((fv (reverse (vars-of term))))
(if (null? fv) term ; the term is ground
(let ((renaming ; build the renaming substitution
(let loop ((counter 0) (fv fv))
(if (null? fv) empty-subst
(extend-subst
(car fv)
(string->symbol
(string-append "_." (number->string counter)))
(loop (+ 1 counter) (cdr fv)))))))
(subst-in term renaming))))))
; we will also need to print the substitution, either in whole or in part
; reify-subst:: list-of-vars subst -> reified-subst
; where list-of-vars is a list of variables to reify, or the empty
; list. In the latter case, all variables from subst are reified.
; reified-subst has a form ((var-name reified-term) ...)
; where var-name, for historical reasons, has the form id.0
; where `id' is logical-variable-id.
(define reify-subst
(lambda (vars subst)
(let* ((vars (if (null? vars) (map commitment->var subst) vars))
(terms (reify (subst-in vars subst))))
(map (lambda (x y)
(list (string->symbol
(string-append (symbol->string (logical-variable-id x))
".0"))
y))
vars terms))))
; (define compose-subst/own-survivors
; (lambda (base refining survivors)
; (let refine ((b* base))
; (if (null? b*) survivors
; (cons-if-real-commitment
; (commitment->var (car b*))
; (subst-in (commitment->term (car b*)) refining)
; (refine (cdr b*)))))))
;
; (define compose-subst
; (lambda (base refining)
; (cond
; ((null? base) refining)
; ((null? refining) base)
; (else
; (compose-subst/own-survivors base refining
; (let survive ((r* refining))
; (cond
; ((null? r*) '())
; ((assq (commitment->var (car r*)) base) (survive (cdr r*)))
; (else (cons (car r*) (survive (cdr r*)))))))))))
; Replace a logical variable with the corresponding eigen-variable
; Note: to be really right, universalize should be a scoping predicate,
; something like exists:
; (universalize (term) goal)
; to prove 'goal' in the env where term is universalized.
; In that case, the introduced eigen-variables do not escape.
; Also, perhaps universalize should take a subst and first
; do (subst-in term subst) and then universalize the remaining
; logical variables -- which by that time would surely be free.
(define universalize
(lambda (term)
(let ((fv (vars-of term)))
(let ((subst
(map
(lambda (v)
(commitment v (eigen-variable (logical-variable-id v))))
fv)))
(subst-in term subst)))))
; copy-term TERM -> TERM
; return a TERM that is identical to the input term modulo the replacement
; of variables in TERM with fresh logical variables.
; If a logical variable occurs several times in TERM, the result
; will have the same number of occurrences of the replacement fresh
; variable.
; This is a sort-of dual to universalize, to be used on the other side
; of the implication. It replaces the existential quantification
; (implicit in free logical variables of a term) with the universal
; quantification.
(define copy-term
(lambda (t)
(let* ((fv (vars-of t))
(subst
(map (lambda (old-var)
(commitment old-var
(logical-variable (logical-variable-id old-var))))
fv)))
(subst-in t subst))))
; Similar to universalize: makes nicer symbols for variables that look
; nicer when printed. The 'reverse' in (reverse (vars-of t))
; just makes the output look as it used to look before. Consider it
; a historical accident.
; (define concretize
; (lambda (t)
; (subst-in t
; (let loop ((fv (reverse (vars-of t))) (env '()))
; (cond
; ((null? fv) empty-subst)
; (else (let ((id (logical-variable-id (car fv))))
; (let ((num (let*-and 0 ((pr (assq id env))) (+ (cdr pr) 1))))
; (cons (commitment (car fv) (artificial-id id num))
; (loop (cdr fv) (cons (cons id num) env)))))))))))
; (define artificial-id
; (lambda (t-id num)
; (string->symbol
; (string-append
; (symbol->string t-id) "." (number->string num)))))
;-------------------------------------------------------
;;;; This is Oleg's unifier
; Either t or u may be:
; __
; free-var
; bound-var
; pair
; other-value
; So, we have in general 25 possibilities to consider.
; actually, a pair or components of a pair can be variable-free
; or not. In the latter case, we have got to traverse them.
; Also, if a term to unify has come from subst, it has special properties,
; which we can exploit. See below.
;
; "Measurements of the dynamic behavior of unification on four real
; programs show that one or both of the arguments are variables about
; 85% of the time [63]. A subroutine call is made only if both arguments
; are nonvariables." (Peter Van Roy, The Wonder Years ...)
;
; Just like in the union-find unification algorithm, we produce
; substitutions in the "triangular form" (see Baader, Snyder, Unification
; Theory). Circularity is detected only at the end (when we do subst-in).
(define unify
(lambda (t u subst)
(cond
((eq? t u) subst) ; quick tests first
((eq? t __) subst)
((eq? u __) subst)
((var? t)
(let*-and (unify-free/any t u subst) ((ct (assq t subst)))
(if (var? u) ; ct is a bound var, u is a var
(let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
(unify-bound/bound ct cu subst))
(unify-bound/nonvar ct u subst))))
((var? u) ; t is not a variable...
(let*-and
(cond
((pair? t) (unify-free/list u t subst))
; t is not a var and is not a pair: it's atomic
(else (extend-subst u t subst)))
((cu (assq u subst)))
(unify-bound/nonvar cu t subst)))
((and (pair? t) (pair? u))
(let*-and #f ((subst (unify (car t) (car u) subst)))
(unify (cdr t) (cdr u) subst)))
(else (and (equal? t u) subst)))))
; ct is a commitment to a bound variable, u is a atomic or a composite
; value -- but not a variable
(define unify-bound/nonvar
(lambda (ct u subst)
(let ((t (commitment->term ct)))
(cond ; search for the end of ct -> chain
((eq? t u) subst)
((var? t)
(let*-and
(cond
((pair? u) (unify-free/list t u subst))
; u is not a var and is not a pair: it's atomic
(else (extend-subst t u subst)))
((ct (assq t subst)))
(unify-bound/nonvar ct u subst)))
; t is some simple or composite value. So is u.
((and (pair? t) (pair? u))
(let*-and #f ((subst (unify-internal/any (car t) (car u) subst)))
(unify-internal/any (cdr t) (cdr u) subst)))
(else (and (equal? t u) subst))))))
; Just like unify. However, the first term, t, comes from
; an internalized term. We know it can't be __ and can't contain __
(define unify-internal/any
(lambda (t u subst)
(cond
((eq? t u) subst) ; quick tests first
((eq? u __) subst)
((var? t)
(let*-and (unify-free/any t u subst) ((ct (assq t subst)))
(if (var? u) ; ct is a bound var, u is a var
(let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
(unify-bound/bound ct cu subst))
(unify-bound/nonvar ct u subst))))
((var? u) ; t is not a variable...
(let*-and ; It's a part of an internal term
(extend-subst u t subst) ; no further checks needed
((cu (assq u subst)))
(unify-internals (commitment->term cu) t subst)))
((and (pair? t) (pair? u))
(let*-and #f ((subst (unify-internal/any (car t) (car u) subst)))
(unify-internal/any (cdr t) (cdr u) subst)))
(else (and (equal? t u) subst)))))
; Unify two already bound variables represented by their commitments
; ct and cu.
; We single out this case because in the future we may wish
; to unify the classes of these variables, by making a redundant
; binding of (commitment->var ct) to (commitment->term cu) or
; the other way around.
; Aside from the above, this function can take advantage of the following
; facts about (commitment->term cx) (where cx is an existing commitment):
; - it is never __
; - it never contains __
; Most importantly, if, for example, (commitment->term ct) is a free variable,
; we enter its binding to (commitment->term cu) with fewer checks.
; in particular, we never need to call unify-free/list nor
; unify-free/any as we do need to rebuild any terms.
(define unify-internals
(lambda (t u subst)
(cond
((eq? t u) subst) ; quick tests first
((var? t)
(let*-and (cond ; t is a free variable
((var? u)
(let*-and (extend-subst t u subst) ((cu (assq u subst)))
(unify-free/bound t cu subst)))
(else ; t is free, u is not a var: done
(extend-subst t u subst)))
((ct (assq t subst)))
(cond ; t is a bound variable
((var? u)
(let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
(unify-bound/bound ct cu subst)))
(else ; unify bound and a value
(unify-internals (commitment->term ct) u subst)))))
((var? u) ; t is not a variable...
(let*-and (extend-subst u t subst) ((cu (assq u subst)))
(unify-internals (commitment->term cu) t subst)))
((and (pair? t) (pair? u))
(let*-and #f ((subst (unify-internals (car t) (car u) subst)))
(unify-internals (cdr t) (cdr u) subst)))
(else (and (equal? t u) subst)))))
(define unify-bound/bound
(lambda (ct cu subst)
(unify-internals (commitment->term ct) (commitment->term cu) subst)))
; t-var is a free variable, u can be anything
; This is analogous to get_variable instruction of Warren Abstract Machine
; (WAM).
; This function is not recursive and always succeeds,
; because unify-free/bound and unify-free/list always succeed.
(define unify-free/any
(lambda (t-var u subst)
(cond
((eq? u __) subst)
((var? u)
(let*-and (extend-subst t-var u subst) ((cu (assq u subst)))
(unify-free/bound t-var cu subst)))
((pair? u) (unify-free/list t-var u subst))
(else ; u is not a var and is not a pair: it's atomic
(extend-subst t-var u subst)))))
; On entrance: t-var is free.
; we are trying to unify it with a bound variable (commitment->var cu)
; Chase the binding chain, see below for comments
; This also works somewhat like union-find...
; This function always succeeds. The resulting substitution is either
; identical to the input one, or differs only in the binding to t-var.
;
; Unlike the previous version of the unifier,
; The following code does not introduce the temp variables *a and *d
; It makes substitutions more complex. Therefore, pruning them
; will take a while, and will break up the sharing. Therefore, we
; don't do any pruning.
(define unify-free/bound
(lambda (t-var cu s)
(let loop ((cm cu))
(let ((u-term (commitment->term cm)))
(cond
((eq? u-term t-var) s)
((var? u-term)
(cond
((assq u-term s) => loop)
(else (extend-subst t-var u-term s)))) ; u-term is free here
(else (extend-subst t-var u-term s)))))))
; ((and (pattern-var? tree2) (assq tree2 env)) => ; tree2 is a bound var
; ; binding a free variable to a bound. Search for a substantial binding
; ; or a loop. If we find a loop tree1->tree2->...->tree1
; ; then we do not enter the binding to tree1, because tree1 is not
; ; actually constrained.
; (lambda (tree2-binding)
; (let loop ((binding tree2-binding))
; (cond
; ((eq? tree1 (cdr binding)) env) ; loop: no binding needed
; ((and (pattern-var? (cdr binding)) (assq (cdr binding) env))
; => loop)
; (else (cons (cons tree1 (cdr binding)) env))))))
; t-var is a free variable, u-value is a proper or improper
; list, which may be either fully or partially grounded (or not at all).
; We scan the u-value for __, and if, found, replace them with fresh
; variables. We then bind t-var to the term.
; This function is not recursive and always succeeds.
;
; We assume that more often than not u-value does not contain __.
; Therefore, to avoid the wasteful rebuilding of u-value, we
; first scan it for the occurrence of __. If the scan returns negative,
; we can use u-value as it is.
; Rebuild lst replacing all anonymous variables with some
; fresh logical variables
; If lst contains no anonymous variables, return #f
; Note that lst itself may be #f -- and yet no contradiction arises.
(define ufl-rebuild-without-anons
(lambda (lst)
(cond
((eq? lst __) (logical-variable '*anon))
((not (pair? lst)) #f)
((null? (cdr lst))
(let ((new-car (ufl-rebuild-without-anons (car lst))))
(and new-car (cons new-car '()))))
(else
(let ((new-car (ufl-rebuild-without-anons (car lst)))
(new-cdr (ufl-rebuild-without-anons (cdr lst))))
(if new-car
(cons new-car (or new-cdr (cdr lst)))
(and new-cdr (cons (car lst) new-cdr))))))))
(define unify-free/list
(lambda (t-var u-value subst)
(extend-subst t-var
(or (ufl-rebuild-without-anons u-value) u-value)
subst)))
;------------------------------------------------------------------------
; Tests
(define (term-tests)
; (cout nl "Compositions of substitutions" nl)
; (let-lv (x y)
; (test-check 'test-compose-subst-0
; (append (unit-subst x y) (unit-subst y 52))
; `(,(commitment x y) ,(commitment y 52))))
; (test-check 'test-compose-subst-1
; (let-lv (x y)
; (equal?
; (compose-subst (unit-subst x y) (unit-subst y 52))
; `(,(commitment x 52) ,(commitment y 52))))
; #t)
; (test-check 'test-compose-subst-2
; (let-lv (w x y)
; (equal?
; (let ((s (compose-subst (unit-subst y w) (unit-subst w 52))))
; (compose-subst (unit-subst x y) s))
; `(,(commitment x 52) ,(commitment y 52) ,(commitment w 52))))
; #t)
; (test-check 'test-compose-subst-3
; (let-lv (w x y)
; (equal?
; (let ((s (compose-subst (unit-subst w 52) (unit-subst y w))))
; (compose-subst (unit-subst x y) s))
; `(,(commitment x w) ,(commitment w 52) ,(commitment y w))))
; #t)
; (test-check 'test-compose-subst-4
; (let-lv (x y z)
; (equal?
; (let ((s (compose-subst (unit-subst y z) (unit-subst x y)))
; (r (compose-subst
; (compose-subst (unit-subst x 'a) (unit-subst y 'b))
; (unit-subst z y))))
; (compose-subst s r))
; `(,(commitment x 'b) ,(commitment z y))))
; #t)
; (test-check 'test-compose-subst-5
; (concretize-subst
; (compose-subst
; (let-lv (x) (unit-subst x 3))
; (let-lv (x) (unit-subst x 4))))
; '((x.0 . 3) (x.1 . 4)))
; (test-check 'test-compose-subst-5
; (let-lv (x y z)
; (equal?
; (let ((term `(p ,x ,y (g ,z))))
; (let ((s (compose-subst (unit-subst y z) (unit-subst x `(f ,y))))
; (r (compose-subst (unit-subst x 'a) (unit-subst z 'b))))
; (let ((term1 (subst-in term s)))
; (write term1)
; (newline)
; (let ((term2 (subst-in term1 r)))
; (write term2)
; (newline)
; (let ((sr (compose-subst s r)))
; (write sr)
; (newline)
; (subst-in term sr))))))
; (begin
; `(p (f ,y) ,z (g ,z))
; `(p (f ,y) b (g b))
; `(,(commitment y 'b) ,(commitment x `(f ,y)) ,(commitment z 'b))
; `(p (f ,y) b (g b)))))
; #t)
(test-check 'test-unify/pairs-oleg1
(let-lv (x y)
(unify `(,x ,4) `(3 ,x) empty-subst))
#f)
(test-check 'test-unify/pairs-oleg2
(let-lv (x y)
(unify `(,x ,x) '(3 4) empty-subst))
#f)
(let-lv (x y)
(test-check 'test-unify/pairs-oleg3
(reify-subst '() (unify `(,x ,y) '(3 4) empty-subst))
'((y.0 4) (x.0 3))))
(let-lv (x y)
(test-check 'test-unify/pairs-oleg4
(reify-subst '() (unify `(,x 4) `(3 ,y) empty-subst))
`((y.0 4) (x.0 3))))
(let-lv (x y w z)
(test-check 'test-unify/pairs-oleg5
(reify-subst (list w y x)
(unify `(,x 4 3 ,w) `(3 ,y ,x ,z) empty-subst))
'((w.0 _.0) (y.0 4) (x.0 3))))
(let-lv (x y w z)
(test-check 'test-unify/pairs-oleg6
(reify-subst (list y x)
(unify `(,x 4) `(,y ,y) empty-subst))
'((y.0 4) (x.0 4))))
(test-check 'test-unify/pairs-oleg7
(let-lv (x y)
(unify `(,x 4 3) `(,y ,y ,x) empty-subst))
#f)
(let-lv (x y w z u)
(test-check 'test-unify/pairs-oleg8
(reify-subst (list u z y x)
(unify
`(,w (,x (,y ,z) 8))
`(,w (,u (abc ,u) ,z))
empty-subst))
'((u.0 8) (z.0 8) (y.0 abc) (x.0 8))))
(let-lv (x y w z u)
(test-check 'test-unify/pairs-oleg8
(reify-subst (list y x)
(unify `(p (f a) (g ,x)) `(p ,x ,y) empty-subst))
'((y.0 (g (f a))) (x.0 (f a)))))
(let-lv (x y w z u)
(test-check 'test-unify/pairs-oleg10
(reify-subst (list x y)
(unify `(p (g ,x) (f a)) `(p ,y ,x) empty-subst))
'((x.0 (f a)) (y.0 (g (f a))))))
(let-lv (x y w z u)
(test-check 'test-unify/pairs-oleg11
(reify-subst (list y x z)
(unify
`(p a ,x (h (g ,z)))
`(p ,z (h ,y) (h ,y))
empty-subst))
'((y.0 (g a)) (x.0 (h (g a))) (z.0 a))))
; The following loops...
; (concretize-subst
; (let-lv (x y)
; (let* ((s (unify x `(1 ,x) '()))
; (s (unify y `(1 ,y) s))
; (s (unify x y s))) s)))
; (let-lv (x y w z u)
; (test-check 'test-unify/pairs-oleg12
; (concretize-subst ;;; was #f
; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst)))
; (let ((var (map commitment->var s)))
; (map commitment
; var
; (subst-vars-recursively var s)))))
; `(;,(commitment '*d.0 '())
; ,(commitment '*a.0 '(f *a.0))
; ;,(commitment '*d.1 '((f . *d.1)))
; ,(commitment '*d.0 '((f . *d.0)))
; ;,(commitment '*a.1 'f)
; ;,(commitment 'y.0 '(f (f . *d.1)))
; ,(commitment 'y.0 '(f (f . *d.0)))
; ,(commitment 'x.0 '(f (f . *d.0))))))
; (let-lv (x y w z u)
; (test-check 'test-unify/pairs-oleg13
; (concretize-subst ;;; was #f
; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst)))
; (let ((var (map commitment->var s)))
; (map commitment
; var
; (subst-vars-recursively var s)))))
; `(;,(commitment '*d.0 '())
; ,(commitment '*a.0 '(f *a.0))
; ;,(commitment '*d.1 '((f . *d.1)))
; ,(commitment '*d.0 '((f . *d.0)))
; ;,(commitment '*a.1 'f)
; ;,(commitment 'y.0 '(f (f . *d.1)))
; ,(commitment 'y.0 '(f (f . *d.0)))
; ,(commitment 'x.0 '(f (f . *d.0))))))
;Baader & Snyder
(test-check 'test-pathological
(list
(let-lv (x0 x1 y0 y1)
(begin
(_pretty-print
(reify-subst '()
(unify
`(h ,x1 (f ,y0 ,y0) ,y1)
`(h (f ,x0 ,x0) ,y1 ,x1)
empty-subst)))
(newline) #t))
(let-lv (x0 x1 x2 y0 y1 y2)
(begin
(_pretty-print
(reify-subst '()
(unify
`(h ,x1 ,x2 (f ,y0 ,y0) (f ,y1 ,y1) ,y2)
`(h (f ,x0 ,x0) (f ,x1 ,x1) ,y1 ,y2 ,x2)
empty-subst)))
(newline) #t))
(let-lv (x0 x1 x2 x3 x4 y0 y1 y2 y3 y4)
(begin
(_pretty-print
(reify-subst '()
(unify
`(h ,x1 ,x2 ,x3 ,x4 (f ,y0 ,y0) (f ,y1 ,y1) (f ,y2 ,y2) (f ,y3 ,y3) ,y4)
`(h (f ,x0 ,x0) (f ,x1 ,x1) (f ,x2 ,x2) (f ,x3 ,x3) ,y1 ,y2 ,y3 ,y4 ,x4)
empty-subst))) #t)))
(list #t #t #t))
(test-check 'length-of-subst
(let-lv (x y z)
(let* ((subst (unify x `(1 2 3 4 5 ,z) '()))
(subst (unify x `(1 . ,y) subst))
(subst (unify z 42 subst)))
(reify-subst '() subst)))
'((z.0 42) (y.0 (2 3 4 5 42)) (x.0 (1 2 3 4 5 42))))
;'((z.0 . 42) (y.0 2 3 4 5 a*.0) (a*.0 . z.0) (x.0 1 2 3 4 5 a*.0)))
10
)
;; =========================================================================
;; kanren.scm
;; =========================================================================
; The body of KANREN
;
; The appropriate prelude (e.g., chez-specific.scm) is assumed.
;
; $Id: kanren.ss,v 4.50 2005/02/12 00:05:05 oleg Exp $
(define-syntax lambda@
(syntax-rules ()
((_ (formal) body0 body1 ...) (lambda (formal) body0 body1 ...))
((_ (formal0 formal1 formal2 ...) body0 body1 ...)
(lambda (formal0)
(lambda@ (formal1 formal2 ...) body0 body1 ...)))))
(define-syntax at@
(syntax-rules ()
((_ rator rand) (rator rand))
((_ rator rand0 rand1 rand2 ...) (at@ (rator rand0) rand1 rand2 ...))))
;(test-check 'test-@-lambda@
; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3)
; 6)
;'(test-check 'test-@-lambda@
; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3)
; 42)
(define Y
(lambda (f)
((lambda (u) (u (lambda (x) (lambda (n) ((f (u x)) n)))))
(lambda (x) (x x)))))
; An attempt to do a limited beta-substitution at macro-expand time
; (define-syntax @
; (syntax-rules (syntax-rules)
; ((_ (syntax-rules sdata ...) rand0 ...)
; (let-syntax
; ((tempname (syntax-rules sdata ...)))
; (tempname rand0 ...)))
; ((_ rator rand0 rand1 ...)
; (@-simple rator rand0 rand1 ...))))
; Fk = () -> Ans
; Ans = Nil + [Subst,Fk] or just a conceptual stream of substitutions
; Sk = Subst -> Fk -> Ans
; Goal = Subst -> SGoal
; SGoal = Sk -> Fk -> Ans
; initial-sk : Sk
; initial-fk : Fk
(define initial-sk (lambda@ (subst fk)
(cons subst fk)))
(define initial-fk (lambda () '()))
; Trivial goals
(define succeed (lambda@ (s k) (at@ k s))) ; eta-reduced
(define fail (lambda@ (s k f) (f)))
(define sfail (lambda@ (k f) (f))) ; Failed SGoal
;------------------------------------------------------------------------
; Making logical variables "scoped" and garbage-collected
; -----> it was used, but no longer
; -----> The code is still here, as we plan to come back to this...
;
; A framework to remove introduced variables when they leave their scope.
; To make removing variables easier, we consider the list of subst as a
; "stack". Before we add a new variable, we retain a pointer to the
; stack. Then, when we are about to remove the added variables after their
; scope is ended, we stop at the shared retained substitution, and we know
; that anything below the retained substitution can't possibly contain the
; reference to the variables we're about to remove.
;
; Pruning of substitutions is analogous to environment pruning (aka tail-call
; optimization) in WAM on _forward_ execution.
; LV-ELIM IN-SUBST SUBST ID ....
; remove the bindings of ID ... from SUBST (by composing with the
; rest of subst). IN-SUBST is the mark.
; If we locate IN-SUBST in SUBST, we know that everything below the
; mark can't possibly contain ID ...
; lv-elim-1 VAR IN-SUBST SUBST
; VAR is a logical variable, SUBST is a substitution, and IN-SUBST
; is a tail of SUBST (which may be '()).
; VAR is supposed to have non-complex binding in SUBST
; (see Definition 3 in the document "Properties of Substitutions").
; If VAR is bound in SUBST, the corresponding commitment
; is supposed to occur in SUBST up to but not including IN-SUBST.
; According to Proposition 10, if VAR freely occurs in SUBST, all such
; terms are VAR itself.
; The result is a substitution with the commitment to VAR removed
; and the other commitments composed with the removed commitment.
; The order of commitments is preserved.
(define lv-elim-1
(lambda (var in-subst subst)
(if (eq? subst in-subst) subst
; if VAR is not bound, there is nothing to prune
(let*-and subst ((var-binding (assq var subst)))
(let ((tv (commitment->term var-binding)))
(let loop ((current subst))
(cond
((null? current) current)
((eq? current in-subst) current)
((eq? (car current) var-binding)
(loop (cdr current)))
((eq? (commitment->term (car current)) var)
(cons (commitment (commitment->var (car current)) tv)
(loop (cdr current))))
(else (cons (car current) (loop (cdr current)))))))))))
; The same but for multiple vars
; To prune multiple-vars, we can prune them one-by-one
; We can attempt to be more efficient and prune them in parallel.
; But we encounter a problem:
; If we have a substitution
; ((x . y) (y . 1) (a . x))
; Then pruning 'x' first and 'y' second will give us ((a . 1))
; Pruning 'y' first and 'x' second will give us ((a . 1))
; But naively attempting to prune 'x' and 'y' in parallel
; disregarding dependency between them results in ((a . y))
; which is not correct.
; We should only be concerned about a direct dependency:
; ((x . y) (y . (1 t)) (t . x) (a . x))
; pruning x and y in sequence or in parallel gives the same result:
; ((t . (1 t)) (a . (1 t)))
; We should also note that the unifier will never return a substitution
; that contains a cycle ((x1 . x2) (x2 . x3) ... (xn . x1))
(define lv-elim
(lambda (vars in-subst subst)
(if (eq? subst in-subst)
subst
(let ((var-bindings ; the bindings of truly bound vars
(let loop ((vars vars))
(if (null? vars) vars
(let ((binding (assq (car vars) subst)))
(if binding
(cons binding (loop (cdr vars)))
(loop (cdr vars))))))))
(cond
((null? var-bindings) subst) ; none of vars are bound
((null? (cdr var-bindings))
; only one variable to prune, use the faster version
(lv-elim-1 (commitment->var (car var-bindings))
in-subst subst))
((let test ((vb var-bindings)) ; check multiple dependency
(and (pair? vb)
(or (let ((term (commitment->term (car vb))))
(and (var? term) (assq term var-bindings)))
(test (cdr vb)))))
; do pruning sequentially
(let loop ((var-bindings var-bindings) (subst subst))
(if (null? var-bindings) subst
(loop (cdr var-bindings)
(lv-elim-1 (commitment->var (car var-bindings))
in-subst subst)))))
(else ; do it in parallel
(let loop ((current subst))
(cond
((null? current) current)
((eq? current in-subst) current)
((memq (car current) var-bindings)
(loop (cdr current)))
((assq (commitment->term (car current)) var-bindings) =>
(lambda (ct)
(cons (commitment (commitment->var (car current))
(commitment->term ct))
(loop (cdr current)))))
(else (cons (car current) (loop (cdr current))))))))))))
; when the unifier is moved up, move lv-elim test from below up...
; That was the code for the unifier that introduced temp variables
; (define-syntax exists
; (syntax-rules ()
; ((_ () gl) gl)
; ((_ (ex-id) gl)
; (let-lv (ex-id)
; (lambda@ (sk fk in-subst)
; (at@ gl
; (lambda@ (fk out-subst)
; (at@ sk fk (lv-elim-1 ex-id in-subst out-subst)))
; fk in-subst))))
; ((_ (ex-id ...) gl)
; (let-lv (ex-id ...)
; (lambda@ (sk fk in-subst)
; (at@ gl
; (lambda@ (fk out-subst)
; (at@ sk fk (lv-elim (list ex-id ...) in-subst out-subst)))
; fk in-subst))))))
; For the unifier that doesn't introduce temp variables,
; exists is essentially let-lv
; At present, we don't do any GC.
; Here's the reason we don't do any pruning now:
; Let's unify the variable x with a term `(1 2 3 4 5 ,z). The result
; will be the binding x -> `(1 2 3 4 5 ,z). Let's unify `(1 . ,y) with
; x. The result will be a binding y -> `(2 3 4 5 ,z). Note that the
; bindings of x and y share a tail. Let us now unify z with 42. The
; result will be a binding z->42. So far, so good. Suppose however that
; z now "goes out of scope" (the exists form that introduced z
; finishes). We now have to traverse all the terms in the substitution
; and replace z with its binding. The result will be a substitution
; x -> (1 2 3 4 5 42)
; y -> (2 3 4 5 42)
; Now, the bindings of x and y do not share anything at all! The pruning
; has broke sharing. If we want to unify x and `(1 . ,y) again, we have
; to fully traverse the corresponding terms again.
; So, to prune variables and preserve sharing, we have to topologically sort
; the bindings first!
(define-syntax _exists
(syntax-rules ()
((_ () gl) gl)
((_ (ex-id ...) gl)
(let-lv (ex-id ...) gl))
))
;-----------------------------------------------------------
; Sequencing of relations
; Goal is a multi-valued function (which takes
; subst, sk, fk, and exits to either sk or fk).
; A relation is a parameterized goal.
;
; All sequencing operations are defined on goals.
; They can be "lifted" to relations (see below).
;
; TRACE-GOAL-RAW TITLE GL -> GL
; Traces all invocations and re-invocations of a goal
; printing subst before and after, in their raw form
(define trace-goal-raw
(lambda (title gl)
(let ((print-it
(lambda (event subst)
(display title) (display " ")
(display event) (_pretty-print subst) (newline))))
(lambda@ (subst sk fk)
(print-it "CALL:" subst)
(at@ gl subst
(lambda@ (subst fk)
(print-it "RETURN:" subst)
(at@ sk subst
(lambda ()
(display title) (display " REDO") (newline)
(fk))
))
(lambda ()
(display title) (display " FAIL") (newline)
(fk))
)))))
; Conjunctions
; All conjunctions below satisfy properties
; ans is an answer of (a-conjunction gl1 gl2 ...) ==>
; forall i. ans is an answer of gl_i
; (a-conjunction) ==> success
; (all gl1 gl2 ...)
; A regular Prolog conjunction. Non-deterministic (i.e., can have 0, 1,
; or more answers).
; Properties:
; (all gl) ==> gl
; (all gl1 ... gl_{n-1} gln) is a "join" of answerlists of
; (all gl1 ... gl_{n-1}) and gln
(define-syntax all
(syntax-rules ()
((_) succeed)
((_ gl) gl)
((_ gl0 gl1 ...)
(lambda@ (subst sk) (splice-in-gls/all subst sk gl0 gl1 ...)))))
(define-syntax splice-in-gls/all
(syntax-rules ()
((_ subst sk gl) (at@ gl subst sk))
((_ subst sk gl0 gl1 ...)
(at@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...))))))
; (promise-one-answer gl)
; Operationally, it is the identity.
; It is an optimization directive: if the user knows that an goal
; can produce at most one answer, he can tell the system about it.
; The behavior is undefined if the user has lied.
(define-syntax promise-one-answer
(syntax-rules ()
((_ gl) gl)))
; (all! gl1 gl2 ...)
; A committed choice nondeterminism conjunction
; From the Mercury documentation:
; In addition to the determinism annotations described earlier, there
; are "committed choice" versions of multi and nondet, called cc_multi
; and cc_nondet. These can be used instead of multi or nondet if all
; calls to that mode of the predicate (or function) occur in a context
; in which only one solution is needed.
;
; (all! gl) evaluates gl in a single-choice context. That is,
; if gl fails, (all! gl) fails. If gl has at least one answer,
; this answer is returned.
; (all! gl) has at most one answer regardless of the answers of gl.
; ans is an answer of (all! gl) ==> ans is an answer of gl
; The converse is not true.
; Corollary: (all! gl) =/=> gl
; Corollary: gl is (semi-) deterministic: (all! gl) ==> gl
; (all! (promise-one-answer gl)) ==> gl
;
; By definition, (all! gl1 gl2 ...) ===> (all! (all gl1 gl2 ...))
(define-syntax all!
(syntax-rules (promise-one-answer)
((_) (promise-one-answer (all)))
((_ (promise-one-answer gl)) (promise-one-answer gl)) ; keep the mark
((_ gl0 gl1 ...)
(promise-one-answer
(lambda@ (subst sk fk)
(at@
(splice-in-gls/all subst
(lambda@ (subst fk-ign) (at@ sk subst fk)) gl0 gl1 ...)
fk))))))
; (all!! gl1 gl2 ...)
; Even more committed choice nondeterministic conjunction
; It evaluates all elements of the conjunction in a single answer context
; (all!! gl) ==> (all! gl) =/=> gl
; (all!! gl1 gl2 ...) ==> (all (all! gl1) (all! gl2) ...)
; ==> (all! (all! gl1) (all! gl2) ...)
; (all!! gl1 ... gln (promise-one-answer gl)) ==>
; (all (all!! gl1 ... gln) gl)
(define-syntax all!!
(syntax-rules ()
((_) (all!))
((_ gl) (all! gl))
((_ gl0 gl1 ...)
(promise-one-answer
(lambda@ (subst sk fk)
(splice-in-gls/all!! subst sk fk gl0 gl1 ...))))))
(define-syntax splice-in-gls/all!!
(syntax-rules (promise-one-answer)
((_ subst sk fk)
(at@ sk subst fk))
((_ subst sk fk (promise-one-answer gl))
(at@ gl subst sk fk))
((_ subst sk fk gl0 gl1 ...)
(at@ gl0 subst
(lambda@ (subst fk-ign) (splice-in-gls/all!! subst sk fk gl1 ...))
fk))))
; (if-only COND THEN)
; (if-only COND THEN ELSE)
; Here COND, THEN, ELSE are goals.
; If COND succeeds at least once, the result is equivalent to
; (all (all! COND) TNEN)
; If COND fails, the result is the same as ELSE.
; If ELSE is omitted, it is assumed fail. That is, (if-only COND THEN)
; fails if the condition fails. "This unusual semantics
; is part of the ISO and all de-facto Prolog standards."
; Thus, declaratively,
; (if-only COND THEN ELSE) ==> (any (all (all! COND) THEN)
; (all (fails COND) ELSE))
; Operationally, we try to generate a good code.
; "The majority of predicates written by human programmers are
; intended to give at most one solution, i.e., they are
; deterministic. These predicates are in effect case statements
; [sic!], yet they are too often compiled in an inefficient manner
; using the full generality of backtracking (which implies saving the
; machine state and repeated failure and state restoration)." (Peter
; Van Roy, 1983-1993: The Wonder Years of Sequential Prolog
; Implementation).
(define-syntax if-only
(syntax-rules ()
((_ condition then)
(lambda@ (subst sk fk)
(at@ condition subst
; sk from cond
(lambda@ (subst fk-ign) (at@ then subst sk fk))
; failure from cond
fk)))
((_ condition then else)
(lambda@ (subst sk fk)
(at@ condition subst
(lambda@ (subst fk-ign) (at@ then subst sk fk))
(lambda () (at@ else subst sk fk))
)))))
; (if-all! (COND1 ... CONDN) THEN)
; (if-all! (COND1 ... CONDN) THEN ELSE)
;
; (if-all! (COND1 ... CONDN) THEN ELSE) ==>
; (if-only (all! COND1 ... CONDN) THEN ELSE)
; (if-all! (COND1) THEN ELSE) ==>
; (if-only COND1 THEN ELSE)
; Eventually, it might be a recognized special case in if-only.
; (define-syntax if-all!
; (syntax-rules ()
; ((_ (condition) then) (if-only condition then))
; ((_ (condition) then else) (if-only condition then else))
; ((_ (condition1 condition2 ...) then)
; (lambda@ (sk fk)
; (@ (splice-in-gls/all
; (lambda@ (fk-ign)
; (@ then sk fk))
; condition1 condition2 ...)
; fk)))
; ((_ (condition1 condition2 ...) then else)
; (lambda@ (sk fk subst)
; (@ (splice-in-gls/all
; (lambda@ (fk-ign)
; (@ then sk fk)) condition1 condition2 ...)
; (lambda ()
; (@ else sk fk subst))
; subst)))))
; Disjunction of goals
; All disjunctions below satisfy properties
; ans is an answer of (a-disjunction gl1 gl2 ...) ==>
; exists i. ans is an answer of gl_i
; (a-disjunction) ==> fail
; Any disjunction. A regular Prolog disjunction (introduces
; a choicepoints, in Prolog terms)
; Note that 'any' is not a union! In particular, it is not
; idempotent.
; (any) ===> fail
; (any gl) ===> gl
; (any gl1 ... gln) ==> _concatenation_ of their answerlists
(define-syntax any
(syntax-rules ()
((_) fail)
((_ gl) gl)
((_ gl ...)
(lambda@ (subst sk fk)
(splice-in-gls/any subst sk fk gl ...)))))
(define-syntax splice-in-gls/any
(syntax-rules ()
((_ subst sk fk gl1) (at@ gl1 subst sk fk))
((_ subst sk fk gl1 gl2 ...)
(at@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...))))))
; Negation
; (fails gl) succeeds iff gl has no solutions
; (fails gl) is a semi-deterministic predicate: it can have at most
; one solution
; (succeeds gl) succeeds iff gl has a solution
;
; (fails (fails gl)) <===> (succeeds gl)
; but (succeeds gl) =/=> gl
; Cf. (equal? (not (not x)) x) is #f in Scheme in general.
; Note, negation is only sound if some rules (Grounding Rules) are satisfied.
(define fails
(lambda (gl)
(lambda@ (subst sk fk)
(at@ gl subst
(lambda@ (subst current-fk) (fk))
(lambda () (at@ sk subst fk))
))))
; Again, G-Rule must hold for this predicate to be logically sound
(define succeeds
(lambda (gl)
(lambda@ (subst sk fk)
(at@ gl subst (lambda@ (subst-ign fk-ign) (at@ sk subst fk))
fk))))
; partially-eval-sgl: Partially evaluate a semi-goal. A
; semi-goal is an expression that, when applied to two
; arguments, sk and fk, can produce zero, one, or more answers. Any
; goal can be turned into a semi-goal if partially applied
; to subst. The following higher-order semi-goal takes a
; goal and yields the first answer and another, residual
; goal. The latter, when evaluated, will give the rest of the
; answers of the original semi-goal. partially-eval-sgl could
; be implemented with streams (lazy lists). The following is a purely
; combinational implementation.
;
; (at@ partially-eval-sgl sgl a b) =>
; (b) if sgl has no answers
; (a s residial-sgl) if sgl has a answer. That answer is delivered
; in s.
; The residial semi-goal can be passed to partially-eval-sgl
; again, and so on, to obtain all answers from a goal one by one.
; The following definition is eta-reduced.
(define (partially-eval-sgl sgl)
(at@ sgl
(lambda@ (subst fk a b)
(at@ a subst
(lambda@ (sk1 fk1)
(at@
(fk)
; new a
(lambda@ (sub11 x) (at@ sk1 sub11 (lambda () (at@ x sk1 fk1))))
; new b
fk1))))
(lambda () (lambda@ (a b) (b)))))
; An interleaving disjunction.
; Declaratively, any-interleave is the same as any.
; Operationally, any-interleave schedules each component goal
; in round-robin. So, any-interleave is fair: it won't let a goal
; that produces infinitely many answers (such as repeat) starve the others.
; any-interleave introduces a breadth-first-like traversal of the
; decision tree.
; I seem to have seen a theorem that says that a _fair_ scheduling
; (like that provided by any-interleave) entails a minimal or well-founded
; semantics of a Prolog program.
(define-syntax any-interleave
(syntax-rules ()
((_) fail)
((_ gl) gl)
((_ gl ...)
(lambda@ (subst sk fk)
(interleave sk fk (list (gl subst) ...))))))
; we treat sgls as a sort of a circular list
(define interleave
(lambda (sk fk sgls)
(cond
((null? sgls) (fk)) ; all of the sgls are finished
((null? (cdr sgls))
; only one of sgls left -- run it through the end
(at@ (car sgls) sk fk))
(else
(let loop ((curr sgls) (residuals '()))
; check if the current round is finished
(if (null? curr) (interleave sk fk (reverse residuals))
(at@
partially-eval-sgl (car curr)
; (car curr) had an answer
(lambda@ (subst residual)
(at@ sk subst
; re-entrance cont
(lambda () (loop (cdr curr) (cons residual residuals)))))
; (car curr) is finished - drop it, and try next
(lambda () (loop (cdr curr) residuals)))))))))
; An interleaving disjunction removing duplicates: any-union
; This is a true union of the constituent goals: it is fair, and
; it removes overlap in the goals to union, if any. Therefore,
; (any-union gl gl) ===> gl
; whereas (any gl gl) =/=> gl
; because the latter has twice as many answers as gl.
;
; Any-union (or interleave-non-overlap, to be precise) is quite similar
; to the function interleave above. But now, the order of goals
; matters. Given goals gl1 gl2 ... glk ... gln,
; at the k-th step we try to partially-eval glk. If it yields an answer,
; we check if gl_{k+1} ... gln can be satisfied with that answer.
; If any of them does, we disregard the current answer and ask glk for
; another one. We maintain the invariant that
; ans is an answer of (any-union gl1 ... gln)
; ===> exists i. ans is an answer of gl_i
; && forall j>i. ans is not an answer of gl_j
; The latter property guarantees the true union.
; Note the code below does not check if the answers of each individual
; goal are unique. It is trivial to modify the code so that
; any-union removes the duplicates not only among the goals but
; also within a goal. That change entails a run-time cost. More
; importantly, it breaks the property
; (any-union gl gl) ===> gl
; Only a weaker version, (any-union' gl gl) ===> (any-union' gl)
; would hold. Therefore, we do not make that change.
(define-syntax any-union
(syntax-rules ()
((_) fail)
((_ gl) gl)
((_ gl ...)
(lambda@ (subst sk fk)
(interleave-non-overlap sk fk (list (cons (gl subst) gl) ...))))))
; we treat sagls as a sort of a circular list
; Each element of sagls is a pair (sgl . gl)
; where gl is the original goal (needed for the satisfiability testing)
; and sgl is the corresponding semi-goal or a
; residual thereof.
(define interleave-non-overlap
(lambda (sk fk sagls)
(let outer ((sagls sagls))
(cond
((null? sagls) (fk)) ; all of the sagls are finished
((null? (cdr sagls)) ; only one gl is left -- run it through the end
(at@ (caar sagls) sk fk))
(else
(let loop ((curr sagls)
(residuals '()))
; check if the current round is finished
(if (null? curr) (outer (reverse residuals))
(at@
partially-eval-sgl (caar curr)
; (caar curr) had an answer
(lambda@ (subst residual)
; let us see now if the answer, subst, satisfies any of the
; gls down the curr.
(let check ((to-check (cdr curr)))
(if (null? to-check) ; OK, subst is unique,give it to user
(at@ sk subst
; re-entrance cont
(lambda ()
(loop (cdr curr)
(cons (cons residual (cdar curr)) residuals))))
(at@ (cdar to-check) subst
; subst was the answer to some other gl:
; check failed
(lambda@ (subst1 fk1)
(loop (cdr curr)
(cons (cons residual (cdar curr)) residuals)))
; subst was not the answer: continue check
(lambda () (check (cdr to-check)))))))
; (car curr) is finished - drop it, and try next
(lambda () (loop (cdr curr) residuals))))))))))
; Another if-then-else
; (if-some COND THEN)
; (if-some COND THEN ELSE)
; Here COND, THEN, ELSE are goals.
; If COND succeeds at least once, the result is equivalent to
; (all COND TNEN)
; If COND fails, the result is the same as ELSE.
; If ELSE is omitted, it is assumed fail. That is, (if-some COND THEN)
; fails if the condition fails. "This unusual semantics
; is part of the ISO and all de-facto Prolog standards."
; Thus, declaratively,
; (if-some COND THEN ELSE) ==> (any (all COND THEN)
; (all (fails COND) ELSE))
; from which follows
; (if-some COND THEN) ==> (all COND THEN)
; (if-some COND THEN fail) ==> (all COND THEN)
; but
; (if-some COND succeed ELSE) =/=> (any COND ELSE)
;
; Other corollary:
; (if-some COND THEN ELSE) ==> (if-only (fails COND) ELSE (all COND THEN))
;
; Operationally, we try to generate a good code.
;
; In Prolog, if-some is called a soft-cut (aka *->). In Mercury,
; if-some is the regular IF-THEN-ELSE.
;
; We can implement if-some with partially-eval-sgl. Given a COND, we
; peel off one answer, if possible. If there is one, we then execute THEN
; passing it the answer and the fk from COND so that if THEN fails,
; it can obtain another answer. If COND has no answers, we execute
; ELSE. Again, we can do all that purely declaratively, without
; talking about introducing and destroying choice points.
(define-syntax if-some
(syntax-rules ()
((_ condition then) (all condition then))
((_ condition then else)
(lambda@ (subst sk fk)
(at@ partially-eval-sgl (condition subst)
(lambda@ (ans residual)
(at@ then ans sk
; then failed. Check to see if condition has another answer
(lambda () (at@ residual (lambda@ (subst) (at@ then subst sk)) fk))))
; condition failed
(lambda () (at@ else subst sk fk)))))))
; An interleaving conjunction: all-interleave
;
; This conjunction is similar to the regular conjunction `all' but
; delivers the answers in the breadth-first rather than depth-first
; order.
;
; Motivation.
; Let us consider the conjunction (all gl1 gl2)
; where gl1 is (any gl11 gl12) and gl2 is an goal with the
; infinite number of answers (in the environment when either gl11 or
; gl12 succeed). It is easy to see (all gl1 gl2) will have the
; infinite number of answers too -- but only the proper subset of
; all the possible answers. Indeed, (all gl1 gl2) will essentially
; be equivalent to (all gl11 gl2). Because gl2 succeeds infinitely
; many times, the choice gl12 in gl1 will never be explored.
; We can see that formally:
; (all gl1 gl2)
; = (all (any gl11 gl12) gl2)
; = (any (all gl11 gl2) (all gl12 gl2))
; Because (all gl11 gl2) can succeed infinitely many times, it starves
; the other disjunction, (all gl12 gl2).
; But we know how to deal with that: we just replace any with any-interleave:
; (all gl1 gl2) --> (any-interleave (all gl11 gl2) (all gl12 gl2))
;
; It seems that the problem is solved? We just re-write our expressions
; into the disjunctive normal form, and then replace the top-level
; `any' with `any-interleave'. Alas, that means that to get the benefit
; of fair scheduling and get all the possible solutions of the conjunction
; (i.e., recursive enumerability), we need to re-write all the code.
; We have to explicitly re-write a conjunction of disjunctions into
; the disjunctive normal form. That is not that easy considering that gl2
; will most likely be a recursive goal re-invoking the original
; conjunction. That would be a lot of re-writing.
;
; The conjunction all-interleave effectively does the above `re-writing'
; That is, given the example above,
; (all-interleave (any gl11 gl12) gl2)
; is observationally equivalent to
; (any-interleave (all gl11 gl2) (all gl12 gl2))
;
; The advantage is that we do not need to re-write our conjunctions:
; we merely replace `all' with `all-interleave.'
;
; How can we do that in the general case, (all gl1 gl2)
; where gl1 is not _explicitly_ a disjunction? We should remember the
; property of partially-eval-sgl: Any goal `gl' with at least one
; answer can be represented as (any gl-1 gl-rest)
; where gl-1 is a primitive goal holding the first answer of `gl',
; and gl-rest holding the rest of the answers. We then apply the
; all-any-distributive law and re-write
; (all-interleave gl1 gl2)
; ==> (all-interleave (any gl1-1 gl1-rest) gl2)
; ==> (any-interleave (all gl1 gl2) (all-interleave gl1-rest gl2))
;
; If gl1 has no answers, then (all-interleave gl1 gl2) fails, as
; a conjunction must.
; It is also easy to see that
; (all-interleave gl1 gl2 ...) is the same as
; (all-interleave gl1 (all-interleave gl2 ...))
;
; Although all-interleave was motivated by an example (all gl1 gl2)
; where gl1 is finitary and only gl2 is infinitary, the above
; equations (and the implementation below) show that all-interleave
; can do the right thing even if gl1 is infinitary as well. To be
; precise, given
;
; (all-interleave gl1 gl2)
;
; with gl1 and gl2 infinitary, the i-th solution of gl1 will be
; observed in every 2^i-th solution to the whole conjunction. Granted,
; all-interleave isn't precisely very fair -- the later solutions of
; gl1 will appear progressively more rarely -- yet, they will all
; appear. The infinity of c0 is big enough. That is, given any
; solution to gl1, we will eventually, in finite time, find it in the
; solution of the whole conjunction (provided gl2 doesn't fail on
; that solution, of course).
(define-syntax all-interleave
(syntax-rules ()
((_) (all))
((_ gl) gl)
((_ gl0 gl1 ...)
(lambda@ (subst)
(all-interleave-bin
(gl0 subst) (all-interleave gl1 ...))))))
(define all-interleave-bin
(lambda (sgl1 gl2)
(lambda@ (sk fk)
(at@ partially-eval-sgl sgl1
(lambda@ (ans residual)
(interleave sk fk
(list
(at@ gl2 ans)
(all-interleave-bin residual gl2)
)))
;gl1 failed
fk))))
; Relations...........................
; The current incremented unification of argument passing is quite similar to
; the compilation of argument unifications in WAM.
; relation (VAR ...) (to-show TERM ...) [GL]
; Defines a relation of arity (length '(TERM ...)) with an optional body
; GL. VAR ... are logical variables that are local to the relation, i.e.,
; appear in TERM or GL. It's better to list as VAR ... only logical
; variables that appear in TERM. Variables that appear only in GL should
; be introduced with exists. That makes their existential quantification
; clearer. Variables that appear in TERM are universally quantified.
;
; relation (head-let TERM ...) [GL]
; See relation-head-let below.
;
; relation (ANNOT-VAR ...) (to-show TERM ...) [GL] (see remark below!)
; where ANNOT-VAR is either a simple VAR or (once VAR)
; where 'once' is a distingushed symbol. The latter form introduces
; a once-var, aka linear variable. A linear variable appears only once in
; TERM ... and only at the top level (that is, one and only one TERM
; in the to-show pattern contains ONCE-VAR, and that term is ONCE-VAR
; itself). In addition, ONCE-VAR must appear at most once in the body GL.
; (Of course, then ONCE-VAR could be _, instead.)
; If these conditions are satisfied, we can replace a logical variable
; ONCE-VAR with a regular Scheme variable.
; Alternative notation:
; (relation (a c) (to-show term1 (once c) term2) body)
; Makes it easier to deal with. But it is unsatisfactory:
; to-show becomes a binding form...
;
; When ``compiling'' a relation, we now look through the
; (to-show ...) pattern for a top-level occurrence of the logical variable
; introduced by the relation. For example:
; (relation (x y) (to-show `(,x . ,y) x) body)
; we notice that the logical variable 'x' occurs at the top-level. Normally we
; compile the relation like that into the following
; (lambda (g1 g2)
; (_exists (x y)
; (lambda@ (subst)
; (let*-and (fail subst) ((subst (unify g1 `(,x . ,y) subst))
; (subst (unify g2 x subst)))
; (at@ body subst)))))
;
; However, that we may permute the order of 'unify g...' clauses
; to read
; (lambda (g1 g2)
; (_exists (x y)
; (lambda@ (subst)
; (let*-and (fail subst) ((subst (unify x g2 subst))
; (subst (unify g1 `(,x . ,y) subst))
; )
; (at@ body subst)))))
;
; We may further note that according to the properties of the unifier
; (see below), (unify x g2 subst) must always succeed,
; because x is a fresh variable.
; Furthermore, the result of (unify x g2 subst) is either subst itself,
; or subst with the binding of x. Therefore, we can check if
; the binding at the top of (unify x g2 subst) is the binding to x. If
; so, we can remove the binding and convert the variable x from being logical
; to being lexical. Thus, we compile the relation as
;
; (lambda (g1 g2)
; (_exists (x y)
; (lambda@ (subst)
; (let* ((subst (unify-free/any x g2 subst))
; (fast-path? (and (pair? subst)
; (eq? x (commitment->var (car subst)))))
; (x (if fast-path? (commitment->term (car subst)) x))
; (subst (if fast-path? (cdr subst) subst)))
; (let*-and sfail ((subst (unify g1 `(,x . ,y) subst))
; )
; (at@ body subst))))))
;
; The benefit of that approach is that we limit the growth of subst and avoid
; keeping commitments that had to be garbage-collected later.
(define-syntax relation
(syntax-rules (to-show head-let once __)
((_ (head-let head-term ...) gl)
(relation-head-let (head-term ...) gl))
((_ (head-let head-term ...)) ; not particularly useful without body
(relation-head-let (head-term ...)))
((_ () (to-show term ...) gl) ; pattern with no vars _is_ linear
(relation-head-let (`,term ...) gl))
((_ () (to-show term ...)) ; the same without body: not too useful
(relation-head-let (`,term ...)))
((_ (ex-id ...) (to-show term ...) gl) ; body present
(relation "a" () () (ex-id ...) (term ...) gl))
((_ (ex-id ...) (to-show term ...)) ; no body
(relation "a" () () (ex-id ...) (term ...)))
; process the list of variables and handle annotations
((_ "a" vars once-vars ((once id) . ids) terms . gl)
(relation "a" vars (id . once-vars) ids terms . gl))
((_ "a" vars once-vars (id . ids) terms . gl)
(relation "a" (id . vars) once-vars ids terms . gl))
((_ "a" vars once-vars () terms . gl)
(relation "g" vars once-vars () () () (subst) terms . gl))
; generating temp names for each term in the head
; don't generate if the term is a variable that occurs in
; once-vars
; For _ variables in the pattern, generate unique names for the lambda
; parameters, and forget them
; also, note and keep track of the first occurrence of a term
; that is just a var (bare-var)
((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (__ . terms) . gl)
(relation "g" vars once-vars (gs ... anon) gunis
bvars bvar-cl terms . gl))
((_ "g" vars once-vars (gs ...) gunis bvars (subst . cls)
(term . terms) . gl)
(id-memv?? term once-vars
; success continuation: term is a once-var
(relation "g" vars once-vars (gs ... term) gunis bvars (subst . cls)
terms . gl)
; failure continuation: term is not a once-var
(id-memv?? term vars
; term is a bare var
(id-memv?? term bvars
; term is a bare var, but we have seen it already: general case
(relation "g" vars once-vars (gs ... g) ((g . term) . gunis)
bvars (subst . cls) terms . gl)
; term is a bare var, and we have not seen it
(relation "g" vars once-vars (gs ... g) gunis
(term . bvars)
(subst
(subst (unify-free/any term g subst))
(fast-path? (and (pair? subst)
(eq? term (commitment->var (car subst)))))
(term (if fast-path? (commitment->term (car subst)) term))
(subst (if fast-path? (cdr subst) subst))
. cls)
terms . gl))
; term is not a bare var
(relation "g" vars once-vars (gs ... g) ((g . term) . gunis)
bvars (subst . cls) terms . gl))))
((_ "g" vars once-vars gs gunis bvars bvar-cl () . gl)
(relation "f" vars once-vars gs gunis bvar-cl . gl))
; Final: writing the code
((_ "f" vars () () () (subst) gl) ; no arguments (no head-tests)
(lambda ()
(_exists vars gl)))
; no tests but pure binding
((_ "f" (ex-id ...) once-vars (g ...) () (subst) gl)
(lambda (g ...)
(_exists (ex-id ...) gl)))
; the most general
((_ "f" (ex-id ...) once-vars (g ...) ((gv . term) ...)
(subst let*-clause ...) gl)
(lambda (g ...)
(_exists (ex-id ...)
(lambda (subst)
(let* (let*-clause ...)
(let*-and sfail ((subst (unify gv term subst)) ...)
(at@ gl subst)))))))))
; A macro-expand-time memv function for identifiers
; id-memv?? FORM (ID ...) KT KF
; FORM is an arbitrary form or datum, ID is an identifier.
; The macro expands into KT if FORM is an identifier that occurs
; in the list of identifiers supplied by the second argument.
; Otherwise, id-memv?? expands to KF.
; All the identifiers in (ID ...) must be unique.
; Two identifiers match if both refer to the same binding occurrence, or
; (both are undefined and have the same spelling).
(define-syntax id-memv??
(syntax-rules ()
((id-memv?? form (id ...) kt kf)
(let-syntax
((test
(syntax-rules (id ...)
((test id _kt _kf) _kt) ...
((test otherwise _kt _kf) _kf))))
(test form kt kf)))))
; Test cases
; (id-memv?? x (a b c) #t #f)
; (id-memv?? a (a b c) 'OK #f)
; (id-memv?? () (a b c) #t #f)
; (id-memv?? (x ...) (a b c) #t #f)
; (id-memv?? "abc" (a b c) #t #f)
; (id-memv?? x () #t #f)
; (let ((x 1))
; (id-memv?? x (a b x) 'OK #f))
; (let ((x 1))
; (id-memv?? x (a x b) 'OK #f))
; (let ((x 1))
; (id-memv?? x (x a b) 'OK #f))
; relation-head-let (head-term ...) gl
; A simpler, and more efficient kind of relation. The simplicity comes
; from a simpler pattern at the head of the relation. The pattern must
; be linear and shallow with respect to introduced variables. The gl
; is optional (although omitting it doesn't make much sense in
; practice) There are two kinds of head-terms. One kind is an
; identifier. This identifier is taken to be a logical identifier, to
; be unified with the corresponding actual argument. Each logical
; identifier must occur exactly once. Another kind of a head-terms is
; anything else. That anything else may be a constant, a scheme
; variable, or a complex term that may even include logical variables
; such as _ -- but not logical variables defined in the same head-let
; pattern. To make the task of distinguishing logical identifiers
; from anything else easier, we require that anything else of a sort
; of a manifest constant be explicitly quoted or quasiquoted. It would
; be OK to add `, to each 'anything else' term.
;
; Examples:
; (relation-head-let (x y z) (foo x y z))
; Here x y and z are logical variables.
; (relation-head-let (x y '7) (foo x y))
; Here we used a manifest constant that must be quoted
; (relation-head-let (x y `(1 2 . ,_)) (foo x y))
; We used a quasi-quoted constant with an anonymous variable.
; (let ((z `(1 2 . ,_))) (relation-head-let (x y `,z) (foo x y))
; The same as above, but using a lexical Scheme variable.
; The binding procedure is justified by Proposition 9 of
; the Properties of Substitutions.
;
; 'head-let' is an example of "compile-time" simplifications.
; For example, we distinguish constants in the term head at
; "compile time" and so we re-arrange the argument-passing
; unifications to handle the constants first.
; The test for the anonymous variable (eq? gvv0 _) below
; is an example of a global simplification with a run-time
; test. A compiler could have inferred the result of the test -- but only
; upon the global analysis of all the clauses.
; Replacing a logical variable with an ordinary variable, which does
; not have to be pruned, is equivalent to the use of temporary and
; unsafe variables in WAM.
(define-syntax relation-head-let
(syntax-rules ()
((_ (head-term ...) . gls)
(relation-head-let "g" () (head-term ...) (head-term ...) . gls))
; generate names of formal parameters
((_ "g" (genvar ...) ((head-term . tail-term) . ht-rest)
head-terms . gls)
(relation-head-let "g" (genvar ... g) ht-rest head-terms . gls))
((_ "g" (genvar ...) (head-term . ht-rest) head-terms . gls)
(relation-head-let "g" (genvar ... head-term) ht-rest head-terms . gls))
((_ "g" genvars () head-terms . gls)
(relation-head-let "d" () () genvars head-terms genvars . gls))
; partition head-terms into vars and others
((_ "d" vars others (gv . gv-rest) ((hth . htt) . ht-rest) gvs . gls)
(relation-head-let "d" vars ((gv (hth . htt)) . others)
gv-rest ht-rest gvs . gls))
((_ "d" vars others (gv . gv-rest) (htv . ht-rest) gvs . gls)
(relation-head-let "d" (htv . vars) others
gv-rest ht-rest gvs . gls))
((_ "d" vars others () () gvs . gls)
(relation-head-let "f" vars others gvs . gls))
; final generation
((_ "f" vars ((gv term) ...) gvs) ; no body
(lambda gvs ; don't bother bind vars
(lambda@ (subst)
(let*-and sfail ((subst (unify gv term subst)) ...)
(at@ succeed subst)))))
((_ "f" (var0 ...) ((gvo term) ...) gvs gl)
(lambda gvs
(lambda@ (subst) ; first unify the constants
(let*-and sfail ((subst (unify gvo term subst)) ...)
(let ((var0 (if (eq? var0 __) (logical-variable '?) var0)) ...)
(at@ gl subst))))))))
; (define-syntax relation/cut
; (syntax-rules (to-show)
; ((_ cut-id (ex-id ...) (to-show x ...) gl ...)
; (relation/cut cut-id (ex-id ...) () (x ...) (x ...) gl ...))
; ((_ cut-id ex-ids (var ...) (x0 x1 ...) xs gl ...)
; (relation/cut cut-id ex-ids (var ... g) (x1 ...) xs gl ...))
; ((_ cut-id (ex-id ...) (g ...) () (x ...) gl ...)
; (lambda (g ...)
; (_exists (ex-id ...)
; (all! (== g x) ...
; (lambda@ (sk fk subst cutk)
; (let ((cut-id (!! cutk)))
; (at@ (all gl ...) sk fk subst cutk)))))))))
(define-syntax fact
(syntax-rules ()
((_ (ex-id ...) term ...)
(relation (ex-id ...) (to-show term ...) succeed))))
; Lifting from goals to relations
; (define-rel-lifted-comb rel-syntax gl-proc-or-syntax)
; Given (gl-proc-or-syntax gl ...)
; define
; (rel-syntax (id ...) rel-exp ...)
; We should make rel-syntax behave as a CBV function, that is,
; evaluate rel-exp early.
; Otherwise, things like
; (define father (extend-relation father ...))
; loop.
; (define-syntax extend-relation
; (syntax-rules ()
; ((_ (id ...) rel-exp ...)
; (extend-relation-aux (id ...) () rel-exp ...))))
; (define-syntax extend-relation-aux
; (syntax-rules ()
; ((_ (id ...) ((g rel-exp) ...))
; (let ((g rel-exp) ...)
; (lambda (id ...)
; (any (g id ...) ...))))
; ((_ (id ...) (let-pair ...) rel-exp0 rel-exp1 ...)
; (extend-relation-aux (id ...)
; (let-pair ... (g rel-exp0)) rel-exp1 ...))))
(define-syntax define-rel-lifted-comb
(syntax-rules ()
((_ rel-syntax-name gl-proc-or-syntax)
(define-syntax rel-syntax-name
(syntax-rules ()
((_ ids . rel-exps)
(lift-gl-to-rel-aux gl-proc-or-syntax ids () . rel-exps)))))))
(define-syntax lift-gl-to-rel-aux
(syntax-rules ()
((_ gl-handler ids ((g rel-var) ...))
(let ((g rel-var) ...)
(lambda ids
(gl-handler (g . ids) ...))))
((_ gl-handler ids (let-pair ...) rel-exp0 rel-exp1 ...)
(lift-gl-to-rel-aux gl-handler ids
(let-pair ... (g rel-exp0)) rel-exp1 ...))))
(define-rel-lifted-comb extend-relation any)
; The following goal-to-relations
; transformers are roughly equivalent. I don't know which is better.
; see examples below.
; (lift-to-relations ids (gl-comb rel rel ...))
(define-syntax lift-to-relations
(syntax-rules ()
((_ ids (gl-comb rel ...))
(lift-gl-to-rel-aux gl-comb ids () rel ...))))
; (let-gls ids ((name rel) ...) body)
; NB: some macro systems do not like if 'ids' below is replaced by (id ...)
(define-syntax let-gls
(syntax-rules ()
((_ ids ((gl-name rel-exp) ...) body)
(lambda ids
(let ((gl-name (rel-exp . ids)) ...)
body)))))
; Unify lifted to be a binary relation
(define-syntax ==
(syntax-rules (__)
((_ __ u) (lambda@ (subst sk) (at@ sk subst)))
((_ t __) (lambda@ (subst sk) (at@ sk subst)))
((_ t u)
(lambda@ (subst)
(let*-and sfail ((subst (unify t u subst)))
(succeed subst))))))
; query (redo-k subst id ...) A SE ... -> result or '()
; The macro 'query' runs the goal A in the empty
; initial substitution, and reifies the resulting
; answer: the substitution and the redo-continuation bound
; to fresh variables with the names supplied by the user.
; The substitution and the redo continuation can then be used
; by Scheme expressions SE ...
; Before running the goal, the macro creates logical variables
; id ... for use in A and SE ...
; If the goal fails, '() is returned and SE ... are not evaluated.
; Note the similarity with shift/reset-based programming
; where the immediate return signifies "failure" and the invocation
; of the continuation a "success"
; Returning '() on failure makes it easy to create the list of answers
(define-syntax query
(syntax-rules ()
((_ (redo-k subst id ...) A SE ...)
(let-lv (id ...)
(at@ A empty-subst
(lambda@ (subst redo-k) SE ...)
(lambda () '()))))))
(define stream-prefix
(lambda (n strm)
(if (null? strm) '()
(cons (car strm)
(if (zero? n) '()
(stream-prefix (- n 1) ((cdr strm))))))))
(define-syntax solve
(syntax-rules ()
((_ n (var0 ...) gl)
(if (<= n 0) '()
(stream-prefix (- n 1)
(query (redo-k subst var0 ...)
gl
(cons (reify-subst (list var0 ...) subst) redo-k)))))))
(define-syntax solution
(syntax-rules ()
((_ (var0 ...) x)
(let ((ls (solve 1 (var0 ...) x)))
(if (null? ls) #f (car ls))))))
(define-syntax project
(syntax-rules ()
((_ (var ...) gl)
(lambda@ (subst)
(let ((var (nonvar! (subst-in var subst))) ...)
(at@ gl subst))))))
(define-syntax project/no-check
(syntax-rules ()
((_ (var ...) gl)
(lambda@ (subst)
(let ((var (subst-in var subst)) ...)
(at@ gl subst))))))
(define-syntax predicate
(syntax-rules ()
((_ scheme-expression)
(lambda@ (subst)
(if scheme-expression (succeed subst) (fail subst))))))
(define nonvar!
(lambda (t)
(if (var? t)
(errorf 'nonvar! "Logic variable ~s found after substituting."
(reify t))
t)))
; TRACE-VARS TITLE (VAR ...)
; Is a deterministic goal that prints the current values of VARS
; TITLE is any displayable thing.
; (define-syntax trace-vars
; (syntax-rules ()
; ((trace-vars title (var0 ...))
; (promise-one-answer
; (predicate/no-check (var0 ...)
; (begin (display title) (display " ")
; (display '(var0 ...)) (display " ") (display (list var0 ...))
; (newline)))))))
(define-syntax trace-vars
(syntax-rules ()
((_ title (var0 ...))
(promise-one-answer
(project/no-check (var0 ...)
(predicate
(for-each
(lambda (name val)
(cout title " " name ": " val nl))
'(var0 ...) (reify `(,var0 ...)))
))))))
;equality predicate: X == Y in Prolog
;if X is a var, then X == Y holds only if Y
;is the same var
(define *equal?
(lambda (x y)
(cond
((and (var? x) (var? y)) (eq? x y))
((var? x) #f) ; y is not a var
((var? y) #f) ; x is not a var
(else (equal? x y)))))
; extend-relation-with-recur-limit LIMIT VARS RELS -> REL
; This is a variation of 'extend-relation' that makes sure
; that the extended relation is not recursively entered more
; than LIMIT times. The form extend-relation-with-recur-limit
; can be used to cut a left-recursive relation, and to implement
; an iterative deepening strategy.
; extend-relation-with-recur-limit must be a special form
; because we need to define the depth-counter-var
; outside of relations' lambda (so we count the recursive invocations
; for all arguments).
(define-syntax extend-relation-with-recur-limit
(syntax-rules ()
((_ limit ids rel ...)
(let ((depth-counter-var (logical-variable '*depth-counter*)))
(lambda ids
(let ((gl (any (rel . ids) ...)))
(lambda@ (subst)
(cond
((assq depth-counter-var subst)
=> (lambda (cmt)
(let ((counter (commitment->term cmt)))
(if (>= counter limit)
sfail
(let ((s (extend-subst depth-counter-var
(+ counter 1) subst)))
(at@ gl s))))))
(else
(let ((s (extend-subst depth-counter-var 1 subst)))
(at@ gl s)))))))))
))
; ?- help(call_with_depth_limit/3).
; call_with_depth_limit(+Goal, +Limit, -Result)
; If Goal can be proven without recursion deeper than Limit levels,
; call_with_depth_limit/3 succeeds, binding Result to the deepest
; recursion level used during the proof. Otherwise, Result is
; unified with depth_limit_exceeded if the limit was exceeded during
; the proof, or the entire predicate fails if Goal fails without
; exceeding Limit.
; The depth-limit is guarded by the internal machinery. This may
; differ from the depth computed based on a theoretical model. For
; example, true/0 is translated into an inlined virtual machine
; instruction. Also, repeat/0 is not implemented as below, but as a
; non-deterministic foreign predicate.
; repeat.
; repeat :-
; repeat.
; As a result, call_with_depth_limit/3 may still loop inifitly on
; programs that should theoretically finish in finite time. This
; problem can be cured by using Prolog equivalents to such built-in
; predicates.
; This predicate may be used for theorem-provers to realise
; techniques like iterrative deepening. It was implemented after
; discussion with Steve Moyle smoyle@ermine.ox.ac.uk.
;------------------------------------------------------------------------
;;;;; Starts the real work of the system.
(define-rel-lifted-comb intersect-relation all)
(define (kanren-tests)
(let* ((father
(relation ()
(to-show 'jon 'sam)))
(child-of-male
(relation (child dad)
(to-show child dad)
(father dad child)))
(child-of-male1
(relation (child dad)
(to-show child dad)
(child-of-male dad child)))
)
(test-check 'test-father0
(let ((result
(at@ (father 'jon 'sam) empty-subst
initial-sk initial-fk)))
(and
(equal? (car result) '())
(equal? ((cdr result)) '())))
#t)
(test-check 'test-child-of-male-0
(reify-subst '()
(car (at@ (child-of-male 'sam 'jon) empty-subst
initial-sk initial-fk)))
;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon)))
'()) ; variables shouldn't leak
; The mark should be found here...
(test-check 'test-child-of-male-1
(reify-subst '()
(car (at@ (child-of-male 'sam 'jon) empty-subst
initial-sk initial-fk)))
;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon)))
'())
)
(let* ((father
(relation ()
(to-show 'jon 'sam)))
(rob/sal
(relation ()
(to-show 'rob 'sal)))
(new-father
(extend-relation (a1 a2) father rob/sal))
(rob/pat
(relation ()
(to-show 'rob 'pat)))
(newer-father
(extend-relation (a1 a2) new-father rob/pat))
)
(test-check 'test-father-1
(let ((result
(at@ (new-father 'rob 'sal) empty-subst
initial-sk initial-fk)))
(and
(equal? (car result) '())
(equal? ((cdr result)) '())))
#t)
(test-check 'test-father-2
(query (redo-k subst x)
(new-father 'rob x)
(list (equal? (car subst) (commitment x 'sal)) (redo-k)))
'(#t ()))
(test-check 'test-father-3
(query (_ subst x)
(new-father 'rob x)
(reify-subst (list x) subst))
'((x.0 sal)))
(test-check 'test-father-4
(query (_ subst x y)
(new-father x y)
(reify-subst (list x y) subst))
'((x.0 jon) (y.0 sam)))
(test-check 'test-father-5
(query (redok subst x)
(newer-father 'rob x)
(_pretty-print subst)
(cons
(reify-subst (list x) subst)
(redok)))
'(((x.0 sal)) ((x.0 pat))))
)
(let* ((father
(extend-relation (a1 a2)
(relation () (to-show 'jon 'sam))
(relation () (to-show 'rob 'sal))
(relation () (to-show 'rob 'pat))
(relation () (to-show 'sam 'rob)))
))
(test-check 'test-father-6/solve
(and
(equal?
(solve 5 (x) (father 'rob x))
'(((x.0 sal)) ((x.0 pat))))
(equal?
(solve 6 (x y) (father x y))
'(((x.0 jon) (y.0 sam))
((x.0 rob) (y.0 sal))
((x.0 rob) (y.0 pat))
((x.0 sam) (y.0 rob)))))
#t)
(test-check 'test-father-7/solution
(solution (x) (father 'rob x))
'((x.0 sal)))
)
; (define-syntax intersect-relation
; (syntax-rules ()
; ((_ (id ...) rel-exp) rel-exp)
; ((_ (id ...) rel-exp0 rel-exp1 rel-exp2 ...)
; (binary-intersect-relation (id ...) rel-exp0
; (intersect-relation (id ...) rel-exp1 rel-exp2 ...)))))
(let*
((parents-of-scouts
(extend-relation (a1 a2)
(fact () 'sam 'rob)
(fact () 'roz 'sue)
(fact () 'rob 'sal)))
(parents-of-athletes
(extend-relation (a1 a2)
(fact () 'sam 'roz)
(fact () 'roz 'sue)
(fact () 'rob 'sal)))
(busy-parents
(intersect-relation (a1 a2) parents-of-scouts parents-of-athletes))
(conscientious-parents
(extend-relation (a1 a2) parents-of-scouts parents-of-athletes))
)
(test-check 'test-conscientious-parents
(solve 7 (x y) (conscientious-parents x y))
'(((x.0 sam) (y.0 rob))
((x.0 roz) (y.0 sue))
((x.0 rob) (y.0 sal))
((x.0 sam) (y.0 roz))
((x.0 roz) (y.0 sue))
((x.0 rob) (y.0 sal))))
)
(let* ((father
(extend-relation (a1 a2)
(relation () (to-show 'jon 'sam))
(relation () (to-show 'rob 'sal))
(relation () (to-show 'rob 'pat))
(relation () (to-show 'sam 'rob)))
))
(let
((grandpa-sam
(relation (grandchild)
(to-show grandchild)
(_exists (parent)
(all (father 'sam parent)
(father parent grandchild))))))
(test-check 'test-grandpa-sam-1
(solve 6 (y) (grandpa-sam y))
'(((y.0 sal)) ((y.0 pat))))
)
(let
((grandpa-sam
(relation ((once grandchild))
(to-show grandchild)
(_exists (parent)
(all (father 'sam parent)
(father parent grandchild))))))
(test-check 'test-grandpa-sam-1
(solve 6 (y) (grandpa-sam y))
'(((y.0 sal)) ((y.0 pat))))
)
(let ((child
(relation ((once child) (once dad))
(to-show child dad)
(father dad child))))
(test-check 'test-child-1
(solve 10 (x y) (child x y))
'(((x.0 sam) (y.0 jon))
((x.0 sal) (y.0 rob))
((x.0 pat) (y.0 rob))
((x.0 rob) (y.0 sam))))
)
(let ((grandpa
(relation ((once grandad) (once grandchild))
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent)
(father parent grandchild))))))
(test-check 'test-grandpa-1
(solve 4 (x) (grandpa 'sam x))
'(((x.0 sal)) ((x.0 pat)))))
(let ((grandpa-maker
(lambda (guide* grandad*)
(relation (grandchild)
(to-show grandchild)
(_exists (parent)
(all
(guide* grandad* parent)
(guide* parent grandchild)))))))
(test-check 'test-grandpa-maker-2
(solve 4 (x) ((grandpa-maker father 'sam) x))
'(((x.0 sal)) ((x.0 pat)))))
)
(let*
((father
(extend-relation (a1 a2)
(fact () 'jon 'sam)
(extend-relation (a1 a2)
(fact () 'sam 'rob)
(extend-relation (a1 a2)
(fact () 'sam 'roz)
(extend-relation (a1 a2)
(fact () 'rob 'sal)
(fact () 'rob 'pat))))))
(mother
(extend-relation (a1 a2)
(fact () 'roz 'sue)
(fact () 'roz 'sid)))
)
(let*
((grandpa/father
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent)
(father parent grandchild)))))
(grandpa/mother
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent)
(mother parent grandchild)))))
(grandpa
(extend-relation (a1 a2) grandpa/father grandpa/mother)))
(test-check 'test-grandpa-5
(solve 10 (y) (grandpa 'sam y))
'(((y.0 sal)) ((y.0 pat)) ((y.0 sue)) ((y.0 sid))))
)
; A relation is just a function
(let
((grandpa-sam
(let ((r (relation (child)
(to-show child)
(_exists (parent)
(all
(father 'sam parent)
(father parent child))))))
(relation (child)
(to-show child)
(r child)))))
(test-check 'test-grandpa-55
(solve 6 (y) (grandpa-sam y))
'(((y.0 sal)) ((y.0 pat))))
)
; The solution that used cuts
; (define grandpa/father
; (relation/cut cut (grandad grandchild)
; (to-show grandad grandchild)
; (_exists (parent)
; (all
; (father grandad parent)
; (father parent grandchild)
; cut))))
;
; (define grandpa/mother
; (relation (grandad grandchild)
; (to-show grandad grandchild)
; (_exists (parent)
; (all
; (father grandad parent)
; (mother parent grandchild)))))
; Now we don't need it
(let*
((grandpa/father
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all!
(father grandad parent)
(father parent grandchild)))))
(grandpa/mother
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent)
(mother parent grandchild)))))
(grandpa
(lift-to-relations (a1 a2)
(all!
(extend-relation (a1 a2) grandpa/father grandpa/mother))))
)
(test-check 'test-grandpa-8
(solve 10 (x y) (grandpa x y))
'(((x.0 jon) (y.0 rob))))
)
; The solution that used to require cuts
; (define grandpa/father
; (relation/cut cut (grandad grandchild)
; (to-show grandad grandchild)
; (_exists (parent)
; (all cut (father grandad parent) (father parent grandchild)))))
(let
((grandpa/father
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent) (father parent grandchild)))))
(grandpa/mother
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all
(father grandad parent) (mother parent grandchild)))))
)
; Properly, this requires soft cuts, aka *->, or Mercury's
; if-then-else. But we emulate it...
(let
((grandpa
(let-gls (a1 a2) ((grandpa/father grandpa/father)
(grandpa/mother grandpa/mother))
(if-only (succeeds grandpa/father) grandpa/father grandpa/mother)))
)
(test-check 'test-grandpa-10
(solve 10 (x y) (grandpa x y))
'(((x.0 jon) (y.0 rob))
((x.0 jon) (y.0 roz))
((x.0 sam) (y.0 sal))
((x.0 sam) (y.0 pat))))
(test-check 'test-grandpa-10-1
(solve 10 (x) (grandpa x 'sue))
'(((x.0 sam))))
)
; The same as above, with if-all! -- just to test the latter.
(let
((grandpa
(let-gls (a1 a2) ((grandpa/father grandpa/father)
(grandpa/mother grandpa/mother))
(if-only (all! (succeeds grandpa/father) (succeeds grandpa/father))
grandpa/father grandpa/mother))))
(test-check 'test-grandpa-10
(solve 10 (x y) (grandpa x y))
'(((x.0 jon) (y.0 rob))
((x.0 jon) (y.0 roz))
((x.0 sam) (y.0 sal))
((x.0 sam) (y.0 pat))))
(test-check 'test-grandpa-10-1
(solve 10 (x) (grandpa x 'sue))
'(((x.0 sam))))
)
; Now do it with soft-cuts
(let
((grandpa
(let-gls (a1 a2) ((grandpa/father grandpa/father)
(grandpa/mother grandpa/mother))
(if-some grandpa/father succeed grandpa/mother)))
)
(test-check 'test-grandpa-10-soft-cut
(solve 10 (x y) (grandpa x y))
'(((x.0 jon) (y.0 rob))
((x.0 jon) (y.0 roz))
((x.0 sam) (y.0 sal))
((x.0 sam) (y.0 pat))))
)
(let*
((a-grandma
(relation (grandad grandchild)
(to-show grandad grandchild)
(_exists (parent)
(all! (mother grandad parent)))))
(no-grandma-grandpa
(let-gls (a1 a2) ((a-grandma a-grandma)
(grandpa (lift-to-relations (a1 a2)
(all!
(extend-relation (a1 a2)
grandpa/father grandpa/mother)))))
(if-only a-grandma fail grandpa)))
)
(test-check 'test-no-grandma-grandpa-1
(solve 10 (x) (no-grandma-grandpa 'roz x))
'()))
))
(let
((parents-of-scouts
(extend-relation (a1 a2)
(fact () 'sam 'rob)
(fact () 'roz 'sue)
(fact () 'rob 'sal)))
(fathers-of-cubscouts
(extend-relation (a1 a2)
(fact () 'sam 'bob)
(fact () 'tom 'adam)
(fact () 'tad 'carl)))
)
(test-check 'test-partially-eval-sgl
(let-lv (p1 p2)
(let* ((parents-of-scouts-sgl
((parents-of-scouts p1 p2) empty-subst))
(cons@ (lambda@ (x y) (cons x y)))
(split1 (at@
partially-eval-sgl parents-of-scouts-sgl
cons@ (lambda () '())))
(a1 (car split1))
(split2 (at@ partially-eval-sgl (cdr split1) cons@
(lambda () '())))
(a2 (car split2))
(split3 (at@ partially-eval-sgl (cdr split2) cons@
(lambda () '())))
(a3 (car split3)))
(map (lambda (subst)
(reify-subst (list p1 p2) subst))
(list a1 a2 a3))))
'(((p1.0 sam) (p2.0 rob)) ((p1.0 roz) (p2.0 sue)) ((p1.0 rob) (p2.0 sal))))
)
(test-check 'test-pred1
(let ((test1
(lambda (x)
(any (predicate (< 4 5))
(== x (< 6 7))))))
(solution (x) (test1 x)))
'((x.0 _.0)))
(test-check 'test-pred2
(let ((test2
(lambda (x)
(any (predicate (< 5 4))
(== x (< 6 7))))))
(solution (x) (test2 x)))
'((x.0 #t)))
(test-check 'test-pred3
(let ((test3
(lambda (x y)
(any
(== x (< 5 4))
(== y (< 6 7))))))
(solution (x y) (test3 x y)))
`((x.0 #f) (y.0 _.0)))
(test-check 'test-Seres-Spivey
(let ((father
(lambda (dad child)
(any
(all (== dad 'jon) (== child 'sam))
(all (== dad 'sam) (== child 'rob))
(all (== dad 'sam) (== child 'roz))
(all (== dad 'rob) (== child 'sal))
(all (== dad 'rob) (== child 'pat))
(all (== dad 'jon) (== child 'hal))
(all (== dad 'hal) (== child 'ted))
(all (== dad 'sam) (== child 'jay))))))
(letrec
((ancestor
(lambda (old young)
(any
(father old young)
(_exists (not-so-old)
(all
(father old not-so-old)
(ancestor not-so-old young)))))))
(solve 20 (x) (ancestor 'jon x))))
'(((x.0 sam))
((x.0 hal))
((x.0 rob))
((x.0 roz))
((x.0 jay))
((x.0 sal))
((x.0 pat))
((x.0 ted))))
(let ()
(define towers-of-hanoi
(letrec
((move
(extend-relation (a1 a2 a3 a4)
(fact () 0 __ __ __)
(relation (n a b c)
(to-show n a b c)
(project (n)
(if-only (predicate (positive? n))
(let ((m (- n 1)))
(all
(move m a c b)
(project (a b)
(begin
(cout "Move a disk from " a " to " b nl)
(move m c b a)))))))))))
(relation (n)
(to-show n)
(move n 'left 'middle 'right))))
(cout "test-towers-of-hanoi with 3 disks: "
(solution () (towers-of-hanoi 3))
nl nl
))
(test-check 'test-fun-resubst
(reify
(let ((j (relation (x w z)
(to-show z)
(let ((x 4)
(w 3))
(== z (cons x w))))))
(solve 4 (q) (j q))))
'(((q.0 (4 . 3)))))
(let ()
(define towers-of-hanoi-path
(let ((steps '()))
(let ((push-step (lambda (x y) (set! steps (cons `(,x ,y) steps)))))
(letrec
((move
(extend-relation (a1 a2 a3 a4)
(fact () 0 __ __ __)
(relation (n a b c)
(to-show n a b c)
(project (n)
(if-only (predicate (positive? n))
(let ((m (- n 1)))
(all
(move m a c b)
(project (a b)
(begin
(push-step a b)
(move m c b a)))))))))))
(relation (n path)
(to-show n path)
(begin
(set! steps '())
(any
(fails (move n 'l 'm 'r))
(== path (reverse steps)))))))))
(test-check 'test-towers-of-hanoi-path
(solution (path) (towers-of-hanoi-path 3 path))
'((path.0 ((l m) (l r) (m r) (l m) (r l) (r m) (l m))))))
;------------------------------------------------------------------------
(test-check 'unification-of-free-vars-1
(solve 1 (x)
(let-lv (y)
(all!! (== x y) (== y 5))))
'(((x.0 5))))
(test-check 'unification-of-free-vars-2
(solve 1 (x)
(let-lv (y)
(all!! (== y 5) (== x y))))
'(((x.0 5))))
(test-check 'unification-of-free-vars-3
(solve 1 (x)
(let-lv (y)
(all!! (== y x) (== y 5))))
'(((x.0 5))))
(test-check 'unification-of-free-vars-3
(solve 1 (x)
(let-lv (y)
(all!! (== x y) (== y 5) (== x y))))
'(((x.0 5))))
(test-check 'unification-of-free-vars-4
(solve 1 (x)
(_exists (y)
(all! (== y x) (== y 5) (== x y))))
'(((x.0 5))))
(letrec
((concat
(lambda (xs ys)
(cond
((null? xs) ys)
(else (cons (car xs) (concat (cdr xs) ys)))))))
(test-check 'test-concat-as-function
(concat '(a b c) '(u v))
'(a b c u v))
(test-check 'test-fun-concat
(solve 1 (q)
(== q (concat '(a b c) '(u v))))
'(((q.0 (a b c u v)))))
)
; Now the same with the relation
(letrec
((concat
(extend-relation (a1 a2 a3)
(fact (xs) '() xs xs)
(relation (x xs (once ys) zs)
(to-show `(,x . ,xs) ys `(,x . ,zs))
(concat xs ys zs)))))
(test-check 'test-concat
(values
(and
(equal?
(solve 6 (q) (concat '(a b c) '(u v) q))
'(((q.0 (a b c u v)))))
(equal?
(solve 6 (q) (concat '(a b c) q '(a b c u v)))
'(((q.0 (u v)))))
(equal?
(solve 6 (q) (concat q '(u v) '(a b c u v)))
'(((q.0 (a b c)))))
(equal?
(solve 6 (q r) (concat q r '(a b c u v)))
'(((q.0 ()) (r.0 (a b c u v)))
((q.0 (a)) (r.0 (b c u v)))
((q.0 (a b)) (r.0 (c u v)))
((q.0 (a b c)) (r.0 (u v)))
((q.0 (a b c u)) (r.0 (v)))
((q.0 (a b c u v)) (r.0 ()))))
(equal?
(solve 6 (q r s) (concat q r s))
'(((q.0 ()) (r.0 _.0) (s.0 _.0))
((q.0 (_.0)) (r.0 _.1) (s.0 (_.0 . _.1)))
((q.0 (_.0 _.1)) (r.0 _.2) (s.0 (_.0 _.1 . _.2)))
((q.0 (_.0 _.1 _.2)) (r.0 _.3) (s.0 (_.0 _.1 _.2 . _.3)))
((q.0 (_.0 _.1 _.2 _.3)) (r.0 _.4) (s.0 (_.0 _.1 _.2 _.3 . _.4)))
((q.0 (_.0 _.1 _.2 _.3 _.4)) (r.0 _.5)
(s.0 (_.0 _.1 _.2 _.3 _.4 . _.5))))
)
'(equal?
(solve 6 (q r) (concat q '(u v) `(a b c . ,r)))
'(((q.0 (a b c)) (r.0 (u v)))
((q.0 (a b c _.0)) (r.0 (_.0 u v)))
((q.0 (a b c _.0 _.1)) (r.0 (_.0 _.1 u v)))
((q.0 (a b c _.0 _.1 _.2)) (r.0 (_.0 _.1 _.2 u v)))
((q.0 (a b c _.0 _.1 _.2 _.3)) (r.0 (_.0 _.1 _.2 _.3 u v)))
((q.0 (a b c _.0 _.1 _.2 _.3 _.4))
(r.0 (_.0 _.1 _.2 _.3 _.4 u v)))))
(equal?
(solve 6 (q) (concat q '() q))
'(((q.0 ()))
((q.0 (_.0)))
((q.0 (_.0 _.1)))
((q.0 (_.0 _.1 _.2)))
((q.0 (_.0 _.1 _.2 _.3)))
((q.0 (_.0 _.1 _.2 _.3 _.4)))))
))
#t)
)
; Using the properties of the unifier to do the proper garbage
; collection of logical vars
; (test-check 'lv-elim-1
; (reify
; (let-lv (x z dummy)
; (at@
; (_exists (y)
; (== `(,x ,z ,y) `(5 9 ,x)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((y.0 . 5) (z.0 . 9) (x.0 . 5) (dummy.0 . dummy)))
; ;'((z.0 . 9) (x.0 . 5) (dummy.0 . dummy)))
; (test-check 'lv-elim-2
; (reify
; (let-lv (x dummy)
; (at@
; (_exists (y)
; (== `(,x ,y) `((5 ,y) ,7)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((y.0 . 7) (x.0 5 y.0) (dummy.0 . dummy)))
; ;'((a*.0 . 7) (x.0 5 a*.0) (dummy.0 . dummy)))
; ; verifying corollary 2 of proposition 10
; (test-check 'lv-elim-3
; (reify
; (let-lv (x v dummy)
; (at@
; (_exists (y)
; (== x `(a b c ,v d)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((x.0 a b c v.0 d) (dummy.0 . dummy)))
; ;'((a*.0 . v.0) (x.0 a b c a*.0 d) (dummy.0 . dummy)))
; ; pruning several variables sequentially and in parallel
; (test-check 'lv-elim-4-1
; (reify
; (let-lv (x v b dummy)
; (at@
; (let-lv (y)
; (== `(,b ,x ,y) `(,x ,y 1)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy)))
; ; (test-check 'lv-elim-4-2
; ; (concretize
; ; (let-lv (v b dummy)
; ; (at@
; ; (_exists (x)
; ; (_exists (y)
; ; (== `(,b ,x ,y) `(,x ,y 1))))
; ; (lambda@ (fk subst) subst)
; ; initial-fk
; ; (unit-subst dummy 'dummy))))
; ; '((b.0 . 1) (dummy.0 . dummy)))
; ; (test-check 'lv-elim-4-3
; ; (concretize
; ; (let-lv (v b dummy)
; ; (at@
; ; (_exists (y)
; ; (_exists (x)
; ; (== `(,b ,x ,y) `(,x ,y 1))))
; ; (lambda@ (fk subst) subst)
; ; initial-fk
; ; (unit-subst dummy 'dummy))))
; ; '((b.0 . 1) (dummy.0 . dummy)))
; (test-check 'lv-elim-4-4
; (reify
; (let-lv (v b dummy)
; (at@
; (_exists (x y)
; (== `(,b ,x ,y) `(,x ,y 1)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy)))
; ;'((b.0 . 1) (dummy.0 . dummy)))
; ; pruning several variables sequentially and in parallel
; ; for indirect (cyclic) dependency
; (test-check 'lv-elim-5-1
; (reify
; (let-lv (x v b dummy)
; (at@
; (let-lv (y)
; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy)))
; ;'((x.0 1 a*.0) (a*.0 . x.0) (y.0 1 a*.0) (b.0 . x.0) (dummy.0 . dummy)))
; ; (test-check 'lv-elim-5-2
; ; (concretize
; ; (let-lv (v b dummy)
; ; (at@
; ; (_exists (x)
; ; (_exists (y)
; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))))
; ; (lambda@ (fk subst) subst)
; ; initial-fk
; ; (unit-subst dummy 'dummy))))
; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
; ; (test-check 'lv-elim-5-3
; ; (concretize
; ; (let-lv (v b dummy)
; ; (at@
; ; (_exists (y)
; ; (_exists (x)
; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))))
; ; (lambda@ (fk subst) subst)
; ; initial-fk
; ; (unit-subst dummy 'dummy))))
; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
; (test-check 'lv-elim-5-4
; (reify
; (let-lv (v b dummy)
; (at@
; (_exists (x y)
; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))
; (lambda@ (fk subst) subst)
; initial-fk
; (unit-subst dummy 'dummy))))
; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy)))
; ;'((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
; ; We should only be concerned about a direct dependency:
; ; ((x . y) (y . (1 t)) (t . x) (a . x))
; ; pruning x and y in sequence or in parallel gives the same result:
; ; ((t . (1 t)) (a . (1 t)))
; Extending relations in truly mathematical sense.
; First, why do we need this.
(let*
((fact1 (fact () 'x1 'y1))
(fact2 (fact () 'x2 'y2))
(fact3 (fact () 'x3 'y3))
(fact4 (fact () 'x4 'y4))
; R1 and R2 are overlapping
(R1 (extend-relation (a1 a2) fact1 fact2))
(R2 (extend-relation (a1 a2) fact1 fact3))
)
; Infinitary relation
; r(z,z).
; r(s(X),s(Y)) :- r(X,Y).
(letrec
((Rinf
(extend-relation (a1 a2)
(fact () 'z 'z)
(relation (x y t1 t2)
(to-show t1 t2)
(all
(== t1 `(s ,x))
(== t2 `(s ,y))
(Rinf x y)))))
)
(cout nl "R1:" nl)
(_pretty-print (solve 10 (x y) (R1 x y)))
(cout nl "R2:" nl)
(_pretty-print (solve 10 (x y) (R2 x y)))
(cout nl "R1+R2:" nl)
(_pretty-print
(solve 10 (x y)
((extend-relation (a1 a2) R1 R2) x y)))
(cout nl "Rinf:" nl)
(values (_pretty-print (solve 5 (x y) (Rinf x y))))
(cout nl "Rinf+R1: Rinf starves R1:" nl)
(values
(_pretty-print
(solve 5 (x y)
((extend-relation (a1 a2) Rinf R1) x y))))
; Solving the starvation problem: extend R1 and R2 so that they
; are interleaved
; ((sf-extend R1 R2) sk fk)
; (R1 sk fk)
; If R1 fails, we try the rest of R2
; If R1 succeeds, it executes (sk fk)
; with fk to re-prove R1. Thus fk is the "rest" of R1
; So we pass sk (lambda () (run-rest-of-r2 interleave-with-rest-of-r1))
; There is a fixpoint in the following algorithm!
; Or a second-level shift/reset!
(test-check "Rinf+R1"
(values
(solve 7 (x y)
(any-interleave (Rinf x y) (R1 x y))))
'(((x.0 z) (y.0 z))
((x.0 x1) (y.0 y1))
((x.0 (s z)) (y.0 (s z)))
((x.0 x2) (y.0 y2))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))
)
(test-check "R1+Rinf"
(values
(solve 7 (x y)
(any-interleave (R1 x y) (Rinf x y))))
'(((x.0 x1) (y.0 y1))
((x.0 z) (y.0 z))
((x.0 x2) (y.0 y2))
((x.0 (s z)) (y.0 (s z)))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))
)
(test-check "R2+R1"
(solve 7 (x y)
(any-interleave (R2 x y) (R1 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x1) (y.0 y1))
((x.0 x3) (y.0 y3))
((x.0 x2) (y.0 y2)))
)
(test-check "R1+fact3"
(solve 7 (x y)
(any-interleave (R1 x y) (fact3 x y)))
'(((x.0 x1) (y.0 y1)) ((x.0 x3) (y.0 y3)) ((x.0 x2) (y.0 y2)))
)
(test-check "fact3+R1"
(solve 7 (x y)
(any-interleave (fact3 x y) (R1 x y)))
'(((x.0 x3) (y.0 y3)) ((x.0 x1) (y.0 y1)) ((x.0 x2) (y.0 y2)))
)
; testing all-interleave
(test-check 'all-interleave-1
(solve 100 (x y z)
(all-interleave
(any (== x 1) (== x 2))
(any (== y 3) (== y 4))
(any (== z 5) (== z 6) (== z 7))))
'(((x.0 1) (y.0 3) (z.0 5))
((x.0 2) (y.0 3) (z.0 5))
((x.0 1) (y.0 4) (z.0 5))
((x.0 2) (y.0 4) (z.0 5))
((x.0 1) (y.0 3) (z.0 6))
((x.0 2) (y.0 3) (z.0 6))
((x.0 1) (y.0 4) (z.0 6))
((x.0 2) (y.0 4) (z.0 6))
((x.0 1) (y.0 3) (z.0 7))
((x.0 2) (y.0 3) (z.0 7))
((x.0 1) (y.0 4) (z.0 7))
((x.0 2) (y.0 4) (z.0 7)))
)
(test-check "R1 * Rinf: clearly starvation"
(solve 5 (x y u v)
(all (R1 x y) (Rinf u v)))
; indeed, only the first choice of R1 is apparent
'(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z))
((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z)))
((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z))))
((x.0 x1) (y.0 y1) (u.0 (s (s (s z)))) (v.0 (s (s (s z)))))
((x.0 x1) (y.0 y1) (u.0 (s (s (s (s z))))) (v.0 (s (s (s (s z)))))))
)
(test-check "R1 * Rinf: interleaving"
(solve 5 (x y u v)
(all-interleave (R1 x y) (Rinf u v)))
; both choices of R1 are apparent
'(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z))
((x.0 x2) (y.0 y2) (u.0 z) (v.0 z))
((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z)))
((x.0 x2) (y.0 y2) (u.0 (s z)) (v.0 (s z)))
((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z)))))
)
;; Test for nonoverlapping.
(cout nl "any-union" nl)
(test-check "R1+R2"
(solve 10 (x y)
(any-union (R1 x y) (R2 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x2) (y.0 y2))
((x.0 x3) (y.0 y3))))
(test-check "R2+R1"
(solve 10 (x y)
(any-union (R2 x y) (R1 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x3) (y.0 y3))
((x.0 x2) (y.0 y2))))
(test-check "R1+R1"
(solve 10 (x y)
(any-union (R1 x y) (R1 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x2) (y.0 y2))))
(test-check "Rinf+R1"
(solve 7 (x y)
(any-union (Rinf x y) (R1 x y)))
'(((x.0 z) (y.0 z))
((x.0 x1) (y.0 y1))
((x.0 (s z)) (y.0 (s z)))
((x.0 x2) (y.0 y2))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
(test-check "R1+RInf"
(solve 7 (x y)
(any-union (R1 x y) (Rinf x y)))
'(((x.0 x1) (y.0 y1))
((x.0 z) (y.0 z))
((x.0 x2) (y.0 y2))
((x.0 (s z)) (y.0 (s z)))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
; Infinitary relation Rinf2
; r(z,z).
; r(s(s(X)),s(s(Y))) :- r(X,Y).
; Rinf2 overlaps with Rinf in the infinite number of points
(letrec
((Rinf2
(extend-relation (a1 a2)
(fact () 'z 'z)
(relation (x y t1 t2)
(to-show t1 t2)
(all
(== t1 `(s (s ,x)))
(== t2 `(s (s ,y)))
(Rinf2 x y)))))
)
(test-check "Rinf2"
(solve 5 (x y) (Rinf2 x y))
'(((x.0 z) (y.0 z))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
((x.0 (s (s (s (s (s (s z)))))))
(y.0 (s (s (s (s (s (s z))))))))
((x.0 (s (s (s (s (s (s (s (s z)))))))))
(y.0 (s (s (s (s (s (s (s (s z))))))))))))
(test-check "Rinf+Rinf2"
(solve 9 (x y)
(any-union (Rinf x y) (Rinf2 x y)))
'(((x.0 z) (y.0 z))
((x.0 (s z)) (y.0 (s z)))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s (s (s z)))))))
(y.0 (s (s (s (s (s (s z))))))))
((x.0 (s (s (s (s (s (s (s (s z)))))))))
(y.0 (s (s (s (s (s (s (s (s z))))))))))
((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z)))))))
((x.0 (s (s (s (s (s (s (s (s (s (s z)))))))))))
(y.0 (s (s (s (s (s (s (s (s (s (s z))))))))))))))
(test-check "Rinf2+Rinf"
(solve 9 (x y)
(any-union (Rinf2 x y) (Rinf x y)))
'(((x.0 z) (y.0 z))
((x.0 (s z)) (y.0 (s z)))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z)))))))
((x.0 (s (s (s (s (s (s z)))))))
(y.0 (s (s (s (s (s (s z))))))))
((x.0 (s (s (s (s (s (s (s z))))))))
(y.0 (s (s (s (s (s (s (s z)))))))))
((x.0 (s (s (s (s (s (s (s (s z)))))))))
(y.0 (s (s (s (s (s (s (s (s z))))))))))))
)))
(cout nl "Append with limited depth" nl)
; In Prolog, we normally write:
; append([],L,L).
; append([X|L1],L2,[X|L3]) :- append(L1,L2,L3).
;
; If we switch the clauses, we get non-termination.
; In our system, it doesn't matter!
(letrec
((extend-clause-1
(relation (l)
(to-show '() l l)
succeed))
(extend-clause-2
(relation (x l1 l2 l3)
(to-show `(,x . ,l1) l2 `(,x . ,l3))
(extend-rel l1 l2 l3)))
(extend-rel
(extend-relation-with-recur-limit 5 (a b c)
extend-clause-1
extend-clause-2))
)
; Note (solve 100 ...)
; Here 100 is just a large number: we want to print all solutions
(cout nl "Extend: clause1 first: "
(solve 100 (a b c) (extend-rel a b c))
nl))
(letrec
((extend-clause-1
(relation (l)
(to-show '() l l)
succeed))
(extend-clause-2
(relation (x l1 l2 l3)
(to-show `(,x . ,l1) l2 `(,x . ,l3))
(extend-rel l1 l2 l3)))
(extend-rel
(extend-relation-with-recur-limit 3 (a b c)
extend-clause-2
extend-clause-1)))
(cout nl "Extend: clause2 first. In Prolog, it would diverge!: "
(solve 100 (a b c) (extend-rel a b c)) nl))
(letrec
((base-+-as-relation
(fact (n) 'zero n n))
(recursive-+-as-relation
(relation (n1 n2 n3)
(to-show `(succ ,n1) n2 `(succ ,n3))
(plus-as-relation n1 n2 n3)))
; Needed eta-expansion here: otherwise, SCM correctly reports
; an error (but Petite doesn't, alas)
; This is a peculiarity of extend-relation as a macro
; Potentially, we need the same approach as in minikanren
(plus-as-relation
(extend-relation (a1 a2 a3)
(lambda (a1 a2 a3) (base-+-as-relation a1 a2 a3))
(lambda (a1 a2 a3) (recursive-+-as-relation a1 a2 a3))
))
)
(test-check "Addition"
(solve 20 (x y)
(plus-as-relation x y '(succ (succ (succ (succ (succ zero)))))))
'(((x.0 zero) (y.0 (succ (succ (succ (succ (succ zero)))))))
((x.0 (succ zero)) (y.0 (succ (succ (succ (succ zero))))))
((x.0 (succ (succ zero))) (y.0 (succ (succ (succ zero)))))
((x.0 (succ (succ (succ zero)))) (y.0 (succ (succ zero))))
((x.0 (succ (succ (succ (succ zero))))) (y.0 (succ zero)))
((x.0 (succ (succ (succ (succ (succ zero)))))) (y.0 zero))))
(newline)
)
10)
;; ========================================================================
;; type-inference example
;; ========================================================================
; Type Inference
;
; We show two variations of Hindley-Milner type inference. Both
; variations support polymorphic, generalizing `let'. Both variations
; use Kanren's logical variables for type variables, and take advantage
; of Kanren's unifier to solve the equations that arise during the course
; of type inference. These features make the Kanren realization of the
; type inference algorithm concise and lucid.
;
; The variations differ in the syntax of the `source' language, and in
; the way type environments are implemented. One variation realizes
; type environments as regular lists, of associations between symbolic
; variable names and their types. The other variation extends the type
; entailment relation (which is a first-class relation in Kanren). The
; latter approach is similar to that of inductive proofs (see files
; ./deduction.scm and ./mirror-equ.scm)
;
; $Id: type-inference.scm,v 4.50 2005/02/12 00:05:01 oleg Exp $
; (display "Type inference") (newline)
; Variation 1: use a subset of Scheme itself as the source language
; The following two functions translate between the source language
; and intermediate one.
(define parse
(lambda (e)
(cond
((symbol? e) `(var ,e))
((number? e) `(intc ,e))
((boolean? e) `(boolc ,e))
(else (case (car e)
((zero?) `(zero? ,(parse (cadr e))))
((sub1) `(sub1 ,(parse (cadr e))))
((+) `(+ ,(parse (cadr e)) ,(parse (caddr e))))
((if) `(if ,(parse (cadr e)) ,(parse (caddr e)) ,(parse (cadddr e))))
((fix) `(fix ,(parse (cadr e))))
((lambda) `(lambda ,(cadr e) ,(parse (caddr e))))
((let) `(let ((,(car (car (cadr e))) ,(parse (cadr (car (cadr e))))))
,(parse (caddr e))))
(else `(app ,(parse (car e)) ,(parse (cadr e)))))))))
(define unparse
(lambda (e)
(case (car e)
((var) (cadr e))
((intc) (cadr e))
((boolc) (cadr e))
((zero?) `(zero? ,(unparse (cadr e))))
((sub1) `(sub1 ,(unparse (cadr e))))
((+) `(+ ,(unparse (cadr e)) ,(unparse (caddr e))))
((if) `(if ,(unparse (cadr e)) ,(unparse (caddr e)) ,(unparse (cadddr e))))
((fix) `(fix ,(unparse (cadr e))))
((lambda) `(lambda (,(car (cadr e))) ,(unparse (caddr e))))
((let)
`(let ((,(car (car (cadr e)))
,(unparse (cadr (car (cadr e))))))
,(unparse (caddr e))))
((app) `(,(unparse (cadr e)) ,(unparse (caddr e)))))))
; Type environments
;
; A type environment (often denoted as \Gamma, or g in this code)
; is an association between the names of variables of source language
; terms and the types of those variables.
; As a side condition, each variable may occur in the list
; exactly once.
; Hmm, to model lexical scope better, we may relax that condition.
;
; Here we implement type environments as regular associative lists,
; lists of triples:
; ( non-generic )
; ( generic )
;
; is a symbolic name of a source term variable.
; is a type term, e.g., int, bool, (--> int bool), etc.
; may include logical variables, which are treated then as
; type variables.
;
; The association '( generic )' asserts that
; is given a _generic_ type. then is a
; predicate of arity 1. To be more precise, ( )
; is an goal that succeeds or fails depending on the fact if
; is an instance of a generic type represented by .
;
; This is precisely the logical meaning of generalization, as
; pointed out by Ken:
;
; A cleaner, but less efficient, formulation of HM type inference is to
; use the following let rule instead:
;
; Gamma |- M : t Gamma |- N[M/x] : t'
; -------------------------------------- Let
; Gamma |- let x = M in N : t'
;
; Look ma, no FV! In words, this rule treats let as a construct for
; syntactic substitution. This means storing either M, or a thunk
; returning (a logical variable associated with a fresh copy of) the type
; of M, under x in the environment. This formulation avoids var? while
; taking advantage of built-in unification (to some extent).
;
;
; We must emphasize that in Kanren, relations are first-class, and may,
; therefore, be included as parts of a data structure: of an associative
; list in our case.
; Because type environments are regular lists, we can build them using
; regular cons. The empty type environemnt is the empty list. The
; following is a Kanren relation that searches the associative
; list. We are interested in the first match.
; The following is a general-purpose function
; (membero v l) holds if v is a member of the list l.
; 'v' must be sufficiently instantiated (at least, the search key
; must be instantiated, to justify our use of the committed choice
; non-determinism).
(define membero
(relation (v lt lh)
(to-show v `(,lh . ,lt))
(if-some (== v lh) succeed
(membero v lt))))
; The following is the type-environment-specific function.
; (env g v t) holds if the source term variable v has a type t
; in the environment g.
; We require that 'v' be instantiated, to justify our use
; of the committed choice non-determinism (e.g., membero).
(define env
(relation (head-let g v t)
(_exists (tq)
(all!!
(membero `(,v . ,tq) g)
(any
(== tq `(non-generic ,t))
(_exists (type-gen)
(all!!
(== tq `(generic ,type-gen))
(project (type-gen)
(type-gen t)))))))))
;;;; This starts the rules
(define int 'int)
(define bool 'bool)
(define var-rel
(relation (g v t)
(to-show g `(var ,v) t)
(all! (env g v t))))
(define int-rel
(fact (g x) g `(intc ,x) int))
(define bool-rel
(fact (g x) g `(boolc ,x) bool))
(define zero?-rel
(relation (g x)
(to-show g `(zero? ,x) bool)
(all! (!- g x int))))
(define sub1-rel
(relation (g x)
(to-show g `(sub1 ,x) int)
(all! (!- g x int))))
(define plus-rel
(relation (g x y)
(to-show g `(+ ,x ,y) int)
(all!! (!- g x int) (!- g y int))))
(define if-rel
(relation (g t test conseq alt)
(to-show g `(if ,test ,conseq ,alt) t)
(all!! (!- g test bool) (!- g conseq t) (!- g alt t))))
(define lambda-rel
(relation (g v t body type-v)
(to-show g `(lambda (,v) ,body) `(a--> ,type-v ,t))
(all! (!- `((,v non-generic ,type-v) . ,g) body t))))
(define app-rel
(relation (g t rand rator)
(to-show g `(app ,rator ,rand) t)
(_exists (t-rand)
(all!! (!- g rator `(a--> ,t-rand ,t)) (!- g rand t-rand)))))
(define fix-rel
(relation (g rand t)
(to-show g `(fix ,rand) t)
(all! (!- g rand `(a--> ,t ,t)))))
; Type-checking polymorphic let: (let ([,v ,rand]) ,body)
; There is obviously an inefficiency, because we typecheck `rand'
; every time the variable `v' occurs in the body (and once more).
; We can fix it, with copy term. But for now, we leave this optimization out.
; The reason to test `(!- g rand some-type)' at the very beginning is
; to make sure that `rand' itself is well-typed. As Ken pointed out,
; we must outlaw expressions such as (let ((x (z z))) y) where 'x'
; does not occur in the body. The variable 'x' still must have some
; type.
(define polylet-rel
(relation (g v rand body t)
(to-show g `(let ((,v ,rand)) ,body) t)
(all!!
(_exists (some-type) (!- g rand some-type))
(!- `((,v generic ,(relation (head-let t-rand)
(all!!
(!- g rand t-rand)
(trace-vars 'poly-let (t-rand rand)))))
. ,g)
body t))))
(define !-
(extend-relation (a1 a2 a3)
var-rel int-rel bool-rel zero?-rel sub1-rel plus-rel
if-rel lambda-rel app-rel fix-rel polylet-rel))
(define (ti-tests)
(test-check 'test-!-1
(and
(equal?
(solution (?) (!- '() '(intc 17) int))
'((?.0 _.0)))
(equal?
(solution (?) (!- '() '(intc 17) ?))
'((?.0 int))))
#t)
(test-check 'arithmetic-primitives
(solution (?) (!- '() '(zero? (intc 24)) ?))
'((?.0 bool)))
(test-check 'test-!-sub1
(solution (?) (!- '() '(zero? (sub1 (intc 24))) ?))
'((?.0 bool)))
(test-check 'test-!-+
(solution (?)
(!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
'((?.0 bool)))
(test-check 'test-!-2
(and
(equal?
(solution (?) (!- '() '(zero? (intc 24)) ?))
'((?.0 bool)))
(equal?
(solution (?) (!- '() '(zero? (+ (intc 24) (intc 50))) ?))
'((?.0 bool)))
(equal?
(solution (?)
(!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
'((?.0 bool))))
#t)
(test-check 'test-!-3
(solution (?) (!- '() '(if (zero? (intc 24)) (intc 3) (intc 4)) ?))
'((?.0 int)))
(test-check 'if-expressions
(solution (?)
(!- '() '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?))
'((?.0 bool)))
(test-check 'variables
(and
(equal?
(solution (?)
(env '((b non-generic int) (a non-generic bool)) 'a ?))
'((?.0 bool)))
(equal?
(solution (?)
(!- '((a non-generic int)) '(zero? (var a)) ?))
'((?.0 bool)))
(equal?
(solution (?)
(!- '((b non-generic bool) (a non-generic int))
'(zero? (var a))
?))
'((?.0 bool))))
#t)
(test-check 'variables-4a
(solution (?)
(!- '((b non-generic bool) (a non-generic int))
'(lambda (x) (+ (var x) (intc 5)))
?))
'((?.0 (a--> int int))))
(test-check 'variables-4b
(solution (?)
(!- '((b non-generic bool) (a non-generic int))
'(lambda (x) (+ (var x) (var a)))
?))
'((?.0 (a--> int int))))
(test-check 'variables-4c
(solution (?)
(!- '() '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?))
'((?.0 (a--> int (a--> int int)))))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!- '() (parse
'(lambda (f)
(lambda (x)
((f x) x))))
?))
'((?.0 (a-->
(a--> _.0 (a--> _.0 _.1))
(a--> _.0 _.1)))))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!- '()
(parse
'((fix (lambda (sum)
(lambda (n)
(if (zero? n)
0
(+ n (sum (sub1 n)))))))
10))
?))
'((?.0 int)))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!- '()
(parse
'((fix (lambda (sum)
(lambda (n)
(+ n (sum (sub1 n))))))
10))
?))
'((?.0 int)))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!- '()
(parse '((lambda (f)
(if (f (zero? 5))
(+ (f 4) 8)
(+ (f 3) 7)))
(lambda (x) x)))
?))
#f)
(test-check 'polymorphic-let
(solution (?)
(!- '()
(parse
'(let ((f (lambda (x) x)))
(if (f (zero? 5))
(+ (f 4) 8)
(+ (f 3) 7))))
?))
'((?.0 int)))
(test-check 'with-robust-syntax
(solution (?)
(!- '()
'(app
(fix
(lambda (sum)
(lambda (n)
(if (if (zero? (var n)) (boolc #t) (boolc #f))
(intc 0)
(+ (var n) (app (var sum) (sub1 (var n))))))))
(intc 10))
?))
'((?.0 int)))
(test-check 'with-robust-syntax-but-long-jumps/poly-let
(solution (?)
(!- '()
'(let ((f (lambda (x) (var x))))
(if (app (var f) (zero? (intc 5)))
(+ (app (var f) (intc 4)) (intc 8))
(+ (app (var f) (intc 3)) (intc 7))))
?))
'((?.0 int)))
(test-check 'type-habitation-1
(solution (g ?)
(!- g ? '(a--> int int)))
'((g.0 ((_.0 non-generic (a--> int int)) . _.1)) (?.0 (var _.0))))
(test-check 'type-habitation-2
(solution (g h r q z y t)
(!- g `(,h ,r (,q ,z ,y)) t))
'((g.0 ((_.0 non-generic int) . _.1))
(h.0 +)
(r.0 (var _.0))
(q.0 +)
(z.0 (var _.0))
(y.0 (var _.0))
(t.0 int))
)
(test-check 'type-habitation-3
(and
(equal?
(solution (la f b)
(!- '() `(,la (,f) ,b) '(a--> int int)))
'((la.0 lambda) (f.0 _.0) (b.0 (var _.0))))
(equal?
(solution (h r q z y t u v)
(!- '() `(,h ,r (,q ,z ,y)) `(,t ,u ,v)))
'((h.0 lambda)
(r.0 (_.0))
(q.0 +)
(z.0 (var _.0))
(y.0 (var _.0))
(t.0 a-->)
(u.0 int)
(v.0 int))))
#t)
10)
;----------------------------------------------------------------------
; A different implementation of type environments
; We define a first-class (and recursive) relation !-
; so that (!- `(var ,v) t) holds iff the source term variable v has a type
; t.
; This variant is close to the `natural deduction' scheme.
; It also has an OO flavor: we need open recursion.
; The following are the separate components of which the relation
; !- will be built. All these components nevertheless receive the full
; !- as the argument. Actually, they will receive the 'self'-like
; argument. We need to explicitly find the fixpoint.
; (cout nl "Natural-deduction-like type inference" nl nl)
(define pint-rel
(lambda (s!-)
(fact (x) `(intc ,x) int)))
(define pbool-rel
(lambda (s!-)
(fact (x) `(boolc ,x) bool)))
(define pzero?-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (x)
(to-show `(zero? ,x) bool)
(all! (!- x int))))))
(define psub1-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (x)
(to-show `(sub1 ,x) int)
(all! (!- x int))))))
(define p+-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (x y)
(to-show `(+ ,x ,y) int)
(all!! (!- x int) (!- y int))))))
(define pif-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (t test conseq alt)
(to-show `(if ,test ,conseq ,alt) t)
(all!! (!- test bool) (!- conseq t) (!- alt t))))))
; Here we extend !- with an additional assumption that v has the type
; type-v. This extension corresponds to a non-generic, regular type.
(define plambda-rel
(lambda (s!-)
(relation (v t body type-v)
(to-show `(lambda (,v) ,body) `(a--> ,type-v ,t))
(let* ((snew-!-
(lambda (self)
(extend-relation (v t)
(fact () `(var ,v) type-v) ; lexically-scoped relation
(s!- self))))
(!- (snew-!- snew-!-)))
(all! (!- body t))))))
(define papp-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (t rand rator)
(to-show `(app ,rator ,rand) t)
(_exists (t-rand)
(all!! (!- rator `(a--> ,t-rand ,t)) (!- rand t-rand)))))))
(define pfix-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (rand t)
(to-show `(fix ,rand) t)
(all! (!- rand `(a--> ,t ,t)))))))
; Type-checking polymorphic let: (let ((,v ,rand)) ,body)
; There is obviously an inefficiency, because we typecheck `rand'
; every time the variable `v' occurs in the body (and once more).
; We can fix it, with copy term. But for now, we leave this optimization out.
; The reason to test `(!- g rand some-type)' at the very beginning is
; to make sure that `rand' itself is well-typed. As Ken pointed out,
; we must outlaw expressions such as (let ((x (z z))) y) where 'x'
; does not occur in the body. The variable 'x' still must have some
; type.
(define ppolylet-rel
(lambda (s!-)
(let ((!- (s!- s!-)))
(relation (v rand body t)
(to-show `(let ((,v ,rand)) ,body) t)
(all!!
(_exists (some-type) (!- rand some-type))
(let* ((snew-!-
(lambda (self)
(extend-relation (v t)
(relation (head-let `(var ,v) t-rand)
(all!!
(!- rand t-rand)
(trace-vars 'poly-let (t-rand rand))))
(s!- self))))
(!- (snew-!- snew-!-)))
(!- body t)))))))
; Now we build the recursive !- relation, as a fixpoint
(define s!-
(lambda (self)
(lambda (v t)
((extend-relation (a1 a2)
(pint-rel self)
(pbool-rel self) (pzero?-rel self)
(psub1-rel self) (p+-rel self)
(pif-rel self) (plambda-rel self)
(papp-rel self) (pfix-rel self)
(ppolylet-rel self)) v t))))
(define !-/2 (s!- s!-))
; And we re-do all the tests
(define (ti-tests-2)
(test-check 'test-!-1
(and
(equal?
(solution (?) (!-/2 '(intc 17) int))
'((?.0 _.0)))
(equal?
(solution (?) (!-/2 '(intc 17) ?))
'((?.0 int))))
#t)
(test-check 'arithmetic-primitives
(solution (?) (!-/2 '(zero? (intc 24)) ?))
'((?.0 bool)))
(test-check 'test-!-sub1
(solution (?) (!-/2 '(zero? (sub1 (intc 24))) ?))
'((?.0 bool)))
(test-check 'test-!-+
(solution (?)
(!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
'((?.0 bool)))
(test-check 'test-!-2
(and
(equal?
(solution (?) (!-/2 '(zero? (intc 24)) ?))
'((?.0 bool)))
(equal?
(solution (?) (!-/2 '(zero? (+ (intc 24) (intc 50))) ?))
'((?.0 bool)))
(equal?
(solution (?)
(!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
'((?.0 bool))))
#t)
(test-check 'test-!-3
(solution (?) (!-/2 '(if (zero? (intc 24)) (intc 3) (intc 4)) ?))
'((?.0 int)))
(test-check 'if-expressions
(solution (?)
(!-/2 '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?))
'((?.0 bool)))
; Commented out: we need to extend !- if we wish to typecheck open terms
'(test-check 'variables
(and
(equal?
(solution (?)
(env '((b non-generic int) (a non-generic bool)) 'a ?))
'((?.0 bool)))
(equal?
(solution (?)
(!-/2 '((a non-generic int)) '(zero? (var a)) ?))
'((?.0 bool)))
(equal?
(solution (?)
(!-/2 '((b non-generic bool) (a non-generic int))
'(zero? (var a))
?))
'((?.0 bool))))
#t)
(test-check 'variables-4a
(solution (?)
(!-/2 '(lambda (x) (+ (var x) (intc 5)))
?))
'((?.0 (a--> int int))))
; Commented out: we need to extend !- if we wish to typecheck open terms
'(test-check 'variables-4b
(solution (?)
(!-/2 '((b non-generic bool) (a non-generic int))
'(lambda (x) (+ (var x) (var a)))
?))
'((?.0 (a--> int int))))
(test-check 'variables-4c
(solution (?)
(!-/2 '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?))
'((?.0 (a--> int (a--> int int)))))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!-/2 (parse
'(lambda (f)
(lambda (x)
((f x) x))))
?))
'((?.0 (a-->
(a--> _.0 (a--> _.0 _.1))
(a--> _.0 _.1)))))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!-/2 (parse
'((fix (lambda (sum)
(lambda (n)
(if (zero? n)
0
(+ n (sum (sub1 n)))))))
10))
?))
'((?.0 int)))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!-/2 (parse
'((fix (lambda (sum)
(lambda (n)
(+ n (sum (sub1 n))))))
10))
?))
'((?.0 int)))
(test-check 'everything-but-polymorphic-let
(solution (?)
(!-/2 (parse '((lambda (f)
(if (f (zero? 5))
(+ (f 4) 8)
(+ (f 3) 7)))
(lambda (x) x)))
?))
#f)
(test-check 'polymorphic-let
(solution (?)
(!-/2 (parse
'(let ((f (lambda (x) x)))
(if (f (zero? 5))
(+ (f 4) 8)
(+ (f 3) 7))))
?))
'((?.0 int)))
(test-check 'with-robust-syntax
(solution (?)
(!-/2 '(app
(fix
(lambda (sum)
(lambda (n)
(if (if (zero? (var n)) (boolc #t) (boolc #f))
(intc 0)
(+ (var n) (app (var sum) (sub1 (var n))))))))
(intc 10))
?))
'((?.0 int)))
(test-check 'with-robust-syntax-but-long-jumps/poly-let
(solution (?)
(!-/2 '(let ((f (lambda (x) (var x))))
(if (app (var f) (zero? (intc 5)))
(+ (app (var f) (intc 4)) (intc 8))
(+ (app (var f) (intc 3)) (intc 7))))
?))
'((?.0 int)))
; The latter doesn't work: but it wasn't too informative anyway
'(test-check 'type-habitation-1
(solution (?)
(!-/2 ? '(a--> int int)))
'((g.0 ((v.0 non-generic (a--> int int)) . lt.0)) (?.0 (var v.0))))
(test-check 'type-habitation-2
(solution (h r q z y t)
(!-/2 `(,h ,r (,q ,z ,y)) t))
'((h.0 +)
(r.0 (intc _.0))
(q.0 +)
(z.0 (intc _.1))
(y.0 (intc _.2))
(t.0 int))
)
(test-check 'type-habitation-3
(and
(equal?
(solution (la f b)
(!-/2 `(,la (,f) ,b) '(a--> int int)))
'((la.0 lambda) (f.0 _.0) (b.0 (var _.0))))
(equal?
(solution (h r q z y t u v)
(!-/2 `(,h ,r (,q ,z ,y)) `(,t ,u ,v)))
'((h.0 lambda)
(r.0 (_.0))
(q.0 +)
(z.0 (var _.0))
(y.0 (var _.0))
(t.0 a-->)
(u.0 int)
(v.0 int))))
#t)
10)
; The code below uses the low-level function var? Every use of var?
; entails a proof obligation that such use is safe. In our case here,
; invertible-binary-function->ternary-relation and
; invertible-unary-function->binary-relation are sound.
(define invertible-binary-function->ternary-relation
(lambda (op inverted-op)
(relation (head-let x y z)
(project/no-check (z)
(if-only (predicate (var? z))
(project (x y) (== z (op x y))) ; z is free, x and y must not
(project/no-check (y)
(if-only (predicate (var? y)) ; y is free, z is not
(project (x)
(== y (inverted-op z x)))
(project/no-check (x)
(if-only (predicate (var? x)) ; x is free, y and z are not
(== x (inverted-op z y))
(== z (op x y)))))))))))
(define t++ (invertible-binary-function->ternary-relation + -))
(define t-- (invertible-binary-function->ternary-relation - +))
(define ** (invertible-binary-function->ternary-relation * /))
(define // (invertible-binary-function->ternary-relation / *))
(define symbol->lnum
(lambda (sym)
(map char->integer (string->list (symbol->string sym)))))
(define lnum->symbol
(lambda (lnums)
(string->symbol (list->string (map integer->char lnums)))))
(define invertible-unary-function->binary-relation
(lambda (op inverted-op)
(relation (head-let x y)
(project/no-check (y)
(if-only (predicate (var? y))
(project (x) (== y (op x))) ; y is free, x must not
(project/no-check (x)
(if-only (predicate (var? x))
(== x (inverted-op y))
(== y (op x)))))))))
(define name
(invertible-unary-function->binary-relation symbol->lnum lnum->symbol))
(define (ti-tests-3)
(test-check 'test-instantiated-1
(and
(equal?
(solution (x) (t++ x 16.0 8))
'((x.0 -8.0)))
(equal?
(solution (x) (t++ 10 16.0 x))
'((x.0 26.0)))
(equal?
(solution (x) (t-- 10 x 3))
'((x.0 13))))
#t)
(test-check 'test-instantiated-2
(and
(equal?
(solution (x) (name 'sleep x))
'((x.0 (115 108 101 101 112))))
(equal?
(solution (x) (name x '(115 108 101 101 112)))
'((x.0 sleep))))
#t)
10)
;; ========================================================================
;; typeclasses example
;; ========================================================================
;(newline)
;(display "Checking for dependency satisfaction in Haskell typeclasses")
;(newline)
; Suppose we have the following Haskell class and instance declarations
; class C a b c | a b -> c
; instance C a b c => C a (x,y,b) c
; instance C a (a,c,b) c
;
; They will be compiled into the following database of instances,
; which define the class membership.
(define typeclass-C-instance-1
(relation (a b c x y)
(to-show a `(,x ,y ,b) c)
(typeclass-C a b c)))
(define typeclass-C-instance-2
(relation (a b c)
(to-show a `(,a ,c ,b) c)
succeed))
(define typeclass-C
(extend-relation (a b c)
typeclass-C-instance-2
typeclass-C-instance-1))
; Run the checker for the dependency a b -> c
; Try to find the counter-example, that is, two members of (C a b c)
; such that a's and b's are the same but the c's are different.
(define typeclass-counter-example-query
(lambda (a b c1 c2)
(all
(typeclass-C a b c1)
(typeclass-C a b c2)
(fails (project/no-check (c1 c2) (predicate (*equal? c1 c2)))))))
; This does loop
;'(define typeclass-C
; (extend-relation (a b c)
; typeclass-C-instance-1
; typeclass-C-instance-2))
(define typeclass-C/x
(extend-relation-with-recur-limit 2 (a b c)
typeclass-C-instance-1
typeclass-C-instance-2))
; (pntall "~%Test: checking dependency satisfaction: Another example.~%")
; Suppose we have the following Haskell class and instance declarations
; class F a b | a->b
; instance F a b => F [a] [b]
; instance F [a] a
;
(define typeclass-F
(extend-relation-with-recur-limit 10 (a b)
(relation (a b)
(to-show `(list ,a) `(list ,b))
(typeclass-F a b))
(fact (a) `(list ,a) a)))
; Run the checker for the dependency a -> b
; Try to find the counter-example, that is, two members of (F a b)
; such that as is the same but bs are different.
(define typeclass-F-counter-example-query
(lambda (a b1 b2)
(all
(typeclass-F a b1)
(typeclass-F a b2)
(fails (project/no-check (b1 b2) (predicate (*equal? b1 b2)))))))
; (pntall "~%Overloading resolution in Haskell.~%")
; Suppose we have the following Haskell class and instance declarations
; class F a b | a->b where f :: a->b->Bool
; instance F a b => F [a] [b]
;
; we need to typecheck
; g x = f [x] x
; which says that f:: [a] -> a -> Bool
; In general, we need to figure out which instance to choose for f.
; In other words, we need to find out which subset of F to use.
; Here's only one instance. So we need to figure out if it applies.
(define typeclass-F-instance-1
(relation (a b)
(to-show `(list ,a) `(list ,b))
(typeclass-F/x a b)))
; This is a closed-world assumption
(define typeclass-F/x
(extend-relation-with-recur-limit 10 (a b)
typeclass-F-instance-1))
; This is an open-world assumption
(define typeclass-F/x2
(extend-relation-with-recur-limit 2 (a b)
typeclass-F-instance-1
(relation (a b1 b2) ; a relation under constraint a->b
(to-show a b1)
(fails
(all!
(typeclass-F/x a b2)
(fails (project/no-check (b1 b2) (predicate (*equal? b1 b2)))))))
))
(define (tc-tests)
(pntall "~%Counter-example: ~s~%"
(solution (a b c1 c2)
(typeclass-counter-example-query a b c1 c2)))
(pntall "~%Counter-example: ~s~%"
(solution (a b c1 c2)
(typeclass-counter-example-query a b c1 c2)))
(pntall "~%Counter-example: ~s~%"
(solve 4 (a b c1 c2)
(typeclass-counter-example-query a b c1 c2)))
(pntall "~%Counter-example: ~s~%"
(solve 4 (a b1 b2) (typeclass-F-counter-example-query a b1 b2)))
(test-check "Typechecking (closed world)"
(solve 4 (a)
(typeclass-F-instance-1 `(list ,a) a))
'()) ; meaning: does not typecheck!
(pntall "~%Typechecking (open world): ~s~%"
(solve 4 (a) (typeclass-F-instance-1 `(list ,a) a)))
(test-check "Typechecking (open world) f [x] int"
(solve 4 (a) (typeclass-F-instance-1 `(list ,a) 'int))
'()) ; meaning: does not typecheck!
10
)
;; ========================================================================
;; zebra example
;; ========================================================================
; (display "Zebra") (newline)
; 1. There are five houses in a row, each of a different color
; and inhabited by men of different nationalities,
; with different pets, drinks, and cigarettes.
; 2. The Englishman lives in the red house.
; 3. The Spaniard owns a dog.
; 4. Coffee is drunk in the green house.
; 5. The Ukrainian drinks tea.
; 6. The green house is directly to the right of the ivory house.
; 7. The Old Gold smoker owns snails.
; 8. Kools are being smoked in the yellow house.
; 9. Milk is drunk in the middle house.
; 10. The Norwegian lives in the first house on the left.
; 11. The Chesterfield smoker lives next to the fox owner.
; 12. Kools are smoked in the house next to the house where the horse is kept.
; 13. The Lucky Strike smoker drinks orange juice.
; 14. The Japanese smokes Parliaments.
; 15. The Norwegian lives next to the blue house.
; (define memb
; (extend-relation (a1 a2)
; (fact (item) item `(,item . ,_))
; (relation (item rest) (to-show item `(,_ . ,rest)) (memb item rest))))
(define memb
(relation (head-let item lst)
(any (== lst `(,item . ,__))
(_exists (rest)
(if-only (== lst `(,__ . ,rest)) (memb item rest))))))
(define next-to
(relation (head-let item1 item2 rest)
(any (on-right item1 item2 rest) (on-right item2 item1 rest))))
(define on-right
(extend-relation (a0 a1 a2)
(fact (item1 item2) item1 item2 `(,item1 ,item2 . ,__))
(relation ((once item1) (once item2) rest)
(to-show item1 item2 `(,__ . ,rest))
(on-right item1 item2 rest))))
(define zebra
(relation (head-let h)
(if-only
(all!
(== h `((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ milk ,__ ,__) ,__ ,__))
(memb `(englishman ,__ ,__ ,__ red) h)
(on-right `(,__ ,__ ,__ ,__ ivory) `(,__ ,__ ,__ ,__ green) h)
(next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h)
(memb `(,__ kools ,__ ,__ yellow) h)
(memb `(spaniard ,__ ,__ dog ,__) h)
(memb `(,__ ,__ coffee ,__ green) h)
(memb `(ukrainian ,__ tea ,__ ,__) h)
(memb `(,__ luckystrikes oj ,__ ,__) h)
(memb `(japanese parliaments ,__ ,__ ,__) h)
(memb `(,__ oldgolds ,__ snails ,__) h)
(next-to `(,__ ,__ ,__ horse ,__) `(,__ kools ,__ ,__ ,__) h)
(next-to `(,__ ,__ ,__ fox ,__) `(,__ chesterfields ,__ ,__ ,__) h)
)
(all (memb `(,__ ,__ water ,__ ,__) h)
(memb `(,__ ,__ ,__ zebra ,__) h)))))
;'(_pretty-print
; (time (let loop ((n 100000))
; (cond
; ((zero? n) 'done)
; (else (solution (h) (zebra h))
; (loop (sub1 n)))))))
(define (zebra-test)
(test-check "Zebra"
(values (solution (h) (zebra h)))
'((h.0 ((norwegian kools water fox yellow)
(ukrainian chesterfields tea horse blue)
(englishman oldgolds milk snails red)
(spaniard luckystrikes oj dog ivory)
(japanese parliaments coffee zebra green)))))
10)
; Sample timing (Pentium IV, 2GHz, 1GB RAM)
; (time (solution (h) ...))
; 1 collection
; 22 ms elapsed cpu time, including 0 ms collecting
; 27 ms elapsed real time, including 0 ms collecting
; 981560 bytes allocated, including 1066208 bytes reclaimed
; For version 3.17 of kanren (with head-let ...)
; (time (solution (h) ...))
; 1 collection
; 19 ms elapsed cpu time, including 0 ms collecting
; 19 ms elapsed real time, including 0 ms collecting
; 788928 bytes allocated, including 1052312 bytes reclaimed
;
; For version of kanren 3.36 (with once annotations)
; This seems to be similar of SWI-Prolog, which gives 0.01 sec
; timing for the equivalent zebra code.
; (time (solution (h) ...))
; no collections
; 11 ms elapsed cpu time
; 11 ms elapsed real time
; 532912 bytes allocated
; For version of kanren 4.0 (increased sharing during unification)
; (time (solution (h) ...))
; no collections
; 7 ms elapsed cpu time
; 8 ms elapsed real time
; 443792 bytes allocated
; For version of kanren 4.1 (detection of bare variables, less garbage)
; no collections
; 8 ms elapsed cpu time
; 9 ms elapsed real time
; 448920 bytes allocated
; For version of kanren 4.50 (subst sk fk order)
; no collections
; 8 ms elapsed cpu time
; 8 ms elapsed real time
; 416864 bytes allocated
;; ========================================================================
;; Mirror example
;; ========================================================================
; First we need an extendible database of relations.
; We should be able to add to the database later on -- extend
; it with assumptions.
;
; One approach for the database is a finite map (hash table, assoc
; list) from the name of a relation to the procedure that is a relation
; in our system. Or, to make it even better, from a tuple
; (name arity) to the body of the relation.
; This is the approach of Prolog.
; Suppose we have a term (foo ?a ?b ?c) where ?a, ?b and ?c are arbitrary
; terms (logical variables, constants, expressions, etc).
; We would like to check if this term is consistent with (i.e., can
; be proven by) a particular instance of the database.
; First, we need to look up a key (foo 3) in the database. If the
; lookup fails, so does our query. If the lookup succeeds, we get
; a procedure of three arguments. We apply this procedure to
; ?a, ?b, and ?c and obtain an goal, which we can 'solve'
; as usual.
; In the following, we chose a different approach. We represent the database
; of relations as a relation itself -- we will call it KB. That
; relation takes one argument -- the term to prove, and returns an goal
; that represents the answer (that goal may be 'fail').
; A database of one fact
; foo(a,b,c).
; in Prolog notation will be represented in our approach as a relation
; (relation _ () (to-show `(foo a b c)))
; If we want to add another relation, say
; bar(X,X).
; we need to _extend_ the above relation with
; (relation _ (x) (to-show `(bar x x))).
;
; This approach is probably less efficient than the first one. It has
; however a redeeming value -- we do not need a separate procedure
; to look up names/arities of relations. We don't need separate procedures
; for extending our database. We can use the existing machinery of
; 'solving' relations for 'solving' the database of relations.
; This approach seems reminiscent of the Futamura projections:
; we use the same engine for meta-evaluations. Bootstrapping.
; First we define the inductive structure
; In Athena:
; (structure (BTree S)
; (leaf S)
; (root (BTree S) (BTree S)))
; In Prolog
; btree(leaf(S)).
; btree(root(T1,T2)) :- btree(T1),btree(T2).
; Note, our trees here (as well as those in Prolog) are polytypic
; (polymorphic): leaves can have values of different sorts.
; When we attempt to translate
; btree(root(T1,T2)) :- btree(T1),btree(T2).
; into our system, we encounter the first difficulty. To find out
; if a term btree(root(T1,T2)) is consistent with our database of relations,
; we need to check if terms btree(T1) and btree(T2) are consistent.
; Thus, to add btree(root(T1,T2)) to our database, we need to use
; the database itself to verify btree(T1) and btree(T2). Clearly,
; we need a fixpoint. The need for the fixpoint _exists no matter what is
; the representation of the database -- a finite map or a relation.
; Prolog solves the fixpoint problem by making the database global
; and using mutations (similar to the way letrec is implemented in Scheme).
; If we attempt to be purely functional, we must make the fixpoint explicit
; and employ Y.
; Note, the kb variable below represents the "current" database.
; In our approach, the database is a relation of one argument,
; which is a term to prove. A Second-order relation???
(define btree
(lambda (kb)
(extend-relation (t)
(fact (val) `(btree (leaf ,val)))
(relation (t1 t2)
(to-show `(btree (root ,t1 ,t2)))
(project (t1 t2)
(all
(predicate (pntall "btree ~s ~s ~n" t1 t2))
(kb `(btree ,t1))
(kb `(btree ,t2))))))))
;%> (declare mirror ((S) -> ((BTree S)) (BTree S)))
; Introduce an equality predicate and the first axiom for mirror
; In Athena:
; (define mirror-axiom-1
; (forall ?x
; (= (mirror (leaf ?x)) (leaf ?x))))
; In Prolog
; myeq(leaf(X),mirror(leaf(X))).
(define mirror-axiom-eq-1
(lambda (kb)
(fact (val) `(myeq (leaf ,val) (mirror (leaf ,val))))))
; The second axiom
; In Athena:
; (define mirror-axiom-eq-2
; (forall ?t1 ?t2
; (= (mirror (root ?t1 ?t2))
; (root (mirror ?t2) (mirror ?t1)))))
; In Prolog
; myeq(root(B,A),mirror(root(T1,T2))) :- myeq(A,mirror(T1)),myeq(B,mirror(T2)).
; implicitly the axiom in Prolog and the one below assume
; the transitivity of myeq. Indeed, one may think that the direct
; translation from Athena to Prolog would be
;
; myeq(mirror(root(T1,T2)),root(mirror(T2),mirror(T1)))
; or
; myeq(mirror(root(T1,T2)),root(B,A)) :- B = T2, A = T1.
; However, Athena actually assumes that B and T2 can be myeq rather
; than merely identical. We also switched the order of arguments
; in myeq, assuming symmetry of myeq.
; It really helped in Prolog. In our system, we could have used
; the same order as in Athena and add:
; myeq(A,A). % reflexivity: identity implies equality
; myeq(A,B) :- myeq(B,A). % symmetry
; Clearly if we add these relations to Prolog code, it will diverge.
; In our system, we can use with-depth to keep divergence in check.
; Still, for simplicity and clarity we will simply model the Prolog solution
; in our code.
(define mirror-axiom-eq-2
(lambda (kb)
(relation (a b t1 t2)
(to-show `(myeq (root ,b ,a) (mirror (root ,t1 ,t2))))
(all
(kb `(myeq ,a (mirror ,t1)))
(kb `(myeq ,b (mirror ,t2)))))))
; we could also add reflexivity and transitivity and symmetry axioms
; and with-depth to keep them from diverging.
; Define the goal
; In Athena:
; (define (goal t)
; (= (mirror (mirror t)) t))
; In Prolog
; Note, the goal is _equivalent_ to the conjunction of the
; predicates. That's why we couldn't use the standard Prolog
; notation goal(T) :- btree(T), ...
; because the latter would give us only the implication.
; goal(T,[btree(T),myeq(T,mirror(T1)),myeq(T1,mirror(T))]).
(define goal
(lambda (t)
(let-lv (t1)
(list
`(btree ,t)
`(myeq ,t (mirror ,t1))
`(myeq ,t1 (mirror ,t))))))
; For clarity, the above predicate can be written as two (prolog) relations
; The forward relation:
; (goal t) is implied by (btree t), (myeq t (mirror t1)) and
; (myeq t1 (mirror t))
; In the above, t is universally quantified and t1 is existentially
; quantified
(define goal-fwd
(lambda (kb)
(relation (t t1)
(to-show `(goal ,t))
(all
(kb `(btree ,t))
(kb `(myeq ,t (mirror ,t1)))
(kb `(myeq ,t1 (mirror ,t)))))))
; The reverse relation for the goal:
; (goal t) implies (btree t), (myeq t (mirror t1)) and
; (myeq t1 (mirror t))
; In the above, t is universally quantified and t1 is existentially
; quantified
; Because t1 now appears on the left-hand side, it is represented
; as an eigenvariable (skolem function) rather than a logical variable
(define goal-rev
(let* ((sk (eigen-variable 'sk))
(t1-sk (lambda (t) `(,sk ,t))))
(lambda (kb)
(extend-relation (t)
(relation (t) ; (goal t) => (btree t)
(to-show `(btree ,t))
(kb `(goal ,t)))
(relation (t) ; (goal t) => (myeq t (mirror t1))
(to-show `(myeq ,t (mirror ,(t1-sk t))))
(kb `(goal ,t)))
(relation (t) ; (goal t) => (myeq t1 (mirror t))
(to-show `(myeq ,(t1-sk t) (mirror ,t)))
(kb `(goal ,t)))
))))
; The initial assumptions: just the btree
(define init-kb (Y btree))
; Verification engine
; verify-goal PREDS KB
; returns a nullary relation that is the conjunction of preds against the
; assumption base kb
(define verify-goal
(lambda (preds kb)
(cond
((null? (cdr preds)) (kb (car preds)))
(else (all
(kb (car preds))
(verify-goal (cdr preds) kb))))))
; extend the kb with the list of assumptions
; this is just like 'any' only it's a procedure rather than a syntax
; Why we need universalize?
; Suppose, the list of facts includes
; (fact (x) (foo x)) and (fact (x) (bar x))
; definitely, we do not want to imply that facts foo and bar _share_
; the same logical variable. The facts are independent and should
; not have any variables in common.
; Furthermore, we do not want to add
; (fact (x) (foo x))
; because that would mean exist x. foo x
; We want our facts to be universally quantified. So, we add
; (fact () (foo 'unique-symbol))
; See the distinction between sigma and pi in Lambda-Prolog.
; We use extend-kb to extend the database with assumptions, which most
; often are universally quantified.
(define extend-kb
(lambda (facts kb)
(let ((facts (universalize facts)))
(pntall "Extending KB with ~s~%" facts)
(let loop ((facts facts))
(if (null? facts) kb
(extend-relation (t)
(fact () (car facts))
(loop (cdr facts))))))))
; Here's Athena's induction proof.
;
; (by-induction-on ?t (goal ?t)
; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1]))
; ((root t1 t2)
; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2])))
; The first part of it, the base case, can be expressed in Prolog
; as follows.
; ?- goal(leaf(X),C),verify(C,[]).
; Here how it looks in our system:
(define (mirror-tests)
(test-check "First check the base case"
(query (_ subst)
(verify-goal (goal '(leaf x))
(extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb))
(reify-subst '() subst))
'((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x)))
(test-check "Check the base case, using goal-fwd"
(query (_ subst)
(let ((kb0
(extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb)))
(let ((kb1
(extend-relation (t) (goal-fwd kb0) kb0)))
(kb1 '(goal (leaf x))))) ; note, x is an eigenvariable!
(reify-subst '() subst))
'((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x) (t.0 (leaf x))))
; that is, we obtain the list of subgoals to verify '(leaf x)
; by invoking the function 'goal'.
; we extend the initial database (which contains btree facts)
; with mirror-axiom-eq-1. Thus, mirror-axiom-eq-1 and btree form
; the assumptions. We then verify the subgoals against the assumptions.
; Note that we wrote
; '(leaf x)
; rather than
; (let-lv (x) `(leaf ,x))
; because we want to prove that (goal '(leaf x)) holds for _all_ x
; rather than for some particular x.
;
; non-empty result printed by the above expressions means success...
; The inductive case.
; Now, assume the goal holds for t1 and t2 and check if it holds
; for root(t1,t2)
;?- goal(t1,A1),goal(t2,A2), append(A1,A2,A), goal(root(t1,t2),C), verify(C,A).
(test-check "Some preliminary checks"
(solution (foo)
(verify-goal '((btree t2)) ; (goal t2) => (btree t2)
(let ((kb0
(extend-kb (goal 't1)
(extend-kb (goal 't2) init-kb))))
kb0)))
'((foo.0 _.0)))
(test-check "Some preliminary checks, using goal-rev"
(solution (foo)
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(btree kb)
(goal-rev kb)
(fact () '(goal t1))
(fact () '(goal t2)))))))
(kb '(btree t2))))
'((foo.0 _.0)))
; the above two expressions should give the same result: a non-empty stream
; (with an empty substitution: no variables leak)
(test-check "Another check"
(solution (foo)
;(goal t1), (goal t2) => (btree (root t1 t2))
(verify-goal '((btree t1) (btree t2)
(btree (root t1 t2)))
(let ((kb0
(extend-kb (goal 't1)
(extend-kb (goal 't2)
(fact () 'nothing)))))
(Y
(lambda (kb)
(extend-relation (t)
kb0
(btree kb)
(mirror-axiom-eq-2 kb)))))))
'((foo.0 _.0)))
(test-check "Another check, using goal-rev"
(solution (foo)
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(btree kb)
(goal-rev kb)
(mirror-axiom-eq-2 kb)
(fact () '(goal t1))
(fact () '(goal t2)))))))
(kb '(btree (root t1 t2)))))
'((foo.0 _.0)))
; now we really need Y because we rely on the clause
; btree(root(T1,T2)) :- btree(T1),btree(T2).
; which is recursive.
(test-check "Check the inductive case"
(query (_ subst)
(verify-goal (goal '(root t1 t2))
(let ((kb0
(extend-kb (goal 't1)
(extend-kb (goal 't2)
(fact () 'initial)))))
(Y
(lambda (kb)
(extend-relation (t)
kb0
(btree kb)
(mirror-axiom-eq-2 kb))))))
(cout (reify-subst '() subst) nl) #t)
#t)
(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%"
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(btree kb)
(fact () '(goal t1))
(fact () '(goal t2))
(mirror-axiom-eq-2 kb)
(goal-rev kb)
)))))
(list
(solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x))))
(solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2))))))))
(test-check "Check the inductive case, using goal-rev, goal-fwd"
(query (_ subst)
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(btree kb)
(fact () '(goal t1))
(fact () '(goal t2))
(mirror-axiom-eq-2 kb)
(goal-rev kb))))))
(let ((kb1 (goal-fwd kb)))
(kb1 '(goal (root t1 t2)))))
(cout (reify-subst '() subst) nl) #t)
#t)
10)
; Again, we use Y because btree and mirror-axiom-eq-2 are recursive.
; We need the database that is the fixpoint of all constituent
; relations.
; The output above is a non-empty list: meaning that the inductive
; phase of the proof checks.
;; ========================================================================
;; Mirror-equ example
;; ========================================================================
; See mirror.scm for preliminaries
(define btrii
(lambda (kb)
(extend-relation (t)
(fact (val) `(btrii (leaf ,val)))
(relation (t1 t2)
(to-show `(btrii (root ,t1 ,t2)))
(all
(trace-vars 'btrii (t1 t2))
(kb `(btrii ,t1))
(kb `(btrii ,t2)))))))
(define myeq-axioms
(lambda (kb)
(extend-relation (t)
(fact (val) `(myeq ,val ,val)) ; reflexivity
(relation (a b)
(to-show `(myeq ,a ,b)) ; symmetry
(all
(trace-vars 'symmetry (a b))
(kb `(myeq ,b ,a))))
(relation (a b) ; transitivity
(to-show `(myeq ,a ,b))
(_exists (c)
(all
(kb `(myeq ,a ,c))
(kb `(myeq ,c ,b)))))
)))
(define myeq-axioms-trees ; equational theory of trees
(lambda (kb) ; equality commutes with root
(relation (a b c d)
(to-show `(myeq (root ,a ,b) (root ,c ,d)))
(all
(trace-vars 'trees (a b))
(kb `(myeq ,a ,c))
(kb `(myeq ,b ,d))))))
; equality on leaves follows from the reflexivity of equality
(define myeq-axioms-mirror ; equational theory of mirror
(lambda (kb) ; equality commutes with root
(extend-relation (t)
(relation (a b)
(to-show `(myeq (mirror ,a) ,b))
(all
(trace-vars 'mirror (a b))
(_exists (c)
(all (kb `(myeq ,b (mirror ,c)))
(kb `(myeq ,a ,c)))))))))
; Axioms of mirror
; In Prolog
; myeq(leaf(X),mirror(leaf(X))).
(define mirror-axiom-eq-1/x
(lambda (kb)
(fact (val) `(myeq (leaf ,val) (mirror (leaf ,val))))))
; The second axiom
; In Athena:
; (define mirror-axiom-eq-2/x
; (forall ?t1 ?t2
; (= (mirror (root ?t1 ?t2))
; (root (mirror ?t2) (mirror ?t1)))))
(define mirror-axiom-eq-2/x
(lambda (kb)
(relation (t1 t2)
(to-show `(myeq (mirror (root ,t1 ,t2)) (root (mirror ,t2) (mirror ,t1))))
(trace-vars 'mirror-ax2 (t1 t2)))))
; Define the goal
; In Athena:
; (define (goal t)
; (= (mirror (mirror t)) t))
(define goal/x
(lambda (t)
(list
`(btrii ,t)
`(myeq (mirror (mirror ,t)) ,t))))
(define goal-fwd/x
(lambda (kb)
(relation (t)
(to-show `(goal/x ,t))
(all
(kb `(btrii ,t))
(kb `(myeq (mirror (mirror ,t)) ,t))))))
(define goal-rev/x
(lambda (kb)
(extend-relation (t)
(relation (t) ; (goal t) => (btrii t)
(to-show `(btrii ,t))
(kb `(goal/x ,t)))
(relation (t) ; (goal t) => (myeq (mirror (mirror t)) t)
(to-show `(myeq (mirror (mirror ,t)) ,t))
(kb `(goal/x ,t))))))
; (by-induction-on ?t (goal ?t)
; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1]))
; ((root t1 t2)
; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2])))
(define-syntax un@ ; uncurry
(syntax-rules ()
((_ proc arg1 ...)
(lambda (arg1 ...) (at@ proc arg1 ...)))))
; The initial assumptions: just the btrii
;(define init-kb (Y btrii))
; Note that in order to be effective,
; extend-relation-with-recur-limit should not be under lambda!
; We want to use the same recursion count for all
; entrances to init-kb-coll.
; Also note that the limit 5 is the number of axioms in init-kb-coll
; plus one. This count will guarantee that each axiom will be tried
; once, but not more than twice.
(define init-kb-coll
(extend-relation-with-recur-limit 5 (kb t)
(un@ btrii kb t)
(un@ myeq-axioms kb t)
(un@ myeq-axioms-mirror kb t)
(un@ myeq-axioms-trees kb t)))
(define (mirror-equ-tests)
(test-check "First check the base case, using goal-fwd"
(query (_ subst)
(let ((kb0
(Y (lambda (kb)
(extend-relation (t)
(mirror-axiom-eq-1/x kb)
(lambda (t) (init-kb-coll kb t)))))))
(let ((kb1
(extend-relation (t) (goal-fwd/x kb0) kb0)))
(kb1 '(goal/x (leaf x))))) ; note, x is an eigenvariable!
;(cout (reify-subst '() subst) nl)
#t)
#t)
; (goal t2) => (btrii t2)
(test-check "Some preliminary checks, using goal-rev"
(query (_ subst)
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(lambda (t) (init-kb-coll kb t))
(goal-rev/x kb)
(fact () '(goal/x t1))
(fact () '(goal/x t2)))))))
(kb '(btrii t2)))
;(cout (reify-subst '() subst) nl)
#t)
#t)
(test-check "Another check, using goal-rev"
;(goal t1), (goal t2) => (btrii (root t1 t2))
(query (_ subst)
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(lambda (t) (init-kb-coll kb t))
(goal-rev/x kb)
(mirror-axiom-eq-2/x kb)
(fact () '(goal/x t1))
(fact () '(goal/x t2)))))))
(kb '(btrii (root t1 t2))))
(cout (reify-subst '() subst) nl)
#t)
#t)
(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%"
(let ((kb
(Y
(lambda (kb)
(extend-relation (t)
(lambda (t) (init-kb-coll kb t))
(fact () '(goal/x t1))
(fact () '(goal/x t2))
(mirror-axiom-eq-2/x kb)
(goal-rev/x kb)
)))))
(list
;(solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x))))
(solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2)))))
)))
10)
;; ========================================================================
;; pure bin arith example
;; ========================================================================
; Pure, declarative, and constructive binary arithmetics
;
; aka: Addition, Multiplication, Division with remainder
; as sound and complete, pure and declarative relations that can be
; used in any mode whatsoever and that recursively enumerate their domains.
; The relations define arithmetics over base-2 non-negative numerals
; of *arbitrary* size.
;
; aka: division as relation.
; The function divo below is a KANREN relation between four binary numerals
; n, m, q, and r such that the following holds
; _exists r. 0<=r0!
;
; We give two implementations of addition and multiplication
; relations, `++o' and `**o'. Both versions have the properties of
; soundness and nealy refutational completeness. The first version of `++o'
; is faster, but it does not always recursively enumerate its domain
; if that domain is infinite. This is the case when, e.g., (**o x y
; z) is invoked when all three x, y, and z are uninstantiated
; variables. The relation in that case has the infinite number of
; solutions, as expected. Alas, those solutions look as follows:
; x = 2, y = 3, z = 6
; x = 4, y = 3, z = 12
; x = 8, y = 3, z = 24
; x = 16, y = 3, z = 48
; That is, (**o x y z) keeps generating solutions where x is a power of
; two. Therefore, when the answerset of the relation `**o' is infinite, it
; truly produces an infinite set of solutions -- but only the subset of
; all possible solutions. In other words, `**o' does not recursively
; enumerate the set of all numbers such that x*y=z if that set is infinite.
;
; Therefore,
; (all (== x '(1 1)) (== y '(1 1)) (**o x y z))
; (all (**o x y z) (== x '(1 1)) (== y '(1 1)))
; work differently. The former terminates and binds z to the representation
; of 9 (the product of 3 and 3). The latter fails to terminate.
; This is not generally surprising as `all', like 'commas' in Prolog,
; is not truly a conjunction: they are not commutative. Still,
; we would like our `++o' and `**o' to have the algebraic properties
; expected of addition and multiplication.
;
; The second version of `++o' and `**o' completely fixes the
; problem without losing any performance. The addition and
; multiplication relations completely enumerate their domain, even if
; it is infinite. Furthermore, ++o and **o now generate the numbers
; _in sequence_, which is quite pleasing. We achieve the
; property of recursive enumerability without giving up neither
; completeness nor refutational completeness. As before, if 'z' is
; instantiated but 'x' and 'y' are not, (++o x y z) delivers *all*
; non-negative numbers that add to z and (**o x y z) computes *all*
; factorizations of z.
;
; Such relations are easy to implement in an impure system such as Prolog,
; with the help of a predicate 'var'. The latter can tell if its argument
; is an uninstantiated variable. However, 'var' is impure. The present
; file shows the implementation of arithmetic relations in a _pure_
; logic system.
;
; The present approach places the correct upper bounds on the
; generated numbers to make sure the search process will terminate.
; Therefore, our arithmetic relations are not only sound
; (e.g., if (**o X Y Z) holds then it is indeed X*Y=Z) but also
; complete (if X*Y=Z is true then (**o X Y Z) holds) and
; nearly refutationally complete (if X*Y=Z is false and X, Y, and Z
; are either fully instantiated, or not instantiated, then (**o X Y Z) fails,
; in finite time). The refutational completeness
; claim is limited to the case when all terms passed to arithmetical
; functions do not share variables, are either fully instantiated or not
; instantiated at all. Indeed, sharing of variables or partial
; instantiation essentially imposes the constraint: e.g.,
; (solution (q) (**o `(1 . ,q) `(1 1) `(1 . ,q)))
; is tantamount to
; (solution (q) (exist (q1)
; (all (**o `(1 . ,q) `(1 1) `(1 . ,q1)) (== q q1))))
; That conjunction will never succeed. See the corresponding Prolog
; code for justification and relation to the 10th Hilbert problem.
;
; The numerals are represented in the binary little-endian
; (least-significant bit first) notation. The higher-order bit must be 1.
; () represents 0
; (1) represents 1
; (0 1) represents 2
; (1 1) represents 3
; (0 0 1) represents 4
; etc.
;
; There is a Prolog version of this code, which has termination proofs.
;
; $Id: pure-bin-arithm.scm,v 4.50 2005/02/12 00:04:49 oleg Exp $
; Auxiliary functions to build and show binary numerals
;
(define (build n)
(if (zero? n) '() (cons (if (even? n) 0 1) (build (quotient n 2)))))
(define (trans n)
(if (null? n) 0 (+ (car n) (* 2 (trans (cdr n))))))
; (zeroo x) holds if x is zero numeral
(define zeroo
(fact () '()))
; Not a zero
(define pos
(fact () `(,__ . ,__)))
; At least two
(define gt1
(fact () `(,__ ,__ . ,__)))
; compare the lengths of two numerals
; (0, or if (floor (log2 a)) < (floor (log2 b))
; That is, we compare the length (logarithms) of two numerals
; For a positive numeral, its bitlength = (floor (log2 n)) + 1
; We also make sure that 'n' is a well-formed number.
(define 0 or
; length(p1) < min(length(p), length(n) + length(m) + 1)
(define = 2
; (_exists (r1 r2)
; (all (== r `(,r1 ,r2))
; (half-adder carry-in 1 1 r1 r2))))
;
; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
; (relation (carry-in bb br rb rr)
; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
; (all
; (pos br) (pos rr)
; (_exists (carry-out)
; (all
; (half-adder carry-in 1 bb rb carry-out)
; (full-adder carry-out '() br rr)))))
;
; ; symmetric case for the above
; (relation (head-let carry-in a '(1) r)
; (all
; (gt1 a) (gt1 r)
; (full-adder carry-in '(1) a r)))
;
; ; carry-in + (2*ar + ab) + (2*br + bb)
; ; = (carry-in + ab + bb) (mod 2)
; ; + 2*(ar + br + (carry-in + ab + bb)/2)
; ; The cases of ar= 0 or br = 0 have already been handled.
; ; So, now we require ar >0 and br>0. That implies that rr>0.
; (relation (carry-in ab ar bb br rb rr)
; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
; (all
; (pos ar) (pos br) (pos rr)
; (_exists (carry-out)
; (all
; (half-adder carry-in ab bb rb carry-out)
; (full-adder carry-out ar br rr))))
; )))
; After we have checked that both summands have some bits, and so we
; can decompose them the least-significant bit and the other ones, it appears
; we only need to consider the general case, the last relation in
; the code above.
; But that is not sufficient. Let's consider
; (full-adder 0 (1 . ()) (1 0 . ()) (0 1 . ()))
; It would then hold. But it shouldn't, because (1 0 . ()) is a bad
; number (with the most-significant bit 0). One can say why we should
; care about user supplying bad numbers. But we do: we don't know which
; arguments of full-adder are definite numbers and which are
; uninstantiated variables. We don't know which are the input and which
; are the output. So, if we keep only the last relation for the
; case of positive summands, and try to
; (_exists (x) (full-adder 0 (1 . ()) x (0 1 . ())))
; we will see x bound to (1 0) -- an invalid number. So, our adder, when
; asked to subtract numbers, gave a bad number. And it would give us
; a bad number in all the cases when we use it to subtract numbers and
; the result has fewer bits than the number to subtract from.
;
; To guard against such a behavior (i.e., to transparently normalize
; the numbers when the full-adder is used in the ``subtraction'' mode)
; we have to specifically distinguish cases of
; "bit0 + 2*bit_others" where bit_others>0, and the
; terminal case "1" (that is, the most significant bit 1 and no other
; bits).
; The various (pos ...) conditions in the code are to guarantee that all
; cases are disjoin. At any time, only one case can match. Incidentally,
; the lack of overlap guarantees the optimality of the code.
; The full-adder above is not recursively enumerating however.
; Indeed, (solve 10 (x y z) (full-adder '0 x y z))
; gives solutions with x = 1.
; We now convert the adder into a recursively enumerable form.
; We lose some performance however (but see below!)
;
; The general principles are:
; Convert the relation into a disjunctive normal form, that is
; (any (all a b c) (all c d e) ...)
; and then replace the single, top-level any with any-interleave.
; The conversion may be too invasive. We, therefore, use an effective
; conversion: if we have a relation
; (all (any a b) (any c d))
; then rather than re-writing it into
; (any (all a c) (all a d) (all b c) (all b d))
; to push disjunctions out and conjunctions in, we do
; (all gen (all (any a b) (any c d)))
; where gen is a relation whose answer set is precisely such
; that each answer in gen makes (all (any a b) (any c d))
; semi-deterministic. That is, with the generator gen, we
; make all the further choices determined.
;
; In the code below we use a different kind of generator, whose full
; justification (with proofs) appears in the Prolog version of the code.
; Please see the predicate `enum' in that Prolog code.
;
; The price to pay is slow-down.
; Note, if we had all-interleave, then we would generally have
; breadth-first search and so the changes to the recursively enumerable
; version would be minimal and without loss of speed.
; The following full-adder* is almost the same as full-adder above.
;
; (define full-adder*
; (extend-relation (carry-in a b r)
; ; (fact (a) 0 a '() a) ; 0 + a + 0 = a
; ; (relation (b) ; 0 + 0 + b = b
; ; (to-show 0 '() b b)
; ; (pos b))
; ; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1
; ; (full-adder 0 a '(1) r))
; ; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b
; ; (all (pos b)
; ; (full-adder 0 '(1) b r)))
;
; ; The following three relations are needed
; ; to make all numbers well-formed by construction,
; ; that is, to make sure the higher-order bit is one.
; (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2
; (_exists (r1 r2)
; (all (== r `(,r1 ,r2))
; (half-adder carry-in 1 1 r1 r2))))
;
; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
; (relation (carry-in bb br rb rr)
; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
; (all
; (pos br) (pos rr)
; (_exists (carry-out)
; (all
; (half-adder carry-in 1 bb rb carry-out)
; (full-adder carry-out '() br rr)))))
;
; ; symmetric case for the above
; (relation (head-let carry-in a '(1) r)
; (all
; (gt1 a) (gt1 r)
; (full-adder* carry-in '(1) a r)))
;
; ; carry-in + (2*ar + ab) + (2*br + bb)
; ; = (carry-in + ab + bb) (mod 2)
; ; + 2*(ar + br + (carry-in + ab + bb)/2)
; ; The cases of ar= 0 or br = 0 have already been handled.
; ; So, now we require ar >0 and br>0. That implies that rr>0.
; (relation (carry-in ab ar bb br rb rr)
; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
; (all
; (pos ar) (pos br) (pos rr)
; (_exists (carry-out)
; (all
; (half-adder carry-in ab bb rb carry-out)
; (full-adder* carry-out ar br rr))))
; )))
; This driver handles the trivial cases and then invokes full-adder*
; coupled with the recursively enumerating generator.
; (define full-adder
; (extend-relation (carry-in a b r)
; (fact (a) 0 a '() a) ; 0 + a + 0 = a
; (relation (b) ; 0 + 0 + b = b
; (to-show 0 '() b b)
; (pos b))
; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1
; (full-adder 0 a '(1) r))
; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b
; (all (pos b)
; (full-adder 0 '(1) b r)))
; (relation (head-let carry-in a b r)
; (any-interleave
; ; Note that we take advantage of the fact that if
; ; a + b = r and length(b) <= length(a) then length(a) <= length(r)
; (all (= 2
(_exists (r1 r2)
(all (== r `(,r1 ,r2))
(half-adder carry-in 1 1 r1 r2))))
; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
(relation (carry-in bb br rb rr)
(to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
(all
(pos br) (pos rr)
(_exists (carry-out)
(all-interleave
(half-adder carry-in 1 bb rb carry-out)
(full-adder carry-out '() br rr)))))
; symmetric case for the above
(relation (head-let carry-in a '(1) r)
(all
(gt1 a) (gt1 r)
(full-adder carry-in '(1) a r)))
; carry-in + (2*ar + ab) + (2*br + bb)
; = (carry-in + ab + bb) (mod 2)
; + 2*(ar + br + (carry-in + ab + bb)/2)
; The cases of ar= 0 or br = 0 have already been handled.
; So, now we require ar >0 and br>0. That implies that rr>0.
(relation (carry-in ab ar bb br rb rr)
(to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
(all
(pos ar) (pos br) (pos rr)
(_exists (carry-out)
(all-interleave
(half-adder carry-in ab bb rb carry-out)
(full-adder carry-out ar br rr))))
)))
; a + b = c
(define a++o
(relation (head-let a b c)
(full-adder 0 a b c)))
; a - b = c
(define a--o
(lambda (x y out)
(a++o y out x)))
;(define 0 such that n + x = m
; (relation (head-let n m)
; (_exists (x) (all (pos x) (a++o n x m)))))
; The following is an optimization: it is easier to test for the
; length of two numbers. If one number has fewer bits than the other number,
; the former is clearly shorter (provided that the numbers are well-formed,
; that is, the higher-order bit is one). So we don't need to go through
; the trouble of subtracting them.
(define 0 such that n + x = m
(relation (head-let n m)
(any-interleave
(1
; (2*nr) * m = 2*(nr*m), m>0 (the case of m=0 is taken care of already)
; nr > 0, otherwise the number is ill-formed
(_exists (nr pr)
(all
(gt1 m)
(== n `(0 . ,nr))
(== p `(0 . ,pr))
(pos nr) (pos pr)
(**o nr m pr)))
; The symmetric case to the above: m is even, n is odd
(_exists (mr pr)
(all
(== n `(1 ,__ . ,__)) ; n is odd and n > 1
(== m `(0 . ,mr))
(== p `(0 . ,pr))
(pos mr) (pos pr)
(**o n mr pr)))
; (2*nr+1) * m = 2*(n*m) + m
; m > 0; also nr>0 for well-formedness
; the result is certainly greater than 1.
; we note that m > 0 and so 2*(nr*m) < 2*(nr*m) + m
; and (floor (log2 (nr*m))) < (floor (log2 (2*(nr*m) + m)))
(_exists (nr p1)
(all
(== m `(1 ,__ . ,__)) ; m is odd and n > 1
(== n `(1 . ,nr))
(pos nr) (gt1 p)
(0, so q*m <= n,
; (_exists (p) ; definitely q*m < 2*n
; (all ( (n - r) is even and (n-r)/2 = m*q
; ; (_exists (p m1)
; ; (all (== m `(0 . ,m1))
; ; (== m1 `(__, . ,__))
; ; (**o m1 q p)
; ; (a--o n r `(0 . ,p))))
;
; A faster and more refutationally complete divo algorithm
; Again, divo n m q r
; holds iff n = m*q + r
; Let l be the bit-length of r (if r=0, l=0).
; Let n = 2^(l+1) * n1 + n2
; q = 2^(l+1) * q1 + q2
; Note that n1 or q1 may be zero.
; We obtain that
; n = m*q + r
; is equivalent to the conjunction of the following two relations
; q2*m + r - n2 is divisible by 2^(l+1)
; n1 = q1*m + (q2*m + r - n2)/2^(l+1)
; We note that by construction (see the mentioning of (0) and q2*m + r = n2. The latter can be solved in finite
; time.
; We also note that (q2*m + r - n2)/2^(l+1) < m
; because r - n2 < (2^(l+1) - q2)* m
; because 2^(l+1) - q2 >=1 and m > r by construction. Therefore, to
; solve the relation n1 = q1*m + (q2*m + r - n2)/2^(l+1) we use
; divo itself: (divo n1 m q1 (q2*m + r - n2)/2^(l+1))
; Thus our division algorithm is recursive. On each stage we determine at
; least one bit of the quotient (if r=0, l=0 and q2 is either 0 or 1),
; in finite time.
(define divo
(relation (head-let n m q r)
(any-interleave
; m has more digits than n: q=0,n=r
(all (== r n) (== q '()) (= b^q, n < b^(q+1) = b^q * b = (n-r)* b
; r*b < n*(b-1)
;
; We can also obtain the bounds on q:
; if |b| is the bitwidth of b and |n| is the bitwidth of n,
; we have, by the definition of the bitwidth:
; (1) 2^(|b|-1) <= b < 2^|b|
; (2) 2^(|n|-1) <= n < 2^|n|
; Raising (1) to the power of q:
; 2^((|b|-1)*q) <= b^q
; OTH, b^q <= n, and n < 2^|n|. So we obtain
; (3) (|b|-1)*q < |n|
; which defines the upper bound on |q|.
; OTH, raising (1) to the power of (q+1):
; b^(q+1) < 2^(|b|*(q+1))
; But n < b^(q+1) by definition of exponentiation, and keeping in mind (1)
; (4) |n|-1 < |b|*(q+1)
; which is the lower bound on q.
; When b = 2, exponentiation and discrete logarithm are easier to obtain
; n = 2^q + r, 0<= 2*r < n
; Here, we just relate n and q.
; exp2 n b q
; holds if: n = (|b|+1)^q + r, q is the largest such number, and
; (|b|+1) is a power of two.
; Side condition: (|b|+1) is a power of two and b is L-instantiated.
; To obtain the binary exp/log relation, invoke the relation as
; (exp2 n '() q)
; Properties: if n is L-instantiated, one answer, q is fully instantiated.
; If q is fully instantiated: one answer, n is L-instantiated.
; In any event, q is always fully instantiated in any answer
; and n is L-instantiated.
; We depend on the properties of split.
(define exp2
(letrec
((r-append ; relational append
(extend-relation (a b c)
(fact (b) '() b b)
(relation (ah ar b cr) (to-show `(,ah . ,ar) b `(,ah . ,cr))
(r-append ar b cr)))))
(relation (head-let n b q)
(any-interleave
(all (== n '(1)) (== q '())) ; 1 = b^0
(all (gt1 n) (== q '(1)) (split n b '(1) __))
(_exists (q1 b2) ; n = (2^k)^(2*q) + r
(all-interleave ; = (2^(2*k))^q + r
(== q `(0 . ,q1))
(pos q1)
(0
(all (== q '()) (0
(all (== b '()) (pos q) (== r n)) ; n = 0^q + n, q>0
; in the rest, n is longer than b
(all (== b '(0 1)) ; b = 2
(_exists (n1)
(all
(pos n1)
(== n `(,__ ,__ . ,n1)) ; n is at least 4
(exp2 n '() q) ; that will L-instantiate n and n1
(split n n1 __ r))))
; the general case
(all
(any (== b '(1 1)) (== b `(,__ ,__ ,__ . ,__))) ; b >= 3
(0!
((x.0 (0 _.0 . _.1)) (y.0 (1 _.0 . _.1)))
((x.0 (1 1)) (y.0 (0 0 1)))
((x.0 (1 0 _.0 . _.1)) (y.0 (0 1 _.0 . _.1))))
)
; check that add(X,Y,Z) recursively enumerates all
; numbers such as X+Y=Z
;
(cout "Test recursive enumerability of addition" nl)
(let ((n 7))
(do ((i 0 (+ 1 i))) ((> i n))
(do ((j 0 (+ 1 j))) ((> j n))
(let ((p (+ i j)))
(test-check
(string-append "enumerability: " (number->string i)
"+" (number->string j) "=" (number->string p))
(solve 1 (x y z)
(all (a++o x y z)
(== x (build i)) (== y (build j)) (== z (build p))))
`(((x.0 ,(build i)) (y.0 ,(build j))
(z.0 ,(build p)))))))))
(test-check "strong commutativity"
(solve 5 (a b c)
(all (a++o a b c)
(_exists (x y z)
(all!
(a++o x y z)
(== x b)
(== y a)
(== z c)
))))
'(((a.0 ()) (b.0 ()) (c.0 ()))
((a.0 ()) (b.0 (_.0 . _.1)) (c.0 (_.0 . _.1)))
((a.0 (1)) (b.0 (1)) (c.0 (0 1)))
((a.0 (1)) (b.0 (0 _.0 . _.1)) (c.0 (1 _.0 . _.1)))
((a.0 (0 _.0 . _.1)) (b.0 (1)) (c.0 (1 _.0 . _.1))))
)
(cout nl "subtraction" nl)
(test (x) (a--o (build 29) (build 3) x))
(test (x) (a--o (build 29) x (build 3)))
(test (x) (a--o x (build 3) (build 26)))
(test (x) (a--o (build 29) (build 29) x))
(test (x) (a--o (build 29) (build 30) x))
(test-check "print a few numbers such as Y - Z = 4"
(solve 11 (y z) (a--o y z (build 4)))
'(((y.0 (0 0 1)) (z.0 ())) ; 4 - 0 = 4
((y.0 (1 0 1)) (z.0 (1))) ; 5 - 1 = 4
((y.0 (0 1 1)) (z.0 (0 1))) ; 6 - 2 = 4
((y.0 (1 1 1)) (z.0 (1 1))) ; 7 - 3 = 4
((y.0 (0 0 0 1)) (z.0 (0 0 1))) ; 8 - 4 = 4
((y.0 (1 0 0 1)) (z.0 (1 0 1))) ; 9 - 5 = 4
((y.0 (0 1 0 1)) (z.0 (0 1 1))) ; 10 - 6 = 4
((y.0 (1 1 0 1)) (z.0 (1 1 1))) ; 11 - 7 = 4
; 8*k + 4 - 8*k = 4 forall k> 0!!
((y.0 (0 0 1 _.0 . _.1)) (z.0 (0 0 0 _.0 . _.1)))
((y.0 (1 0 1 _.0 . _.1)) (z.0 (1 0 0 _.0 . _.1)))
((y.0 (0 1 1 _.0 . _.1)) (z.0 (0 1 0 _.0 . _.1))))
)
(test-check "print a few numbers such as X - Y = Z"
(solve 5 (x y z) (a--o x y z))
'(((x.0 _.0) (y.0 _.0) (z.0 ())) ; 0 - 0 = 0
((x.0 (_.0 . _.1)) (y.0 ()) (z.0 (_.0 . _.1))) ; a - 0 = a
((x.0 (0 1)) (y.0 (1)) (z.0 (1)))
((x.0 (1 _.0 . _.1)) (y.0 (1)) (z.0 (0 _.0 . _.1)))
((x.0 (1 _.0 . _.1)) (y.0 (0 _.0 . _.1)) (z.0 (1))))
)
(cout nl "comparisons" nl)
(test (x) ( 0
; 1 * y = y for y > 0
((x.0 (1)) (y.0 (_.0 . _.1)) (z.0 (_.0 . _.1)))
((x.0 (_.0 _.1 . _.2)) (y.0 (1))
(z.0 (_.0 _.1 . _.2))) ; x * 1 = x, x > 1
; 2 * y = even positive number, for y > 1
((x.0 (0 1)) (y.0 (_.0 _.1 . _.2))
(z.0 (0 _.0 _.1 . _.2)))
; x * 2 = shifted-left x, for even x>1
((x.0 (1 _.0 . _.1)) (y.0 (0 1)) (z.0 (0 1 _.0 . _.1)))
; 3 * 3 = 9
((x.0 (1 1)) (y.0 (1 1)) (z.0 (1 0 0 1)))
)
)
(test-check 'multiplication-even-1
(solve 10 (y z) (**o (build 2) y z))
'(((y.0 ()) (z.0 ()))
((y.0 (1)) (z.0 (0 1))) ; 2 * 1 = 2
; 2*y is an even number, for any y > 1!
((y.0 (_.0 _.1 . _.2)) (z.0 (0 _.0 _.1 . _.2)))
)
)
(test-check 'multiplication-even-2
; multiplication by an even number cannot yield an odd number
(solution (q x y u v) (**o '(1 1) `(0 0 1 ,x . ,y) `(1 0 0 ,u . ,v)))
#f
)
(test-check 'multiplication-even-3
; multiplication by an even number cannot yield an odd number
(solution (q x y z) (**o `(0 0 1 . ,y) `(1 . ,x) `(1 0 . ,z)))
#f
)
; check that mul(X,Y,Z) recursively enumerates all
; numbers such as X*Y=Z
;
(cout "Test recursive enumerability of multiplication" nl)
(let ((n 7))
(do ((i 0 (+ 1 i))) ((> i n))
(do ((j 0 (+ 1 j))) ((> j n))
(let ((p (* i j)))
(test-check
(string-append "enumerability: " (number->string i)
"*" (number->string j) "=" (number->string p))
(solve 1 (x y z)
(all (**o x y z)
(== x (build i)) (== y (build j)) (== z (build p))))
`(((x.0 ,(build i)) (y.0 ,(build j))
(z.0 ,(build p)))))))))
(cout nl "split" nl)
(test-check 'split-1
(solve 5 (x y) (split (build 4) '() x y))
'(((x.0 (0 1)) (y.0 ()))))
(test-check 'split-2
(solve 5 (x y) (split (build 4) '(1) x y))
'(((x.0 (1)) (y.0 ()))))
(test-check 'split-3
(solve 5 (x y) (split (build 4) '(1 1) x y))
'(((x.0 ()) (y.0 (0 0 1)))))
(test-check 'split-4
(solve 5 (x y) (split (build 4) '(1 1 1) x y))
'(((x.0 ()) (y.0 (0 0 1)))))
(test-check 'split-5
(solve 5 (x y) (split (build 5) '(1) x y))
'(((x.0 (1)) (y.0 (1)))))
(test-check 'split-6
(solve 5 (n) (split n (build 5) '() '(1)))
'(((n.0 (1)))))
(cout nl "division, general" nl)
(test-check 'divo-1
(solution (x) (divo (build 4) (build 2) x __))
'((x.0 (0 1))))
(test-check 'div-fail-1 (test (x) (divo (build 4) (build 0) x __)) '())
(test-check 'divo-2
(solution (x) (divo (build 4) (build 3) x __))
'((x.0 (1))))
(test-check 'divo-3
(solution (x) (divo (build 4) (build 4) x __))
'((x.0 (1))))
(test-check 'divo-4
(solution (x y) (divo (build 4) (build 5) x y))
'((x.0 ()) (y.0 (0 0 1))))
(test-check 'divo-33-1
(solution (x) (divo (build 33) (build 3) x __))
`((x.0 ,(build 11))))
(test-check 'divo-33-2
(solution (x) (divo (build 33) x (build 11) __))
`((x.0 ,(build 3))))
(test-check 'divo-33-3
(solution (x) (divo x (build 3) (build 11) __))
`((x.0 ,(build 33))))
(test-check 'divo-33-5
(solution (x y) (divo (build 33) (build 5) x y))
`((x.0 ,(build 6)) (y.0 ,(build 3))))
(test-check 'divo-5-4
(solve 3 (x y) (divo x (build 5) y (build 4)))
'(((x.0 (0 0 1)) (y.0 ()))
((x.0 (0 0 0 0 0 0 1)) (y.0 (0 0 1 1)))
((x.0 (1 0 0 0 1 1)) (y.0 (1 0 0 1))))
)
(test-check 'divo-5-5
(solve 3 (x y) (divo x (build 5) y (build 5)))
'())
(test (x) (divo x (build 5) __ (build 4)))
(test (x) (divo x (build 5) (build 3) (build 4)))
(test (x) (divo x __ (build 3) (build 4)))
(test-check 'div-fail-2 (test (x) (divo (build 5) x (build 7) __)) '())
(test-check "all numbers such as 5/Z = 1"
(solve 7 (w)
(_exists (z) (all (divo (build 5) z (build 1) __)
(project (z) (== `(,(trans z)) w)))))
'(((w.0 (5))) ((w.0 (3))) ((w.0 (4)))))
(test-check "all inexact factorizations of 12"
(set-equal?
(solve 100 (w)
(_exists (m q r n)
(all
(== n (build 12))
(0
((x.0 (1)) (y.0 (1)) (z.0 (1)) (r.0 ())) ; 1 = 1*1 + 0
((x.0 (0 1)) (y.0 (1)) (z.0 (0 1)) (r.0 ())) ; 2 = 1*2 + 0
((x.0 (0 1)) (y.0 (1 1)) (z.0 ()) (r.0 (0 1))) ; 2 = 3*0 + 2
))
(test-check 'div-even
(solve 3 (y z r) (divo `(0 . ,y) (build 2) z r))
'(((y.0 (1)) (z.0 (1)) (r.0 ()))
((y.0 (0 1)) (z.0 (0 1)) (r.0 ()))
((y.0 (1 1)) (z.0 (1 1)) (r.0 ())))
)
(test-check 'div-even-fail
(solve 3 (y z r) (divo `(0 . ,y) (build 2) z '(1)))
'()
)
(test-check 'div-odd
(solve 3 (y z) (divo `(1 0 . ,y) (build 2) z '(1)))
'(((y.0 (0 1)) (z.0 (0 0 1))) ; 9 = 2*4 + 1
((y.0 (1)) (z.0 (0 1))) ; 5 = 2*2 + 1
((y.0 (0 0 1)) (z.0 (0 0 0 1)))) ; 17 = 8*2 + 1
)
(test-check 'div-odd-fail
(solve 3 (y z r) (divo `(1 0 . ,y) (build 2) z '()))
'()
)
(test-check 'div-enum-sample
(solve 1 (n m q r)
(all (divo n m q r)
(== n (build 10)) (== m (build 2)) (== q (build 5))
(== r '())))
'(((n.0 (0 1 0 1)) (m.0 (0 1)) (q.0 (1 0 1)) (r.0 ())))
)
; the latter takes awfully long time
'(test-check 'div-enum-sample-1
(solve 1 (n m q r)
(all (divo n m q r)
(== n (build 10)) (== m (build 3)) (== q (build 3))
(== r '(1))))
'(((n.0 (1 1 1)) (m.0 (0 1)) (q.0 (1 1)) (r.0 (1))))
)
; check that divo(N,M,Q,R) recursively enumerates all
; numbers such as N=M*Q+R, R m n))
(do ((q 0 (+ 1 q))) ((> q n))
(do ((r 0 (+ 1 r))) ((>= r m))
(let ((n (+ (* m q) r)))
(test-check
(string-append "enumerability: " (number->string n)
"=" (number->string m) "*" (number->string q)
"+" (number->string r))
(solve 1 (n1 m1 q1 r1)
(all (divo n1 m1 q1 r1)
(== n1 (build n)) (== m1 (build m))
(== q1 (build q)) (== r1 (build r))
))
`(((n1.0 ,(build n)) (m1.0 ,(build m))
(q1.0 ,(build q)) (r1.0 ,(build r))))))))))
; quite dubious tests. The problem is actually in =ol and