(in-package "XWORD")

;;; Represent a basic grid as a 2D array: Represent a blank (empty)
;;; square with T and a black square with NIL.
;;;
;;; \ X
;;;Y \ 0123
;;;   +-----
;;; 0 |
;;; 1 |
;;; 2 |
;;; 3 |

(defun black-square-p (c) (eq c nil))

(defun arccc-print (array stream)
  "Internal. Print the basic 2D array in arccc file format."
  (loop for y below (array-dimension array 1)
	do (loop for x below (array-dimension array 0)
		 for c = (aref array y x)
		 do (case c
		      ((t) (write-char #\. stream))
		      ((nil) (write-char #\# stream))
		      (otherwise	;XXX
		       (write-char c stream))))
	(terpri stream)))

(defun arccc-read (stream)
  "Internal. Return a basic 2D array from reading stream in arccc file
format. "
  (let* ((lines
	  (loop for line = (read-line stream nil) while line collect line))
	(contents
	 (loop for y from 0 for line in lines
	       collect (loop for x from 0 for c across line
			     collect (ecase c
				       (#\# nil)
				       (#\. t))))))
    (make-array (list (length contents)
		      (length (car contents)))
		:initial-contents contents)))

(defun %parse-xword (array)
  "Return as values two lists of property lists---one for the words and the
other for the letters in crossword ARRAY."
  (let (all-words all-letters)
    (let* ((height (array-dimension array 1))
	   (width (array-dimension array 0))
	   (letter-map (make-array (list width height) :initial-element nil))
	   (next-letter-index 0) (next-word-index 0))
      (flet ((intern-letter (x y)
	       (or (aref letter-map y x)
		   (prog1 (setf (aref letter-map y x) next-letter-index)
		     (push (list :x x :y y :index next-letter-index)
			   all-letters)
		     (incf next-letter-index))))
	     (intern-word (rev-letters orientation)
	       (let ((letters (apply 'vector (nreverse rev-letters))))
		 (loop for i across letters for pos from 0
		       for p = (find-if (lambda (x) (= (getf x :index) i))
					all-letters)
		       if (getf p :depword1)
		       do (nconc p (list :depword2 next-word-index
					 :pos2 pos))
		       else do (nconc p (list :depword1 next-word-index
					      :pos1 pos)))
		 (push (list :letters letters
			     :orientation orientation
			     :index (prog1 next-word-index
				      (incf next-word-index)))
		       all-words))))
	(let (current-word)
	  (loop for y below height do
		(loop for x below width
		      for c = (aref array y x) do
		      (cond ((black-square-p c)
			     (if (> (length current-word) 1)
				 (intern-word current-word :across))
			     (setq current-word nil))
			    (t (push (intern-letter x y) current-word))))
		(when current-word
		  (if (> (length current-word) 1)
		      (intern-word current-word :across))
		  (setq current-word nil)))
	  (loop for x below width do
		(loop for y below height
		      for c = (aref array y x) do
		      (cond ((black-square-p c)
			     (if (> (length current-word) 1)
				 (intern-word  current-word :down))
			     (setf current-word nil))
			    (t (push (intern-letter x y) current-word))))
		(when current-word
		  (if (> (length current-word) 1)
		      (intern-word current-word :down))
		  (setf current-word nil))))))
    (setq all-words (apply #'vector (nreverse all-words))
	  all-letters (apply #'vector (nreverse all-letters)))
    (let ((number 1))
      (loop with pos2 for letter-props across all-letters and assigned = nil do
	    (when (zerop (getf letter-props :pos1))
	      (nconc (aref all-words (getf letter-props :depword1))
		     (list :number number))
	      (setq assigned t))
	    (when (and (setq pos2 (getf letter-props :pos2)) (zerop pos2))
	      (nconc (aref all-words (getf letter-props :depword2))
		     (list :number number))
	      (unless assigned (setq assigned t)))
	    (when assigned (incf number))))
    (values all-words all-letters)))