;;;-*- Mode: Lisp; Syntax: CommonLisp Package: CHAOS -*-
;;;
;;; Copyright (c) 2000-2018, 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-a.lisp
==============================================================================|#
#-:chaos-debug
(declaim (optimize (speed 3) (safety 0) #-GCL (debug 0)))
#+:chaos-debug
(declaim (optimize (speed 1) (safety 3) #-GCL (debug 3)))

;;; PROCEDURES for Associative Matching:========================================

;;; A-STATE 
;;;   size   : the number of equations of the system.
;;;   method : the top operator(method) of each of the equations.
;;;            "f" for example, if f is associative and all the equations are 
;;;            of the form f(t1,...,tn) == f(...)
;;;   sys    : the system itself, presented as an array looking like:
;;;                t00 ,...,t0n == t'00,...,t'0p  x00,...,x0n-1
;;;                ...
;;;                ti0 ,...,tin == t'i0,...,t'ip  xi0,...,xin-1
;;;                ...
;;;            where a potential solution is deduced from the xi in the 
;;;            following way:
;;;            xi0 = f(t'i0,...,t'ixi0)
;;;            xij = f(t'_{i_{x_{i_{j-1}}+1}},....,t'_{i_{x_{i_{j}}}})
;;;            xin = f(t'_{i_{x_{i_{n-1}}+1}},....,t'_{i_n})
;;;
;;;(defstruct (match-A-state
;;;             (:type vector)
;;;             (:conc-name match-a-state-void)
;;;             (:constructor make-match-A-state (size method sys no-more)))
;;;  (size 0 :type fixnum :read-only t)    ; number of equations of the system.
;;;  (method nil :read-only t)             ; top operator.
;;;  sys                                   ; array[eq-comp].
;;;  (no-more nil)                         ; bool, a flag indicating no more possible state.
;;;  )

(deftype match-a-state () 'list)

(defmacro make-match-a-state (size!*_? method!*_? sys!*_?)
  `(list ,size!*_? ,method!*_? ,sys!*_? nil))

(defmacro match-a-state-size (as----_)  `(the fixnum (car ,as----_)))
(defmacro match-a-state-method (as----_)  `(cadr ,as----_))
(defmacro match-a-state-sys (as----_)  `(caddr ,as----_))
(defmacro match-a-state-no-more (as----_)  `(cadddr ,as----_))
    
;;;(defstruct (match-equation-comp
;;;             (:type vector)
;;;             (:conc-name match-equation-comp-void)
;;;             (:constructor make-match-equation-comp (sz-left left right comp)))
;;;  (sz-left 0 :type fixnum :read-only t)
;;;  left
;;;  right
;;;  comp
;;;  )
(deftype match-equation-comp () 'list)
(defmacro make-match-equation-comp (*_*_sz-left *_*_left *_*_right *_*_comp)
  `(list ,*_*_sz-left ,*_*_left ,*_*_right ,*_*_comp))

(defmacro match-equation-comp-sz-left (???_v)
  `(the fixnum (car ,???_v)))
(defmacro match-equation-comp-left (?v__?)
  `(the #-GCL simple-vector #+GCL vector (cadr ,?v__?)))
(defmacro match-equation-comp-right (?+_v)
  `(the #-GCL simple-vector #+GCL vector (caddr ,?+_v)))
(defmacro match-equation-comp-comp (v__?)
  `(the #-GCL simple-vector #+GCL vector (cadddr ,v__?)))

;;; Modifies the array "sys" of "match-equation-comp" in such a way that
;;; all the comp array are reset provide that they rank in "sys"
;;; is less (strictly) than K.
;;;
;;; Reset the comp of "eq-comp" to his initial value i.e. (1,2,3,4,5)
;;;
(declaim (inline match-a-reset-comp))
(defun match-A-reset-comp (eq-comp)
  (declare (type list eq-comp)
           (optimize (speed 3) (safety 0)))
  (let ((comp (match-equation-comp-comp eq-comp)))
    (declare (type #+GCL vector #-GCL simple-vector comp))
    (dotimes (x (1- (match-equation-comp-sz-left eq-comp)))
      (declare (type fixnum x))
      (setf (aref comp x) (1+ x)))))


(declaim (inline match-a-reset-match-equation-comp))

(defun match-A-reset-match-equation-comp (sys K)
  (declare (type #+GCL vector #-GCL simple-vector sys)
           (type fixnum k)
           (optimize (speed 3) (safety 0)))
  (dotimes (i K)                                ; i = 0,...,K-1 
    (declare (type fixnum i))
    (match-A-reset-comp (svref sys i))))

(defun print-equation-comp (e-c)
  (princ "[equation-comp size left: ") (prin1 (match-equation-comp-sz-left e-c))
  (print-next)
  (princ "left:")
  (print-term-seq (match-equation-comp-left e-c))
  (print-next)
  (princ "right:")
  (print-term-seq (match-equation-comp-right e-c))
  (print-next)
  (princ " comp: ") (prin1 (match-equation-comp-comp e-c))
  (princ "]")
  )

;;; Try to increase with respect with the lexicographical order
;;; on the arrays of integer the integer array "comp". These are
;;; the following constaints:
;;; 1) the elements of the array are all different and ordered in 
;;; increasing order: example (2 3 4 6 8)
;;; 2) the grastest element of the array in LESS OR EQUAL to "max"
;;; Returns true iff one have succeded to increment.
;;;
(declaim (inline match-a-try-increase-lexico))

(defun match-A-try-increase-lexico (comp max)
  (declare (type fixnum max)
           (type #+GCL vector #-GCL simple-vector comp)
           (optimize (speed 3) (safety 0)))
  (let ((lim (1- (the fixnum (length comp)))))
    (declare (type fixnum lim))
    (do ((i lim (- i 1)))
        ((< i 0) nil)
      (declare (type fixnum i))
      (let ((x (svref comp i)))
        (declare (type fixnum x))
        (when (< x max)
          (setf (svref comp i) (1+ x))
          (do ((j (1+ i) (1+ j))
               (v (+ x 2) (1+ v)))
              ((< lim j))
            (declare (type fixnum j v))
            (setf (svref comp j) v))
          (return t)))
      (setq max (1- max)))))

;;; Simplify the left symbols and the right symbols. Returns the modified list
;;; of terms.  
;;; EXAMPLE: (a,x,c,z,d,c) == (a,b,b,b,c,c,c,c) is simplified into
;;;            (x,c,z,d)   ==   (b,b,b,c,c,c)
;;; NOTICE that a variable  appearing in the right hand side
;;; should never be simplified. It  will be the case
;;; if the right hand side is always renamed before matching ...
;;;
(declaim (inline match-associative-simplify))

(defun match-associative-simplify (sub1 sub2)
  (declare (type list sub1 sub2)
           (optimize (speed 3) (safety 0))
           (values (or null t)))
  (do ((t1 (car sub1) (car sub1))
       (t2 (car sub2) (car sub2)))
      ((or (null sub1)
           (null sub2)
           (term-is-variable? t1)
           (not (term-equational-equal t1 t2))))
    (declare (type term t1 t2))
    (pop sub1)
    (pop sub2))
  ;;
  (setq sub1 (nreverse sub1)
        sub2 (nreverse sub2))
  (do ((t1 (car sub1) (car sub1))
       (t2 (car sub2) (car sub2)))
      ((or (null sub1)
           (null sub2)
           (term-is-variable? t1)
           (not (term-equational-equal t1 t2))))
    (declare (type term t1 t2))
    (pop sub1)
    (pop sub2))
  ;;
  (let ((numvars 0))
    (declare (type fixnum numvars))
    (dolist (x1 sub1)
      (declare (type term x1))
      (when (term-is-variable? x1) (incf numvars)))
    (if (and (<= 2 numvars)
             (<= 3 (the fixnum (length sub1)))
             (<= 5 (the fixnum (length sub2))))
        (if (block test1
              (dolist (x1 sub1 nil)
                (declare (type term x1))
                (unless (term-is-variable? x1)
                  (dolist (x2 sub2 (return-from test1 t))
                    (declare (type term x2))
                    (when (and (not (term-is-variable? x2))
                               (possibly-matches-nonvar x1 x2))
                      (return))))))
            (values nil nil t)
            (values (nreverse sub1) (nreverse sub2) nil))
        (values (nreverse sub1) (nreverse sub2) nil))))

(declaim (inline match-associativity-set-eq-state))
         
(defun match-associativity-set-eq-state (sub1 sub2)
  (declare (type list sub1 sub2)
           (optimize (speed 3) (safety 0)))
  (let* ((sz1 (length sub1))
         (comp (alloc-svec-fixnum (if (= 0 sz1) 0 (- sz1 1)))))
    (declare (type #+GCL vector #-GCL simple-vector comp)
             (type fixnum sz1))
    (dotimes (x (- sz1 1))
      (declare (type fixnum x))
      ;; x = 0,...,sz1-2
      ;;built the array (1, 2, 3, 4) if sz1 = 5 
      (setf (svref comp x) (1+ x)))
    (make-match-equation-comp sz1
                              (apply #'vector sub1)
                              (apply #'vector sub2)
                              comp)))

;;; Create a single term from a collection of terms
;;;
(declaim (inline match-a-make-term))

(defun  match-A-make-term (method vect first last)
  (declare (type fixnum first last)
           (type #+GCL vector #-GCL simple-vector vect)
           (optimize (speed 3) (safety 0)))
  (if (= first last)
      (svref vect first)
    (let ((res (svref vect last)))
      (if (and (< 1 (the fixnum (- last first)))
               (null (cdr (method-lower-methods method))))
          (do ((i (1- last) (1- i)))
              ((< i first) res)
            (declare (type fixnum i))
            (setq res (make-term-with-sort-check method
                                                 (list (svref vect i) res))))
        (do ((i (1- last) (1- i)))
            ((< i first) res)
          (declare (type fixnum i))
          (setq res (make-term-with-sort-check-bin method 
                                                   (list (svref vect i) res))))))))

;;; Returns the list of terms contained in the array of terms "t-arr"
;;; between the indices "from" and "to" both included.
;;; Example: match-A-extract-in-from-to((1,2,3,4,5,6), 1, 4) --> (2,3,4,5)
;;; note that the indices of the array are 0,1,2,3,4,5.
;;;
(declaim (inline match-a-extract-in-from-to))

(defun match-A-extract-in-from-to (t-arr from to)
  (declare (type fixnum from to)
           (type #+GCL vector #-GCL simple-vector t-arr)
           (optimize (speed 3) (safety 0)))
  (let ((t-list nil))
    (do ((i to (1- i)))
        ((< i from)  t-list)
      (declare (type fixnum i))
      (push (svref t-arr i) t-list))))

;;; Modify the match-A-state "A-st" by  incrementing the state local to each
;;; equation of the system in a "variable basis numeration" way
;;;
(declaim (inline increment-the-match-a-state))

(defun increment-the-match-A-state (A-st)
  (declare (type match-a-state A-st)
           (optimize (speed 3) (safety 0)))
  (block the-end
    (let ((sz (match-A-state-size A-st))
          (sys (match-A-state-sys A-st)))
      (declare (type fixnum sz)
               (type #+GCL vector #-GCL simple-vector sys))
      (let ((k 0)
            eq-comp)
        (declare (type fixnum k))
        (while (> sz k)
          (setq eq-comp (svref sys k))
          (when (match-A-try-increase-lexico
                 (match-equation-comp-comp eq-comp)
                 (1- (the fixnum
                       (length (match-equation-comp-right eq-comp)))))
            ;; note that match-A-try-increase-lexico modify in this case
            ;; the  "comp"  of the current equation.
            ;; After that the previous composant are reset like in
            ;; 599 -> 600
            (match-A-reset-match-equation-comp sys k)
            (return-from the-end (values nil)))
          ;;otherwise, try to increase the next equation
          (setq k (1+ k))
          ))
      ;; this "normal" exit of the loop means that none of the
      ;; state has been increased so there is no more state
      (setf (match-A-state-no-more A-st) t)
      )))


;;; A-STATE Initialization -----------------------------------------------------

;;; Initialize an associative state. Suppose that for any equation t1 == t2 of
;;; "sys", t1 and t2 are not E-equal. 
;;;
;;; 0) take the associative normal form (at the first level) of each term of the
;;;    system.
;;; 1) checks if the top symbols of each equation of the system have the same
;;;    (associative) head function. 
;;; 2) checks if length(Left[i]) =< length(Right[i])
;;; 3) simplifies all the similar term in Left[i] and Right[i]  at their left
;;;    or right extremity.
;;; 4) initialize left-state.
;;;
(defun match-A-state-initialize (sys env)
  (block no-match
    (let* ((dim nil)
           (assoc-sys nil)
           (method nil)
           (i 0))
      (declare (type fixnum i)
               (type (or null fixnum) dim)
               (type #+GCL (or null vector)
                     #-GCL (or null simple-vector)
                     assoc-sys)
               )
      (dolist (equation (m-system-to-list sys))
        (let ((t1 (equation-t1 equation))
              (t2 (equation-t2 equation)))
          (unless (and (term-is-application-form? t2)
                       (method-is-of-same-operator+ (term-head t1)
                                                    (term-head t2))
                       (setq method (term-head t1)))
            (return-from no-match (values nil t)))
          ;;
          (let* ((sub1 (list-assoc-subterms t1 method))
                 (sub1add nil)
                 (sub2 (list-assoc-subterms t2 method))
                 (sub2-len (length sub2))
                 (fail nil))
            (declare (type list sub1 sub2)
                     (type fixnum sub2-len))
            ;;
            ;;(when (> (the fixnum (length sub1)) sub2-len)
            ;;  (return-from no-match (values nil t)))
            ;;
            ;; add the additional information contained in "env" into "sub1".
            (dolist (val sub1)
              (declare (type term val))
              (if (term-is-variable? val)
                  (let ((image (environment-image env val))
                        (head nil))
                    (declare (type (or null term) image))
                    (if (null image)
                        (push val sub1add)
                        (if (term-is-variable? image)
                            (push image sub1add)
                          (if (eq method (setf head (term-head image)))
                              (setq sub1add
                                (nconc
                                 (reverse
                                  (list-assoc-subterms image head))
                                 sub1add))
                            (push image sub1add)))))
                (push val sub1add)))
            ;;
            (setq sub1 (nreverse sub1add))
            ;;
            (when (> (the fixnum (length sub1)) sub2-len)
              (return-from no-match (values nil t)))
            (multiple-value-setq (sub1 sub2 fail)
                (match-associative-simplify sub1 sub2))
            (when (or fail
                      (and (null sub1) sub2)
                      (and (null sub2) sub1))
              (return-from no-match (values nil t)))
            ;; sub1 may be nil but have modified match-A-..set-eq-state
            (unless assoc-sys
              (setq dim (size-of-m-system sys))
              (setq assoc-sys (alloc-svec (the fixnum dim))))
            (setf (svref assoc-sys i)
                  (match-associativity-set-eq-state sub1 sub2))))
        (setq i (1+ i)))
      (values (make-match-A-state dim method assoc-sys)
              nil))))

;;; ASSOCITIVITY NEXT STATE ----------------------------------------------------

(defun match-A-next-state (A-st)
  (declare (type match-a-state a-st)
           (values list (or null match-a-state) (or null t)))
  (let* ((new-sys (new-m-system))
         (sz (match-A-state-size A-st))
         (sys (match-A-state-sys A-st))
         (method (match-A-state-method A-st)))
    (declare (type fixnum sz)
             (type vector sys))
    (if (match-A-state-no-more A-st)    
        ;; there is no more match-A-state.
        (values nil nil t)
        (progn
          (dotimes (k sz)
            (declare (type fixnum k))
            ;; for each equation of the system
            (let* ((eq-comp (svref sys k))
                   (sz-left (match-equation-comp-sz-left eq-comp))
                   (left (match-equation-comp-left eq-comp))
                   (right (match-equation-comp-right eq-comp))
                   (sz-right (1- (the fixnum (length right))))
                   (comp (match-equation-comp-comp eq-comp)))
              (declare (type fixnum sz-left sz-right)
                       (type #+GCL vector #-GCL simple-vector left right)
                       (type #+GCL vector #-GCL simple-vector comp))
              (dotimes (l sz-left)
                (declare (type fixnum l))
                ;; i.e. for each term of the left hand 
                ;; side of the equation 
                (let ((deb (if (= l 0)
                               0 
                               (svref comp (the fixnum (1- l)))))
                      (fin (if (= l (the fixnum (1- sz-left)))
                               sz-right 
                               (1- (the fixnum (svref comp l))))))
                  (declare (type fixnum deb fin))
                  (add-equation-to-m-system
                   new-sys
                   (make-equation
                    (svref left l)
                    (match-A-make-term method right deb fin)))))
              ))
          (increment-the-match-A-state A-st) ; A-st is modified
          (values new-sys A-st nil)))))


;;; Associative Equational Equal ------------------------------------------------ 

;;; match-A-equal: Term Term -> Bool
;;;
(defun match-A-equal (t1 t2)
  (declare (type term t1 t2)
           (values (or null t)))
  (if (term-is-application-form? t2)
      (let ((hd2 (term-head t2)))
        (if (method-is-of-same-operator (term-head t1)
                                        hd2)
            (let ((l1 (list-assoc-subterms t1 (term-head t1)))
                  (l2 (list-assoc-subterms t2 hd2)))
              (declare (type list l1 l2))
              (and (= (the fixnum (length l1)) (the fixnum (length l2)))
                   (loop (when (null l1) (return (null l2)))
                       (unless (term-equational-equal (car l1) (car l2))
                         (return nil))
                     (setq l1 (cdr l1) l2 (cdr l2)))))
            nil))
      nil))
 
;;; EOF
