;;;----------------------------------------------------------------------------
;;;
;;; $Source: /home/madhu/RCS/dongeddis-grid.lisp,v $
;;; $Id: dongeddis-grid.lisp,v 1.1 2007/06/30 13:03:20 madhu Exp madhu $
;;;
;;; (c) Copyright 1992-2007 Don Geddis.  No rights reserved.
;;; Released into the public domain 2007-06-28 by Don Geddis.
;;;
;;;----------------------------------------------------------------------------
;;;
;;; GRID
;;;
;;; Make a blank grid suitable for crossword or cross-sum puzzles, with
;;; typical symmetry and connectiveness.
;;;
;;; Implemented in ANSI Common Lisp.
;;;
;;; Code available from
;;;	http://don.geddis.org/lisp/grid.lisp
;;;
;;;----------------------------------------------------------------------------
;;;
;;; Sample uses:
;;;	(print-frame (make-xword-frame 15))
;;;	(print-frame (make-xsum-frame 13))
;;;
;;; Sample output:
;;;
;;;	lisp> (load "grid")
;;;	T
;;;	lisp> (print-frame (make-xword-frame 15))
;;;	XWord is 15 by 15.
;;;	. . . . . . . # . . . # . . .
;;;	. . . . . . . # . . . . . . .
;;;	. . . . . . . # . . . . . . .
;;;	. . . . . . . # . . . . . . .
;;;	# . . . # # . . . . # . . . #
;;;	. . . . # . . . . # . . . . .
;;;	. . . . # . . . # . . . . . .
;;;	. . . . . . . # . . . . . . .
;;;	. . . . . . # . . . # . . . .
;;;	. . . . . # . . . . # . . . .
;;;	# . . . # . . . . # # . . . #
;;;	. . . . . . . # . . . . . . .
;;;	. . . . . . . # . . . . . . .
;;;	. . . . . . . # . . . . . . .
;;;	. . . # . . . # . . . . . . .
;;;	lisp> (print-frame (make-xsum-frame 13))
;;;	XWord is 13 by 13.
;;;	. . # . . # # # . . # . .
;;;	. . . . . . # . . . . . .
;;;	# . . # # . . . # . . . #
;;;	. . . . # # . . . # . . .
;;;	. . # . . . # # . . # . .
;;;	# . . # . . . . # . . . #
;;;	# # . . # . . . # . . # #
;;;	# . . . # . . . . # . . #
;;;	. . # . . # # . . . # . .
;;;	. . . # . . . # # . . . .
;;;	# . . . # . . . # # . . #
;;;	. . . . . . # . . . . . .
;;;	. . # . . # # # . . # . .
;;;
;;;----------------------------------------------------------------------------

(defpackage "DONGEDDIS-GRID"
  (:use "CL"))
(in-package "DONGEDDIS-GRID")

(defvar *original-frame*)

(defparameter *diagonal-percent* 100)
(defparameter *three-letter-percent* 25)
(defparameter *edge-row-percent* 10)
(defparameter *percent-decay* 10)
(defparameter *corner-percent* 5)

(defparameter *show-progress* nil)
(defparameter *show-flood-fill* nil)

(defparameter *two-letter-ok* nil)

;;;----------------------------------------------------------------------------

(defun print-frame (frame)
  (let ((r-size (array-dimension frame 0))
	(c-size (array-dimension frame 1)) )
    (format t "~&XWord is ~D by ~D.~%" c-size r-size)
    (dotimes (row r-size)
      (dotimes (col c-size)
	(let ((ele (aref frame row col)))
	  (cond
	    ((null ele) (format t "# "))
	    ((eq ele t) (format t ". "))
	    (t (format t "~A " ele))
	    )))
      (format t "~%") ))
  (values) )

;;;----------------------------------------------------------------------------

(defun make-xsum-frame (size)
  "Like crosswords, but crosssums want fewer long blocks; rules also relaxed."
  (let ((*two-letter-ok* t))
    (make-xword-frame
     size :percent 50 :iterations 10 :edge-row-percent 40 :corner-percent 25
     :percent-decay 75 )
    ))

;;;----------------------------------------------------------------------------

