;;;-*- Mode: Lisp; Package: PARSER -*-

(in-package :parser)

;;; implementation of unordered and optional elements
;;; (C) Paul Meurer 11.10.1997, 1998, 1999 
;;; paul.meurer@hit.uib.no
;;;
;;; to do: Kleene-star

; Elements enclosed in [...] are optional and elements enclosed
; in {...} are unordered. Those constructs can be nested with each other
; and with (ordered) lists.
; An expansion of an extended list is any ordinary list which is compatible 
; with the extended list. For example, (1 2 3) is an expansion of {2 [4 3] 1}.

(defstruct (extended-list
            (:print-function
             (lambda (m s d &aux (char (extended-list-char m))
                        (form (extended-list-form m)))
               (declare (ignore d))
               (ecase char
                 (#\[ (format s "[~{~s~^ ~}]" form))
                 (#\{ (format s "{~{~s~^ ~}}" form))))))
  char
  form)

(defmethod make-load-form ((exp extended-list)
			   #-(and mcl (not openmcl) (not ansi-make-load-form))
			   &optional
			   #-(and mcl (not openmcl) (not ansi-make-load-form))
			   environment)
  #-(and mcl (not openmcl)(not ansi-make-load-form))
  (declare (ignore environment))
  (values
   `(make-extended-list)
   `(setf (extended-list-char ,exp) ',(extended-list-char exp)
          (extended-list-form ,exp) ',(extended-list-form exp))))

(set-macro-character #\[
 #'(lambda (s c)
     (make-extended-list :char c :form (read-delimited-list #\] s t))))

(set-macro-character #\{
 #'(lambda (s c)
     (make-extended-list :char c :form (read-delimited-list #\} s t))))

(mapc #'(lambda (c) (set-macro-character c (get-macro-character #\))))
      '(#\] #\}))

; in the following, an ext-list is a recursive *combination* of plain lists and
; structures of type extended list

(defun extended-list-equal (ext-list1 ext-list2)
  (cond ((null ext-list1)
         (null ext-list2))
        ((listp ext-list1)
         (and (listp ext-list2)
              (= (length ext-list1) (length ext-list2))
              (loop for i in ext-list1
                    and j in ext-list2
                    always (extended-list-equal i j)))) 
        ((extended-list-p ext-list1)
         (and (extended-list-p ext-list2)
              (ecase (extended-list-char ext-list1)
                (#\[
                 (and (char= (extended-list-char ext-list2) #\[)
                      (extended-list-equal (extended-list-form ext-list1)
                                               (extended-list-form ext-list2))))
                (#\{
                 (and (char= (extended-list-char ext-list2) #\{)
                      (= (length (extended-list-form ext-list1))
                         (length (extended-list-form ext-list2)))
                      ; check if all elements in form1 exist in form2
                      ; order is irrelevant
                      (loop for e1 in (extended-list-form ext-list1)
                            always
                            (find-if #'(lambda (e2) 
                                         (extended-list-equal e1 e2))
                                     (extended-list-form ext-list2))))))))
        ((atom ext-list1)
         (equal ext-list1 ext-list2))))

(defun extended-list-length (ext-list)
  "computes the number of atoms in an extended list"
  (cond ((listp ext-list)
         (reduce #'+ ext-list :key #'extended-list-length))
        ((extended-list-p ext-list)
         (reduce #'+ (extended-list-form ext-list)
                 :key #'extended-list-length))
        (t
         1)))

(defun extended-list-min-length (ext-list)
  "computes the length of the extended list not counting optional elements"
  (cond ((listp ext-list)
         (reduce #'+ ext-list :key #'extended-list-min-length))
        ((extended-list-p ext-list)
         (if (char= (extended-list-char ext-list) #\{)
           (reduce #'+ (extended-list-form ext-list)
                   :key #'extended-list-min-length)
           0))
        (t
         1)))

(defun flatten-extended-list (ext-list)
  "flattens an extended list to an ordinary list"
  (labels ((flatten (elist)
              (cond ((listp elist)
                     (reduce #'append elist :key #'flatten))
                    ((extended-list-p elist)
                     (reduce #'append (extended-list-form elist)
                             :key #'flatten))
                    (t
                     (list elist)))))
    (flatten ext-list)))

(defun optional-extended-list-p (ext-list)
  "checks if the extended list contains exclusively optional elements"
  (cond ((null ext-list)
         t)
        ((listp ext-list)
         (not (find-if-not 'optional-extended-list-p ext-list))) 
        ((extended-list-p ext-list)
         (ecase (extended-list-char ext-list)
           (#\[
            t)
           (#\{
            (not (find-if-not 'optional-extended-list-p 
                              (extended-list-form ext-list))))))
        ((atom ext-list)
         nil)))

(defun extended-first-elt-p (elt ext-list &optional (test #'eq))
  "checks if the given elt can be the first elt in some expansion of the ext-list"
  (cond ((null ext-list)
         nil)
        ((listp ext-list)
         (or
          (extended-first-elt-p elt (car ext-list) test)
          (and
           (cdr ext-list)
           (optional-extended-list-p (car ext-list))
           (extended-first-elt-p elt (cdr ext-list) test))))
        ((extended-list-p ext-list)
         (ecase (extended-list-char ext-list)
           (#\[
            (extended-first-elt-p elt (extended-list-form ext-list) test))
           (#\{
            (find-if #'(lambda (e)
                         (extended-first-elt-p elt e test))
                     (extended-list-form ext-list)))))
        ((atom ext-list)
         (funcall test elt ext-list))))

; the crucial function
(defun remove-first-elt (elt ext-list &optional (test #'eq))
  "If elt is the first element in an expansion of ext-list,
returns the reduced ext-list and t, else nil."
  (let (succeeded)
    (labels 
      ((reduce-list (list)
         (let ((reduced-elt (remove-elt (car list))))
           (cond ((null list)
                  nil)
                 (succeeded
                  (cons reduced-elt (cdr list)))
                 ((optional-extended-list-p (car list))
                  (reduce-list (cdr list)))
                 (t
                  list))))
       (reduce-unordered-list (list new-list)
          ; is somewhat complicated because we have to reduce '{{1 2} 3} to (2 3) eg.
          (let ((reduced-elt (remove-elt (car list))))
            (cond ((null list)
                   nil) 
                  (succeeded
                   (if (and reduced-elt
                            (extended-list-p (car list))
                            (char= (extended-list-char (car list)) #\{))
                     (let ((uo-rest-list (append new-list (cdr list))))
                       (if (cdr uo-rest-list)
                         (list (list reduced-elt
                                     (make-extended-list :char #\{
                                                         :form uo-rest-list)))
                         (if (listp reduced-elt)
                           (list (append reduced-elt uo-rest-list))
                           (list (cons reduced-elt uo-rest-list)))))
                     (append (list reduced-elt) new-list (cdr list))))
                  (t
                   (reduce-unordered-list (cdr list)
                                          (cons (car list) new-list))))))
       (remove-elt (ext-list)
         (cond (succeeded ; we have already removed the elt and take the rest unchanged
                ext-list)
               ((null ext-list)
                nil)
               ((listp ext-list) ; ordered
                (let ((reduced-list 
                       (delete-if #'null (reduce-list ext-list))))
                  (if succeeded
                    (if (cadr reduced-list)
                      reduced-list
                      (car reduced-list))
                    ext-list)))
               ((extended-list-p ext-list)
                (ecase (extended-list-char ext-list)
                  (#\[ ; facultative
                   (let ((reduced-list
                          (delete-if 
                           #'null
                           (reduce-list (extended-list-form ext-list)))))
                     (if succeeded
                       (when (car reduced-list)
                         ; here we copy!
                         (make-extended-list :char #\[ :form reduced-list))
                       ext-list)))
                  (#\{ ; arbitrary order
                   (let ((reduced-list
                          (delete-if
                           #'null
                           (reduce-unordered-list 
                            (extended-list-form ext-list) ()))))
                     (if succeeded
                       (cond 
                        ((cadr reduced-list)
                         (make-extended-list :char #\{ :form reduced-list))
                        ((car reduced-list)
                         (car reduced-list))
                        (t
                         nil))
                       ext-list)))))
               ((atom ext-list)
                (if (funcall test elt ext-list)
                  (progn (setf succeeded t)
                         nil)
                  ext-list)))))
      (let ((removed-list (remove-elt ext-list)))
        (when succeeded
          (values removed-list t))))))

(defun first-elements (ext-list)
  "finds the first elements of the expansions of ext-list"
  (let (first-elts)
    (labels ((find-first-elts (elist)
                (cond ((null elist)
                       nil)
                      ((listp elist)
                       (find-first-elts (car elist))
                       (when (and (extended-list-p (car elist))
                                  (char= (extended-list-char (car elist)) #\[))
                         (find-first-elts (cdr elist))))
                      ((extended-list-p elist)
                       (ecase (extended-list-char elist)
                         (#\[
                          (find-first-elts (extended-list-form elist)))
                         (#\{
                          (mapc #'find-first-elts 
                                (extended-list-form elist)))))
                      ((atom elist)
                       (push elist first-elts)))))
      (find-first-elts ext-list)
      first-elts)))


#|
; examples

(first-elements '{(7 [4] 1) {[0 2] (6 5) [3]}})
(extended-first-elt-p 1 '{([4] 1) {[2] (4 5) [3]}})

(remove-first-elt 1 '{{[4] 1} {[2] (4 5) [3]}})

(remove-first-elt 3 '{([4] [1] [7]) {[2] (6 5) [3]}})

(remove-first-elt 5 '{[2] (6 5) [3]})

(remove-first-elt 5 '{[2] (6 5)})

(remove-first-elt 5 '{(6)})

(remove-first-elt 2 '{([1] [2]) [3]})

(remove-first-elt 1 '{[1] [2] 3})

(remove-first-elt 2 '{[1] [2] 3})

(remove-first-elt 1 '[1])
(remove-first-elt 1 '{1})

(remove-first-elt 1 '{2 {1 3}})
(remove-first-elt 1 '{{2 {{1 [4]} 0}} 3})

(extended-list-equal '{c [{a e}] b} '{[{e a}] b c})
|#