April 2009 - cl-unification-cvs@common-lisp.net

[cl-unification-cvs] CVS cl-unification/test
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification/test In directory cl-net:/tmp/cvs-serv30009/test Modified Files: unification-tests.lisp Log Message: Modified Files: test/unification-tests.lisp Added Files: lib-dependent/cl-ppcre-template.lisp The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library to provide a seamless (YMMV) reuse of regular expressions within CL-UNIFICATION. --- /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp 2008/07/13 13:14:56 1.1 +++ /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp 2009/04/15 10:24:28 1.2 @@ -3,6 +3,8 @@ ;;;; unification-tests.lisp -- ;;;; CL-UNIFICATION test suite. Requires Franz's util.test package. +(in-package "UNIFY.TESTS") + (use-package "UNIFY") (use-package "UTIL.TEST") @@ -108,24 +110,79 @@ ((a :initarg :a :accessor a) (b :initarg :b :accessor b))) +(defstruct s-root a) +(defstruct (s-child (:include s-root)) b) + (with-tests (:name "advanced templates unification") (test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _)) #2A((1 a 3) (q w e)))) :multiple-values t) - (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x)))) - :multiple-values t - :known-failure t - :fail-info "ELT templates must be fixed.") - - (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x)))) - :multiple-values t - :known-failure t - :fail-info "NTH templates must be fixed.") + (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x)))) + :multiple-values t) + + (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x)))) + :multiple-values t) + + (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x)))) + :multiple-values t) + + (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x)))) + :multiple-values t) + + (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x)))) + :multiple-values t) + + (test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x))) + :multiple-values t) + + (test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5)))) + :multiple-values t) + + (test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42))) + :multiple-values t) + + (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x)) + :condition-type 'unification-failure + :announce t) + + (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42) + '(0 1 (?y bar (1) (2) (3)) 42))) + ) + (cons (v? '?y result-env) + (v? '?z result-env))) + :test #'equal) (test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot") - (make-instance 'test1 :a '(1 2 3) :b "woot"))) + (make-instance 'test1 :a '(1 2 3) :b "woot"))) + :multiple-values t) + + (test-error (unify #T(s-root s-root-a '(1 ?x 3 4)) + (make-s-root :a '(1 2 3 4))) + :condition-type 'unification-failure + :announce t + ;; #T reader non evaluating sub forms. + ) + + (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4)) + (make-s-root :a '(1 2 3 4)))) + :multiple-values t) + + (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4)) + (make-s-root :a '(1 2 3 4)))) + :multiple-values t) + + (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest)) + (make-s-root :a '(1 2 3 4)))) + :multiple-values t) + + (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4)) + (make-s-root :a #(1 2 3 4)))) + :multiple-values t) + + (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest)) + (make-s-root :a #(1 2 3 4)))) :multiple-values t) ) @@ -139,11 +196,15 @@ ('(:c ?c) ?c) ('(:d ?d) ?d) (otherwise (error "error-inner"))))) - (otherwise "error-outer"))) + (otherwise (error "error-outer")))) (with-tests (:name "control flow") - (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=) + (test-error (nested-match-cases '(:a 42 :b 33)) :announce t) + + (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t) + (test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44)))) + :test #'equal) )

1 0

[cl-unification-cvs] CVS cl-unification/lib-dependent
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent In directory cl-net:/tmp/cvs-serv27661/lib-dependent Log Message: Directory /project/cl-unification/cvsroot/cl-unification/lib-dependent added to the repository

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27591 Modified Files: templates-hierarchy.lisp Log Message: Added LAMBDA-TEMPLATE. --- /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2008/07/13 13:10:48 1.4 +++ /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2009/04/15 10:18:59 1.5 @@ -1,4 +1,6 @@ -;;; -*- Mode: Lisp -*- +;;;; -*- Mode: Lisp -*- + +;;;; templates-hierarchy.lisp -- (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. @@ -121,6 +123,15 @@ (:method ((x list-template)) t) (:method ((x t)) nil)) + +(defclass lambda-template (list-template expression-template) ()) + +(defgeneric lambda-template-p (x) + (:method ((x lambda-template)) t) + (:method ((x t)) nil)) + + + (defclass array-template (type-template) ()) (defgeneric array-template-p (x) @@ -332,6 +343,9 @@ (defmethod make-template ((kind (eql 'list)) (spec cons)) (make-instance 'list-template :spec spec)) +(defmethod make-template ((kind (eql 'lambda)) (spec cons)) + (make-instance 'lambda-template :spec spec)) + (defmethod make-template ((kind (eql 'vector)) (spec cons)) (make-instance 'vector-template :spec spec))

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27503 Modified Files: substitutions.lisp Log Message: Added some functionality to extract all variables and/or all values from an environment or a frame. --- /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2008/07/13 13:10:48 1.4 +++ /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2009/04/15 10:17:48 1.5 @@ -39,6 +39,11 @@ (setf (cdr b) v)) +(defun bindings-values (bindings) (mapcar #'cdr bindings)) + +(defun bindings-keys (bindings) (mapcar #'car bindings)) + + (define-condition unification-variable-unbound (unbound-variable) () @@ -51,7 +56,7 @@ ;;;--------------------------------------------------------------------------- ;;; Frames. -(defstruct frame +(defstruct (frame (:constructor make-frame (&optional bindings))) (bindings () :type bindings)) (defun empty-frame-p (f) @@ -72,6 +77,13 @@ (values (cdr b) t) (values nil nil)))) +(defun frame-variables (frame) + (mapcar 'binding-variable (frame-bindings frame))) + + +(defun frame-values (frame) + (mapcar 'binding-value (frame-bindings frame))) + ;;;--------------------------------------------------------------------------- ;;; Environments. @@ -106,10 +118,12 @@ (defun make-shared-environment (env) (make-environment :frames (environment-frames env))) -(defun empty-environment-p (env &aux (env-frames (environment-frames env))) +(defun empty-environment-p (env) (declare (type environment env)) - (and (= 1 (list-length env-frames)) - (empty-frame-p (first env-frames)))) + (let ((env-frames (environment-frames env))) + (declare (type list env-frames)) + (and (= 1 (list-length env-frames)) + (empty-frame-p (first env-frames))))) (defparameter *null-environment* (make-empty-environment)) @@ -131,19 +145,43 @@ -(defun extend-environment (var pat env) +(defun extend-environment (var pat &optional (env (make-empty-environment))) (let ((first-frame (first-frame env))) (setf (frame-bindings first-frame) (extend-bindings var pat (frame-bindings first-frame))) env)) +(defun fill-environment (vars pats &optional (env (make-empty-environment))) + (map nil (lambda (v p) (extend-environment v p env)) vars pats) + env) + + +(defun fill-environment* (vars-pats &optional (env (make-empty-environment))) + (loop for (v . p) in vars-pats do (extend-environment v p env)) + env) + + +(declaim (inline v?)) +(declaim (ftype (function (symbol environment &optional boolean) + (values t boolean)) + find-variable-value + v?)) + (defun v? (s env &optional (plain-symbol-p nil)) (find-variable-value (if plain-symbol-p (make-var-name s) s) env)) - + + +(defun environment-variables (env) + (mapcan #'frame-variables (environment-frames env))) + +(defun environment-values (env) + (mapcan #'frame-values (environment-frames env))) + + ;;;; end of file -- substitutions.lisp --

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27397 Modified Files: match-block.lisp Log Message: Added MATCHF (whose name may change) to simplify the 'destructuring-bind'-like syntax and behavior of the matching facilities. --- /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2007/11/09 13:43:20 1.8 +++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2009/04/15 10:16:24 1.9 @@ -13,6 +13,7 @@ (defmacro match ((template object &key + (match-named nil) (substitution '(make-empty-environment)) (errorp t) (error-value nil)) @@ -32,6 +33,9 @@ whose default is NIL is returned. (Note that UNIFICATION-FAILUREs raising from the evaluation of FORMS will also be caught and handled according to ERRORP settings.) + +If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED +is set up around the matching code. " (let ((template-vars (collect-template-vars template)) (env-var (gensym "UNIFICATION-ENV-")) @@ -45,7 +49,73 @@ ,env-var)) `(,(clean-unify-var-name v) ,v)))) ) - `(block nil + `(block ,match-named + (handler-case + (let* ((,env-var (unify ,template ,object ,substitution)) + ,@(generate-var-bindings) + ) + (declare (ignorable ,@(mapcar #'first + (generate-var-bindings)))) + ,@forms) + + ;; Yes. The above is sligthly wasteful. + + (unification-failure (uf) + (if ,errorp + (error uf) + ,error-value)) + ))))) + + +(defmacro matchf ((template object + &key + (match-named nil) + (substitution '(make-empty-environment)) + (errorp t) + (error-value nil)) + &body forms) + "Sets up a lexical environment to evaluate FORMS after an unification. + +MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical +environment where the variables present in the template are bound +lexically. Note that both variable names '?FOO' and 'FOO' are bound +for convenience. + +MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will +generate a template at read-time). + +The MATCHF form returns the values returned by the evaluation of the +last of the FORMS. + +If ERRORP is non-NIL (the default) then the form raises a +UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE, +whose default is NIL is returned. (Note that UNIFICATION-FAILUREs +raising from the evaluation of FORMS will also be caught and handled +according to ERRORP settings.) + +If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED +is set up around the matching code. +" + (let ((template-vars (collect-template-vars template)) + (env-var (gensym "UNIFICATION-ENV-")) + (template (cond ((variablep template) + `',template) ; Logical variables are special-cased. + ((listp template) ; Same for lists. + (make-instance 'list-template + :spec (cons 'list template))) + ;`',template) + (t + template))) + ) + ;; Logical variables and lists are special cased for convenience. + ;; Lists are especially inteded as abbreviation for destructuring. + (flet ((generate-var-bindings () + (loop for v in template-vars + nconc (list `(,v (find-variable-value ',v + ,env-var)) + `(,(clean-unify-var-name v) ,v)))) + ) + `(block ,match-named (handler-case (let* ((,env-var (unify ,template ,object ,substitution)) ,@(generate-var-bindings) @@ -70,7 +140,8 @@ (defmacro matching ((&key errorp (default-substitution - (make-empty-environment))) + (make-empty-environment)) + (matching-named nil)) &rest match-clauses) "MATCHING sets up a COND-like environment for multiple template matching clauses. @@ -150,7 +221,7 @@ match-clauses)) ) - `(block matching + `(block ,matching-named (let ,match-clauses-env-vars (declare (dynamic-extent ,@match-clauses-env-vars)) (cond ,@(mapcar (lambda (match-clause match-clause-env-var) @@ -171,11 +242,11 @@ ;;; Notes: ;;; ;;; [MA 20071109] -;;; When the construction of the inner MATCH clauses could be done +;;; The construction of the inner MATCH clauses could be done ;;; more intelligently by supplying :ERRORP NIL, thus avoiding the ;;; HANDLER-CASEs, which are quite expensive. Any takers? -(defmacro match-case ((object &key errorp default-substitution) +(defmacro match-case ((object &key errorp default-substitution match-case-named) &rest clauses) "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses. @@ -227,9 +298,10 @@ `(handler-case (match (,pattern ,object-var) ,@body) (unification-failure () - ,(generate-matchers (cdr clauses)))))))) - `(let ((,object-var ,object)) - ,(generate-matchers non-otherwise-clauses))))) + ,(generate-matchers (cdr clauses)))))))) + `(block ,match-case-named + (let ((,object-var ,object)) + ,(generate-matchers non-otherwise-clauses)))))) ;;;;--------------------------------------------------------------------------- ;;;; Testing.

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27295 Modified Files: COPYING Log Message: Dates updated. --- /project/cl-unification/cvsroot/cl-unification/COPYING 2008/07/13 13:17:29 1.4 +++ /project/cl-unification/cvsroot/cl-unification/COPYING 2009/04/15 10:14:59 1.5 @@ -1,4 +1,4 @@ -Copyright (c) 2004-2008 Marco Antoniotti +Copyright (c) 2004-2009 Marco Antoniotti All rights reserved. Permission is hereby granted, without written agreement and without

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27225 Modified Files: unifier.lisp Log Message: Major API change to 'unify'. It now accepts keywords. Old code shouls not be affected, but new code is now more flexible. Look the the STRING and (new) CHARACTER methods to see how this change is affecting the code. --- /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2006/07/19 21:52:34 1.5 +++ /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2009/04/15 10:14:24 1.6 @@ -5,7 +5,7 @@ (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. -(defgeneric unify (a b &optional env) +(defgeneric unify (a b &optional env &key &allow-other-keys) (:documentation "Unifies two objects A and B given a substitution ENV. A is a Common Lisp object and B is either a Common Lisp object or a @@ -22,7 +22,9 @@ ;;;=========================================================================== ;;; Simple, non template methods. -(defmethod unify ((a symbol) (b list) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b list) + &optional (env (make-empty-environment)) + &key &allow-other-keys) "Unifies a symbol A and a list B in an environment ENV. If A is not a variable then an error of type UNIFICATION-FAILURE is signaled. If A is a unification variable, then the environment ENV is @@ -35,7 +37,9 @@ :format-arguments (list a b))))) -(defmethod unify ((b list) (a symbol) &optional (env (make-empty-environment))) +(defmethod unify ((b list) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) "Unifies a symbol B and a list A in an environment ENV. If A is not a variable then an error of type UNIFICATION-FAILURE is signaled. If A is a unification variable, then the environment ENV is @@ -48,7 +52,9 @@ :format-arguments (list b a))))) -(defmethod unify ((a list) (b list) &optional (env (make-empty-environment))) +(defmethod unify ((a list) (b list) + &optional (env (make-empty-environment)) + &key &allow-other-keys) "Unifies a list A and a list B in an environment ENV. The unification procedure proceedes recursively on each element of both lists. If two elements cannot be unified then an error of type @@ -58,7 +64,9 @@ -(defmethod unify ((a number) (b number) &optional (env (make-empty-environment))) +(defmethod unify ((a number) (b number) + &optional (env (make-empty-environment)) + &key &allow-other-keys) "Unifies two numbers A and B. Two numbers unify only if and only if they are equal as per the function #'=, in which case an unmodified envirironment ENV is returned. @@ -72,9 +80,35 @@ :format-arguments (list a b)))) -(defparameter *unify-string-case-insensitive-p* nil) +(defparameter *unify-string-case-sensitive-p* t) -(defmethod unify ((a string) (b string) &optional (env (make-empty-environment))) +(defmethod unify ((a character) (b character) + &optional (env (make-empty-environment)) + &key + (case-sensitive *unify-string-case-sensitive-p*) + &allow-other-keys) + "Unifies two strings A and B. +Two CHARACTERs A and B unify if and only if they satisfy either #'CHAR= or +#'CHAR-EQUAL. The choice of which of test to perform (#'CHAR= or #'CHAR-EQUAL) +is made according to the value of the variable +*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL. +If A and B unify then an unmodified environment ENV is returned, +otherwise an error of type UNIFICATION-FAILURE is signaled." + (cond ((and case-sensitive (char= a b)) + env) + ((char-equal a b) + env) + (t + (error 'unification-failure + :format-control "Connot unify two different characters: ~S ~S." + :format-arguments (list a b))))) + + +(defmethod unify ((a string) (b string) + &optional (env (make-empty-environment)) + &key + (case-sensitive *unify-string-case-sensitive-p*) + &allow-other-keys) "Unifies two strings A and B. Two strings A and B unify if and only if they satisfy either #'STRING= or #'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL) @@ -82,9 +116,9 @@ *UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL. If A and B unify then an unmodified environment ENV is returned, otherwise an error of type UNIFICATION-FAILURE is signaled." - (cond ((and *unify-string-case-insensitive-p* (string-equal a b)) + (cond ((and case-sensitive (string= a b)) env) - ((string= a b) + ((string-equal a b) env) (t (error 'unification-failure @@ -92,7 +126,9 @@ :format-arguments (list a b))))) -(defmethod unify ((a symbol) (b string) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b string) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (error 'unification-failure @@ -100,7 +136,9 @@ :format-arguments (list a b))))) -(defmethod unify ((b string) (a symbol) &optional (env (make-empty-environment))) +(defmethod unify ((b string) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (error 'unification-failure @@ -108,7 +146,9 @@ :format-arguments (list b a))))) -(defmethod unify ((a symbol) (b symbol) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) ((variable-any-p b) env) @@ -119,27 +159,36 @@ :format-arguments (list a b))))) -(defmethod unify ((a symbol) (b t) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b t) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (call-next-method)))) -(defmethod unify ((b t) (a symbol) &optional (env (make-empty-environment))) +(defmethod unify ((b t) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (call-next-method)))) -(defmethod unify ((a symbol) (b array) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b array) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (error 'unification-failure - :format-control "Cannot unify a symbol with an array or vector: ~S and ~S." + :format-control "Cannot unify a symbol with ~ + an array or vector: ~S and ~S." :format-arguments (list a b))))) -(defmethod unify ((b array) (a symbol) &optional (env (make-empty-environment))) +(defmethod unify ((b array) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (error 'unification-failure @@ -147,7 +196,9 @@ :format-arguments (list a b))))) -(defmethod unify ((as vector) (bs vector) &optional (env (make-empty-environment))) +(defmethod unify ((as vector) (bs vector) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unless (= (length as) (length bs)) (error 'unification-failure :format-control "Cannot unify two vectors of different length: ~D and ~D." @@ -158,7 +209,9 @@ finally (return mgu))) -(defmethod unify ((s1 sequence) (s2 sequence) &optional (env (make-empty-environment))) +(defmethod unify ((s1 sequence) (s2 sequence) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unless (= (length s1) (length s2)) (error 'unification-failure :format-control "Cannot unify two sequences of different length: ~D and ~D." @@ -186,7 +239,9 @@ (unify a b env)) -(defmethod unify ((as array) (bs array) &optional (env (make-empty-environment))) +(defmethod unify ((as array) (bs array) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unless (= (array-total-size as) (array-total-size bs)) (error 'unification-failure :format-control "Cannot unify two arrays of different total size: ~D and ~D." @@ -200,7 +255,9 @@ ;;; Catch all method. -(defmethod unify ((a t) (b t) &optional (env (make-empty-environment))) +(defmethod unify ((a t) (b t) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (if (equalp a b) env (error 'unification-failure @@ -229,10 +286,13 @@ ;;; Special catch all method. -(defmethod unify ((x template) (y template) &optional (env (make-empty-environment))) +(defmethod unify ((x template) (y template) + &optional (env) + &key &allow-other-keys) (declare (ignore env)) (error 'unification-failure - :format-control "Unification of two templates of type ~A and ~A has not been yet implemented." + :format-control "Unification of two templates of type ~A and ~A ~ + has not been yet implemented." :format-arguments (list (class-name (class-of x)) (class-name (class-of y))))) @@ -241,45 +301,58 @@ ;;; NIL special unification methods. (defmethod unify ((x null) (y null) - &optional (env (make-empty-environment))) + &optional (env (make-empty-environment)) + &key &allow-other-keys) env) (defmethod unify ((x null) (nt nil-template) - &optional (env (make-empty-environment))) + &optional (env (make-empty-environment)) + &key &allow-other-keys) env) (defmethod unify ((nt nil-template) (x null) - &optional (env (make-empty-environment))) + &optional (env (make-empty-environment)) + &key &allow-other-keys) env) (defmethod unify ((nt1 nil-template) (nt2 nil-template) - &optional (env (make-empty-environment))) + &optional (env (make-empty-environment)) + &key &allow-other-keys) env) ;;;--------------------------------------------------------------------------- ;;; Symbol methods. -(defmethod unify ((a symbol) (b symbol-template) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b symbol-template) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (cond ((variable-any-p a) env) ((variablep a) (var-unify a b env)) (t (unify a (symbol-template-symbol b) env)))) -(defmethod unify ((b symbol-template) (a symbol) &optional (env (make-empty-environment))) +(defmethod unify ((b symbol-template) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) -(defmethod unify ((a symbol) (b template) &optional (env (make-empty-environment))) +(defmethod unify ((a symbol) (b template) + &optional (env) + &key &allow-other-keys) (declare (ignore env)) (error 'unification-failure :format-control "Cannot unify symbol ~S with template ~S." :format-arguments (list a b))) -(defmethod unify ((b template) (a symbol) &optional (env (make-empty-environment))) + +(defmethod unify ((b template) (a symbol) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) @@ -287,47 +360,74 @@ ;;;--------------------------------------------------------------------------- ;;; Number template methods. -(defmethod unify ((a number) (b number-template) &optional (env (make-empty-environment))) +(defmethod unify ((a number) (b number-template) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a (number-template-number b) env)) -(defmethod unify ((b number-template) (a number) &optional (env (make-empty-environment))) +(defmethod unify ((b number-template) (a number) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) -(defmethod unify ((a number) (b template) &optional (env (make-empty-environment))) +(defmethod unify ((a number) (b template) + &optional (env) + &key &allow-other-keys) (declare (ignore env)) (error 'unification-failure :format-control "Cannot unify the number ~S with template ~S." :format-arguments (list a b))) -(defmethod unify ((b template) (a number) &optional (env (make-empty-environment))) +(defmethod unify ((b template) (a number) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) ;;;--------------------------------------------------------------------------- ;;; Sequence (List) template methods -(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment))) +(defmethod unify ((a sequence) (b template) + &optional (env) + &key &allow-other-keys) (declare (ignore env)) (error 'unification-failure - :format-control "Cannot unify a sequence with a non sequence or non sequence access template: ~S ~S." + :format-control "Cannot unify a sequence with a non sequence ~ + or non sequence access template: ~S and ~S." :format-arguments (list a b))) -(defmethod unify ((b template) (a sequence) &optional (env (make-empty-environment))) +(defmethod unify ((b template) (a sequence) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) +#| Needs to be fixed. +(defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment))) + (unify a (template-spec b) env)) + + +(defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment))) + (unify (template-spec b) a env)) +|# + + ;;; The next is incomplete and does not signal appropriate errors. -(defmethod unify ((a list) (b template) &optional (env (make-empty-environment))) +(defmethod unify ((a list) (b template) + &optional (env) + &key &allow-other-keys) (declare (ignore env)) (error 'unification-failure :format-control "Cannot unify a list with a non-list template: ~S ~S." :format-arguments (list a b))) -(defmethod unify ((a list) (b sequence-template) &optional (env (make-empty-environment))) +(defmethod unify ((a list) (b sequence-template) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (let ((template-lambda-list (sequence-template-lambda-list b)) (ll (list-length a)) ) @@ -355,7 +455,9 @@ -(defmethod unify ((b template) (a list) &optional (env (make-empty-environment))) +(defmethod unify ((b template) (a list) + &optional (env (make-empty-environment)) + &key &allow-other-keys) (unify a b env)) [368 lines skipped]

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27120 Modified Files: variables.lisp Log Message: Some 'diff' unfathomable change happened. --- /project/cl-unification/cvsroot/cl-unification/variables.lisp 2008/07/13 13:10:48 1.2 +++ /project/cl-unification/cvsroot/cl-unification/variables.lisp 2009/04/15 10:12:22 1.3 @@ -3,7 +3,7 @@ (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. -(defun make-var-name (&optional (s (gensym)) (package *package*)) +(defun make-var-name (&optional (s (gensym "UNIFVAR-")) (package *package*)) (intern (concatenate 'string "?" (symbol-name s)) package))

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv26976 Modified Files: unification-package.lisp Log Message: Added exports of a few symbols. --- /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2008/07/13 13:10:48 1.4 +++ /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2009/04/15 10:10:25 1.5 @@ -3,6 +3,7 @@ (defpackage "CL.EXT.DACF.UNIFICATION" (:use "CL") (:nicknames "UNIFY") (:documentation "The CL.EXT.DACF.UNIFICATION Package. + This package contains all the definitions necessary for the general Common Lisp unifier to work. The package also has the \"UNIFY\" nickname.") @@ -31,7 +32,14 @@ (:export "MATCH" + "MATCHF" "MATCHING" - "MATCH-CASE")) + "MATCH-CASE") + + (:export + "UNIFY*" + "UNIFY-EQUATIONS" + "UNIFY-EQUATIONS*") + ) ;;; end of file -- unification-package.lisp --

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 15 Apr '09

15 Apr '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv26906 Modified Files: cl-unification.system Log Message: Fixed a few snags and added "lib-dependent" module. --- /project/cl-unification/cvsroot/cl-unification/cl-unification.system 2008/07/13 12:51:14 1.2 +++ /project/cl-unification/cvsroot/cl-unification/cl-unification.system 2009/04/15 10:09:43 1.3 @@ -12,6 +12,13 @@ "templates-hierarchy" "unifier" "match-block" - "apply-substitution")) + "apply-substitution" + (:module "lib-dependent" + :depends-on ("templates-hierarchy" "unifier") + :components ( + #+cl-ppcre + (:file "cl-ppcre-template") + )) + )) ;;; end of file -- cl-unification.system --

1 0