(defun make-xword-frame
       (size-or-array
	&key
	(iterations 1)
	(percent 75)
	(only-doubly-connected nil)
	(three-letter-percent 25 tlp)
	(diagonal-percent 100 dp)
	(edge-row-percent 10 erp)
	(percent-decay 10 pd)
	(corner-percent 5 cp)
	(show-progress nil sp)
	(show-flood-fill nil sff)
	&allow-other-keys )


  (when tlp (setq *three-letter-percent* three-letter-percent))
  (when dp (setq *diagonal-percent* diagonal-percent))
  (when erp (setq *edge-row-percent* edge-row-percent))
  (when pd (setq *percent-decay* (/ (- 100 percent-decay) 100)))
  (when cp (setq *corner-percent* corner-percent))
  (when sff
    (setq *show-progress* show-flood-fill)
    (setq *show-flood-fill* show-flood-fill) )
  (when sp (setq *show-progress* show-progress))


  (if (arrayp size-or-array)
      (setq *original-frame* size-or-array)
      (progn
	(unless (oddp size-or-array)
	  (format t "~&Size must be odd.~%")
	  (return-from make-xword-frame) )
	(setq *original-frame*
	      (make-array `(,size-or-array ,size-or-array)
			  :initial-element t ))))


  (do* ((size (array-dimension *original-frame* 0))
	(frame (make-array `(,size ,size)))
	(done nil) )
       (done
	 (binarize frame) )
    (invent-frame frame iterations percent)
    (if (flood-fill frame)
	(if (and only-doubly-connected
		 (not (doubly-connected frame)) )
	    (format t "~&Generated singly-connected frame, trying again...~%")
	    (setq done t) )
	(format t "~&Generated unconnected frame, trying again...~%") ))
  )

;;;----------------------------------------------------------------------------

(defun invent-frame (frame iterations percent)
  (when *show-progress* (setup-inprogress frame))
  (empty-frame frame)
  (dotimes (ignore iterations)
    (add-blocks-to-frame frame :percent percent) )
  (when *show-progress* (end-inprogress)) )

;;;----------------------------------------------------------------------------

(defun add-blocks-to-frame (frame &key (percent 75))
  (let (size half)
    (setq size (array-dimension frame 0))
    (setq half (/ (1- size) 2))
    (maybe-fill frame half half percent)	; Middle square
    (dotimes (diag half)
      (maybe-fill frame diag half percent)	; Middle column
      (do ((col diag (1+ col))			; Horizontal
	   (rev-col (- (array-dimension frame 1) diag 1) (1- rev-col)) )
	  ((= col half))
	(maybe-fill frame diag col percent)
	(maybe-fill frame diag rev-col percent) )
      (do ((rev-col (- (array-dimension frame 1) diag 1))
	   (row (1+ diag) (1+ row)) )		; Vertical
	  ((> row half))
	(maybe-fill frame row diag percent)
	(maybe-fill frame row rev-col percent) ))
    frame ))

;;;----------------------------------------------------------------------------

(defun maybe-fill (frame row col percent &optional (direction nil))
  (when (and (empty-square frame row col)
	     (< (random 100) percent) )


    (unless direction
      (let (all-possible poss-diags)
	(setq all-possible (find-empty-directions frame row col))
	(setq poss-diags (remove-if-not #'(lambda (x)
					    (and (not (zerop (first x)))
						 (not (zerop (second x))) ))
					all-possible ))
	(if (and poss-diags (< (random 100) *diagonal-percent*))
	    (setq direction (nth (random (length poss-diags)) poss-diags))
	    (setq direction (nth (random (length all-possible)) all-possible))
)))


    (let ((num (get-reflections frame row col))
	  (refl-col (- (array-dimension frame 1) col 1)) )
      (when num
	(add-square frame row col num)
	(if (case num
	      (2 (illegal-square frame row col))
	      (4 (or (illegal-square frame row col)
		     (illegal-square frame row refl-col) )))
	    (add-square frame row col num t)
	    (maybe-fill frame (+ row (first direction))
			(+ col (second direction))
			(* percent *percent-decay*) direction )))
      )))

;;;----------------------------------------------------------------------------

(defun add-square (frame r c refl &optional (token refl))
  "Add a black square at (r,c).  Refl: 2=across center, 4=grid"
  (let* ((size (array-dimensions frame))
	 (rows (first size))
	 (cols (second size))
	 (r2 (- rows r 1))
	 (c2 (- cols c 1)) )
    (add-one-square frame r c token)
    (add-one-square frame r2 c2 token)
    (when (= refl 4)
      (add-one-square frame r2 c token)
      (add-one-square frame r c2 token) )
    ))

