--- /dev/null
+;;;; 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)
+
+;;; Protocol
+
+(defgeneric pattern-more-specific-p (pattern1 pattern2)
+ (:documentation
+ "Return true if PATTERN1 is strictly more specific than
+ PATTERN2.
+
+ General principles:
+
+ * Constant pattern are more specific than all other patterns
+
+ * 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."))
+
+(defun subpatterns-unrestricted-p (pattern)
+ (every (of-type 'optima.core:variable-pattern)
+ (optima.core:complex-pattern-subpatterns pattern)))
+
+;;; Implementation
+
+(defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ (if (eq pattern1 pattern2)
+ '=
+ (call-next-method)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ '/=)
+
+;; `constant-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:complex-pattern)
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:constant-pattern))
+ (if (typep pattern1 'optima.core:complex-pattern)
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
+ (pattern2 optima.core:constant-pattern))
+ (if (equal (optima.core:constant-pattern-value pattern1)
+ (optima.core:constant-pattern-value pattern2))
+ '=
+ '/=))
+
+;; `variable-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:variable-pattern))
+ (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
+ (pattern2 optima.core:variable-pattern))
+ '=)
+
+;;; `guard-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern)) ; TODO not-pattern
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:guard-pattern))
+ (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
+ (pattern2 optima.core:guard-pattern))
+ (if (equal (optima.core:guard-pattern-test-form pattern1) ; TODO not enough because of variable names; encode variables with TODO numbers
+ (optima.core:guard-pattern-test-form pattern2))
+ (pattern-more-specific-p
+ (optima.core:guard-pattern-subpattern pattern1)
+ (optima.core:guard-pattern-subpattern pattern2))
+ '/=))
+
+;; `and-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:and-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:and-pattern)
+ (call-next-method)
+ (let ((result (pattern-more-specific-p pattern2 pattern1)))
+ (case result
+ (< '>)
+ (> '<)
+ (t result)))))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:and-pattern))
+ (reduce (lambda (result subpattern)
+ (case (pattern-more-specific-p pattern1 subpattern)
+ (< (case result
+ ((nil <) '<)
+ (= '=)
+ (t '/=)))
+ (> (case result
+ ((nil > =) '>)
+ (t '/=)))
+ (= (case result
+ ((nil < =) '=)
+ (> '>)
+ (t '/=)))
+ (t '/=)))
+ (optima.core:complex-pattern-subpatterns pattern2)
+ :initial-value nil))
+
+;; `or-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:or-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:or-pattern)
+ (call-next-method)
+ (let ((result (pattern-more-specific-p pattern2 pattern1)))
+ (case result
+ (< '>)
+ (> '<)
+ (t result)))))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:or-pattern))
+ (reduce (lambda (result subpattern)
+ (case (pattern-more-specific-p pattern1 subpattern)
+ (< '<)
+ (> (case result
+ ((nil >) '>)
+ (t result)))
+ (= (case result
+ ((nil = >) '=)
+ (t result)))
+ (/= (case result
+ ((nil) '/=)
+ (= '<)
+ (t result)))))
+ (optima.core:complex-pattern-subpatterns pattern2)
+ :initial-value nil))
+
+;; `cons-pattern'
+
+; TODO do this in a generic way via optima.core:complex-pattern-subpatterns
+(defmethod pattern-more-specific-p ((pattern1 optima.core:cons-pattern)
+ (pattern2 optima.core:cons-pattern))
+ (let* ((car1 (optima.core:cons-pattern-car-pattern pattern1))
+ (cdr1 (optima.core:cons-pattern-cdr-pattern pattern1))
+ (car2 (optima.core:cons-pattern-car-pattern pattern2))
+ (cdr2 (optima.core:cons-pattern-cdr-pattern pattern2))
+ (result/car (pattern-more-specific-p car1 car2))
+ (result/cdr (pattern-more-specific-p cdr1 cdr2)))
+ (cond
+ ((and (eq result/cdr '=) (eq result/car '=))
+ '=)
+ ((and (eq result/car '<) (member result/cdr '(< =)))
+ '<)
+ ((and (eq result/cdr '<) (member result/car '(< =)))
+ '<)
+ ((and (eq result/car '>) (member result/cdr '(> =)))
+ '>)
+ ((and (eq result/cdr '>) (member result/car '(> =)))
+ '>)
+ (t
+ '/=))))
+
+;; `class-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:class-pattern)
+ (pattern2 optima.core:class-pattern))
+ (let* ((class1 (optima.core:class-pattern-class-name pattern1))
+ (slots1 (optima.core:class-pattern-slot-names pattern1))
+ (subpatterns1 (optima.core:class-pattern-subpatterns pattern1))
+ (class2 (optima.core:class-pattern-class-name pattern2))
+ (slots2 (optima.core:class-pattern-slot-names pattern2))
+ (subpatterns2 (optima.core:class-pattern-subpatterns pattern2))
+ (fewer-slots1-p (set-difference slots2 slots1))
+ (fewer-slots2-p (set-difference slots1 slots2)))
+ (labels ((lookup (slot)
+ (when-let ((position (position slot slots2)))
+ (nth position subpatterns2)))
+ (compare-slots (initial)
+ ;; TODO alternate idea: iterate over (union slots1 slots2); use lookup1 and lookup2 leading to :missing1 and :missing2
+ (reduce (lambda (result slot1-and-subpattern1)
+ (destructuring-bind (slot1 . subpattern1) slot1-and-subpattern1
+ (case (if-let ((subpattern2 (lookup slot1)))
+ (pattern-more-specific-p subpattern1 subpattern2)
+ :missing)
+ ((< :missing) (case result
+ ((nil < =) '<)
+ (t '/=)))
+ (> (case result
+ ((nil > =) '>)
+ (t '/=)))
+ (= result)
+ (t '/=))))
+ (mapcar #'cons slots1 subpatterns1)
+ :initial-value initial)))
+ (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)
+ (compare-slots (if fewer-slots1-p '> '=)))
+ (result1
+ (cond
+ (fewer-slots1-p '/=)
+ (fewer-slots2-p (compare-slots '<))
+ (t (compare-slots '<))))
+ (result2
+ (cond
+ (fewer-slots2-p '/=)
+ (fewer-slots1-p (compare-slots '>))
+ (t (compare-slots '>))))
+ (t
+ '/=)))))))
+
+;; `structure-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:structure-pattern)
+ (pattern2 optima.core:structure-pattern))
+ (error "not implemented"))
projects / specializable.git / blobdiff