(in-package "XWORD")

(kr:create-schema 'WORD_VAR
  (:key-space
   (kr:o-formula
    (let* ((length (kr:g-value (kr:gv :self) :n))
	   (key-space (make-key-space length))
	   (array (kr:gvl :dict)))
      (loop for string across array do
	    #+dbg
	    (assert (= (length string) length))
	    (loop for i below length
		  do (setf (elt key-space i)
			   (charset-add-char (elt key-space i)
					     (char string i)))))
      key-space)))
  (:key
   (kr:o-formula
    (map-into (kr:g-value (kr:gv :self) :key-charsets)
	      (lambda (l)
		(kr:gv l :allowed-chars))
	      (kr:g-value (kr:gv :self) :letters))))
  (:possible-words-dict
   (kr:o-formula
    (let* ((array (kr:gvl :dict))
	   (key-space (kr:gvl :key))
	   (index 0)
	   (orig-length (dict-length array))
	   string)
      (loop while (< index (dict-length array)) do
	    (setq string (aref array index))
	    (loop for c1 across string
		  for k1 across key-space
		  do (etypecase k1
		       (charset
			(unless (charset-has-char k1 c1)
			  (array-remove-at-index array index)
			  (return)))
		       (character
			(unless (char= c1 k1)
			  (array-remove-at-index array index)
			  (return))))
		  finally (incf index)))
      #+nil
      (format t "recomputed possible-words:~@[Unchanged ~*~] ~S~%"
	      (= orig-length (dict-length array))
	      (kr:gv :self))
      (unless (= orig-length (dict-length array))
	(kr:mark-as-changed (kr:gv :self) :dict))
      array))))

