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

;;;; (C) Paul Meurer 1998
;;
;;
;; 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)
  (cond ((null tree)
        t)
        ((atom 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)))

(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))))

;(resolve '((:and 1 2 (:not 3))) '(2 4 2 5 1))

(defmethod (setf relation-get) (value key (relation boolean-list-relation))
  ;(print key)
  (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)
      (pushnew ;(print (cons (cdr key) value))
               (cons (cdr key) value)
               (skip-list:skip-list-get (car key) 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))