;;;----------------------------------------------------------------------------

(defun add-one-square (frame row col token)
  (setf (aref frame row col) token)
  (when *show-progress* (show-inprogress row col token)) )

;;;----------------------------------------------------------------------------

(defun illegal-square (frame row col)
  (or (barrier-nearby frame row col)
      (in-diagonal frame row col)
      (in-corner frame row col)
      (bad-edge frame row col)
      (is-corner frame row col)
      ))

;;;----------------------------------------------------------------------------

(defun barrier-nearby (frame r c)
  "The directions L, R, U, D, can't have 1, 2 or (sometimes) 3 letter words"
  (cond
   (*two-letter-ok*
    (some #'(lambda (coords) (funcall #'bad-dir frame coords))
	  (list (list nil (- r 1) c (- r 2) c) ; Left
		(list nil (+ r 1) c (+ r 2) c) ; Right
		(list nil r (- c 1) r (- c 2)) ; Up
		(list nil r (+ c 1) r (+ c 2)) ; Down
		)))
   ((< (random 100) *three-letter-percent*)
    (some #'(lambda (coords) (funcall #'bad-dir frame coords))
	  (list (list nil (- r 1) c (- r 2) c (- r 3) c) ; Left
		(list nil (+ r 1) c (+ r 2) c (+ r 3) c) ; Right
		(list nil r (- c 1) r (- c 2) r (- c 3)) ; Up
		(list nil r (+ c 1) r (+ c 2) r (+ c 3)) ; Down
		)))
   (t
    (some #'(lambda (coords) (funcall #'bad-dir frame coords))
	  (list (list nil (- r 1) c (- r 2) c (- r 3) c (- r 4) c) ; Left
		(list nil (+ r 1) c (+ r 2) c (+ r 3) c (+ r 4) c) ; Right
		(list nil r (- c 1) r (- c 2) r (- c 3) r (- c 4)) ; Up
		(list nil r (+ c 1) r (+ c 2) r (+ c 3) r (+ c 4)) ; Down
		)))
   ))

;;;----------------------------------------------------------------------------

(defun bad-dir (frame coord)
  (when (null coord) (return-from bad-dir nil))
  (let (first-square r c barrier)
    (setq first-square (not (first coord)))
    (when first-square (setq coord (cdr coord)))
    (setq r (first coord))
    (setq c (second coord))
    (setq barrier (or (< r 0)
		      (< c 0)
		      (>= r (first (array-dimensions frame)))
		      (>= c (second (array-dimensions frame)))
		      (full-square frame r c) ))
    (cond
      ((null barrier)
       (bad-dir frame (cddr coord)) )
      (first-square
       nil )
      (t
       t ))))

;;;----------------------------------------------------------------------------

(defun in-corner (frame r c)
  (let ((triples `(((,(- r 1) ,c) (,(- r 1) ,(+ c 1)) (,r ,(+ c 1)))
		   ((,r ,(+ c 1)) (,(+ r 1) ,(+ c 1)) (,(+ r 1) ,c))
		   ((,(+ r 1) ,c) (,(+ r 1) ,(- c 1)) (,r ,(- c 1)))
		   ((,r ,(- c 1)) (,(- r 1) ,(- c 1)) (,(- r 1) ,c)) )))
    (some #'(lambda (triple)
	      (every #'(lambda (coord)
			 (let ((r2 (first coord))
			       (c2 (second coord)) )
			   (full-square frame r2 c2) ))
		     triple ))
	  triples )))

;;;----------------------------------------------------------------------------

(defun in-diagonal (frame r c)
  (let ((doubles `(((,(- r 1) ,c) (,r ,(+ c 1)))
		   ((,r ,(+ c 1)) (,(+ r 1) ,c))
		   ((,(+ r 1) ,c) (,r ,(- c 1)))
		   ((,r ,(- c 1)) (,(- r 1) ,c)) )))
    (some #'(lambda (double)
	      (every #'(lambda (coord)
			 (let ((r2 (first coord))
			       (c2 (second coord)) )
			   (full-square frame r2 c2) ))
		     double ))
	  doubles )))

;;;----------------------------------------------------------------------------

