;;; This work is licensed under the Creative Commons
;;; Attribution-NonCommercial-ShareAlike 4.0 International License.
;;; To view a copy of this license, visit
;;; http://creativecommons.org/licenses/by-nc-sa/4.0/ or send a letter to
;;; Creative Commons, PO Box 1866, Mountain View, CA 94042, USA.

;;; Auxiliary functions to support lfgmodel.lisp
;;; THIS FILE WILL HOLD ANY SPECIAL FUNCTIONS FOR BUFFER QUERIES

(defun istrue () t)

(defun multibuffer-set-empty (buffer)
   (if (= (length (get-m-buffer-chunks buffer)) 0)
    t
    nil))

(defun compilable-empty (buffer)
    (query-buffer buffer '(buffer empty)))

(defun buffer-set-empty (buffer)
    (not (get-m-buffer-chunks buffer)))

(defun one-chunk-in-buffer-set (buffer)
    (= (length (get-m-buffer-chunks buffer)) 1))

(defun fill-buffer-from-set (buffer)
    (let ((newchunk (car (get-m-buffer-chunks buffer))))
        (set-buffer-chunk buffer newchunk)
        (remove-m-buffer-chunk buffer newchunk)))

(defun clear-multibuffer-to-dm (buffer)
    (dolist (toclear (get-m-buffer-chunks buffer) t)
        (set-buffer-chunk buffer toclear)
        (remove-m-buffer-chunk buffer toclear)
        (clear-buffer buffer)))

(defun is-not-coherent (buffer1 buffer2)
     (let ((chunk1 (car (buffer-chunk-fct (list buffer1))))
           (chunk2 (car (buffer-chunk-fct (list buffer2)))))
        (or (and (equal (chunk-slot-value-fct chunk1 'subj) 'no)
                 (or (equal (chunk-slot-value-fct chunk2 'dep1.gf) 'subj)
                     (equal (chunk-slot-value-fct chunk2 'dep2.gf) 'subj)
                     (equal (chunk-slot-value-fct chunk2 'dep3.gf) 'subj)
                     (equal (chunk-slot-value-fct chunk2 'dep4.gf) 'subj)))
            (and (equal (chunk-slot-value-fct chunk1 'obj) 'no)
                 (or (equal (chunk-slot-value-fct chunk2 'dep1.gf) 'obj)
                     (equal (chunk-slot-value-fct chunk2 'dep2.gf) 'obj)
                     (equal (chunk-slot-value-fct chunk2 'dep3.gf) 'obj)
                     (equal (chunk-slot-value-fct chunk2 'dep4.gf) 'obj)))
            (and (equal (chunk-slot-value-fct chunk1 'obl) 'no)
                 (or (equal (chunk-slot-value-fct chunk2 'dep1.gf) 'obl)
                     (equal (chunk-slot-value-fct chunk2 'dep2.gf) 'obl)
                     (equal (chunk-slot-value-fct chunk2 'dep3.gf) 'obl)
                     (equal (chunk-slot-value-fct chunk2 'dep4.gf) 'obl))))))

;;; This function has to find the feature value lists from chunks in two buffers
;;; then go through one of the lists feature by feature and confirm that either
;;; the corresponding feature in the other buffer is not specifiec, or that
;;; the values match.
;;; If that is true for the whole list, it returns t otherwise nil.


(defun no-feature-clashp (feature list1 list2)
     "The function returns T if EITHER the feature value of the two lists matches OR at least one list is unspecified for the feature"
     (or (not (assoc feature list1))
         (not (assoc feature list2))
         (equal (cdr (assoc feature list1)) (cdr (assoc feature list2)))))

(defun specd-no-feature-clashp (feature list1 list2)
    "The function returns T if the feature value of the two lists matches AND at most one list is unspecified for the feature"
    (and  (or (assoc feature list1)
              (assoc feature list2))
          (or (not (assoc feature list1))
              (not (assoc feature list2))
              (equal (cdr (assoc feature list1)) (cdr (assoc feature list2))))))

(defun congruentp (slot1 buffer1 slot2 buffer2)
     "Returns T if the feature sets for slot in buffer1 and buffer2 are congruent"
     (let* ((list1 (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer1))) slot1)))
           (list2 (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer2))) slot2)))
           (featurelist (mapcar #'first list1))
           (matches (mapcar #'(lambda (n) (no-feature-clashp n list1 list2)) featurelist))
           (alltrue (not (member nil matches))))
           alltrue))


(defun congruentp1 (slot1 buffer1 slot2 buffer2)
     "Returns T if both slot values are lists and the feature sets for slot in buffer1 and buffer2 are congruent, else nil"
     (if (and (equal (type-of (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer1))) slot1))) 'cons)
              (equal (type-of (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer2))) slot2))) 'cons))
         (congruentp slot1 buffer1 slot2 buffer2)
        nil))

;           (format t "~S: ~S~&~S: ~S ~&~S ~&~S All true: ~S" buffer1 list1 buffer2 list2 featurelist matches alltrue)))
(defun specd-congruentp (list0 slot1 buffer1 slot2 buffer2)
     "Returns T if the feature sets for slot in buffer1 and buffer2 are congruent and between them fully specify list0"
     (let* ((list1 (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer1))) slot1)))
           (list2 (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer2))) slot2)))
           (featurelist (mapcar #'first list0))
           (matches (mapcar #'(lambda (n) (congruent-and-specp n list0 list1 list2)) featurelist))
           (alltrue (not (member nil matches))))
           alltrue))

(defun congruent-and-specp (feature speclist list1 list2)
     "Returns T if the value of feature is in either list1 or list2 and lists1,2 are congruent"
     (and  (no-feature-clashp feature list1 list2)
           (or (equal (second (assoc feature speclist)) (second (assoc feature list1)))
               (equal (second (assoc feature speclist)) (second (assoc feature list2))))))

(defun list-slot-congruentp (list1 slot2 buffer2)
     "Returns T if the feature set for slot2 buffer2 is congruent with the list"
     (let* ((list2 (no-output (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer2))) slot2)))
           (featurelist (mapcar #'first list1))
           (matches (mapcar #'(lambda (n) (no-feature-clashp n list1 list2)) featurelist))
           (alltrue (not (member nil matches))))
           alltrue))

(defun gf-if-match-underspec-poss (spec slot1 buffer1 slot2 buffer2)
     "Spec is a list ('gfname (feature spec list)), returns gfname if slot1 and slot2 congruent with speclist"
     (if (and (list-slot-congruentp (second spec) slot1 buffer1)
              (list-slot-congruentp (second spec) slot2 buffer2))
         (first spec)))

(defun gf-if-match-full-spec (spec slot1 buffer1 slot2 buffer2)
    "Spec is a list ('gfname (feature spec list)), returns gfname if slot1 and slot2 congruent with speclist"
    (if (specd-congruentp (second spec) slot1 buffer1 slot2 buffer2)
        (first spec)))

(defun collect-gf-matches (speclist slot1 buffer1 slot2 buffer2)
     "Returns a list of matching gfs from a gf-function speclist eg *ugflist*"
     (mapcar #'(lambda (x) (gf-if-match-full-spec x slot1 buffer1 slot2 buffer2)) speclist))

(defun find-gf-match (speclist slot1 buffer1 slot2 buffer2)
     "Returns the first non-nil item on a list of potential gfs matching speclist and specs in two buffer slots"
     (find-if #'(lambda (x) (not (equal x nil))) (collect-gf-matches speclist slot1 buffer1 slot2 buffer2)))

(defun chunk-in-buffer (buffer)
     "Retrieves the name of the chunk in the buffer"
     (no-output (car (buffer-chunk-fct (list buffer)))))

(defun not-neg (feature slot buffer)
     "Returns T if the feature value in buffer.slot is nil or plus"
     (not (equal (second (assoc feature (chunk-slot-value-fct (chunk-in-buffer buffer) slot))) 'minus)))

(defun value-of-indexed-slot (buffer index)
     "Retrieves the value of a slot whose name is the value of the index slot"
     (chunk-slot-value-fct (chunk-in-buffer buffer) (chunk-slot-value-fct (chunk-in-buffer buffer) index)))

(defun attachablep (buffer)
    "Returns T if the ma slot of buffer is either REQD or T or NIL"
     (let ((x (value-of-indexed-slot buffer 'ma)))
          (or (equal x 'reqd)
              (equal x t)
              (equal x nil))))

(defun prodrop (gf buffer)
    "Returns T if there are no vacant DEP slots in buffer whose DEP.GF value is congruent with gf"
    (let ((thisspec (second (assoc gf *ugflist*))))
         (not (or (and (not (equal (chunk-slot-value-fct buffer 'dep1.gf) nil))
                       (equal (chunk-slot-value-fct buffer 'dep1) nil)
                       (list-slot-congruentp thisspec 'dep1.gf buffer))
                  (and (not (equal (chunk-slot-value-fct buffer 'dep2.gf) nil))
                       (equal (chunk-slot-value-fct buffer 'dep2) nil)
                       (list-slot-congruentp thisspec 'dep2.gf buffer))
                  (and (not (equal (chunk-slot-value-fct buffer 'dep3.gf) nil))
                       (equal (chunk-slot-value-fct buffer 'dep3) nil)
                       (list-slot-congruentp thisspec 'dep3.gf buffer))
                  (and (not (equal (chunk-slot-value-fct buffer 'dep4.gf) nil))
                       (equal (chunk-slot-value-fct buffer 'dep4) nil)
                       (list-slot-congruentp thisspec 'dep4.gf buffer))))))

(defun corespecp (chunk slot)
    "Returns T if the chunk has gf feature values for r, o and c"
    (let ((speclist (chunk-slot-value-fct chunk slot)))
      (and (assoc 'r speclist)
           (assoc 'o speclist)
           (assoc 'c speclist))))


(defun nonuniquep (buffer1 buffer2)
    "Returns T if buffer1 pre/post.ma.gf (depending on buffer2 predreqd) is fully spec'd and matches buffer2 depX.gf"
    (let* ((b1chunk (chunk-in-buffer buffer1))
          (b2chunk (chunk-in-buffer buffer2))
          (testgf (if (chunk-slot-value-fct b2chunk 'predreqd)
                      (chunk-slot-value-fct b1chunk 'pre.ma.gf)
                      (chunk-slot-value-fct b1chunk 'post.ma.gf))))
          (and  (if (equal (type-of testgf) 'cons)
                    (corespecp b1chunk testgf)
                    t)
                (or (equal testgf (chunk-slot-value-fct b2chunk 'dep1.gf))
                    (equal testgf (chunk-slot-value-fct b2chunk 'dep2.gf))
                    (equal testgf (chunk-slot-value-fct b2chunk 'dep3.gf))
                    (equal testgf (chunk-slot-value-fct b2chunk 'dep4.gf))))))



(defun attachable-cats (mother daughter)
    "Returns T if the category specs of the chunks in mother and daughter allow attachment"
    (let  ((machunk (no-output (car (buffer-chunk-fct (list mother))))))
        (or (and (equal (chunk-slot-value-fct machunk 'predreqd) t)
                 (congruentp 'pre.ma.cat daughter 'cat mother))
            (and (equal (chunk-slot-value-fct machunk 'predreqd) nil)
                 (congruentp 'post.ma.cat daughter 'cat mother)))))

(defun slot-value-type-eqp (buffer slot type)
     "Returns T if the chunk in buffer has slot value of type TYPE"
     (equal (type-of (chunk-slot-value-fct (chunk-in-buffer buffer) slot)) type))
;(defun increment-deps (buffer)
;    "Increases the value of the dep slot in the buffer by one"
;    (let* ((chunkname (no-output (car (buffer-chunk-fct (list buffer)))))
;           (chunkdeps (chunk-slot-value-fct chunkname 'deps))
;           (output (set-chunk-slot-value-fct chunkname 'deps (+ chunkdeps 1))))
;           output))

(defun incongruent-or-not-cons (slot1 buffer1 slot2 buffer2)
      "Returns T if either buffer2 slot2 is not type CONS or buffer1 slot1 and buffer2 slot2 not congruent"
      (or (not (slot-value-type-eqp buffer2 slot2 'cons))
          (not (congruentp slot1 buffer1 slot2 buffer2))))

(defun increment-deps (buffer)
      "Returns the value of deps slot in buffer +1"
      (+ (chunk-slot-value-fct (chunk-in-buffer buffer) 'deps) 1))

;(defun find-other-alt (buffer slot)
;      "If  buffer slot value is alt, returns the other slot name whose value is alt"
;      t)

(defun list-alts-in-slotlist (chunk slotlist slot0)
      "Returns a list of slots from slotslist whose value is slot and which are not themselves slot0"
      (mapcar #'(lambda (x) (if (and (equal (chunk-slot-value-fct chunk x) 'alt)
                                     (not (equal x slot0)))
                                x
                                nil)) slotlist))

(defun find-other-alt-in-buffer-chunk (buffer slot1)
      "Returns the first slot from chunk in buffer with value ALT that is not slot1"
      (let* ((thischunk (chunk-in-buffer buffer))
             (knownalt (chunk-slot-value-fct thischunk slot1))
             (otheralts (list-alts-in-slotlist thischunk (chunk-filled-slots-list-fct thischunk) knownalt))
             (firstalt (find-if #'(lambda (x) (not (equal x nil))) otheralts)))
             firstalt))


(defun ma-in-buffer-set (buffer)
    (no-output (not (not (member (chunk-slot-value-fct (car (buffer-chunk-fct (list buffer))) 'ma) (get-m-buffer-chunks buffer))))
  ))

(defun add-to-chunk-set (buffer)
    (no-output (let ((thischunk (car (buffer-chunk-fct (list buffer)))))
      (setf *f-rep-chunks* (if (member thischunk *f-rep-chunks*)
                          *f-rep-chunks*
                         (push thischunk *f-rep-chunks*))))))

(defun add-chunk-to-chunk-set (thischunk)
    (setf *f-rep-chunks* (if (member thischunk *f-rep-chunks*)
                              *f-rep-chunks*
                              (push thischunk *f-rep-chunks*))))

(defun set-eq (seta setb)
    (and (subsetp seta setb) (subsetp setb seta)))

(defun next-bigpro ()
    "Returns the first member of list *bigpro*, removes this item from *bigpro*"
    (let ((a (car *bigpro*)))
         (setf *bigpro* (cdr *bigpro*))
         a))

(defun next-smallpro ()
   "Returns the first member of list *smallpro*, removes this item from *smallpro*"
   (let ((a (car *smallpro*)))
        (setf *smallpro* (cdr *smallpro*))
        a))
