add files from Jan Moringen's pattern-specializer repository

[specializable.git] / src / optima-extensions.lisp

diff --git a/src/optima-extensions.lisp b/src/optima-extensions.lisp
new file mode 100644 (file)
index 0000000..19eefac
--- /dev/null
+++ b/src/optima-extensions.lisp
@@ -0,0 +1,119 @@
+;;;; optima-extensions.lisp --- Necessary extensions of the optima library.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+(defgeneric pattern-more-specific-p (pattern1 pattern2)
+  (:documentation
+   "Return true if PATTERN1 is strictly more specific than
+    PATTERN2.
+
+    General principles:
+
+    * Variable patterns are less specific than all other patterns
+
+    * For most complex patterns, subpatterns are compared
+      lexicographically. Exceptions:
+
+      * For `class-pattern' s, subclass relations have higher
+        precedence. The above rule applies only when the classes are
+        identical.
+
+      * `and-pattern's are comparable to all patterns by checking
+        whether some of their subpatterns are more specific than the
+        pattern in question.
+
+      * `or-pattern's are similar."))
+
+(defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
+                                            (pattern2 optima::pattern))
+  (unless (eq pattern1 pattern2)
+    (call-next-method)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+                                    (pattern2 optima::pattern))
+  nil)
+
+;; `variable-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+                                    (pattern2 optima::variable-pattern))
+  t)
+
+(defmethod pattern-more-specific-p ((pattern1 optima::variable-pattern)
+                                    (pattern2 optima::variable-pattern))
+  nil)
+
+;; `and-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::and-pattern)
+                                    (pattern2 optima::pattern))
+  (some (lambda (subpattern)
+          (pattern-more-specific-p subpattern pattern2))
+        (optima::complex-pattern-subpatterns pattern1)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+                                    (pattern2 optima::and-pattern))
+  (some (lambda (subpattern)
+          (pattern-more-specific-p pattern1 subpattern))
+        (optima::complex-pattern-subpatterns pattern2)))
+
+;; `or-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::or-pattern)
+                                    (pattern2 optima::pattern))
+  (every (lambda (subpattern)
+           (pattern-more-specific-p subpattern pattern2))
+         (optima::complex-pattern-subpatterns pattern1)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+                                    (pattern2 optima::or-pattern))
+  (every (lambda (subpattern)
+           (pattern-more-specific-p pattern1 subpattern))
+         (optima::complex-pattern-subpatterns pattern2)))
+
+;; `cons-pattern'
+
+; TODO do this in a generic way via optima::complex-pattern-subpatterns
+(defmethod pattern-more-specific-p ((pattern1 optima::cons-pattern)
+                                    (pattern2 optima::cons-pattern))
+  (let ((car1 (optima::cons-pattern-car-pattern pattern1))
+        (cdr1 (optima::cons-pattern-cdr-pattern pattern1))
+        (car2 (optima::cons-pattern-car-pattern pattern2))
+        (cdr2 (optima::cons-pattern-cdr-pattern pattern2)))
+    (or (pattern-more-specific-p car1 car2)
+        (and (not (pattern-more-specific-p car2 car1))
+             (pattern-more-specific-p cdr1 cdr2)))))
+
+;; `class-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::class-pattern)
+                                    (pattern2 optima::class-pattern))
+  (let ((class1 (optima::class-pattern-class-name pattern1))
+        (class2 (optima::class-pattern-class-name pattern2)))
+    (multiple-value-bind (result1 certain1-p) (subtypep class1 class2)
+      (multiple-value-bind (result2 certain2-p) (subtypep class2 class1)
+        (assert (and certain1-p certain2-p))
+        (cond
+          ((and result1 result2)
+           ;; TODO this will be call-next-method => method for complex-pattern-sub-patterns
+           (loop :for subpattern1 :in (optima::complex-pattern-subpatterns pattern1) ; TODO permutations
+                 :for subpattern2 :in (optima::complex-pattern-subpatterns pattern2)
+                 :do (cond
+                       ((pattern-more-specific-p subpattern1 subpattern2)
+                        (return t))
+                       ((pattern-more-specific-p subpattern2 subpattern1)
+                        (return nil)))))
+          (result1
+           t)
+          (t
+           nil))))))
+
+;; `structure-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::structure-pattern)
+                                    (pattern2 optima::structure-pattern))
+  (error "not implemented"))