;;;-*- Mode: Lisp; Package: FSA -*-
;;;
;;; (C) Paul Meurer, Aksis, 2000--2004
;;; paul.meurer@aksis.uib.no

(in-package :fsa)

;; connect to the database containing the dictionary

(defclass boolean-regexp-symbols () ())

(defmethod fsa-list< ((fsa boolean-regexp-symbols) s1 s2)
  (cond ((null s1)
         (if s2 t :equal))
        ((null s2)
         nil)
        (t (let ((car-equal-p (funcall (symbol-order-fn fsa) (car s1) (car s2))))
             (if (eq car-equal-p :equal)
                 (fsa-list< fsa (cdr s1) (cdr s2))
               car-equal-p)))))

(defclass string-test-function ()
  ((name :initarg :name :reader name)
   (function :initarg :function :reader test-function)))

(defmacro def-string-test-function (fname arglist &body body)
  (let ((function (gensym)))
    `(defparameter ,fname
      (let ((,function (defun ,fname ,arglist ,@body)))
	(make-instance 'string-test-function :name (symbol-name ',fname) :function ,function)))))


;; cp. resolve()
(defmethod symbol-order-fn ((fsa boolean-regexp-symbols))
  (lambda (s1 s2)
    (declare #.cl-user::*highly-optimized*)
    ;; sort chars before fixnums before strings before symbols before lists before functions
    (etypecase s1
      (character (etypecase s2
                   (character
                    (if (char= (the character s1) (the character s2))
                        :equal
                      #+excl (and (char< (the character s1)(the character s2)) t)
                      #-excl (char< (the character s1) (the character s2))))
                   ((or fixnum simple-string symbol list string-test-function) t)))
      (fixnum (etypecase s2
                (character nil)
                (fixnum  (if (= (the fixnum s1) (the fixnum s2))
                             :equal
                           (< (the fixnum s1) (the fixnum s2))))
                ((or simple-string symbol list string-test-function) t)))
      (simple-string (etypecase s2
                       ((or character fixnum) nil)
                       (simple-string
                        (if (string= s1 s2) :equal
                          (and (string< s1 s2) t)))
                       ((or symbol list string-test-function) t)))
      (symbol (etypecase s2
                ((or character fixnum simple-string) nil)
                (symbol
                 (if (eq s1 s2) :equal
                   (and (string< s1 s2) t)))
                ((or list string-test-function) t)))
      (list (etypecase s2
              ((or character fixnum simple-string symbol) nil)
              (list
               (fsa-list< fsa s1 s2))
	      (string-test-function t)))
      (string-test-function (etypecase s2
			      ((or character fixnum simple-string symbol list) nil)
			      (string-test-function
			       (if (eq s1 s2) :equal
				 (and (string< (name s1) (name s2)) t))))))))

#+test
(defparameter *cp*
  (dfa-compile-parsed-boolean-list 
   '(:* a)
   (make-instance 'boolean-list-fsa)))

(defclass boolean-list-fsa
  (standard-states::fixnum-states boolean-regexp-symbols boolean-list-relations list-sets::list-sets)
  ())

;(make-instance 'standard-states::fixnum-states)

(defclass boolean-list-nfa (boolean-list-fsa nfa) ())
(defclass boolean-list-dfa (boolean-list-fsa dfa) ())

(defmethod fsa-print ((fsa boolean-list-fsa) &optional (stream *standard-output*))
  (format stream "start: ~s~%final: ~s~%" (fsa-start-state fsa)
	  (fsa-final-states fsa))
  (relation-map
   #'(lambda (state relation)
       (format stream "~2d: ~%" state)
       (relation-map
        #'(lambda (symbol dest)
            (format stream "   ~a : ~a~%" dest symbol))
        relation)
       (terpri stream))
   (fsa-delta fsa)))

;(fsa::fsa-print *cp*)

(defmethod make-state-relation ((fsa boolean-list-fsa))
  (make-instance 'skip-list-relations::skip-list-relation :order-fn (state-order-fn fsa))
  #+ignore
  (make-relation (state-order-fn fsa) fsa))

(defmethod make-nfa ((fsa boolean-list-fsa))
  (make-instance 'boolean-list-nfa))
(defmethod make-dfa ((fsa boolean-list-fsa))
  (make-instance 'boolean-list-dfa))

(defmethod dfa-compile-parsed-boolean-list ((list-regexp list) (fsa boolean-list-fsa))
  (labels 
    ((walk (exp)
        (etypecase exp
          (list
           (ecase (car exp) 
             (:seq
              (minimize (apply #'fsa-concat (mapcar #'walk (cdr exp)))))
             (:or
              (minimize (apply #'fsa-union (mapcar #'walk (cdr exp)))))
             (:?
              (assert (null (cddr exp)))
              (minimize (fsa-optional (walk (cadr exp)))))
             (:*
              (assert (null (cddr exp)))
              (minimize (fsa-closure (walk (cadr exp)))))
             (:+
              (assert (null (cddr exp)))
              (minimize (fsa-plus (walk (cadr exp)))))
             (:and
              (fsa-symbol (cdr exp) fsa))))
          (string
           (fsa-symbol exp fsa)
           #+test
           (minimize (apply #'fsa-concat
                            (map 'list (lambda (c) (fsa-symbol c fsa)) exp))))
          (symbol
           (case exp
             (:@
              (fsa-symbol exp fsa))
             (otherwise
              (fsa-symbol exp fsa)))))))
    ;;(any-determinize 
     (walk list-regexp)))

#|| ;; the input:

-- compoundregexp
-- JBJ, received Nov. 16, 1998
-- partadj removed
-- N | N S replaced by N S?

compound
        ((( P | (N & sg  & indef ) |(N & sg  & indef S)| 
        (N & sg  & indef) | (N & sgpl & indef S) |
        (V & imp) | infimp | (Det & quant & !indef) | Adv | Adj | 
        (Pro & nom) | (Pro & nomacc)) E?)*  HYPHEN?)*
        (Adv | N S? | V | P | Adj)

suspicious . & SHORT & !FREQUENT_AS_COMPOUND
||#

#+test
(defparameter *cp*
  (dfa-compile-parsed-boolean-list 
   '(:seq
     (:*
      (:seq
       (:*
        (:seq 
         (:or P 
              (:seq (:and N (:or sg sgpl) indef) (:? S))
              (:and C imp)
              infimp
              (:and Det quant (:not indef))
              Adv
              Adj
              (:and Pro nom)
              (:and Pro nomacc))
         (:? E)))
       (:? Hyphen)))
     (:or Adv (:seq N (:? S)) V P Adj))
   (make-instance 'boolean-list-fsa)))

:eof