;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  grid-domain.lisp
;;;  Written by:  Shaul Markovitch
;;;  Last time modified: 10/1/2000
;;;
;;;
;;;  This file contains the functions that implements the grid domain.
;;; 






(defparameter *default-we-size* 100 "the west-east size of the domain")
(defparameter *default-sn-size* 100 "the south-north size of te domain")
(defparameter *default-wall-density* 0.2
  "the portion of the links in the grid that remain connected")
(defparameter *default-we-sn-ratio* 0.5)
(defparameter *default-wall-length* 0.5
  "Dominant over the other 4 wall length parameters")
(defparameter *default-we-min-wall-length* 0.3
  "the minimal size of a wall in the grid (as a portionn of the size)")
(defparameter *default-we-max-wall-length* 0.3
  "the maximal size of a wall in the grid (as a portionn of the
size)")
(defparameter *default-sn-min-wall-length* 0.3
  "the maximal size of a wall in the grid (as a portionn of the
size)")
(defparameter *default-sn-max-wall-length* 0.3
  "the maximal size of a wall in the grid (as a portionn of the
size)")




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; *connected-technique*
;;;
;;; The default method used for generating grids.  It creates a full
;;; grid (where every junction that is not on the edge has four
;;; connections).  It then creates walls (a sequence of links that
;;; that are disconnected.  It has two parameters that control the
;;; creation.  One is the portion of the grid links that should
;;; stay connected.  The other is the maximum size of a wall (as
;;; portion of the entire size).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A grid is a two dimensional arary where each element is a
;;; junction.  A junction is a stucture which four fields.  Each field
;;; contains the bit "1" if transition is allowed in this direction
;;; and 0 otherwise.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct intersection
  (east 1 :type bit)
  (south 1 :type bit)
  (west 1 :type bit)
  (north 1 :type bit)
  )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A state is a list of two elements: the x and y coordinates
