;;;-*- Package: FSA; Mode: Lisp; Base: 10 -*-

;;;; (C) Paul Meurer 1998-2005
;;
;;
;; useful for small automata with complex keys

(in-package :fsa)

(defclass boolean-list-relation (skip-list-relations::skip-list-relation)
  ())

(defclass boolean-list-relations () ())

(defmethod make-relation (order (relations boolean-list-relations))
  (make-instance 'boolean-list-relation :order-fn order))

(defmethod relation-get (key (relation boolean-list-relation))
  (key-match key (skip-list-relations::relation-skip-list relation)))

(defun key-match (key boolean-list)
  (when (atom key) (setf key (list key)))  
  (let ((results ()))
    (dolist (features+value (skip-list:skip-list-get (car key) boolean-list))
      (destructuring-bind (features . value) features+value
        (when (equal (cdr key) features)
          (push value results))))
    (if (cdr results)
      results
      (car results))))

(defmethod relation-subsumed-get (key (relation boolean-list-relation))
  (key-subsume key (skip-list-relations::relation-skip-list relation)))

(defun resolve (key tree)
  #+debug(print (list :key key :tree tree))
  (cond ((null tree)
        t)
        ((stringp tree)
         (if (find (char tree 0) "+*")
           ;; simple pattern match; replace by something more powerful!
           (find-if (lambda (word)
                      (and (stringp word)
                           (let ((pos (search tree word :start1 1 :from-end t)))
                             (and pos
				  (if (char= (char tree 0) #\+) (> pos 0) t)
				  (= (+ pos -1 (length tree)) (length word))))))
                    key)
           (find-if (lambda (word) (and (stringp word) (string-equal tree word))) key)))
	((typep tree 'string-test-function)
	 (let ((word (car key)))
	   (when (stringp word)
	     (funcall (test-function tree) word))))
        ((atom tree)
	 #+debug(Print (list :key key :tree tree))
         (find tree key :test #'equal))
        (t
         (case (car tree)
           (:and
            (not (find-if #'(lambda (x) (not (resolve key x))) (cdr tree))))
           (:or
            (find-if #'(lambda (x) (resolve key x)) (cdr tree)))
           (:not
            (assert (not (cddr tree)))
            (not (resolve key (cadr tree))))
           (otherwise
            (not (find-if (lambda (x) (not (resolve key x))) tree)))))))

;(resolve '(quant indef) '(quant (:not indef)))

#+old
(defun key-subsume (key boolean-list)
  (when (atom key) (setf key (list key)))  
  (let ((results ()))
    (dolist (features+value (skip-list:skip-list-get (car key) boolean-list))
      (destructuring-bind (features . value) features+value
        (when (resolve (cdr key) features)
          (push value results))))
    (if (cdr results)
      results
      (car results))))

#+orig
(defun key-subsume (key boolean-list)
  (when (atom key) (setf key (list key)))  
  (let ((results ()))
    (dolist (k key)
      (dolist (features+value (skip-list:skip-list-get k boolean-list))
        (destructuring-bind (features . value) features+value
          (when (resolve key features)
            (push value results)))))
    (if (cdr results)
      results
      (car results))))

(defun key-subsume (key boolean-list)
  #+debug(print (list :key key :bl (skip-list::skip-list-header boolean-list)))
  (when (atom key) (setf key (list key)))  
  (let ((results ()))
    (dolist (k (cons '* key)) ;; * stands for any category
      (when (atom k)
        (dolist (features+value (skip-list:skip-list-get k boolean-list))
	  #+debug(print (list :key k :f+v features+value)) 
          (destructuring-bind (features . value) features+value
            (let* ((add-features (when (and (consp (car features))
                                            (eq :add (caar features)))
                                   (cdar features)))
                   (features (if add-features (cdr features) features)))
              #+debug(print (list :key key :features features :resolve (resolve key features)))
	      (when (resolve key features)
		(push (list value add-features) results)))))))
    results))

#+test
(print (resolve '(2 4 2 5 1) '((:and 1 2 (:not 3)))))

(defmethod (setf relation-get) (value key (relation boolean-list-relation))
  (let ((skip-list (skip-list-relations::relation-skip-list relation)))
    (if (atom key)
        (pushnew (cons nil value)
                 (skip-list:skip-list-get key skip-list nil)
                 :test #'equal)
      (let* ((add nil)
	     (features
	      (u:collecting (dolist (f key)
			      (if (and (consp f) (eq (car f) :add))
				  (setf add f)
				(u:collect f))))))
	(when add (setf (cdr features) (cons add (cdr features))))
	(pushnew (cons (cdr features) value)
		 (skip-list:skip-list-get (car features) skip-list nil)
		 :test #'equal)))
    value))

(defmethod relation-map (fn (relation boolean-list-relation))
  (let ((skip-list (skip-list-relations::relation-skip-list relation)))
    (skip-list:do-skip-list (key features+values skip-list)
      (dolist (features+value features+values)
        (destructuring-bind (features . value) features+value
          (if features
            (funcall fn (cons key features) value)
            (funcall fn key value)))))))

#+ignore
(defmethod relation-empty-p ((relation boolean-list-relation))
  (call-next-method))

;;; EOF