;;;-*- Mode:Lisp; Syntax:CommonLisp, Package:CHAOS; Base:10 -*-
;;;
;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
(in-package :chaos)
#|==============================================================================
                                  System:Chaos
                                 Module:e-match
                              File:match-idem.lisp
==============================================================================|#
#-:chaos-debug
(declaim (optimize (speed 3) (safety 0) #-GCL (debug 0)))
#+:chaos-debug
(declaim (optimize (speed 1) (safety 3) #-GCL (debug 3)))


;;;                  METHODS FOR IDEMPOTENT LIKE RULES:
;;;   x + x = r
;;;   (x + x) + e = r + e  -- extension

;;; NOTE: The current implementation for idempotent theory is restricted to
;;;       the following case:
;;;  (1) rule is unconditional and
;;;  (2) op is AC and
;;;  (3) variable is "general"
;;;

;;; AXIOMS for idempotent like rules are generated by `add-operator-theory-axioms'
;;; (see gen-rule.lisp of module rewrite) in a form X op X = X for each method of
;;; an idempotent operator.
;;;

;;; THE MATCHER:________________________________________________________________
;;;_____________________________________________________________________________

;;; if order rules right may not need the simple case at all
;;; the extension version succeeds except when the input is of length 2
;;; That is might be able to tremendously simplify match-idem.
;;;

;;; IDEM-MATCH : Term Term -> GlobalState Substitution NO-MATCH E-EQUAL
;;;-----------------------------------------------------------------------------
;;; - global state will always be nil
;;; - pattern is in form `x op x' and unconditional
;;; - first arg is the pattern
;;;
(defun idem-match (t1 t2)
  (declare (type term t1 t2))
  (if (not (term-is-applform? t2))
      nil
      (let* ((meth (term-head t2))
             (subs (list-AC-subterms t2 meth)))
        (declare (type list subs))
        (if (oddp (length subs))
            (values nil nil t nil)
            (let ((var (car (term-subterms t1)))
                  (ms-tm (list-to-multiset subs #'term-equational-equal)))
              (if (dolist (x (multiset-elements ms-tm) t)
                    (when (oddp (the fixnum (cdr x))) (return nil)))
                  ;; if all even
                  (values nil
                          (list (cons var
                                      (make-right-assoc-normal-form-with-sort-check
                                       (term-head t1)
                                       (multiset-to-set ms-tm))))
                          nil
                          nil)
                  (values nil nil t nil))
              )))))

;;; IDEM-EXT-MATCH : Term Term -> GlobalState Substitution NO-MATCH E-EQUAL
;;;-----------------------------------------------------------------------------
;;; - global state will always be nil
;;; - pattern is in form `(x op x) op e' and unconditional
;;; - first arg is the pattern
;;;
(defun idem-ext-match (t1 t2)
  (declare (type term t1 t2))
  (let* ((method (term-head t2))
         (subs (list-AC-subterms t2 method)))
    (declare (type list subs)
             (type method method))
    (if (< (the fixnum (length subs)) 3)
        (values nil nil t nil)
        ;; assume that the rules is actually created in the form e + (x + x)
        (let* ((t1subs (term-subterms t1))
               (evar (car t1subs))
               (var (car (term-subterms (cadr t1subs))))
               (ms-tm (list-to-multiset subs #'term-equational-equal)))
          (declare (type term evar var)
                   (type list t1subs))
          ;; if any odds that one from each goes in evar
          ;; if no odds then must put two in evar (evar has to match something)
          ;; if all 1, then fail (nothing to match var against)
          (let ((tl (multiset-elements ms-tm))
                (singletons nil)
                (evens nil)
                (odds nil)
                (n nil)
                (fr nil)
                (it nil))
            ;; split into singletons evens and odds (just categorize)
            (while tl
              (setq fr tl
                    tl (cdr tl)
                    it (car fr)
                    n (cdr it))
              (if (= 1 (the fixnum n))
                  (progn (rplacd fr singletons) (setq singletons fr))
                  (if (oddp n)
                      (progn (rplacd fr odds) (setq odds fr))
                      (progn (rplacd fr evens) (setq evens fr)))))
            ;;
            (if (and (null evens) (null odds))
                (values nil nil t nil)
                (progn
                  ;; change form of singletons to simple list of terms
                  (if (and (null singletons) (null odds))
                      (let ((fe (car evens)))
                        (setq singletons (list (car fe) (car fe)))
                        (let ((n (cdr fe)))
                          (declare (type fixnum n))
                          (if (= 2 n)
                              (setq evens (cdr evens))
                              (setf (the fixnum (cdr fe)) (- n 2)))))
                      ;; else
                      (let ((lst singletons))
                        (while lst
                          (rplaca lst (caar lst))
                          (setq lst (cdr lst)))))
                  ;; transfer odds to singletons and evens
                  (while odds
                    (setq fr odds
                          odds (cdr odds)
                          it (car fr))
                    (setq singletons (cons (car it) singletons))
                    ;; know that repetition count is 3 or larger
                    (rplacd fr evens)
                    (setq evens fr)
                    (decf (the fixnum (cdr it))))
                  (values nil           ; global state
                          (list
                           ;; evens
                           (cons var
                                 (make-right-assoc-normal-form-with-sort-check
                                  (term-head t1)
                                  (mapcar #'car evens)))
                           ;; singletons
                           (cons evar
                                 (make-right-assoc-normal-form-with-sort-check
                                  (term-head t1)
                                  singletons)))
                          nil
                          nil)          ;error indications
                  )))
          ))))

;;; EOF