;;; (west-east and south-north) TThe following are two short access
;;; functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun x-coord (state)(first state))
(defun y-coord (state)(second state))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; grid-apply-op
;;;
;;; A function for applying one of the grid basic operators.  The
;;; operators are the atoms N,S,W,E (stands for North, South, West and east)
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun grid-apply-op (op state domain)
  (let* ((grid-array (grid-array domain))
	 (inter (aref grid-array (x-coord state)(y-coord state))))
  (case op
	(e (when (= (intersection-east inter) 1)
		 (list (1+ (x-coord state))(y-coord state))))
	(n (when (= (intersection-north inter) 1)
		 (list (x-coord state)(1+ (y-coord state)))))
	(w (when (= (intersection-west inter) 1)
		 (list (1- (x-coord state))(y-coord state))))
	(s (when (= (intersection-south inter) 1)
		 (list  (x-coord state) (1- (y-coord state))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  manhatan-distance
;;;
;;;  The basic heuristic function for grids.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	
(defun manhatan-distance (s1 s2 &optional (domain nil))
  (declare (ignore domain))
  (+ (abs (- (x-coord s1)(x-coord s2)))
     (abs (- (y-coord s1)(y-coord s2)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The definition of the domain-type grid.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass grid (domain)
      (
       ;; New defaults
       (operators :initform '(n e s w))
       (apply-op-fn :initform #'grid-apply-op)
       (heuristic-fn :initform 'manhatan-distance)
       (heuristic-functions :initform '(manhatan-distance))
       (gen-goal-fn :initform 'generate-random-state)
       (reverse-operators :initform '(s w n e))
       (apply-rev-op-fn  :initform 'grid-apply-op)
       (initialize-hash-fn :initform 'init-grid-hash)
       (get-hashed-state-fn :initform 'get-hashed-grid-state)
       (put-hashed-state-fn :initform 'put-hashed-grid-state)
       ;; New slots
       (we-size :initform *default-we-size*
		:accessor grid-we-size
		:initarg :we-size
		:type fixnum)
       (sn-size :initform *default-sn-size*
		:accessor grid-sn-size
		:initarg :sn-size
		:type fixnum)
       (array :initform nil
	      :initarg :array
	      :accessor grid-array)
       ))

(defclass connected-grid (grid)
  (
   ;; New Defaults
   ;; New slots
   (wall-density :initform  *default-wall-density*
		      :accessor grid-wall-density
		      :initarg :wall-density
		      :type single-float)
   (we-sn-ratio :initform *default-we-sn-ratio*
		 :accessor grid-we-sn-ratio
		 :initarg :we-sn-ratio
		 :type single-float)
   (we-min-wall-length :initform  (or *default-wall-length*
		       *default-we-min-wall-length*)
		      :accessor grid-we-min-wall-length
		      :initarg :we-min-wall-length
		      :type single-float)
   (we-max-wall-length :initform  (or  *default-wall-length*
				       *default-we-max-wall-length*)
		      :accessor grid-we-max-wall-length
		      :initarg :we-max-wall-length
		      :type single-float)
   (sn-min-wall-length :initform  (or *default-wall-length*
				      *default-sn-min-wall-length*)
		      :accessor grid-sn-min-wall-length
		      :initarg :sn-min-wall-length
		      :type single-float)
   (sn-max-wall-length :initform  (or *default-wall-length*
				      *default-sn-max-wall-length*)
		      :accessor grid-sn-max-wall-length
		      :initarg :sn-max-wall-length
		      :type single-float)))

(defclass parallel-grid (connected-grid)
  ((we-sn-ration :initform 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  generate-random-state
;;;
;;;  A simple function for generating a random state.  It is used by the
;;;  problem generator to create a goal state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod generate-random-state ((domain grid))
  (list (random (grid-we-size domain))
	(random (grid-sn-size domain))))

(defmethod generate-problem
  ((domain connected-grid)(method random-generation))
  (make-problem :init-state (generate-random-state domain)
		:goal-state (generate-random-state domain)))


(defparameter *default-source-we-portion* 0.2)
(defparameter *default-source-sn-portion* 0.2)
(defparameter *default-target-we-portion* 0.2)
(defparameter *default-target-sn-portion* 0.2)


(defclass restricted-generation (problem-generation)
  ((source-we-portion
    :initform *default-source-we-portion*
    :initarg :source-we-portion
    :accessor restricted-generation-source-we-portion
    )
   (source-sn-portion

    :initform *default-source-sn-portion*
    :initarg :source-sn-portion
    :accessor restricted-generation-source-sn-portion
    )
   (target-we-portion
    :initform *default-target-we-portion*
    :initarg :target-we-portion
    :accessor restricted-generation-target-we-portion
    )
   (target-sn-portion
    :initform *default-source-sn-portion*
    :initarg :source-sn-portion
    :accessor restricted-generation-target-sn-portion)))

(defmethod generate-problem
  ((domain connected-grid)(method restricted-generation))
  (make-problem :init-state
		(list (random (truncate
			       (*
				(restricted-generation-source-we-portion
				 method)
				(grid-we-size domain))))
		      (+
		       (truncate
		         (* (/ (- 1 (restricted-generation-source-sn-portion
				 method)) 2)
			    (grid-sn-size domain)))
		       (random
			(truncate
			       (*
				(restricted-generation-source-sn-portion
				 method)
				(grid-sn-size domain))))))
		:goal-state

		(list (- (- (grid-we-size domain) 1)
		       (random (truncate
			       (*
				(restricted-generation-target-we-portion
				 method)
				(grid-we-size domain)))))
		      (+
		       (truncate
		         (* (/ (- 1 (restricted-generation-target-sn-portion
				 method)) 2)
			    (grid-sn-size domain)))
		       (random
			(truncate
			       (*
				(restricted-generation-target-sn-portion
				 method)
				(grid-sn-size domain))))))



		))


  
(defun init-grid-hash (domain)
   (make-array (list (grid-we-size domain)
                     (grid-sn-size domain))
                     :initial-element nil))
                    
(defun get-hashed-grid-state (state hash)
  (aref hash (first state)(second state)))
  
(defun put-hashed-grid-state (state hash node)
  (setf (aref hash (first state)(second state)) node))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; generate-random-connected-grid
;;;
;;; The main function for the connected grid technqiue.  It creates a
;;; fully connected grid and then generates walls.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod generate-domain
  ((grid connected-grid) &key (generation-seed (make-random-state t)))
  (let ((saved-state (make-random-state generation-seed)))
  (setf *random-state* generation-seed)
  (let* ((grid-array
	  (create-grid-array
	   (grid-we-size grid)(grid-sn-size grid))))
    (setf (domain-generation-seed grid) saved-state)
    (setf (grid-array grid) grid-array)
    (create-walls-for-connected-grid grid)
    grid)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A function that creates an initialized array for the grid
;;; The only complication is on the edges where the right
;;; links need to be disconnected.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-grid-array
  (we-size sn-size)
  (let ((grid (make-array (list we-size sn-size)
			  :element-type 'intersection)))
    (loop for x below we-size do
	  (loop for y below sn-size do
		   (setf (aref grid x y) (make-intersection))))
    (loop for x below we-size  do
	  (setf (intersection-north (aref grid x (1- sn-size))) 0)
	  (setf (intersection-south (aref grid x 0)) 0))
    (loop for y below sn-size do
	  (setf (intersection-east (aref grid (1- we-size) y)) 0)
	  (setf (intersection-west (aref grid 0 y)) 0))
    grid))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; create-walls-for-connected-grid
;;;
;;; The function continues to generate walls until it diconnects
;;; enough link (according to the parameter 'wall-density")
;;; It tosses a coin to decide whether a wall will be west-east
;;; or south north.
;;; The walls are created so that the grid will stay fully connected.
;;; To avoid a closed areas we seperate between creation of
;;; a wall that is built from south to north and wall that is built
;;; from north to south.  We try to build the wall in the requested
;;; size.  However, whenever the currently built wall is run into another
;;; wall, we stop the creation just one step before.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-walls-for-connected-grid
  (grid)
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (wall-density (grid-wall-density grid))
	 (total-connections (- (* we-size sn-size 4)
			       (+ (* 2 we-size)(* 2 sn-size))))
	 (current-connections total-connections))
    (loop while (< (- 1 (/ current-connections total-connections))
		   wall-density)
	  finally (return (/ current-connections total-connections))
	  for disconnected =
	  (if (<= (random 1.0) (grid-we-sn-ratio grid))
	      (if (= (random 2) 0)
		  (create-ew-wall grid-array we-size sn-size
				  (random-in-range
				   (grid-we-min-wall-length grid)
				   (grid-we-max-wall-length grid)))
		(create-we-wall grid-array we-size sn-size
				  (random-in-range
				   (grid-we-min-wall-length grid)
				   (grid-we-max-wall-length grid)))
		)
	    (if (= (random 2) 0)
		(create-sn-wall grid-array we-size sn-size
				(random-in-range
				   (grid-sn-min-wall-length grid)
				   (grid-sn-max-wall-length grid)))
	      (create-ns-wall grid-array we-size sn-size
				(random-in-range
				   (grid-sn-min-wall-length grid)
				   (grid-sn-max-wall-length grid)))))
	      
	  do (setf current-connections (- current-connections disconnected)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A function that creates a walll from south to north.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create-sn-wall
  (grid-array we-size sn-size wall-length)
  (loop with x  = (random (1- we-size))
	with start-y  = (random (- sn-size 2))
        for y from start-y
	repeat (floor (* wall-length sn-size))
	until
	  (or (= y (- sn-size 1))
	      (zerop (intersection-north (aref grid-array x y)))
	      (zerop (intersection-north (aref grid-array (1+ x) y)))
	      (zerop (intersection-east (aref grid-array x (+ y 1)))))
	      
	do
	  (setf (intersection-east (aref grid-array x y)) 0)
	  (setf (intersection-west (aref grid-array (1+ x) y)) 0)
	sum 2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A function that creates a walll from north to south.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create-ns-wall
  (grid-array we-size sn-size wall-length) 
  (loop with x  = (random (1- we-size))
	with start-y  = (+ 2 (random (- sn-size 2)))
        for y from start-y by -1
	repeat (floor (* wall-length sn-size))
	until
	  (or (= y 0)
	      (zerop (intersection-south (aref grid-array x y)))
	      (zerop (intersection-south (aref grid-array (1+ x) y)))
	      (zerop (intersection-east (aref grid-array x (- y 1)))))
	      
	do
	  (setf (intersection-east (aref grid-array x y)) 0)
	  (setf (intersection-west (aref grid-array (1+ x) y)) 0)
	sum 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A function that creates a walll from east to west.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create-ew-wall
  (grid-array we-size sn-size wall-length) 
  (loop with y  = (random (1- sn-size))
	with start-x  = (random (- we-size 2))
        for x from start-x
	repeat (floor (* wall-length we-size))
	until
	  (or (= x (- we-size 1))
	      (zerop (intersection-east (aref grid-array x y)))
	      (zerop (intersection-east (aref grid-array x (+ 1 y))))
	      (zerop (intersection-north (aref grid-array (+ x 1) y))))
	      
	do
	  (setf (intersection-north (aref grid-array x y)) 0)
	  (setf (intersection-south (aref grid-array x (+ y 1))) 0)
	sum 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A function that creates a walll from  north to south
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-we-wall
  (grid-array we-size sn-size wall-length) 
  (loop with y  = (random (1- sn-size))
	with start-x  = (+ 2 (random (- we-size 2)))
        for x from start-x by -1
	repeat (floor (* wall-length we-size))
	until
	  (or (= x 0)
	      (zerop (intersection-west (aref grid-array x y)))
	      (zerop (intersection-west (aref grid-array x (+ 1 y))))
	      (zerop (intersection-north (aref grid-array (- x 1) y))))
	      
	do
	  (setf (intersection-north (aref grid-array x y)) 0)
	  (setf (intersection-south (aref grid-array x (+ y 1))) 0)
	sum 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod generate-new-db
  ((domain grid))
  (let ((new-db (make-instance 'macro-db)))
    (setf (macro-db-hash new-db)
      (make-array (list (grid-we-size domain)
                     (grid-sn-size domain))
                     :initial-element nil))
    new-db))

(defmethod add-macro
  ((db macro-db) new-macro (domain grid))
  (push new-macro (macro-db-macros db))
  (let ((state (macro-start-state new-macro)))
    (push new-macro (aref (macro-db-hash db) (first state)(second state)))))

(defmethod remove-macro
  ((db macro-db) macro (domain grid))
  (declare (ignore macro))
  )

(defmethod get-hashed-macros
  ((db macro-db) state (domain grid))
  (aref (macro-db-hash db) (first state)(second state)))




(defmethod save-domain
  ((d grid))
  (list (domain-generation-seed d)
	(grid-wall-density d)
	(grid-we-sn-ratio d)
	(grid-we-min-wall-length d)
	(grid-we-max-wall-length d)
	(grid-sn-min-wall-length d)
	(grid-sn-max-wall-length d)
	(grid-we-size d)
	(grid-sn-size d)))

(defmethod restore-domain
  ((d grid) list)
  (setf	(grid-wall-density d) (elt list 1)
	(grid-we-sn-ratio d)(elt list 2)
	(grid-we-min-wall-length d)(elt list 3)
	(grid-we-max-wall-length d)(elt list 4)
	(grid-sn-min-wall-length d)(elt list 5)
	(grid-sn-max-wall-length d)(elt list 6)
	(grid-we-size d)(elt list 7)
	(grid-sn-size d)(elt list 8))
  (generate-domain d :generation-seed (make-random-state (first list))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Ascii grid printing utils
;;;
;;;  These functions print an ascii representation of a grid.  They
;;; will be less useful when the GUI part will work.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *wall-symbol* " ")
(defparameter *ew-path-symbol* "-")
(defparameter *sn-path-symbol* "|")
(defparameter *intersection-symbol* "o")
(defparameter *start-state-symbol* "S")
(defparameter *goal-state-symbol* "G")
(defparameter *solution-state-symbol* "+")
(defparameter *macro-state-symbol* "M")


(defun create-printed-grid (grid)
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (a (make-array (list (* 2 we-size)(* 2 sn-size))
			:initial-element " ")))
    (loop for x below we-size do
	  (loop for y below sn-size do
		(setf (aref a (* 2 x)(* 2 y)) *intersection-symbol*)
		(when (< x (1- we-size))
		      (cond ((= (intersection-east (aref grid-array x y)) 1)
			     (setf (aref a (1+ (* 2 x))(* 2 y)) *ew-path-symbol*))
			    (t (setf (aref a (1+ (* 2 x))(* 2 y)) *wall-symbol*)
			       (when (> y 0)
				     (setf (aref a (1+ (* 2 x))(1- (* 2 y))) *wall-symbol*))
			       (when (< y (1- sn-size))
				     (setf (aref a (1+ (* 2 x))(1+ (* 2 y))) *wall-symbol*)))))
		(when (< y (1- sn-size))
		      (cond ((= (intersection-north (aref grid-array x y)) 1)
			     (setf (aref a (* 2 x)(+ 1 (* 2 y))) *sn-path-symbol*))
			    (t (setf (aref a (* 2 x)(+ 1 (* 2 y))) *wall-symbol*)
			       (when (> x 0)
				     (setf (aref a (1- (* 2 x))(1+ (* 2 y))) *wall-symbol*))
			       (when (< x (1- we-size))
				     (setf (aref a (1+ (* 2 x))(1+ (* 2 y))) *wall-symbol*))))))) a))

(defun mark-state
  (char-array state symbol)
  (setf (aref char-array (* 2 (x-coord state))(* 2 (y-coord state)))
	symbol))


(defun mark-solution (char-array solution)
  (let* ((current-node solution)
	 (s (search-node-state current-node)))
    (mark-state char-array s *goal-state-symbol*)
    (loop while (search-node-parent s)
	  do
	  (setf s (search-node-parent s))
	  (mark-state char-array s *solution-state-symbol*))
    (mark-state char-array s *start-state-symbol*)))

			    


(defun print-grid (grid &optional solution)
  (let* ((we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (a (create-printed-grid grid)))
    (when solution
	  (mark-solution a solution))
    (loop for y from (1- (* 2 sn-size)) downto 0 do
	  (loop for x below (1- (* 2 we-size)) do
		(princ (aref a x y)))
	  (terpri))))

(defun hardcopy-grid (grid &optional solution)
  (with-open-file (f "/tmp/grid-disp" :direction :output
		     :if-exists :supersede)
       (let ((*standard-output* f))
	 (print-grid grid solution)))
  (run-program "postprint" (list "-s" "6" "-l" "0" "/tmp/grid-disp") 
:output "/tmp/grid.ps")
  (run-program "lpr" (list  "/tmp/grid.ps"))
  (run-program "rm" (list "/tmp/grid.ps"))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is an alternative method for printing grids.  Again I hope
;;; that soon it will become unnecessary.  This method uses a utility
;;; called "postmd" which takes a matrix of real numbers and produces
;;; a postscript visualization of it.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter  *open-space-num* 1.0)
(defparameter *expanded-num* 2.0)
(defparameter *solution-num* 3.0)
(defparameter  *block-num*     4.0)
(defparameter *open-space-color* 254)
(defparameter *expanded-color* 200)
(defparameter *solution-color* 150)
(defparameter *block-color* 0)

(defun pretty-grid (grid &key solution closed-array)
  
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (char-array-width (1- (* 2 we-size)))
	 (char-array-height (1- (* 2 sn-size)))
	 (a (make-array (list char-array-width char-array-height) 
:initial-element *open-space-num*)))
 
    (loop for x below  we-size do
         (loop for y below sn-size
                for int = (aref grid-array x y)
                do
		(when (and (< x (1- we-size))(zerop (intersection-east int)))
                      (setf (aref a (1+ (* 2 x))(* 2 y)) *block-num*))
                (when (and (< y (1- sn-size))(zerop (intersection-north 
int)))
                      (setf (aref a  (* 2 x)(1+ (* 2 y)))
			    *block-num*))
		(when solution
		      (let
			  ((sol(find (list x y) solution :test
					    #'equal :key #'second)))
			(when sol
		      (setf (aref a (* 2 x)(* 2 y)) *solution-num*)
		      (case (first sol)
			    (n (setf (aref a (* 2 x)(1- (* 2 y)))
				     *solution-num*))
			    (s (setf (aref a (* 2 x)(1+ (* 2 y)))
				     *solution-num*))
			    (w (setf (aref a (1- (* 2 x)) (* 2 y))
				     *solution-num*))
			    (n (setf (aref a (1+ (* 2 x)) (* 2 y))
				     *solution-num*))
			    )
		      )))
		(when (and closed-array (aref closed-array x y))
		      (setf (aref a (* 2 x)(* 2 y)) *expanded-num*))))
    (loop for x from 1 by 2 below char-array-width do
	  (loop for y from 1 by 2 below char-array-height
		when (or (= (aref a (1- x) y) *block-num*)
			 (= (aref a x (1- y)) *block-num*)
			 (= (aref a (1+ x) y) *block-num*)
			 (= (aref a x (1+  y)) *block-num*))
		do (setf (aref a x y) *block-num*)))
    (with-open-file (f "/tmp/grid-disp" :direction :output
		     :if-exists :supersede)
       (let ((*standard-output* f))
	 (loop for y from (1- (1- (* 2 sn-size))) downto 0 do
	  (loop for x below (1- (* 2 we-size)) do
		(format t "~f  " (aref a x y)))
	  (terpri))))
   (run-program "postmd" (list "-i" (format nil "~a,~a,~a,~a"
					     (truncate *open-space-num*)
					     (truncate *expanded-num*)
					     (truncate *solution-num*) 
					     (truncate *block-num*))
					    "-g"
					    (format nil
						  "0,~a,0,~a,0,~a,0,~a,0"
						 *open-space-color*
						 *expanded-color*
						 *solution-color*
						 *block-color*
						 )  
"/tmp/grid-disp") :output "grid.ps")
  ;(run-program "lpr" (list  "grid.ps"))
  ;(run-program "rm" (list "/tmp/grid-disp"))
  ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Yet another method for printing grids.  Using pgm format
;;; pgm format. 4 lines on the file:
;;; P5 (or P6 for color)
;;; 200 200 (size of picture)
;;; 255 (levels of gray)
;;; abcdes6328393 (long sequence of bytes. If color - triples of rgb bytes)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter  *char-open-space-gray* 254)
(defparameter *char-expanded-gray* 100)
(defparameter *char-generated-gray* 200)
(defparameter *char-solution-gray* 50)
(defparameter *char-reopened-gray* 150)
(defparameter  *char-block-gray*   0)
(defparameter *chars-open-space-color*
  (format nil "~a ~a ~a" 255 255 255))
(defparameter *chars-expanded-color*
  (format nil "~a ~a ~a" 0 255 0))
(defparameter *chars-generated-color*
  (format nil "~a ~a ~a" 0 120 0))
(defparameter *chars-reopened-color*
  (format nil "~a ~a ~a" 200 0 200))
(defparameter *chars-solution-color*
  (format nil "~a ~a ~a" 255 0 0))
(defparameter *chars-block-color*
  (format nil "~a ~a ~a" 0 0 255))

(defun pgm-grid (grid &key solution closed-array open-array (color t)
		      (name "grid.pgm"))
  
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (char-array-width (1- (* 2 we-size)))
	 (char-array-height (1- (* 2 sn-size)))
	 (open (if color *chars-open-space-color*
		 *char-open-space-gray*))
	 (exp (if color *chars-expanded-color*
		 *char-expanded-gray*))
	 (gen (if color *chars-generated-color*
		 *char-generated-gray*))
	 (sol (if color *chars-solution-color*
		 *char-solution-gray*))
	 (block (if color *chars-block-color*
		 *char-block-gray*))
	 (reopened (if color *chars-reopened-color*
		 *char-reopened-gray*))
	 
	 (a (make-array (list char-array-width char-array-height) 
:initial-element open)))
 
    (loop for x below  we-size do
         (loop for y below sn-size
                for int = (aref grid-array x y)
                do
		(when (and (< x (1- we-size))(zerop (intersection-east int)))
                      (setf (aref a (1+ (* 2 x))(* 2 y)) block))
                (when (and (< y (1- sn-size))(zerop (intersection-north 
int)))
                      (setf (aref a  (* 2 x)(1+ (* 2 y)))
			    block))
		(when (and closed-array (aref closed-array x y))
		      (setf (aref a (* 2 x)(* 2 y)) exp))
		(when (and open-array (aref open-array x y))
		      (setf (aref a (* 2 x)(* 2 y)) gen))
		(when solution
		      (let
			  ((s (find (list x y) solution :test
					    #'equal :key #'second)))
			(when s
		      (setf (aref a (* 2 x)(* 2 y)) sol)
		      (case (first s)
			    (n (setf (aref a (* 2 x)(1- (* 2 y)))
				     sol))
			    (s (setf (aref a (* 2 x)(1+ (* 2 y)))
				     sol))
			    (w (setf (aref a (1+ (* 2 x)) (* 2 y))
				     sol))
			    (e (setf (aref a (1- (* 2 x)) (* 2 y))
				     sol))
			    )
		      )))
		(let ((v (or (and open-array (aref open-array x y))
			     (and closed-array (aref closed-array x y)))))
		  (when (and v (> (search-node-reopened v) 0))
			(setf (aref a (* 2 x)(* 2 y)) reopened)))))
    (loop for x from 1 by 2 below char-array-width do
	  (loop for y from 1 by 2 below char-array-height
		when (or (equalp (aref a (1- x) y) block)
			 (equalp (aref a x (1- y)) block)
			 (equalp (aref a (1+ x) y) block)
			 (equalp (aref a x (1+  y)) block))
		do (setf (aref a x y) block)))
    (with-open-file (f name :direction :output
		     :if-exists :supersede)
      (format f "~a~%~a ~a~%255~%"
	      (if color "P3" "P2") (+ 4 char-array-width)
	      (+ 4 char-array-height))
      (loop with c = 1
	    for y from (1- char-array-height) downto 0 do
	    (when (= y (1- char-array-height))
		  (loop repeat (* 2 (+ 4 char-array-width))
			for k from 1
			do
			(format f "~a " block)
			(when (= (mod k 4) 0)(format f "~%"))))
	    (format f "~% ~a ~a ~%" block block)
	  (loop for x below char-array-width do
		(incf c)
		(format f "~a " (aref a x y))
		(when (= (mod c 4) 0)(format f "~%")))
	 (format f "~% ~a ~a ~%" block block)
	 (when (= y 0)
		  (loop repeat (* 2 (+ 4 char-array-width))
			for k from 1
			do
			(format f "~a " block)
			(when (= (mod k 4) 0)(format f "~%"))))
	  
	  )
      (format f "~%"))
    )
  name)

(defparameter *default-grid-mm-size* 100)
(defparameter *ps-offset* 5)
(defun ps-grid (grid &key
		     (total-size *default-grid-mm-size*)
		     (offset *ps-offset*)
		      (name (format nil "~a.eps" (gensym "grid"))))
  
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (section-size (float (/ total-size we-size )))
	 (total-size-in-ps-points
	    (round (* 72 (/ (+ offset offset total-size) 25.4)))))
 (with-open-file
    (f name :direction :output :if-exists :supersede)
    (format f "%!PS-Adobe-1.0~%")
    (format f "%%BoundingBox: 0 0 ~d ~d~%" total-size-in-ps-points
	    total-size-in-ps-points)
    (format f "72 25.4 div dup scale~%")
    (format f "0.1 setlinewidth~%")
    (format f "/rl/rlineto load def~%/np/newpath load def~%/st/stroke~%/mt/moveto load def ~%")

    (loop for x below  we-size
	  with y-from = 0
	  with y-to = 0
	  do
	  (setq y-from 0)
	  (setq y-to 0)
	  (loop until (>= y-from (1- sn-size)) do
		(setq y-to y-from)
		(loop until (or (= y-to (1- sn-size))
			     (= (intersection-north
				(aref grid-array x y-to))
			       0))
		      do (incf y-to))
		(when (/= y-from y-to)
		      (format f "np ~5,2F ~5,2F mt 0 ~5,2F  rl st~%"
			     (+ offset (* x section-size))
			     (+ offset (* y-from section-size))
			     (* section-size (- y-to y-from))))
		(setf y-from y-to)
		(loop while (and (< y-from  sn-size)
			     (= (intersection-north
				(aref grid-array x y-from))
			       0))
		      do (incf y-from))))
    (loop for y below  sn-size
	  with x-from = 0
	  with x-to = 0
	  do
	  (setq x-from 0)
	  (setq x-to 0)
	  (loop until (>= x-from (1- we-size)) do
		(setq x-to x-from)
		(loop until (or (= x-to (1- we-size))
			     (= (intersection-east
				(aref grid-array x-to y))
			       0))
		      do (incf x-to))
		(when (/= x-from x-to)
		      (format f "np ~5,2F ~5,2F mt  ~5,2F 0 rl st~%"
			     (+ offset (* x-from section-size))
			     (+ offset (* y  section-size))
			     (* section-size (- x-to x-from))))
		(setf x-from x-to)
		(loop while (and (< x-from  we-size)
			     (= (intersection-east
				(aref grid-array x-from y))
			       0))
		      do (incf x-from))))))
  name)

(defun ps-reverse-grid (grid &key
		     (total-size *default-grid-mm-size*)
		     (offset *ps-offset*)
		      (name nil))
  (when (null name) (setq name
			  (format nil "grid-~a-~a.eps"
				  (grid-wall-density grid)
				  (grid-sn-max-wall-length grid))))
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (char-array-width (1- (* 2 we-size)))
	 (char-array-height (1- (* 2 sn-size)))
	 (section-size (float (/ total-size char-array-width )))
	 (total-size-in-ps-points
	    (round (* 72 (/ (+ offset offset total-size) 25.4))))
	 (a (make-array (list char-array-width char-array-height) 
:initial-element nil))

	 )
 
    (loop for x below  we-size do
         (loop for y below sn-size
                for int = (aref grid-array x y)
                do
		(when (and (< x (1- we-size))(zerop (intersection-east int)))
                      (setf (aref a (1+ (* 2 x))(* 2 y)) t))
                (when (and (< y (1- sn-size))(zerop (intersection-north 
int)))
                      (setf (aref a  (* 2 x)(1+ (* 2 y)))
			    t))
	))
    (loop for x from 1 by 2 below char-array-width do
	  (loop for y from 1 by 2 below char-array-height
		when (or  (aref a (1- x) y)
			  (aref a x (1- y))
			  (aref a (1+ x) y)
			  (aref a x (1+  y)))
		do (setf (aref a x y) t)))
    (with-open-file (f name :direction :output
		     :if-exists :supersede)
    (format f "%!PS-Adobe-1.0~%")		    
    (format f "%%BoundingBox: 0 0 ~d ~d~%" total-size-in-ps-points
	    total-size-in-ps-points)
    (format f "72 25.4 div dup scale~%")
    (format f "0.1 setlinewidth~%")
    (format f "/rf{gsave newpath ~% ")
    (format f "/ZZZtry exch def /ZZZtrx exch def /ZZZbly exch def /ZZZblx exch def~%")
    (format f "ZZZblx ZZZbly moveto ZZZblx ZZZtry lineto ZZZtrx ZZZtry lineto ZZZtrx ZZZbly lineto~%")
    (format f "closepath fill~% grestore} def~%")
    (format f "newpath ~5,1F ~5,1F moveto 0 ~5,1F rlineto ~5,1F 0 rlineto 0 ~5,1F rlineto ~5,1F 0 rlineto stroke"
	     offset offset total-size total-size (- total-size)(- total-size))
    (loop for x from 1 by 2 below char-array-width
	  with y-from = 0
	  with y-to = 0
	  do
	  (setq y-from 0)
	  (setq y-to 0)
	  (loop until (>= y-from (1- char-array-height)) do
		(setq y-to y-from)
		(loop until (or (> y-to (1- char-array-height))
			     (null (aref a x y-to)))
		      do (incf y-to))
		(when (> (-  y-to y-from) 1)
		      (format f " ~5,2F ~5,2F ~5,2F ~5,2F  rf~%"
			     (+ offset (* x section-size))
			     (+ offset (* y-from section-size))
			     (+ offset (* (1+ x) section-size))
			     (+ offset (* section-size  y-to))))
		(setf y-from y-to)
		(loop while (and (< y-from  (1- char-array-height))
			     (null (aref a x y-from)))
			
		      do (incf y-from))))
    (loop for y from 1 by 2 below char-array-height
	  with x-from = 0
	  with x-to = 0
	  do
	  (setq x-from 0)
	  (setq x-to 0)
	  (loop until (>= x-from (1- char-array-width)) do
		(setq x-to x-from)
		(loop until (or (> x-to (1- char-array-width))
			     (null (aref a x-to y)))
		      do (incf x-to))
		(when (> (- x-to x-from) 1)
		      (format f " ~5,2F ~5,2F ~5,2E ~5,2F  rf~%"
			     (+ offset (* x-from section-size))
			     (+ offset (* y section-size))
			     (+ offset (*  x-to section-size))
			     (+ offset (* (1+ y) section-size ))))
		(setf x-from x-to)
		(loop while (and (< x-from  (1- char-array-width))
			     (null (aref a x-from y)))
			
		      do (incf x-from))))


    ))
  name)


(defun draw-grids (density-length-pairs)
  (loop for p in density-length-pairs
	do
	(let* ((*default-wall-density* (first p))
	      (*default-wall-length* (second p))
	      (domain (make-instance 'connected-grid)))
	  (generate-domain domain)
	  (ps-reverse-grid domain))))

(defun old-ps-grid (grid &key
		     (total-size *default-grid-mm-size*)
		     (offset *ps-offset*)
		      (name (format nil "~a.eps" (gensym "grid"))))
  
  (let* ((grid-array (grid-array grid))
	 (we-size (grid-we-size grid))
	 (sn-size (grid-sn-size grid))
	 (section-size (float (/ total-size we-size )))
	 (total-size-in-ps-points
	    (round (* 72 (/ (+ offset offset total-size) 25.4)))))
 (with-open-file
    (f name :direction :output :if-exists :supersede)
    (format f "%!PS-Adobe-1.0~%")
    (format f "%%BoundingBox: 0 0 ~d ~d~%" total-size-in-ps-points
	    total-size-in-ps-points)
    (format f "72 25.4 div dup scale~%")
    (format f "0.1 setlinewidth~%")

    (loop for x below  we-size do
         (loop for y below sn-size
	       for int = (aref grid-array x y)
	       do
	       (when (= (intersection-east int) 1)
		     (format f "newpath ~5,2F ~5,2F moveto  ~5,2F 0 rlineto stroke~%"
			     (+ offset (* x section-size))
			     (+ offset (* y section-size))
			     section-size))
	       (when (= (intersection-north int) 1)
		     (format f "newpath ~5,2F ~5,2F moveto 0 ~5,2F rlineto stroke~%"
			     (+ offset (* x section-size))
			     (+ offset (* y section-size))
			     section-size)
		     )
	       ))))
  name)