src/pattern-specializer/optima-extensions.lisp

   1 ;;;; optima-extensions.lisp --- Necessary extensions of the optima library.
   2 ;;;;
   3 ;;;; Copyright (C) 2014 Jan Moringen
   4 ;;;;
   5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
   6
   7 (cl:in-package #:pattern-specializer)
   8
   9 ;;; Protocol
  10
  11 (defgeneric pattern-more-specific-p (pattern1 pattern2)
  12   (:documentation
  13    "Return true if PATTERN1 is strictly more specific than
  14     PATTERN2.
  15
  16     General principles:
  17
  18     * Constant pattern are more specific than all other patterns
  19
  20     * Variable patterns are less specific than all other patterns
  21
  22     * For most complex patterns, subpatterns are compared
  23       lexicographically. Exceptions:
  24
  25       * For `class-pattern' s, subclass relations have higher
  26         precedence. The above rule applies only when the classes are
  27         identical.
  28
  29       * `and-pattern's are comparable to all patterns by checking
  30         whether some of their subpatterns are more specific than the
  31         pattern in question.
  32
  33       * `or-pattern's are similar."))
  34
  35 (defun subpatterns-unrestricted-p (pattern)
  36   (every (of-type 'optima.core:variable-pattern)
  37          (optima.core:complex-pattern-subpatterns pattern)))
  38
  39 ;;; Implementation
  40
  41 (defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
  42                                             (pattern2 optima::pattern))
  43   (if (eq pattern1 pattern2)
  44       '=
  45       (call-next-method)))
  46
  47 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  48                                     (pattern2 optima::pattern))
  49   '/=)
  50
  51 ;; `constant-pattern'
  52
  53 (defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
  54                                     (pattern2 optima::pattern))
  55   (if (typep pattern2 'optima.core:complex-pattern)
  56       (call-next-method)
  57       '<))
  58
  59 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  60                                     (pattern2 optima.core:constant-pattern))
  61   (if (typep pattern1 'optima.core:complex-pattern)
  62       (call-next-method)
  63       '>))
  64
  65 (defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
  66                                     (pattern2 optima.core:constant-pattern))
  67   (if (equal (optima.core:constant-pattern-value pattern1)
  68              (optima.core:constant-pattern-value pattern2))
  69       '=
  70       '/=))
  71
  72 ;; `variable-pattern'
  73
  74 (defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
  75                                     (pattern2 optima::pattern))
  76   (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern))
  77       (call-next-method)
  78       '>))
  79
  80 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  81                                     (pattern2 optima.core:variable-pattern))
  82   (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
  83       (call-next-method)
  84       '<))
  85
  86 (defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
  87                                     (pattern2 optima.core:variable-pattern))
  88   '=)
  89
  90 ;;; `guard-pattern'
  91
  92 (defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
  93                                     (pattern2 optima::pattern))
  94   (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern)) ; TODO not-pattern
  95       (call-next-method)
  96       '<))
  97
  98 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  99                                     (pattern2 optima.core:guard-pattern))
 100   (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
 101       (call-next-method)
 102       '>))
 103
 104 (defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
 105                                     (pattern2 optima.core:guard-pattern))
 106   (if (equal (optima.core:guard-pattern-test-form pattern1) ; TODO not enough because of variable names; encode variables with TODO numbers
 107              (optima.core:guard-pattern-test-form pattern2))
 108       (pattern-more-specific-p
 109        (optima.core:guard-pattern-subpattern pattern1)
 110        (optima.core:guard-pattern-subpattern pattern2))
 111       '/=))
 112
 113 ;; `and-pattern'
 114
 115 (defmethod pattern-more-specific-p ((pattern1 optima.core:and-pattern)
 116                                     (pattern2 optima::pattern))
 117   (if (typep pattern2 'optima.core:and-pattern)
 118       (call-next-method)
 119       (let ((result (pattern-more-specific-p pattern2 pattern1)))
 120         (case result
 121           (< '>)
 122           (> '<)
 123           (t result)))))
 124
 125 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
 126                                     (pattern2 optima.core:and-pattern))
 127   (reduce (lambda (result subpattern)
 128             (case (pattern-more-specific-p pattern1 subpattern)
 129               (<  (case result
 130                     ((nil <) '<)
 131                     (=       '=)
 132                     (t       '/=)))
 133               (>  (case result
 134                     ((nil > =) '>)
 135                     (t         '/=)))
 136               (=  (case result
 137                     ((nil < =) '=)
 138                     (>         '>)
 139                     (t         '/=)))
 140               (t '/=)))
 141           (optima.core:complex-pattern-subpatterns pattern2)
 142           :initial-value nil))
 143
 144 ;; `or-pattern'
 145
 146 (defmethod pattern-more-specific-p ((pattern1 optima.core:or-pattern)
 147                                     (pattern2 optima::pattern))
 148   (if (typep pattern2 'optima.core:or-pattern)
 149       (call-next-method)
 150       (let ((result (pattern-more-specific-p pattern2 pattern1)))
 151         (case result
 152           (< '>)
 153           (> '<)
 154           (t result)))))
 155
 156 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
 157                                     (pattern2 optima.core:or-pattern))
 158   (reduce (lambda (result subpattern)
 159             (case (pattern-more-specific-p pattern1 subpattern)
 160               (<  '<)
 161               (>  (case result
 162                     ((nil >) '>)
 163                     (t       result)))
 164               (=  (case result
 165                     ((nil = >) '=)
 166                     (t         result)))
 167               (/= (case result
 168                     ((nil) '/=)
 169                     (=     '<)
 170                     (t     result)))))
 171           (optima.core:complex-pattern-subpatterns pattern2)
 172           :initial-value nil))
 173
 174 ;; `cons-pattern'
 175
 176 ; TODO do this in a generic way via optima.core:complex-pattern-subpatterns
 177 (defmethod pattern-more-specific-p ((pattern1 optima.core:cons-pattern)
 178                                     (pattern2 optima.core:cons-pattern))
 179   (let* ((car1 (optima.core:cons-pattern-car-pattern pattern1))
 180          (cdr1 (optima.core:cons-pattern-cdr-pattern pattern1))
 181          (car2 (optima.core:cons-pattern-car-pattern pattern2))
 182          (cdr2 (optima.core:cons-pattern-cdr-pattern pattern2))
 183          (result/car (pattern-more-specific-p car1 car2))
 184          (result/cdr (pattern-more-specific-p cdr1 cdr2)))
 185     (cond
 186       ((and (eq result/cdr '=) (eq result/car '=))
 187        '=)
 188       ((and (eq result/car '<) (member result/cdr '(< =)))
 189        '<)
 190       ((and (eq result/cdr '<) (member result/car '(< =)))
 191        '<)
 192       ((and (eq result/car '>) (member result/cdr '(> =)))
 193        '>)
 194       ((and (eq result/cdr '>) (member result/car '(> =)))
 195        '>)
 196       (t
 197        '/=))))
 198
 199 ;; `class-pattern'
 200
 201 (defmethod pattern-more-specific-p ((pattern1 optima.core:class-pattern)
 202                                     (pattern2 optima.core:class-pattern))
 203   (let* ((class1         (optima.core:class-pattern-class-name pattern1))
 204          (slots1         (optima.core:class-pattern-slot-names pattern1))
 205          (subpatterns1   (optima.core:class-pattern-subpatterns pattern1))
 206          (class2         (optima.core:class-pattern-class-name pattern2))
 207          (slots2         (optima.core:class-pattern-slot-names pattern2))
 208          (subpatterns2   (optima.core:class-pattern-subpatterns pattern2))
 209          (fewer-slots1-p (set-difference slots2 slots1))
 210          (fewer-slots2-p (set-difference slots1 slots2)))
 211     (labels ((lookup (slot)
 212                (when-let ((position (position slot slots2)))
 213                  (nth position subpatterns2)))
 214              (compare-slots (initial)
 215                ;; TODO alternate idea: iterate over (union slots1 slots2); use lookup1 and lookup2 leading to :missing1 and :missing2
 216                (reduce (lambda (result slot1-and-subpattern1)
 217                          (destructuring-bind (slot1 . subpattern1) slot1-and-subpattern1
 218                            (case (if-let ((subpattern2 (lookup slot1)))
 219                                    (pattern-more-specific-p subpattern1 subpattern2)
 220                                    :missing)
 221                              ((< :missing) (case result
 222                                              ((nil < =) '<)
 223                                              (t         '/=)))
 224                              (>            (case result
 225                                              ((nil > =) '>)
 226                                              (t         '/=)))
 227                              (=            result)
 228                              (t            '/=))))
 229                        (mapcar #'cons slots1 subpatterns1)
 230                        :initial-value initial)))
 231       (multiple-value-bind (result1 certain1-p) (subtypep class1 class2)
 232         (multiple-value-bind (result2 certain2-p) (subtypep class2 class1)
 233           (assert (and certain1-p certain2-p))
 234           (cond
 235             ((and result1 result2)
 236              (compare-slots (if fewer-slots1-p '> '=)))
 237             (result1
 238              (cond
 239                (fewer-slots1-p '/=)
 240                (fewer-slots2-p (compare-slots '<))
 241                (t              (compare-slots '<))))
 242             (result2
 243              (cond
 244                (fewer-slots2-p '/=)
 245                (fewer-slots1-p (compare-slots '>))
 246                (t              (compare-slots '>))))
 247             (t
 248              '/=)))))))
 249
 250 ;; `structure-pattern'
 251
 252 (defmethod pattern-more-specific-p ((pattern1 optima.core:structure-pattern)
 253                                     (pattern2 optima.core:structure-pattern))
 254   (error "not implemented"))