(defun bad-edge (frame r c)
  (when (< (random 100) *edge-row-percent*) (return-from bad-edge nil))
  (let ((max-r (1- (array-dimension frame 0)))
	(max-c (1- (array-dimension frame 1))) )
    (when (and (or (= r 0)
		   (= r max-r) )
	       (or (full-square frame r (1- c))
		   (full-square frame r (1+ c)) ))
      (return-from bad-edge t) )
    (when (and (or (= c 0)
		   (= c max-c) )
	       (or (full-square frame (1- r) c)
		   (full-square frame (1+ r) c) ))
      (return-from bad-edge t) )))

;;;----------------------------------------------------------------------------

(defun in-bounds (frame r c)
  (and (>= r 0)
       (< r (array-dimension frame 0))
       (>= c 0)
       (< c (array-dimension frame 1)) ))

;;;----------------------------------------------------------------------------

(defun empty-frame (frame)
  (dotimes (r (array-dimension frame 0))
    (dotimes (c (array-dimension frame 1))
      (when *show-progress* (show-inprogress r c (aref *original-frame* r c)))
      (setf (aref frame r c) (aref *original-frame* r c)) )))

;;;----------------------------------------------------------------------------

(defun binarize (frame)
  (dotimes (row (array-dimension frame 0))
    (dotimes (col (array-dimension frame 1))
      (if (full-square frame row col)
	  (setf (aref frame row col) nil)
	  (setf (aref frame row col) t) )))
  frame )

;;;----------------------------------------------------------------------------

(defun empty-square (frame row col)
  (when (in-bounds frame row col)
    (not (full-square frame row col)) ))

;;;----------------------------------------------------------------------------

(defun full-square (frame row col)
  (when (in-bounds frame row col)
    (or (numberp (aref frame row col))
	(null (aref frame row col)) )))

;;;----------------------------------------------------------------------------

