(in-package :u02s03)

(defclass entry-query ()
  ((pattern :col-type varchar :initarg :pattern :initform "")
   (id :col-type serial)
   (entry-node :col-type int4 :initarg :entry-node))
  (:metaclass dao-class)
  (:table-name entryqueries)
  (:keys id))

(defclass node ()
  ((question :col-type varchar :initarg :question :initform "")
   (id :col-type serial)
   (values :col-type varchar :initarg :values :initform ""))
  (:metaclass dao-class)
  (:keys id)
  (:table-name nodes))

(defun setup-classes ()
  (loop for class in '(entry-query node)
     unless (table-exists-p (dao-table-name class))
     do (progn (format *debug-io* "Creating table for the class ~a!~%" class)
	       (execute (dao-table-definition class)))))

(when (postmodern:connected-p postmodern:*database*)
  (setup-classes))

(defun nodes->string (nodes)
  (format nil "~{~a~^;~}"
	  (loop for (keyword . node) in nodes
	     collect (format nil "~d:~d" keyword
			     (etypecase node
			       (integer node)
			       (node (slot-value node 'id)))))))

(defun string->nodes (string)
  (when (find #\Colon string)
    (loop for pair in (split-sequence #\Semicolon string)
       collect (destructuring-bind (keyword node)
		   (split-sequence #\Colon pair)
		 (cons keyword
		       (or (get-dao 'node (parse-integer node))
			   (error "The node #~d does not exist." node)))))))

(defun make-node (&key (question "") next-nodes)
  (make-dao 'node :question question :values (nodes->string next-nodes)))

(defun make-entry-node (&key (pattern "") entry-node)
  (make-dao 'entry-query
	    :pattern pattern
	    :entry-node (etypecase entry-node
			  (integer entry-node)
			  (node (slot-value entry-node 'id)))))

(defun match-entry-nodes (input)
  "Match entry regexp objects against INPUT."
  (delete-duplicates
   (loop for query in (select-dao 'entry-query)
      when (cl-ppcre:all-matches (string-downcase (slot-value query 'pattern)) (string-downcase input))
      collect query)
   :key (lambda (query) (slot-value query 'entry-node))))


(defun search-entry-errors ()
  (loop
     for entry in (select-dao 'entry-query)
     for regexp-error =
       (nth-value 1
		  (ignore-errors
		    (cl-ppcre:all-matches (slot-value entry 'pattern) "foobar")))
     when (null (get-dao 'node (slot-value entry 'entry-node)))
     collect `(:no-entry-node ,(format nil
				       "The entry node #~d on entry-node #~d does not exist."
				       (slot-value entry 'entry-node)
				       (slot-value entry 'id)))
     when regexp-error
     collect `(:bad-regexp ,(format nil
				    "The regular expression ~s for entry-node #~d is invalid: ~a"
				    (slot-value entry 'pattern)
				    (slot-value entry 'id)
				    regexp-error))))

(defun mark-node (node-id node-children table)
  ;; (format t "marking ~a~%" node-id)
  (unless (gethash node-id table)
    (setf (gethash node-id table) t)
    (loop for (answer . node) in node-children
       do (mark-node (slot-value node 'id)
		     (ignore-errors
		       (string->nodes (slot-value node 'values)))
		     table))))

(defun search-node-errors ()
  (let ((findable (make-hash-table)))
    ;; (format t "scanning roots~%")
    (loop
       for root in (select-dao 'entry-query)
       for entry-node = (get-dao 'node (slot-value root 'entry-node))
       when entry-node
       do (mark-node (slot-value entry-node 'id)
		     (ignore-errors
		       (string->nodes (slot-value entry-node 'values)))
		     findable))
    (loop
       for node in (select-dao 'node)
       for (children parse-error) =
	 (multiple-value-list
	  (ignore-errors
	    (string->nodes (slot-value node 'values))))
       when parse-error
       collect `(:values-parse-error ,(format nil "The value string for node #~d is invalid: ~a"
					      (slot-value node 'id)
					      parse-error))
       unless (gethash (slot-value node 'id) findable)
       collect `(:unreachable-node ,(format nil
					    "The node #~d is not reachable from an entry node, or from another node."
					    (slot-value node 'id))))))
