[cl-kanren-trs-cvs] r1 - in cl-kanren-trs: . tests
mswank at common-lisp.net
mswank at common-lisp.net
Wed Jun 18 23:34:20 UTC 2008
Author: mswank
Date: Wed Jun 18 19:34:19 2008
New Revision: 1
Added:
cl-kanren-trs/
cl-kanren-trs/kanren-lib.lisp
cl-kanren-trs/kanren-trs.asd
cl-kanren-trs/kanren.lisp
cl-kanren-trs/packages.lisp
cl-kanren-trs/tests/
cl-kanren-trs/tests/kanren-aux.lisp
cl-kanren-trs/tests/kanren-tests.lisp
cl-kanren-trs/tests/kanren-trs-test.asd
cl-kanren-trs/tests/packages.lisp
Log:
Initial Import.
Added: cl-kanren-trs/kanren-lib.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/kanren-lib.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,110 @@
+(in-package :kanren-trs)
+
+(defmacro choice-case (key-term &body cases)
+ (let ((kt-name (gensym)))
+ `(fresh (,kt-name)
+ (== ,key-term ,kt-name)
+ (conde ,@(mapcar (lambda (case)
+ (destructuring-bind (keys &rest clauses) case
+ (cond ((eql keys 'else)
+ clauses)
+ ((consp keys)
+ (if (cdr keys)
+ `((conde ,@(mapcar (lambda (key)
+ `(== ,kt-name ',key))
+ keys))
+ , at clauses)
+ `((== ,kt-name ',(car keys))
+ , at clauses)))
+ (t `((== ,kt-name ',keys)
+ , at clauses)))))
+ cases)))))
+
+(defun map-choice (fun &rest bindings)
+ (labels ((compose-bindings (relation bindings)
+ (if (some #'null bindings)
+ relation
+ (let ((terms (mapcar #'car bindings)))
+ (compose-bindings (conde (relation)
+ ((apply fun terms)))
+ (mapcar #'cdr bindings))))))
+ (compose-bindings +fail+ bindings)))
+
+(defun permute-binary-relation (relation)
+ (lambda (a b)
+ (conde ((funcall relation a b))
+ ((funcall relation b a)))))
+
+(defun make-binary-relation (mapping)
+ (lambda (a b)
+ (map-choice (lambda (a1 b1)
+ (fresh ()
+ (== a a1)
+ (== b b1)))
+ (mapcar #'first mapping)
+ (mapcar #'second mapping))))
+
+;;this needs to confirm that compile time evaluation is possible:
+;;mapping is a quoted list, n is a number, etc
+#+ (or)
+(define-compiler-macro make-nary-relation (n mapping)
+ (let* ((maps (loop :for x :from 0 :below n
+ :collect `',(mapcar (lambda (list)
+ (nth x list))
+ mapping)))
+ (args (loop :for x :from 0 :below n
+ :collect (gensym)))
+ (args1 (loop :for x :from 0 :below n
+ :collect (gensym)))
+ (sequence (mapcar (lambda (a a1)
+ `(== ,a ,a1))
+ args
+ args1)))
+ `(lambda ,args
+ (map-choice (lambda ,args1
+ (fresh ()
+ , at sequence))
+ , at maps))))
+
+(defun make-nary-relation (n mapping)
+ (let ((maps (loop :for x :from 0 :below n
+ :collect (mapcar (lambda (list)
+ (nth x list))
+ mapping))))
+ (lambda (&rest args)
+ (unless (= (length args) n)
+ (error "invalid number of arguments"))
+ (apply #'map-choice
+ (lambda (&rest args1)
+ (let ((sequence nil))
+ (map nil (lambda (a a1)
+ (unless sequence
+ (setf sequence (== a a1)))
+ ;; we don't want to capture the binding
+ ;; (this should be a fold)
+ (let ((seq sequence))
+ (setf sequence (fresh () seq (== a a1)))))
+ args
+ args1)
+ sequence))
+ maps))))
+
+(defun permute-ternary-relation (relation)
+ (lambda (a b c)
+ (conde ((funcall relation a b c))
+ ((funcall relation a c b))
+ ((funcall relation c b a))
+ ((funcall relation b a c))
+ ((funcall relation c a b))
+ ((funcall relation b c a)))))
+
+(defun make-ternary-relation (mapping)
+ (lambda (a b c)
+ (map-choice (lambda (a1 b1 c1)
+ (fresh ()
+ (== a a1)
+ (== b b1)
+ (== c c1)))
+ (mapcar #'first mapping)
+ (mapcar #'second mapping)
+ (mapcar #'third mapping))))
\ No newline at end of file
Added: cl-kanren-trs/kanren-trs.asd
==============================================================================
--- (empty file)
+++ cl-kanren-trs/kanren-trs.asd Wed Jun 18 19:34:19 2008
@@ -0,0 +1,9 @@
+;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
+
+;;; ASDF system definition for the my local packages.
+
+(asdf:defsystem :kanren-trs
+ :components
+ ((:file "packages")
+ (:file "kanren" :depends-on ("packages"))
+ (:file "kanren-lib" :depends-on ("kanren"))))
Added: cl-kanren-trs/kanren.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/kanren.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,378 @@
+;;; kanren.lisp
+;; by Matthew D. Swank
+;; A functional-logic extension for Common Lisp
+;;
+;; Derived closely from mini-kanren in "The Reasoned Schemer" by
+;; Daniel P. Friedman, William E. Byrd and Oleg Kiselyov
+
+(common-lisp:in-package :kanren-trs)
+
+(defmacro defconst (name value &optional (documentation nil docp))
+ `(eval-when (:execute :load-toplevel :compile-toplevel)
+ (unless (boundp ',name)
+ ,(if docp
+ `(defconstant ,name ,value ,documentation)
+ `(defconstant ,name ,value)))))
+
+;;;A -> stream
+(defmacro unit (a) a)
+
+;;;_ -> stream
+(defmacro mzero () '+empty-stream+)
+
+(defmacro all-aux (bnd &rest goals)
+ (cond ((null goals)
+ '+succeed+)
+ ((null (cdr goals))
+ (car goals))
+ (t (let ((goal (gensym))
+ (subst (gensym))
+ (remaining-goals (cdr goals)))
+ `(let ((,goal ,(car goals)))
+ #'(lambda (,subst)
+ (funcall ,bnd
+ (funcall ,goal ,subst)
+ #'(lambda (,subst)
+ (funcall (all-aux ,bnd , at remaining-goals)
+ ,subst)))))))))
+
+;;;case statement for streams
+;;;a stream is:
+;;; the empty-stream
+;;; a choice --a two member struct with a head and a funcallable tail
+;;; any other object --counts as a singleton stream
+;;;
+(defmacro case-inf (expr on-zero single-clause choice-clause)
+ (destructuring-bind ((a) &body on-one) single-clause
+ (destructuring-bind ((ac f) &body on-choice) choice-clause
+ (let ((e (gensym)))
+ `(let ((,e ,expr))
+ (cond ((eq +empty-stream+ ,e) ,on-zero)
+ ((choice-p ,e)
+ (let ((,ac (choice-head ,e))
+ (,f (choice-tail ,e)))
+ , at on-choice))
+ (t (let ((,a ,e))
+ , at on-one))))))))
+
+(defmacro ife (goal0 goal1 goal2)
+ (let ((subst (gensym)))
+ `#'(lambda (,subst)
+ (mplus (funcall (all ,goal0 ,goal1) ,subst)
+ #'(lambda () (funcall ,goal2 ,subst))))))
+
+(defmacro ifi (goal0 goal1 goal2)
+ (let ((subst (gensym)))
+ `#'(lambda (,subst)
+ (mplusi (funcall (all ,goal0 ,goal1) ,subst)
+ #'(lambda () (funcall ,goal2 ,subst))))))
+
+(defmacro ifa (goal0 goal1 goal2)
+ (let ((subst (gensym))
+ (subst-inf (gensym))
+ (fun (gensym)))
+ `#'(lambda (,subst)
+ (let ((,subst-inf (funcall ,goal0 ,subst)))
+ (case-inf ,subst-inf
+ (funcall ,goal2 ,subst)
+ ((,subst) (funcall ,goal1 ,subst))
+ ((,subst ,fun)
+ (declare (ignore ,fun))
+ (bind ,subst-inf ,goal1)))))))
+
+(defmacro ifu (goal0 goal1 goal2)
+ (let ((subst (gensym))
+ (subst-inf (gensym))
+ (fun (gensym)))
+ `#'(lambda (,subst)
+ (let ((,subst-inf (funcall ,goal0 ,subst)))
+ (case-inf ,subst-inf
+ (funcall ,goal2 ,subst)
+ ((,subst) (funcall ,goal1 ,subst))
+ ((,subst ,fun)
+ (declare (ignore ,fun))
+ (funcall ,goal1 ,subst)))))))
+
+
+(defmacro cond-aux (ifer &body clauses)
+ (if (null clauses)
+ '+fail+
+ (destructuring-bind ((&rest goals) &rest other-clauses) clauses
+ (if (null other-clauses)
+ `(all ,@(if (and goals (eq (car goals) 'else))
+ (cdr goals)
+ goals))
+ (destructuring-bind (goal0 &rest other-goals) goals
+ `(,ifer ,goal0
+ (all , at other-goals)
+ (cond-aux ,ifer , at other-clauses)))))))
+
+(defmacro run (num (var) &body goals)
+ (let ((n (gensym))
+ (subst (gensym)))
+ `(let ((,n ,num)
+ (,var (id ',var)))
+ (declare (ignorable ,var))
+ (declare (type (or null number) ,n))
+ (unless (and ,n (<= ,n 0))
+ (map-inf ,n #'(lambda (,subst)
+ (reify (walk* ,var ,subst)))
+ (funcall (all , at goals) +empty-subst+))))))
+
+(defmacro fresh ((&rest vars) &body goals)
+ (let ((let-clauses (mapcar #'(lambda (var)
+ `(,var (id ',var)))
+ vars))
+ (subst (gensym)))
+ `#'(lambda (,subst)
+ (let ,let-clauses
+ (declare (ignorable , at vars))
+ (funcall (all , at goals) ,subst)))))
+
+(defmacro conde (&body clauses)
+ `(cond-aux ife , at clauses))
+
+(defmacro condi (&body clauses)
+ `(cond-aux ifi , at clauses))
+
+(defmacro conda (&body clauses)
+ `(cond-aux ifa , at clauses))
+
+(defmacro condu (&body clauses)
+ `(cond-aux ifu , at clauses))
+
+(defmacro all (&rest goals)
+ `(all-aux #'bind , at goals))
+
+(defmacro alli (&rest goals)
+ `(all-aux #'bindi , at goals))
+
+(defconst +empty-subst+ nil)
+
+(defconst +empty-stream+ (cons nil nil))
+
+(defconst +succeed+
+ #'(lambda (subst)
+ (unit subst)))
+
+(defconst +fail+
+ #'(lambda (subst)
+ (declare (ignore subst))
+ (mzero)))
+
+(defstruct (id (:constructor id (name)))
+ (name nil :read-only t :type symbol))
+
+;;;choice: (T * (_ -> stream) -> stream)
+;;;
+(defstruct (choice (:constructor choice (head tail)))
+ (head)
+ (tail (constantly +empty-stream+) :type function))
+
+;;;(or null int) * (A -> B) * stream -> list
+(defun map-inf (n p a-inf)
+ (case-inf a-inf
+ ()
+ ((a) (cons (funcall p a) ()))
+ ((a f) (cons (funcall p a)
+ (cond ((not n)
+ (map-inf n p (funcall f)))
+ ((> n 1)
+ (map-inf (- n 1) p (funcall f)))
+ (t ()))))))
+
+
+;;;stream * (_ -> stream) -> stream
+(defun mplus (a-inf fun)
+ (case-inf a-inf
+ (funcall fun)
+ ((a) (choice a fun))
+ ((a fun0)
+ (choice a #'(lambda ()
+ (mplus (funcall fun0) fun))))))
+
+;;;stream * goal -> stream
+;;;where goal <==> (T -> stream)
+(defun bind (a-inf goal)
+ (case-inf a-inf
+ (mzero)
+ ((a) (funcall goal a))
+ ((a f) (mplus (funcall goal a)
+ #'(lambda () (bind (funcall f) goal))))))
+
+;;;stream * (_ -> stream) -> stream
+(defun mplusi (a-inf fun)
+ (case-inf a-inf
+ (funcall fun)
+ ((a) (choice a fun))
+ ((a fun0)
+ (choice a #'(lambda ()
+ (mplusi (funcall fun) fun0))))))
+
+;;;stream * goal -> stream
+;;;where goal <==> (T -> stream)
+(defun bindi (a-inf goal)
+ (case-inf a-inf
+ (mzero)
+ ((a) (funcall goal a))
+ ((a f) (mplusi (funcall goal a)
+ #'(lambda () (bindi (funcall f) goal))))))
+
+(defun id-bound-p (id subst)
+ (assoc id subst))
+
+(defun binding-val (binding)
+ (cdr binding))
+
+(defun binding-id (binding)
+ (car binding))
+
+(defun walk (id? subst)
+ (if (id-p id?)
+ (let ((binding (id-bound-p id? subst)))
+ (if binding
+ (walk (binding-val binding) subst)
+ id?))
+ id?))
+
+(defun walk* (id? subst)
+ (let ((id? (walk id? subst)))
+ (walk-impl id? subst)))
+
+#+ (or)
+(defun walk* (id? subst)
+ (let ((id? (walk id? subst)))
+ (cond ((id-p id?) id?)
+ ((consp id?)
+ (cons (walk* (car id?) subst)
+ (walk* (cdr id?) subst)))
+
+ ((vectorp id?)
+ (map 'vector (lambda (id?)
+ (walk* id? subst))
+ id?))
+ (t id?))))
+
+(defun reify-name (n)
+ (declare (type integer n))
+ (intern (format nil "_.~a" n) :keyword))
+
+(defun reify-subst (id? subst)
+ (let ((id? (walk id? subst)))
+ (reify-subst-impl id? subst)))
+
+#+ (or)
+(defun reify-subst (id? subst)
+ (let ((id? (walk id? subst)))
+ (cond ((id-p id?)
+ (extend-subst id? (reify-name (length subst)) subst))
+ ((consp id?)
+ (reify-subst (cdr id?) (reify-subst (car id?) subst)))
+ (t subst))))
+
+(defun reify (id?)
+ (walk* id? (reify-subst id? ())))
+
+(defun extend-subst (rhs lhs subst)
+ (cons (cons rhs lhs) subst))
+
+(defun unify (v w subst)
+ (let ((v (walk v subst))
+ (w (walk w subst)))
+ (if (eq v w)
+ subst
+ (unify-impl v w subst))))
+
+#+ (or)
+(defun unify (v w subst)
+ (let ((v (walk v subst))
+ (w (walk w subst)))
+ (cond ((eq v w) subst)
+ ((id-p v)
+ (extend-subst v w subst))
+ ((id-p w)
+ (extend-subst w v subst))
+ ((and (consp v) (consp w))
+ (let ((subst (unify (car v) (car w) subst)))
+ (if (not (eq subst +fail+))
+ (unify (cdr v) (cdr w) subst)
+ +fail+)))
+ ((equal v w) subst)
+ (t +fail+))))
+
+
+(defun == (v w)
+ #'(lambda (subst)
+ (let ((subst-1 (unify v w subst)))
+ (if (not (eq subst-1 +fail+))
+ (funcall +succeed+ subst-1)
+ (funcall +fail+ subst)))))
+
+;;;public interface to extend unification
+(defgeneric equivp (lhs rhs)
+ (:method (lhs rhs)
+ (eql lhs rhs))
+ (:method ((lhs vector) (rhs vector))
+ (or (eq lhs rhs)
+ (and (eql (length lhs) (length rhs))
+ (progn (map nil (lambda (l r)
+ (unless (equivp l r)
+ (return-from equivp nil)))
+ lhs rhs)
+ t))))
+ (:method ((lhs list) (rhs list))
+ (or (eq lhs rhs)
+ (and lhs rhs
+ (equivp (car lhs) (car rhs))
+ (equivp (cdr lhs) (cdr rhs))))))
+
+
+(defgeneric unify-impl (v w subst)
+ (:method (v w subst)
+ (if (equivp v w) subst +fail+))
+ (:method ((v id) w subst)
+ (extend-subst v w subst))
+ (:method (v (w id) subst)
+ (extend-subst w v subst))
+ (:method ((v cons) (w cons) subst)
+ (let ((subst (unify (car v) (car w) subst)))
+ (if (not (eq subst +fail+))
+ (unify (cdr v) (cdr w) subst)
+ +fail+)))
+ (:method ((v vector) (w vector) subst)
+ (let ((len (length v)))
+ (cond ((= len (length w))
+ (map nil (lambda (v w)
+ (setf subst (unify v w subst))
+ (when (eq subst +fail+)
+ (return-from unify-impl +fail+)))
+ v w)
+ subst)
+ (t +fail+)))))
+
+(defgeneric walk-impl (val subst)
+ (:method (val subst)
+ (declare (ignore subst))
+ val)
+ (:method ((val cons) subst)
+ (cons (walk* (car val) subst)
+ (walk* (cdr val) subst)))
+ (:method ((val vector) subst)
+ (map 'vector
+ (lambda (val)
+ (walk* val subst))
+ val)))
+
+(defgeneric reify-subst-impl (val subst)
+ (:method (val subst)
+ (declare (ignore val))
+ subst)
+ (:method ((val id) subst)
+ (extend-subst val (reify-name (length subst)) subst))
+ (:method ((val cons) subst)
+ (reify-subst (cdr val) (reify-subst (car val) subst)))
+ (:method ((val vector) subst)
+ (reduce (lambda (subst item)
+ (reify-subst item subst))
+ val
+ :initial-value subst)))
\ No newline at end of file
Added: cl-kanren-trs/packages.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/packages.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,23 @@
+(common-lisp:defpackage :kanren-trs
+ (:use :common-lisp)
+ (:export
+ #:defconst
+;;;developer-interface
+ #:unify #:walk* #:reify-subst
+ ;;extenable generics
+ #:equivp #:unify-impl
+ #:walk-impl #:reify-subst-impl
+
+;;;user-interface
+ #:else
+ #:+succeed+
+ #:+fail+ #:run #:==
+ #:fresh #:conde #:condi
+ #:all #:alli #:conda
+ #:condu
+;;;lib-functions
+ #:choice-case #:map-choice #:make-nary-relation
+ #:permute-binary-relation #:make-binary-relation
+ #:permute-ternary-relation #:make-ternary-relation
+))
+
Added: cl-kanren-trs/tests/kanren-aux.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/tests/kanren-aux.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,436 @@
+(in-package :kanren-trs-test)
+
+;;;chapter 1
+;;1.56
+(defun teacupo (x)
+ (conde ((== 'tea x) +succeed+) ;the succeed is unnecessary
+ ((== 'cup x) +succeed+)
+ (else +fail+))) ;this line is superfluous
+
+;;;chapter 2
+;;2.9
+(defun caro (cons car)
+ (fresh (cdr)
+ (== (cons car cdr) cons)))
+
+;;2.16
+(defun cdro (cons cdr)
+ (fresh (car)
+ (== (cons car cdr) cons)))
+
+;;2.28
+(defun conso (car cdr cons)
+ (== (cons car cdr) cons))
+
+;;2.35
+(defun nullo (object)
+ (== '() object))
+
+;;2.40
+(defun eqo (x y)
+ (== x y))
+
+;;2.53
+(defun pairo (pair?)
+ (fresh (car cdr)
+ (conso car cdr pair?)))
+
+;;;chapter 3
+;;3.5
+(defun listo (list)
+ (conde ((nullo list) +succeed+)
+ ((pairo list)
+ (fresh (d)
+ (cdro list d)
+ (listo d)))
+ (else +fail+)))
+
+;;3.17
+(defun lolo (list)
+ (conde ((nullo list) +succeed+)
+ ;;these two fresh clauses could be consolidated into one
+ ((fresh (a)
+ (caro list a)
+ (listo a))
+ (fresh (d)
+ (cdro list d)
+ (lolo d)))
+ (else +fail+)))
+
+;;3.31
+(defun twinso-0 (s)
+ (fresh (x y)
+ (conso x y s)
+ (conso x () y)))
+
+;;3.36
+(defun twinso-1 (s)
+ (fresh (x)
+ (== `(,x ,x) s)))
+
+(setf (symbol-function 'twinso) #'twinso-1)
+
+;;3.37
+(defun loto (list)
+ (conde ((nullo list)
+ +succeed+)
+ ((fresh (a)
+ (caro list a)
+ (twinso a))
+ (fresh (d)
+ (cdro list d)
+ (loto d)))
+ (else +fail+)))
+
+;;3.48
+(defun listofo (predo list)
+ (conde ((nullo list)
+ +succeed+)
+ ((fresh (a)
+ (caro list a)
+ (funcall predo a))
+ (fresh (d)
+ (cdro list d)
+ (listofo predo d)))
+ (else +fail+)))
+
+;;3.50
+(defun loto-1 (list)
+ (listofo #'twinso list))
+
+;;3.54
+(defun eq-caro (list x)
+ (caro list x))
+
+;;3.54
+(defun membero (x list)
+ (conde ((nullo list) +fail+)
+ ((eq-caro list x) +succeed+)
+ (else (fresh (d)
+ (cdro list d)
+ (membero x d)))))
+
+;;3.65
+(defun list-identity (list)
+ (run nil (y)
+ (membero y list)))
+
+;;3.80
+(defun pmembero-0 (x list)
+ (conde ((nullo list) +fail+)
+ ((eq-caro list x) (cdro list '()))
+ (else (fresh (d)
+ (cdro list d)
+ (pmembero-0 x d)))))
+
+;;3.83
+(defun pmembero-1 (x list)
+ (conde ((nullo list) +fail+)
+ ((eq-caro list x) (cdro list '()))
+ ((eq-caro list x) +succeed+)
+ (else (fresh (d)
+ (cdro list d)
+ (pmembero-1 x d)))))
+
+;;3.86
+(defun pmembero-2 (x list)
+ (conde ((nullo list) +fail+)
+ ((eq-caro list x) (cdro list '()))
+ ((eq-caro list x)
+ (fresh (a d)
+ (cdro list `(,a . ,d))))
+ (else (fresh (d)
+ (cdro list d)
+ (pmembero-2 x d)))))
+
+;;3.93
+(defun pmembero-3 (x list)
+ (conde ((eq-caro list x)
+ (fresh (a d)
+ (cdro list `(,a . ,d))))
+ ((eq-caro list x) (cdro list '()))
+ (else (fresh (d)
+ (cdro list d)
+ (pmembero-3 x d)))))
+
+;;3.95
+(defun first-value (list)
+ (run 1 (y)
+ (membero y list)))
+
+;;3.98
+(defun memberrevo (x list)
+ (conde ((nullo list) +fail+)
+ (+succeed+
+ (fresh (d)
+ (cdro list d)
+ (memberrevo x d)))
+ (else (eq-caro list x))))
+
+;;3.101
+(defun reverse-list (list)
+ (run nil (y)
+ (memberrevo y list)))
+
+;;;chapter 4
+(defun memo-0 (x list out)
+ (conde ((nullo list) +fail+)
+ ((eq-caro list x) (== list out))
+ (else (fresh (d)
+ (cdro list d)
+ (memo-0 x d out)))))
+
+(defun memo-1 (x list out)
+ (conde ((eq-caro list x) (== list out))
+ (else (fresh (d)
+ (cdro list d)
+ (memo-1 x d out)))))
+
+(defun remembero (x list out)
+ (conde ((nullo list) (== '() out))
+ ((eq-caro list x)
+ (cdro list out))
+ (else (fresh (a d result)
+ (conso a d list)
+ (remembero x d result)
+ (conso a result out)))))
+
+(defun surpriseo (s)
+ (remembero s '(a b c) '(a b c)))
+
+;;;chapter 5
+(defun appendo-0 (list rest out)
+ (conde ((nullo list) (== rest out))
+ (else (fresh (a d result)
+ (caro list a)
+ (cdro list d)
+ (appendo-0 d rest result)
+ (conso a result out)))))
+
+(defun appendo-1 (list rest out)
+ (conde ((nullo list) (== rest out))
+ (else (fresh (a d result)
+ (conso a d list)
+ (appendo-1 d rest result)
+ (conso a result out)))))
+
+(defun appendo-2 (list rest out)
+ (conde ((nullo list) (== rest out))
+ (else (fresh (a d result)
+ (conso a d list)
+ (conso a result out)
+ (appendo-2 d rest result)))))
+
+(setf (symbol-function 'appendo) #'appendo-2)
+
+(defun swappendo (list rest out)
+ (conde (+succeed+ (fresh (a d result)
+ (conso a d list)
+ (conso a result out)
+ (swappendo d rest result)))
+ (else (nullo list) (== rest out))))
+
+(defun unwrapo-0 (x out)
+ (conde ((pairo x)
+ (fresh (a)
+ (caro x a)
+ (unwrapo-0 a out)))
+ (else (== x out))))
+
+(defun unwrapo-1 (x out)
+ (conde (+succeed+ (== x out))
+ (else (fresh (a) ;note abscence of pairo
+ (caro x a)
+ (unwrapo-1 a out)))))
+
+(defun flatteno (list? out)
+ (conde ((nullo list?) (== '() out))
+ ((pairo list?)
+ (fresh (a d result-car result-cdr)
+ (conso a d list?)
+ (flatteno a result-car)
+ (flatteno d result-cdr)
+ (appendo result-car result-cdr out)))
+ (else (conso list? '() out))))
+
+(defun flattenrevo (list? out)
+ (conde (+succeed+ (conso list? '() out))
+ ((nullo list?) (== '() out))
+ (else
+ (fresh (a d result-car result-cdr)
+ (conso a d list?)
+ (flattenrevo a result-car)
+ (flattenrevo d result-cdr)
+ (appendo result-car result-cdr out)))))
+;;;chapter 6
+;;6.1
+(eval-when (:execute :load-toplevel :compile-toplevel)
+ (defun anyo (goal)
+ (conde (goal +succeed+)
+ (else (anyo goal)))))
+
+;;6.4
+(defconst +never+ (anyo +fail+))
+
+;;6.7
+(defconst +always+ (anyo +succeed+))
+
+;;6.12
+(defconst +sal+ #'(lambda (goal)
+ (conde (+succeed+ +succeed+)
+ (else goal))))
+
+;;;chapter 7
+(defun bit-xoro (x y r)
+ (conde ((== 0 x) (== 0 y) (== 0 r))
+ ((== 1 x) (== 0 y) (== 1 r))
+ ((== 0 x) (== 1 y) (== 1 r))
+ ((== 1 x) (== 1 y) (== 0 r))
+ (else +fail+)))
+
+(defun bit-nando (x y r)
+ (conde ((== 0 x) (== 0 y) (== 1 r))
+ ((== 1 x) (== 0 y) (== 1 r))
+ ((== 0 x) (== 1 y) (== 1 r))
+ ((== 1 x) (== 1 y) (== 0 r))
+ (else +fail+)))
+
+(defun bit-ando (x y r)
+ (conde ((== 0 x) (== 0 y) (== 0 r))
+ ((== 1 x) (== 0 y) (== 0 r))
+ ((== 0 x) (== 1 y) (== 0 r))
+ ((== 1 x) (== 1 y) (== 1 r))
+ (else +fail+)))
+
+(defun half-addero (x y r c)
+ (all (bit-xoro x y r)
+ (bit-ando x y c)))
+
+(defun full-addero (b x y r c)
+ (fresh (w xy wz)
+ (half-addero x y w xy)
+ (half-addero w b r wz)
+ (bit-xoro xy wz c)))
+
+(defun build-num (n)
+ (cond ((zerop n) '())
+ ((oddp n) `(1 . ,(build-num (/ (- n 1) 2))))
+ ((and (evenp n) (not (zerop n)))
+ `(0 . ,(build-num (/ n 2))))))
+
+(defun poso (n)
+ (fresh (a d)
+ (== `(,a . ,d) n)))
+
+(defun >1o (n)
+ (fresh (a ad dd)
+ (== `(,a ,ad . ,dd) n)))
+
+(defun addero (d n m r)
+ (condi ((== 0 d) (== '() m) (== n r))
+ ((== 0 d) (== '() n) (== m r)
+ (poso m))
+ ((== 1 d) (== '() m)
+ (addero 0 n '(1) r))
+ ((== 1 d) (== '() n)
+ (addero 0 '(1) m r))
+ ((== '(1) n) (== '(1) m)
+ (fresh (a c)
+ (== `(,a ,c) r)
+ (full-addero d 1 1 a c)))
+ ((== '(1) n) (gen-addero d n m r))
+ ((== '(1) m) (>1o n) (>1o r)
+ (addero d '(1) n r))
+ ((>1o n) (gen-addero d n m r))
+ (else +fail+)))
+
+(defun gen-addero (d n m r)
+ (fresh (a b c e x y z)
+ (== `(,a . ,x) n)
+ (== `(,b . ,y) m) (poso y)
+ (== `(,c . ,z) r) (poso z)
+ (alli (full-addero d a b c e)
+ (addero e x y z))))
+
+(defun +o (n m k)
+ (addero 0 n m k))
+
+(defun -o (n m k)
+ (+o m k n))
+
+;;;chapter 8
+
+
+;;;chapter 9 (just forms not already in the reference implementation)
+(defun ext-s-check (rhs lhs subst)
+ (cond ((occurs-check rhs lhs subst) +fail+)
+ (t (extend-subst rhs lhs subst))))
+
+(defun unify-check (v w subst)
+ (let ((v (walk v subst))
+ (w (walk w subst)))
+ (cond ((eq v w) subst)
+ ((id-p v)
+ (ext-s-check v w subst))
+ ((id-p w)
+ (ext-s-check w v subst))
+ ((and (consp v) (consp w))
+ (let ((subst (unify-check (car v) (car w) subst)))
+ (if (not (eq subst +fail+))
+ (unify-check (cdr v) (cdr w) subst)
+ +fail+)))
+ ((equal v w) subst)
+ (t +fail+))))
+
+(defun ==-check (v w)
+ #'(lambda (subst)
+ (let ((subst-1 (unify-check v w subst)))
+ (if (not (eq subst-1 +fail+))
+ (funcall +succeed+ subst-1)
+ (funcall +fail+ subst)))))
+
+;;;chapter 10
+(defun not-pastao (x)
+ (conda ((== 'pasta x) +fail+)
+ (else +succeed+)))
+
+(defun onceo (goal)
+ (condu (goal +succeed+)
+ (else +fail+)))
+
+(defun bumpo (n x)
+ (conde ((== n x) +succeed+)
+ (else (fresh (m)
+ (-o n `(1) m)
+ (bumpo m x)))))
+
+(defun gen&testo (op i j k)
+ (onceo (fresh (x y z)
+ (funcall op x y z)
+ (== i x)
+ (== j y)
+ (== k z))))
+
+(defun enumerateo (op r n)
+ (fresh (i j k)
+ (bumpo n i)
+ (bumpo n j)
+ (funcall op i j k)
+ (gen&testo op i j k)
+ (== `(,i ,j ,k) r)))
+
+(defun gen-addero-1 (d n m r)
+ (fresh (a b c e x y z)
+ (== `(,a . ,x) n)
+ (== `(,b . ,y) m) (poso y)
+ (== `(,c . ,z) r) (poso z)
+ (all (full-addero d a b c e)
+ (addero e x y z))))
+
+
+
+
+
+
+
+
Added: cl-kanren-trs/tests/kanren-tests.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/tests/kanren-tests.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,789 @@
+(in-package :kanren-trs-test)
+
+(defmacro tests (&rest tests)
+ `(lambda ()
+ (list
+ ,@(mapcar #'(lambda (test-pair)
+ (let ((test-result (car test-pair))
+ (test-expected (cadr test-pair)))
+ `(if (equal ,test-result ',test-expected)
+ t
+ (format nil "failed:~s -expected ~s -actual ~s"
+ ',(car test-pair)
+ ',test-expected
+ ,test-result))))
+ tests))))
+
+(defun failed-tests ()
+ (reduce #'(lambda (current rest)
+ (if (eq current t)
+ rest
+ (cons current rest)))
+ (run-tests *tests*)
+ :initial-value nil
+ :from-end t))
+
+(defun run-tests (tests)
+ (funcall tests))
+
+(defparameter *tests*
+ (tests
+
+;;;chapter 1
+ ;;
+ ;;1.10
+ ((run nil (q)
+ +fail+)
+ ())
+
+ ;;1.11
+ ((run nil (q)
+ (== 't q))
+ (t))
+
+ ;;1.12
+ ((run nil (q)
+ +fail+
+ (== 't q))
+ ())
+
+ ;;1.13-14
+ ((run nil (q)
+ +succeed+
+ (== 't q))
+ (t))
+
+ ;;1.15-16
+ ((run nil (r)
+ +succeed+
+ (== 'corn r))
+ (corn))
+
+ ;;1.17
+ ((run nil (r)
+ +fail+
+ (== 'corn r))
+ ())
+
+ ;;1.18
+ ((run nil (q)
+ +succeed+
+ (== 'nil q))
+ (nil))
+
+ ;;1.20
+ ((run nil (q)
+ (let ((x 't))
+ (== nil x)))
+ ())
+
+ ;;1.21
+ ((run nil (q)
+ (let ((x nil))
+ (== nil x)))
+ (:_.0))
+
+ ;;1.22
+ ((run nil (x)
+ (let ((x 'nil))
+ (== 't x)))
+ ())
+
+ ;;1.23
+ ((run nil (q)
+ (fresh (x)
+ (== 't x)
+ (== 't q)))
+ (t))
+
+ ;;1.26
+ ((run nil (q)
+ (fresh (x)
+ (== x 't)
+ (== 't q)))
+ (t))
+
+ ;;1.27
+ ((run nil (q)
+ (fresh (x)
+ (== x 't)
+ (== q 't)))
+ (t))
+
+ ;;1.28
+ ((run nil (x)
+ +succeed+)
+ (:_.0))
+
+ ;;1.29
+ ((run nil (x)
+ (let ((x 'nil))
+ (declare (ignorable x))
+ (fresh (x)
+ (== 't x))))
+ (:_.0))
+
+ ;;1.30
+ ((run nil (r)
+ (fresh (x y)
+ (== (cons x (cons y '())) r)))
+ ((:_.0 :_.1)))
+
+ ;;1.31
+ ((run nil (s)
+ (fresh (tee u)
+ (== (cons tee (cons u '())) s)))
+ ((:_.0 :_.1)))
+
+ ;;1.32
+ ((run nil (r)
+ (fresh (x)
+ (let ((y x))
+ (fresh (x)
+ (== (cons y (cons x (cons y '()))) r)))))
+ ((:_.0 :_.1 :_.0)))
+
+ ;;1.33
+ ((run nil (r)
+ (fresh (x)
+ (let ((y x))
+ (fresh (x)
+ (== (cons x (cons y (cons x '()))) r)))))
+ ((:_.0 :_.1 :_.0)))
+
+ ;;1.34
+ ((run nil (q)
+ (== 'nil q)
+ (== 't q))
+ ())
+
+ ;;1.35
+ ((run nil (q)
+ (== 'nil q)
+ (== 'nil q))
+ (nil))
+
+ ;;1.36
+ ((run nil (q)
+ (let ((x q))
+ (== 't x)))
+ (t))
+
+ ;;1.37
+ ((run nil (r)
+ (fresh (x)
+ (== x r)))
+ (:_.0))
+
+ ;;1.38
+ ((run nil (q)
+ (fresh (x)
+ (== 't x)
+ (== x q)))
+ (t))
+
+ ;;1.39
+ ((run nil (q)
+ (fresh (x)
+ (== x q)
+ (== 't x)))
+ (t))
+
+ ;;1.40
+ ((run nil (q)
+ (fresh (x)
+ (== 't x)
+ (== x q)))
+ (t))
+ ((run nil (q)
+ (fresh (x)
+ (== (eq x q) q)))
+ (nil))
+ ((run nil (q)
+ (let ((x q))
+ (fresh (q)
+ (== (eq x q) x))))
+ (nil))
+
+ ;;1.43
+ ((run nil (q)
+ (cond (nil +succeed+)
+ (t +fail+))
+ (== 't q))
+ ())
+
+ ;;1.44
+ ((run nil (q)
+ (conde (+fail+ +succeed+)
+ (else +fail+))
+ (== 't q))
+ ())
+
+ ;;1.45
+ ((run nil (q)
+ (conde (+fail+ +fail+)
+ (else +succeed+))
+ (== 't q))
+ (t))
+
+ ;;1.46
+ ((run nil (q)
+ (conde (+succeed+ +succeed+)
+ (else +fail+))
+ (== 't q))
+ (t))
+
+ ;;1.47
+ ((run nil (x)
+ (conde ((== 'olive x) +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ (olive oil))
+
+ ;;1.49
+ ((run 1 (x)
+ (conde ((== 'olive x) +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ (olive))
+
+ ;;1.50
+ ((run nil (x)
+ (conde ((== 'virgin x) +fail+)
+ ((== 'olive x) +succeed+)
+ (+succeed+ +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ (olive :_.0 oil))
+
+ ;;1.52
+ ((run 2 (x)
+ (conde ((== 'extra x) +succeed+)
+ ((== 'virgin x) +fail+)
+ ((== 'olive x) +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ (extra olive))
+
+ ;;1.53
+ ((run nil (r)
+ (fresh (x y)
+ (== 'split x)
+ (== 'pea y)
+ (== (cons x (cons y '())) r)))
+ ((split pea)))
+
+ ;;1.54
+ ((run nil (r)
+ (fresh (x y)
+ (conde ((== 'split x) (== 'pea y))
+ ((== 'navy x) (== 'bean y))
+ (else +fail+))
+ (== (cons x (cons y '())) r)))
+ ((split pea)(navy bean)))
+
+ ;;1.55
+ ((run nil (r)
+ (fresh (x y)
+ (conde ((== 'split x) (== 'pea y))
+ ((== 'navy x) (== 'bean y))
+ (else +fail+))
+ (== (cons x (cons y (cons 'soup '()))) r)))
+ ((split pea soup) (navy bean soup)))
+
+ ;;1.56
+ ((run nil (x)
+ (teacupo x))
+ (tea cup))
+
+ ;;1.57
+ ((run nil (r)
+ (fresh (x y)
+ (conde ((teacupo x) (== 't y) +succeed+)
+ ((== 'nil x) (== 't y))
+ (else +fail+))
+ (== (cons x (cons y '())) r)))
+ ((tea t)(cup t)(nil t)))
+
+ ;;1.58
+ ((run nil (r)
+ (fresh (x y z)
+ (conde ((== y x) (fresh (x)(== z x)))
+ ((fresh (x) (== y x)) (== z x))
+ (else +fail+))
+ (== (cons y (cons z '())) r)))
+ ((:_.0 :_.1)(:_.0 :_.1)))
+
+ ;;1.59
+ ((run nil (r)
+ (fresh (x y z)
+ (conde ((== y x) (fresh (x)(== z x)))
+ ((fresh (x) (== y x)) (== z x))
+ (else +fail+))
+ (== 'nil x)
+ (== (cons y (cons z '())) r)))
+ ((nil :_.0)(:_.0 nil)))
+
+ ;;1.60
+ ((run nil (q)
+ (let ((a (== 't q))
+ (b (== 'nil q)))
+ (declare (ignorable a))
+ b))
+ (nil))
+
+ ;;1.61
+ ((run nil (q)
+ (let ((a (== 't q))
+ (b (fresh (x)
+ (== x q)
+ (== 'nil x)))
+ (c (conde ((== 't q) +succeed+)
+ (else (== 'nil q)))))
+ (declare (ignorable a c))
+ b))
+ (nil))
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;chapter 2
+ ;;
+ ;;2.2
+ ((run nil (r)
+ (fresh (y x)
+ (== `(,x ,y) r)))
+ ((:_.0 :_.1)))
+
+ ;;2.3
+ ((run nil (r)
+ (fresh (v w)
+ (== (let ((x v)
+ (y w))
+ `(,x ,y))
+ r)))
+ ((:_.0 :_.1)))
+
+ ;;2.6
+ ((run nil (r)
+ (caro '(a c o r n) r))
+ (a))
+
+ ;;2.7
+ ((run nil (q)
+ (caro '(a c o r n) 'a)
+ (== 't q))
+ (t))
+
+ ;;2.8
+ ((run nil (r)
+ (fresh (x y)
+ (caro `(,r ,y) x)
+ (== 'pear x)))
+ (pear))
+
+ ;;2.11
+ ((run nil (r)
+ (fresh (x y)
+ (caro '(grape raisin pear) x)
+ (caro '((a)(b)(c)) y)
+ (== (cons x y) r)))
+ ((grape a)))
+
+ ;;2.15
+ ((run nil (r)
+ (fresh (v)
+ (cdro '(a c o r n) v)
+ (caro v r)))
+ (c))
+
+ ;;2.18
+ ((run nil (r)
+ (fresh (x y)
+ (cdro '(grape raisin pear) x)
+ (caro '((a)(b)(c)) y)
+ (== (cons x y) r)))
+ (((raisin pear) a)))
+
+ ;;2.19
+ ((run nil (q)
+ (cdro '(a c o r n) '(c o r n))
+ (== 't q))
+ (t))
+
+ ;;2.20
+ ((run nil (x)
+ (cdro '(c o r n) `(,x r n)))
+ (o))
+
+ ;;2.21
+ ((run nil (l)
+ (fresh (x)
+ (cdro l '(c o r n))
+ (caro l x)
+ (== 'a x)))
+ ((a c o r n)))
+
+ ;;2.22
+ ((run nil (l)
+ (conso '(a b c) '(d e) l))
+ (((a b c) d e)))
+
+ ;;2.23
+ ((run nil (x)
+ (conso x '(a b c) '(d a b c)))
+ (d))
+
+ ;;2.24
+ ((run nil (r)
+ (fresh (x y z)
+ (== `(e a d ,x) r)
+ (conso y `(a ,z c) r)))
+ ((e a d c)))
+
+ ;;2.25
+ ((run nil (x)
+ (conso x `(a ,x c) `(d a ,x c)))
+ (d))
+
+ ;;2.26
+ ((run nil (l)
+ (fresh (x)
+ (== `(d a ,x c) l)
+ (conso x `(a ,x c) l)))
+ ((d a d c)))
+
+ ;;2.27
+ ((run nil (l)
+ (fresh (x)
+ (conso x `(a ,x c) l)
+ (== `(d a ,x c) l)))
+ ((d a d c)))
+
+ ;;2.29
+ ((run nil (l)
+ (fresh (d x y w s)
+ (conso w '(a n s) s)
+ (cdro l s)
+ (caro l x)
+ (== 'b x)
+ (cdro l d)
+ (caro d y)
+ (== 'e y)))
+ ((b e a n s)))
+
+ ;;2.32
+ ((run nil (q)
+ (nullo '(grape raisin pear))
+ (== 't q))
+ ())
+
+ ;;2.33
+ ((run nil (q)
+ (nullo '())
+ (== 't q))
+ (t))
+
+ ;;2.34
+ ((run nil (x)
+ (nullo x))
+ (()))
+
+ ;;2.38
+ ((run nil (q)
+ (eqo 'pear 'plum)
+ (== 't q))
+ ())
+
+ ;;2.39
+ ((run nil (q)
+ (eqo 'plum 'plum)
+ (== 't q))
+ (t))
+
+ ;;2.52
+ ((run nil (r)
+ (fresh (x y)
+ (== (cons x (cons y 'salad)) r)))
+ ((:_.0 :_.1 . salad)))
+
+ ;;2.54
+ ((run nil (q)
+ (pairo (cons q q))
+ (== 't q))
+ (t))
+
+ ;;2.55
+ ((run nil (q)
+ (pairo '())
+ (== 't q))
+ ())
+
+ ;;2.56
+ ((run nil (q)
+ (pairo 'pair)
+ (== 't q))
+ ())
+
+ ;;2.57
+ ((run nil (x)
+ (pairo x))
+ ((:_.0 . :_.1)))
+
+ ;;2.58
+ ((run nil (r)
+ (pairo (cons r 'pear)))
+ (:_.0))
+;;;;;;;;;;;;;;;;;;;;;;;
+;;;chapter 3
+ ;;
+ ;;3.7
+ ((run nil (x)
+ (listo `(a b ,x d)))
+ (:_.0))
+
+ ;;3.10
+ ((run 1 (x)
+ (listo `(a b c . ,x)))
+ (()))
+
+ ;;3.14
+ ((run 5 (x)
+ (listo `(a b c . ,x)))
+ (()
+ (:_.0)
+ (:_.0 :_.1)
+ (:_.0 :_.1 :_.2)
+ (:_.0 :_.1 :_.2 :_.3)))
+
+ ;;3.20
+ ((run 1 (l)
+ (lolo l))
+ (()))
+
+ ;;3.21
+ ((run nil (q)
+ (fresh (x y)
+ (lolo `((a b)(,x c)(d ,y)))
+ (== 't q)))
+ (t))
+
+ ;;3.22
+ ((run 1 (q)
+ (fresh (x)
+ (lolo `((a b) . ,x))
+ (== 't q)))
+ (t))
+
+ ;;3.23
+ ((run 1 (x)
+ (lolo `((a b)(c d) . ,x)))
+ (()))
+
+ ;;3.24
+ ((run 5 (x)
+ (lolo `((a b)(c d) . ,x)))
+ (()
+ (())
+ (() ())
+ (() () ())
+ (() () () ())))
+
+ ;;3.32
+ ((run nil (q)
+ (twinso-0 '(tofu tofu))
+ (== 't q))
+ (t))
+ ((run nil (q)
+ (twinso-1 '(tofu tofu))
+ (== 't q))
+ (t))
+
+ ;;3.33
+ ((run nil (z)
+ (twinso-0 `(,z tofu)))
+ (tofu))
+ ((run nil (z)
+ (twinso-1 `(,z tofu)))
+ (tofu))
+
+ ;;3.38
+ ((run 1 (z)
+ (loto `((g g) . ,z)))
+ (()))
+
+ ;;3.42
+ ((run 5 (z)
+ (loto `((g g) . ,z)))
+ (()
+ ((:_.0 :_.0))
+ ((:_.0 :_.0) (:_.1 :_.1))
+ ((:_.0 :_.0) (:_.1 :_.1) (:_.2 :_.2))
+ ((:_.0 :_.0) (:_.1 :_.1) (:_.2 :_.2) (:_.3 :_.3))))
+
+ ;;3:45
+ ((run 5 (r)
+ (fresh (w x y z)
+ (loto `((g g) (e ,w) (,x ,y) . ,z))
+ (== `(,w (,x ,y) ,z) r)))
+ ((e (:_.0 :_.0) ())
+ (e (:_.0 :_.0) ((:_.1 :_.1)))
+ (e (:_.0 :_.0) ((:_.1 :_.1) (:_.2 :_.2)))
+ (e (:_.0 :_.0) ((:_.1 :_.1) (:_.2 :_.2) (:_.3 :_.3)))
+ (e (:_.0 :_.0) ((:_.1 :_.1) (:_.2 :_.2) (:_.3 :_.3) (:_.4 :_.4)))))
+
+ ;;3.47
+ ((run 3 (out)
+ (fresh (w x y z)
+ (== `((g g) (e ,w) (,x ,y) . ,z) out)
+ (loto out)))
+ (((g g) (e e) (:_.0 :_.0))
+ ((g g) (e e) (:_.0 :_.0) (:_.1 :_.1))
+ ((g g) (e e) (:_.0 :_.0) (:_.1 :_.1) (:_.2 :_.2))))
+
+ ;;3.49
+ ((run 3 (out)
+ (fresh (w x y z)
+ (== `((g g) (e ,w) (,x ,y) . ,z) out)
+ (listofo #'twinso out)))
+ (((g g) (e e) (:_.0 :_.0))
+ ((g g) (e e) (:_.0 :_.0) (:_.1 :_.1))
+ ((g g) (e e) (:_.0 :_.0) (:_.1 :_.1) (:_.2 :_.2))))
+
+ ;;3.57
+ ((run nil (q)
+ (membero 'olive '(virgin olive oil))
+ (== 't q))
+ (t))
+
+ ;;3.58
+ ((run 1 (y)
+ (membero y '(hummus with pita)))
+ (hummus))
+
+ ;;3.59
+ ((run 1 (y)
+ (membero y '(with pita)))
+ (with))
+
+ ;;3.60
+ ((run 1 (y)
+ (membero y '(pita)))
+ (pita))
+
+ ;;3.61
+ ((run 1 (y)
+ (membero y '()))
+ ())
+
+ ;;3.62
+ ((run nil (y)
+ (membero y '(hummus with pita)))
+ (hummus with pita))
+
+ ;;3.66
+ ((run nil (x)
+ (membero 'e `(pasta ,x fagioli)))
+ (e))
+
+ ;;3.69
+ ((run nil (x)
+ (membero 'e `(pasta e ,x fagioli)))
+ (:_.0 e))
+
+ ;;3.70
+ ((run nil (x)
+ (membero 'e `(pasta ,x e fagioli)))
+ (e :_.0))
+
+ ;;3.71
+ ((run nil (r)
+ (fresh (x y)
+ (membero 'e `(pasta ,x fagioli ,y))
+ (== `(,x ,y) r)))
+ ((e :_.0) (:_.0 e)))
+
+ ;;3.73
+ ((run 1 (l)
+ (membero 'tofu l))
+ ((tofu . :_.0)))
+
+ ;;3.76
+ ((run 5 (l)
+ (membero 'tofu l))
+ ((tofu . :_.0)
+ (:_.0 tofu . :_.1)
+ (:_.0 :_.1 tofu . :_.2)
+ (:_.0 :_.1 :_.2 tofu . :_.3)
+ (:_.0 :_.1 :_.2 :_.3 tofu . :_.4)))
+
+ ;;3.81
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;6.24
+ ((run 5 (r)
+ (condi ((teacupo r) +succeed+)
+ ((== nil r) +succeed+)
+ (else +fail+)))
+ (tea nil cup))
+
+ ;;6.24
+ ((run 5 (q)
+ (condi ((== 'nil q) +always+)
+ ((== 't q) +always+)
+ (else +fail+))
+ (== 't q))
+ (t t t t t))
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;10.1
+ ((run nil (q)
+ (conda (+fail+ +succeed+)
+ (else +fail+)))
+ ())
+
+ ;;10.2
+ ((run nil (q)
+ (conda (+fail+ +succeed+)
+ (else +succeed+)))
+ (:_.0))
+
+ ;;10.3
+ ((run nil (q)
+ (conda (+succeed+ +fail+)
+ (else +succeed+)))
+ ())
+
+ ;;10.4
+ ((run nil (q)
+ (conda (+succeed+ +succeed+)
+ (else +fail+)))
+ (:_.0))
+
+ ;;10.5
+ ((run nil (x)
+ (conda ((== 'olive x) +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ (olive))
+
+ ;;10.7
+ ((run nil (x)
+ (conda ((== 'virgin x) +fail+)
+ ((== 'olive x) +succeed+)
+ ((== 'oil x) +succeed+)
+ (else +fail+)))
+ ())
+
+ ;;10.14
+ ((run nil (q)
+ (condu (+always+ +succeed+)
+ (else +fail+))
+ (== 't q))
+ (t))
+
+ ;;10.18
+ ((run 1 (q)
+ (condu (+always+ +succeed+)
+ (else +fail+))
+ +fail+
+ (== 't q))
+ ())
+))
+
Added: cl-kanren-trs/tests/kanren-trs-test.asd
==============================================================================
--- (empty file)
+++ cl-kanren-trs/tests/kanren-trs-test.asd Wed Jun 18 19:34:19 2008
@@ -0,0 +1,10 @@
+;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
+
+;;; ASDF system definition for the my local packages.
+
+(asdf:defsystem :kanren-trs-test
+ :components
+ ((:file "packages")
+ (:file "kanren-aux" :depends-on ("packages"))
+ (:file "kanren-tests" :depends-on ("kanren-aux")))
+ :depends-on (:kanren-trs :stefil))
Added: cl-kanren-trs/tests/packages.lisp
==============================================================================
--- (empty file)
+++ cl-kanren-trs/tests/packages.lisp Wed Jun 18 19:34:19 2008
@@ -0,0 +1,2 @@
+(cl:defpackage :kanren-trs-test
+ (:use :cl :kanren-trs :stefil))
\ No newline at end of file
More information about the cl-kanren-trs-cvs
mailing list