(defun get-reflections (frame row col)
  (let ((legals '(2 2 2 4)))
    (dotimes (delta-r 3)
      (dotimes (delta-c 3)
	(let ((r (+ (1- row) delta-r))
	      (c (+ (1- col) delta-c))
	      (c2 (+ (- (array-dimension frame 1) col 2) delta-c)) )
	  (when (and (in-bounds frame r c)
		     (numberp (aref frame r c)) )
	    (if (= (aref frame r c) 2)
		(setq legals (remove 4 legals :test #'=))
		(setq legals (remove 2 legals :test #'=)) ))
	  (when (and (in-bounds frame r c2)
		     (numberp (aref frame r c2))
		     (= (aref frame r c2) 2) )
	    (setq legals (remove 4 legals :test #'=)) )
	  )))
    (when legals (nth (random (length legals)) legals))
    ))

;;;----------------------------------------------------------------------------

(defun flood-fill (frame &key (unflood t))
  "Picks an empty square, tries to color all other empty squares"
  (let ((start-square (find-empty-square frame))
	fail )
    (do* ((fringe (list start-square) (append nearby (cdr fringe)))
	  (square (car fringe) (car fringe))
	  (nearby (find-nearby-empties frame square)
		  (find-nearby-empties frame square) ))
	((null fringe))
      (dolist (sq nearby)
	(when *show-flood-fill* (show-inprogress (first sq) (second sq) '-))
	(setf (aref frame (first sq) (second sq)) 'f) ))
    (setq fail (find-empty-square frame))
    (when unflood (unflood frame))
    (not fail) ))

;;;----------------------------------------------------------------------------

(defun find-empty-square (frame)
  (dotimes (r (array-dimension frame 0))
    (dotimes (c (array-dimension frame 1))
      (when (eq (aref frame r c) t)
	(return-from find-empty-square `(,r ,c)) ))))

;;;----------------------------------------------------------------------------

(defun find-nearby-empties (frame square)
  "Return coordinates of empty squares in dir L, R, U or D"
  (unless square (return-from find-nearby-empties))
  (let* ((row (first square))
	 (col (second square))
	 (one-grid `((,(1- row) ,col) (,row ,(1- col))
		     (,(1+ row) ,col) (,row ,(1+ col))
		     (,row ,col) ))
	 (nearbys nil) )
    (dolist (coord one-grid)
      (let ((r (first coord))
	    (c (second coord)) )
	(when (and (in-bounds frame r c)
		   (eq (aref frame r c) t) )
	  (push `(,r ,c) nearbys) )))
    nearbys ))

;;;----------------------------------------------------------------------------

(defun unflood (frame)
  (dotimes (r (array-dimension frame 0))
    (dotimes (c (array-dimension frame 1))
      (when (eq (aref frame r c) 'f)
	(when *show-flood-fill* (show-inprogress r c t))
	(setf (aref frame r c) t) ))))

;;;----------------------------------------------------------------------------

(defun doubly-connected (frame)
  "False iff adding a block somewhere makes flood-fill fail"
  (dotimes (r (/ (1- (array-dimension frame 0)) 2))
    (dotimes (c (array-dimension frame 1))
      (when (and (eq (aref frame r c) t)
		 (> (number-of-filled-neighbors frame r c) 1) )
	(setf (aref frame r c) nil)
	(unless (flood-fill frame)
	  (return-from doubly-connected nil) )
	(setf (aref frame r c) t) )))
  t )

;;;----------------------------------------------------------------------------

(defun number-of-filled-neighbors (frame r c)
  (let ((count 0))
    (dotimes (del-r 3)
      (dotimes (del-c 3)
	(let ((new-r (+ (1- r) del-r))
	      (new-c (+ (1- c) del-c)) )
	  (unless (in-bounds frame new-r new-c)
	    (return-from number-of-filled-neighbors 0) )
	  (unless (eq (aref frame new-r new-c) t)
	    (setq count (1+ count)) ))))
    count ))

;;;----------------------------------------------------------------------------

(defun is-corner (frame r c)
  (when (< (random 100) *corner-percent*) (return-from is-corner nil))
  (let ((max-r (1- (array-dimension frame 0)))
	(max-c (1- (array-dimension frame 1))) )
    (or (and (= r 0) (= c 0))
	(and (= r max-r) (= c 0))
	(and (= r 0) (= c max-c))
	(and (= r max-r) (= c max-c)) )))

;;;----------------------------------------------------------------------------

(defun find-empty-directions (frame row col)
  (let ((dirs nil)
	r c )
    (dotimes (del-r 3)
      (dotimes (del-c 3)
	(setq r (+ row (1- del-r)))
	(setq c (+ col (1- del-c)))
	(when (and (empty-square frame r c)
		   (not (and (= r row) (= c col))) )
	  (push `(,(1- del-r) ,(1- del-c)) dirs) )))
    dirs ))

;;;----------------------------------------------------------------------------
;;;
;;; Graphical display of intermediate progress
;;;
;;;----------------------------------------------------------------------------

#+lispm
(defun setup-inprogress (frame)
  (ignore frame)
  (send *terminal-io* :clear-history)
  (format t "Crossword frame size is ~D by ~D~%"
	  (array-dimension *original-frame* 0)
	  (array-dimension *original-frame* 1) ))

#+mcl
(defun setup-inprogress (frame)
  (setq *size* (array-dimension frame 0))
  (setq *frame* frame)
  (make-xword-window) )

#-(or lispm mcl)
(defun setup-inprogress (frame)
  (declare (ignore frame)) )

;;;----------------------------------------------------------------------------

#+lispm
(defun show-inprogress (r c token)
  (send *terminal-io* :set-cursorpos (* c 2) (1+ r) :character)
  (send *terminal-io* :clear-char)
  (cond
    ((eq token t) (format t "."))
    ((or (numberp token) (null token)) (format t "#"))
    ((symbolp token) (format t "~A" token))
    (t (format t "X")) ))

#+mcl
(defun show-inprogress (y x token)
  (draw-filled-rectangle
    *active-xword-window*

    (make-position :x (1+ (* *w-factor* x))
		   :y (1+ (* *h-factor* (real-y y))))
    (1- *w-factor*) (1- *h-factor*)
    :operation (if (eql token t) boole-clr boole-1) ))

#-(or lispm mcl)
(defun show-inprogress (r c token)
  (declare (ignore r c token)) )

;;;----------------------------------------------------------------------------

#+lispm
(defun end-inprogress ()
  (send *terminal-io* :set-cursorpos
	0 (1+ (array-dimension *original-frame* 0)) :character ))

#+mcl
(defun end-inprogress ())

#-(or lispm mcl)
(defun end-inprogress ())

;;;----------------------------------------------------------------------------