(kr:create-schema 'LETTER_VAR
  (:char nil)
  (:allowed-chars
   (kr:o-formula
    (etypecase (kr:gvl :char)
      (null
       (let ((depword2 (kr:g-value (kr:gv :self) :depword2))
	     (depword1 (kr:g-value (kr:gv :self) :depword1)))
	 (cond ((null depword2)
		(aref (kr:gv depword1 :key-space)
		      (kr:g-value (kr:gv :self) :pos1)))
	       (t (let* ((charset1
			  (aref (kr:gv depword1 :key-space)
				(kr:g-value (kr:gv :self) :pos1)))
			 (charset2
			  (aref (kr:gv depword2 :key-space)
				(kr:g-value (kr:gv :self) :pos2) ))
			 (new-value
			  (charset-intersection charset1 charset2)))
		    (unless (charset-equal charset1 new-value)
		      (kr:mark-as-invalid depword1 :possible-words-dict))
		    (unless (charset-equal charset2 new-value)
		      (kr:mark-as-invalid depword2 :possible-words-dict))
		    new-value)))))
      (character (make-singleton-charset (kr:gvl :char)))))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defstruct kr-grid x y words letters ordered-words original-state)

(defun kr-grid-state (kr-grid &optional
		      (target (make-array (length (kr-grid-words kr-grid))
					  :initial-element 0)))
  (map-into target #'(lambda (w) (dict-length (kr:gv w :dict)))
	    (kr-grid-words kr-grid)))

(defsetf kr-grid-state (kr-grid &optional ignored-target) (state)
  (declare (ignorable ignored-target))
  `(flet ((restore-state (word-var dict-state)
	    (let ((orig-state (fill-pointer (kr:gv word-var :dict))))
	      (prog1 (setf (fill-pointer (kr:gv word-var :dict)) dict-state)
		(unless (= orig-state dict-state)
		  (kr:mark-as-changed word-var :dict))))))
     (map nil #'restore-state (kr-grid-words ,kr-grid) ,state)))

(defun %init-kr-grid (word-props letter-props &optional
		      (kr-grid (make-kr-grid)) &aux (maxlen 0))
  (setf (kr-grid-words kr-grid)
	(coerce
	 (loop for props across word-props collect
	       (destructuring-bind (&key letters orientation index number)
		   props
		 (let* ((length (length letters))
			(word
			 (kr:create-instance nil WORD_VAR
			   (:n length)
			   (:index index)
			   (:orientation orientation)
			   (:key-charsets (make-key-space length))
			   (:assigned-p nil)
			   (:number number)
			   (:constant '(:n :index :orientation :number
					:key-charsets))
			   (:dict
			    (copy-dict
			     (aref +ordered-dictionaries+ length))))))
		   (when (> length maxlen) (setq maxlen length))
		   word)))
	 'vector))
  (setf (kr-grid-letters kr-grid)
	(coerce
	 (loop for props across letter-props collect
	       (destructuring-bind (&key x y index depword1 pos1 depword2 pos2)
		   props
		 (kr:create-instance nil LETTER_VAR
		   (:x x)
		   (:y y)
		   (:index index)
		   (:depword1 (aref (kr-grid-words kr-grid) depword1))
		   (:depword2 (when depword2
				(aref (kr-grid-words kr-grid) depword2)))
		   (:pos1 pos1)
		   (:pos2 (when pos2 pos2))
		   (:constant '(:x :y :index :depword1 :depword2
				:pos1 :pos2)))))
	 'vector))
  (loop for props across word-props
	for word across (kr-grid-words kr-grid) do
	(destructuring-bind (&key letters &allow-other-keys) props
	     (setf (kr:gv word :letters)
		   (map 'list (lambda (letter-idx)
				(aref (kr-grid-letters kr-grid)
				      letter-idx))
			letters)))
	(kr:declare-constant word :letters))
  (setf (kr-grid-ordered-words kr-grid)
	(make-array (1+ maxlen) :initial-element nil))
  (loop for word across (kr-grid-words kr-grid) do
	(push word (aref (kr-grid-ordered-words kr-grid) (kr:gv word :n))))
  (setf (kr-grid-original-state kr-grid) (kr-grid-state kr-grid))
  kr-grid)

(defun %make-kr-grid (xword-grid)
  (multiple-value-bind (word-props letter-props) (%parse-xword xword-grid)
    (let ((kr-grid (make-kr-grid :y (array-dimension xword-grid 0)
				 :x (array-dimension xword-grid 1))))
      (%init-kr-grid word-props letter-props kr-grid))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun %initialize-assigned-p (kr-grid)
  (map nil (lambda (word-var)
	     (setf (kr:gv word-var :assigned-p) nil)
	     (setf (kr:gv word-var :assigned-letters-list) nil))
       (kr-grid-words kr-grid)))

(defun %assign-word-var (word-var string)
  #+dbg
  (assert (not (kr:gv word-var :assigned-p)))
  (loop for letter-var in (kr:gv word-var :letters)
	for char across string
	with depword and deppos and pos do
	(let ((depword2 (kr:gv letter-var :depword2)))
	  (if depword2
	      (if (eq word-var depword2)
		  (setq deppos (kr:gv letter-var :pos1)
			depword (kr:gv letter-var :depword1)
			pos (kr:gv letter-var :pos2))
		  (setq deppos (kr:gv letter-var :pos2)
			depword depword2
			pos (kr:gv letter-var :pos1)))
	      (progn
		#+dbg
		(assert (eq word-var (kr:gv letter-var :depword1)))
		(setq deppos nil depword nil
		      pos (kr:gv letter-var :pos1)))))
	(unless (charset-has-char (kr:gv letter-var :allowed-chars) char)
	  #+dbg(assert (not (kr:gv word-var :assigned-p)))
	  (map nil (lambda (l) (setf (kr:gv l :char) nil))
	       assigned-letters-list)
	  (return NIL))
	if (kr:gv letter-var :char) do
		(progn)
		;;#+dbg(assert (and depword (kr:gv depword :assigned-p)))
		#+dbg(assert (eql char (kr:gv letter-var :char)))
	else do
		#+dbg(assert (or (null depword) (not (kr:gv depword :assigned-p))))
		(setf (kr:gv letter-var :char) char)
	     and collect letter-var into assigned-letters-list
	end
	finally
	(setf (kr:gv word-var :assigned-p) t)
	(setf (kr:gv word-var :assigned-letters-list) assigned-letters-list)
	(return T)))

(defun %unassign-word-var (word-var)
  #+dbg
  (assert (kr:gv word-var :assigned-p))
  (let ((assigned-letters-list (kr:gv word-var :assigned-letters-list)))
    (loop for letter-var in assigned-letters-list
	  with depword and deppos and pos do
	  #+dbg(assert (characterp (kr:gv letter-var :char)))
	  #+dbg(assert (find letter-var (kr:gv word-var :letters)))
	  (let ((depword2 (kr:gv letter-var :depword2)))
	    (if depword2
		(if (eq word-var depword2)
		    (setq deppos (kr:gv letter-var :pos1)
			  depword (kr:gv letter-var :depword1)
			  pos (kr:gv letter-var :pos2))
		    (setq deppos (kr:gv letter-var :pos2)
			  depword depword2
			  pos (kr:gv letter-var :pos1)))
		(progn
		  #+dbg
		  (assert (eq word-var (kr:gv letter-var :depword1)))
		  (setq deppos nil depword nil
			pos (kr:gv letter-var :pos1)))))
	  (unless (and depword (kr:gv depword :assigned-p))
	    (setf (kr:gv letter-var :char) nil)))
    (setf (kr:gv word-var :assigned-p) nil)
    (kr:mark-as-invalid word-var :possible-words-dict)
    #+nil
    (setf (kr:gv word-var :assigned-letters-list) nil)))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defvar *kr-dict-lengths1* nil)
(defvar *kr-dict-lengths2* nil)

(defun %initialize-dict-lengths (kr-grid)
  (let ((length (length (kr-grid-words kr-grid))))
    (setq *kr-dict-lengths1* (make-array length :initial-element 0)
	  *kr-dict-lengths2* (make-array length :initial-element 0))
    length))

(defun %remove-string-from-dicts (string kr-grid)
  (map nil (lambda (w)
	     (let* ((d (kr:gv w :dict))
		    (i (array-position-of d string)))
	       (when i
		 (array-remove-at-index d i)
		 (when (zerop (dict-length d))
		   (unless (kr:gv w :assigned-p)
		     (return-from %remove-string-from-dicts nil))))))
       (aref (kr-grid-ordered-words kr-grid)
	     (length string)))
  t)
(defun %recompute-closure (kr-grid &optional
			   (state1 *kr-dict-lengths1*)
			   (state2 *kr-dict-lengths2*)
			   (count 0) &aux assigned-words)
  (labels ((handle-empty-dict ()
	     (map nil #'%unassign-word-var assigned-words)
	     (return-from %recompute-closure nil))
	   (dict-length-fn (word-var)
	     (kr:gv word-var :key)	; force recompute
	     (let ((dict-length
		    (dict-length (kr:gv word-var :possible-words-dict))))
	       (cond ((kr:gv word-var :assigned-p) dict-length)
		     ((zerop dict-length) (handle-empty-dict))
		     ((= dict-length 1)
		      (let ((string (elt (kr:gv word-var :dict) 0)))
			(%assign-word-var word-var string)
			#+dbg
			(assert (kr:gv word-var :assigned-p))
			(push word-var assigned-words)
			(unless (%remove-string-from-dicts string kr-grid)
			  (handle-empty-dict))
			#+dbg
			(assert (zerop (dict-length (kr:gv word-var :dict))))
			0))
		     (t dict-length)))))
    (loop
       (when (zerop count)
	 (map-into state2 #'dict-length-fn (kr-grid-words kr-grid)))
       (rotatef state1 state2)
       (map-into state2 #'dict-length-fn (kr-grid-words kr-grid))
       (if (equalp state1 state2)
	   (return (values count assigned-words))
	   (if (> count 1e6)
	    (error "Convergance")
	    (incf count))))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun %initialize-letters-unfilled (kr-grid)
  (map nil (lambda (l) (setf (kr:gv l :char) nil))
       (kr-grid-letters kr-grid)))

(defun kr-fill-grid (kr-grid)
  (labels ((%fill-grid (&optional (depth 0))
	     (let ((word-var (find-if-not (lambda (w) (kr:gv w :assigned-p))
					  (kr-grid-words kr-grid))))
	       (unless word-var
		 (cerror "Continue" "Done at depth ~D" depth)
		 (return-from %fill-grid nil))
	       (let ((grid-state (kr-grid-state kr-grid))
		     (dict (copy-dict (kr:gv word-var :dict)))
		     (index 0) recomputed-p assigned-words
		     string)
		 (tagbody loop
		    (unless (< index (dict-length dict))
		      (return-from %fill-grid nil))
		    (setq string (aref dict index))
		    (incf index)
		    (unless (%assign-word-var word-var string)
		      (go bail2))
		    (unless (%remove-string-from-dicts string kr-grid)
		      (go bail1))
		    (multiple-value-setq (recomputed-p assigned-words) ;XXX
		      (%recompute-closure kr-grid))
		    (unless recomputed-p (go bail1))
		    (%fill-grid (1+ depth))
		  bail1 (%unassign-word-var word-var)
		  bail2 (setf (kr-grid-state kr-grid) grid-state)
		    (when assigned-words
		      (map nil #'%unassign-word-var assigned-words)
		      (setq assigned-words nil))
		    (go loop))))))
    (%initialize-dict-lengths kr-grid)
    (%initialize-letters-unfilled kr-grid)
    (%initialize-assigned-p kr-grid)
    (setf (kr-grid-state kr-grid) (kr-grid-original-state kr-grid))
    (or (%recompute-closure kr-grid) (error "Unfillable."))
    (%fill-grid)))

(defun print-kr-grid (kr-grid &optional (stream *standard-output*))
  (let ((xword-grid (make-array (list (kr-grid-y kr-grid)
				      (kr-grid-x kr-grid))
				:initial-element nil)))
    (loop for letter-var across (kr-grid-letters kr-grid)
	  do (setf (aref xword-grid (kr:gv letter-var :y)
			 (kr:gv letter-var :x))
		   (let ((char (kr:gv letter-var :char)))
		     (etypecase char
		       (character char)
		       (null t)))))
    (arccc-print xword-grid stream)))

(defun print-word-var (x)
  (list (kr:gv x :number)
	(kr:gv x :orientation)
	(map 'string (lambda (x) (or (kr:gv x :char) #\.))
	     (kr:g-value x :letters))))

#||
(initialize-ordered-dictionaries
 "home:/extern/arccc-0.1a/examples/wlist.txt")
(with-open-file (stream "home:/extern/arccc-0.1a/examples/metro1.grid")
  (setq $a (arccc-read stream)))
(setq $kr-grid (%make-kr-grid $a))
(kr-fill-grid $kr-grid)
(print-kr-grid $kr-grid)
(handler-bind ((error (lambda (c)
			(when (find-restart 'continue)
			  (print-kr-grid $kr-grid) (terpri)
			  (invoke-restart 'continue)))))
  (kr-fill-grid $kr-grid))
||#