1 ;;;; -*- Mode: Lisp -*-
  2 
  3 ;;;; unification-tests.lisp --
  4 ;;;; CL-UNIFICATION test suite.  Requires ptester, the public version of
  5 ;;;; Franz's util.test package.
  6 
  7 (defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION.TESTS"
  8   (:use "CL" "UNIFY" "PTESTER")
  9   (:nicknames  "CL.EXT.DACF.UNIFICATION.TESTS" "UNIFY.TESTS"))
 10 
 11 (in-package "UNIFY.TESTS")
 12 
 13 ;; nil seems like a lousy default for this
 14 (setf *error-protect-tests* t)
 15 
 16 (with-tests (:name "basic constant unification")
 17   (test t (unify:environment-p (unify 42 42)))
 18 
 19   (test-error (unify 42 12) :condition-type 'unification-failure)
 20 
 21   (test-error (unify 42 'a) :condition-type 'unification-failure)
 22 
 23   (test t (unify:environment-p (unify 'a 'a)))
 24 
 25   (test t (unify:environment-p (unify '(a s d) '(a s d))))
 26 
 27   (test t (unify:environment-p (unify '(a (s 42) d) '(a (s 42) d))))
 28 
 29   (test-error (unify '(a (s forty-two) d) '(a (s 42) z))
 30 	      :condition-type 'unification-failure)
 31 
 32   (test t (unify:environment-p (unify #(a s d) #(a s d))))
 33 
 34   (test t (unify:environment-p (unify #2a((a s d) (a s d))
 35 				      #2a((a s d) (a s d)))))
 36 
 37   (test-error (unify #2a((a s d) (a s d))
 38                      #2a((a s d) (a 42 d)))
 39               :condition-type 'unification-failure)
 40 
 41   (test t (unify:environment-p (unify "I am a string" "I am a string")))
 42 
 43   (test-error (unify "I am a string" "I am A string")
 44 	      :condition-type 'unification-failure)
 45 
 46   (test t (let ((*unify-string-case-sensitive-p* nil))
 47             (unify:environment-p (unify "I am a string" "I am A string"))))
 48 
 49   )
 50 
 51 
 52 (with-tests (:name "variables unification")
 53   (test '(42 T) (find-variable-value '?x (unify 42 '?x))
 54 	:multiple-values t)
 55   (test '(NIL NIL) (find-variable-value '?y (unify 42 '?x))
 56 	:multiple-values t)
 57 
 58   (test '(42 T) (find-variable-value '?x (unify '?x 42))
 59 	:multiple-values t)
 60 
 61   (test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d)))
 62 	:multiple-values t)
 63   (test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d)))
 64 	:multiple-values t)
 65 
 66   (test '((?x 42) T) (v? '?z (unify '(a (?x 42) d) '(a ?z d)))
 67 	:multiple-values t :test 'equal)
 68 
 69   (test '(NIL T) (v? '?x (unify '(a (?x 42) d) '(a (() 42) d)))
 70 	:multiple-values t)
 71 
 72   (test '(NIL NIL) (v? '?variable (unify '(a (() 42) d) '(a (?x 42) d)))
 73 	:multiple-values t)
 74 
 75   (test t (unify:environment-p (unify '_ '(1 2 3))))
 76 
 77   (test t (unify:environment-p (unify '_ '(1 _ 3))))
 78 
 79   (test t (unify:environment-p (unify '(1 2 _) '(1 _ 3))))
 80 
 81   (test t (unify:environment-p (unify '(1 2 _) '(1 _ 3))))
 82 
 83   (test '(2 T) (v? '?x (unify #(1 2 _) #(1 ?x 3)))
 84 	:multiple-values t)
 85 
 86   (test-error (unify '(1 2 _) #(1 _ 3))
 87               :condition-type 'unification-failure
 88               :known-failure t
 89               :fail-info "Unification on SEQUENCEs does not discriminate type.")
 90   )
 91 
 92 
 93 (with-tests (:name "basic templates unification")
 94 
 95   (with-tests (:name "number templates unification")
 96     (test t (unify:environment-p (unify #T(number 42) 42)))
 97     (test t (unify:environment-p (unify 42 #T(number 42))))
 98     (test t (unify:environment-p (unify 42 #T(integer 42))))
 99     (test t (unify:environment-p (unify 42 #T(fixnum 42))))
100 
101     (test t (unify:environment-p (unify 42.0 #T(real 42))))
102     (test t (unify:environment-p (unify #C(0 1) #T(complex #C(0 1)))))
103 
104     (test '(42 T) (v? '?x (unify #T(number ?x) 42)) :multiple-values t)
105     (test '(42 T) (v? '?x (unify #(0 1 42 3 4 5) #T(sequence 0 1 ?x 3 4 5)))
106           :multiple-values t)
107 
108     (test-error (unify 42 #T(float 42.0))
109                 :condition-type 'unification-failure
110                 :known-failure t
111                 :fail-info "Check rules for unification on numeric tower.")
112     )
113   )
114 
115 
116 (eval-when (:compile-toplevel :load-toplevel :execute)
117 
118 (defclass test1 ()
119   ((a :initarg :a :accessor a)
120    (b :initarg :b :accessor b)))
121 
122 (defstruct s-root a)
123 (defstruct (s-child (:include s-root)) b)
124 
125 )
126 
127 (with-tests (:name "advanced templates unification")
128 
129   (test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _))
130 			      #2A((1 a 3) (q w e))))
131           :multiple-values t)
132 
133   (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))
134         :multiple-values t)
135 
136   (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))
137         :multiple-values t)
138 
139   (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))
140         :multiple-values t)
141 
142   (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))
143         :multiple-values t)
144 
145   (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))
146         :multiple-values t)
147 
148   (test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x)))
149         :multiple-values t)
150 
151   (test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5))))
152         :multiple-values t)
153 
154   (test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42)))
155         :multiple-values t)
156 
157   (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))
158               :condition-type 'unification-failure
159               :announce t)
160 
161   (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)
162                                                     '(0 1 (?y bar (1) (2) (3)) 42)))
163                                  )
164                              (cons (v? '?y result-env)
165                                    (v? '?z result-env)))
166         :test #'equal)
167 
168   (test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot")
169                               (make-instance 'test1 :a '(1 2 3) :b "woot")))
170         :multiple-values t)
171 
172   (test-error (unify #T(s-root s-root-a '(1 ?x 3 4))
173                      (make-s-root :a '(1 2 3 4)))
174               :condition-type 'unification-failure
175               :announce t
176               ;; #T reader non evaluating sub forms.
177               )
178 
179   (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))
180                               (make-s-root :a '(1 2 3 4))))
181         :multiple-values t)
182 
183   (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))
184                               (make-s-root :a '(1 2 3 4))))
185         :multiple-values t)
186 
187   (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))
188                               (make-s-root :a '(1 2 3 4))))
189         :multiple-values t)
190 
191   (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))
192                               (make-s-root :a #(1 2 3 4))))
193         :multiple-values t)
194 
195   (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))
196                               (make-s-root :a #(1 2 3 4))))
197         :multiple-values t)
198 
199   )
200 
201 (define-condition inner-unification-failure (unification-failure) ()
202   (:default-initargs :format-control "Inner unification-failure."))
203 (define-condition inner-error (simple-error) ()
204   (:default-initargs :format-control "Inner error."))
205 (define-condition outer-error (simple-error) ()
206   (:default-initargs :format-control "Outer error."))
207 
208 (defun nested-match-cases (input)
209  (match-case (input)
210    ('(:a ?a :b #T(list &rest ?bs))
211     (loop for b in ?bs
212 	   collect (match-case (b)
213 		     ('(:c ?c)   ?c)
214 		     ('(:d ?d)   ?d)
215 		     (otherwise (error 'inner-error)))))
216    (otherwise (error 'outer-error))))
217 
218 (defun nested-matchf-cases (input)
219  (matchf-case (input)
220    ((:a ?a :b #T(list &rest ?bs))
221     (loop for b in ?bs
222 	   collect (matchf-case (b)
223 		     ((:c ?c)   ?c)
224 		     ((:d ?d)   ?d)
225 		     (otherwise (error 'inner-error)))))
226    (otherwise (error 'outer-error))))
227 
228 (with-tests (:name "control flow")
229   (test-error (nested-match-cases '(:a 42 :b 33)) :condition-type 'outer-error)
230   (test-error (nested-match-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)
231   (test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))
232         :test #'equal)
233 
234   (test-error (nested-matchf-cases '(:a 42 :b 33)) :condition-type 'outer-error)
235   (test-error (nested-matchf-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)
236   (test '(42 43 44) (nested-matchf-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))
237         :test #'equal)
238 
239   (test-error (match ('(x) '(x) :errorp nil)
240                 (error 'inner-unification-failure))
241               :condition-type 'inner-unification-failure)
242 
243   (test-error (matchf ((x) '(x) :errorp nil)
244                 (error 'inner-unification-failure))
245               :condition-type 'inner-unification-failure)
246 
247   (with-tests (:name "final t-or-otherwise")
248     (test :success (matching ()
249                      (('x 'y) :fail)
250                      (t :success)))
251     (test :success (matching ()
252                      (('x 'y) :fail)
253                      (otherwise :success)))
254     (test :success (match-case ('x)
255                      ('y :fail)
256                      (t :success)))
257     (test :success (match-case ('x)
258                      ('y :fail)
259                      (otherwise :success)))
260     (test :success (matchf-case ('(x))
261                      ((y) :fail)
262                      (t :success)))
263     (test :success (matchf-case ('(x))
264                      ((y) :fail)
265                      (otherwise :success))))
266 
267   (test-error (matching ()
268                         (('x 'y) :fail)
269                         (('x 'x) (error 'inner-unification-failure))
270                         (('?x 'x) x))
271               :condition-type 'inner-unification-failure)
272 
273   (test-error (match-case ('(x))
274                           ('(y) :fail)
275                           ('(x) (error 'inner-unification-failure))
276                           ('(?x) x))
277               :condition-type 'inner-unification-failure)
278 
279   (test-error (matchf-case ('(x))
280                            ((y)  :fail)
281                            ((x)  (error 'inner-unification-failure))
282                            ((?x) x))
283               :condition-type 'inner-unification-failure)
284 
285   (test 'sym (match-case ('(sym))
286                           ('(a)  :fail)
287                           ('(b)  :fail)
288                           ('(?x) x)))
289 
290   (test 'sym (matchf-case ('(sym))
291                           ((a)  :fail)
292                           ((b)  :fail)
293                           ((?x) x)))
294   )
295 
296 
297 ;;;; end of file -- unification-tests.lisp --