src/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 (defgeneric pattern-more-specific-p (pattern1 pattern2)
  10   (:documentation
  11    "Return true if PATTERN1 is strictly more specific than
  12     PATTERN2.
  13
  14     General principles:
  15
  16     * Variable patterns are less specific than all other patterns
  17
  18     * For most complex patterns, subpatterns are compared
  19       lexicographically. Exceptions:
  20
  21       * For `class-pattern' s, subclass relations have higher
  22         precedence. The above rule applies only when the classes are
  23         identical.
  24
  25       * `and-pattern's are comparable to all patterns by checking
  26         whether some of their subpatterns are more specific than the
  27         pattern in question.
  28
  29       * `or-pattern's are similar."))
  30
  31 (defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
  32                                             (pattern2 optima::pattern))
  33   (unless (eq pattern1 pattern2)
  34     (call-next-method)))
  35
  36 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  37                                     (pattern2 optima::pattern))
  38   nil)
  39
  40 ;; `variable-pattern'
  41
  42 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  43                                     (pattern2 optima::variable-pattern))
  44   t)
  45
  46 (defmethod pattern-more-specific-p ((pattern1 optima::variable-pattern)
  47                                     (pattern2 optima::variable-pattern))
  48   nil)
  49
  50 ;; `and-pattern'
  51
  52 (defmethod pattern-more-specific-p ((pattern1 optima::and-pattern)
  53                                     (pattern2 optima::pattern))
  54   (some (lambda (subpattern)
  55           (pattern-more-specific-p subpattern pattern2))
  56         (optima::complex-pattern-subpatterns pattern1)))
  57
  58 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  59                                     (pattern2 optima::and-pattern))
  60   (some (lambda (subpattern)
  61           (pattern-more-specific-p pattern1 subpattern))
  62         (optima::complex-pattern-subpatterns pattern2)))
  63
  64 ;; `or-pattern'
  65
  66 (defmethod pattern-more-specific-p ((pattern1 optima::or-pattern)
  67                                     (pattern2 optima::pattern))
  68   (every (lambda (subpattern)
  69            (pattern-more-specific-p subpattern pattern2))
  70          (optima::complex-pattern-subpatterns pattern1)))
  71
  72 (defmethod pattern-more-specific-p ((pattern1 optima::pattern)
  73                                     (pattern2 optima::or-pattern))
  74   (every (lambda (subpattern)
  75            (pattern-more-specific-p pattern1 subpattern))
  76          (optima::complex-pattern-subpatterns pattern2)))
  77
  78 ;; `cons-pattern'
  79
  80 ; TODO do this in a generic way via optima::complex-pattern-subpatterns
  81 (defmethod pattern-more-specific-p ((pattern1 optima::cons-pattern)
  82                                     (pattern2 optima::cons-pattern))
  83   (let ((car1 (optima::cons-pattern-car-pattern pattern1))
  84         (cdr1 (optima::cons-pattern-cdr-pattern pattern1))
  85         (car2 (optima::cons-pattern-car-pattern pattern2))
  86         (cdr2 (optima::cons-pattern-cdr-pattern pattern2)))
  87     (or (pattern-more-specific-p car1 car2)
  88         (and (not (pattern-more-specific-p car2 car1))
  89              (pattern-more-specific-p cdr1 cdr2)))))
  90
  91 ;; `class-pattern'
  92
  93 (defmethod pattern-more-specific-p ((pattern1 optima::class-pattern)
  94                                     (pattern2 optima::class-pattern))
  95   (let ((class1 (optima::class-pattern-class-name pattern1))
  96         (class2 (optima::class-pattern-class-name pattern2)))
  97     (multiple-value-bind (result1 certain1-p) (subtypep class1 class2)
  98       (multiple-value-bind (result2 certain2-p) (subtypep class2 class1)
  99         (assert (and certain1-p certain2-p))
 100         (cond
 101           ((and result1 result2)
 102            ;; TODO this will be call-next-method => method for complex-pattern-sub-patterns
 103            (loop :for subpattern1 :in (optima::complex-pattern-subpatterns pattern1) ; TODO permutations
 104                  :for subpattern2 :in (optima::complex-pattern-subpatterns pattern2)
 105                  :do (cond
 106                        ((pattern-more-specific-p subpattern1 subpattern2)
 107                         (return t))
 108                        ((pattern-more-specific-p subpattern2 subpattern1)
 109                         (return nil)))))
 110           (result1
 111            t)
 112           (t
 113            nil))))))
 114
 115 ;; `structure-pattern'
 116
 117 (defmethod pattern-more-specific-p ((pattern1 optima::structure-pattern)
 118                                     (pattern2 optima::structure-pattern))
 119   (error "not implemented"))