(in-package :org.wanglianghome.pushbox)

(defvar *map* nil "map of pushing box game")
(defvar *directions* nil "direction to move box or person")
(defvar *dead-positions* nil "game over when one of boxes is on one of those positions")
(defvar *ops* nil "Operations to move person or push box")

(defparameter *map-1* '((0 > 1) (0 v 2) (1 v 3) (2 > 3)
			(4 > 5) (5 > 6) (6 > 7) (2 v 4) (3 v 5)
			(8 > 9) (9 > 10) (10 > 11) (4 v 8) (5 v 9) (6 v 10) (7 v 11)
			(12 > 13) (8 v 12) (9 v 13)
			(p 5) (b 4) (b 10) (o 1) (o 4)))

(defparameter *map-2* '((p 5) (b 8) (b 9) (b 13) (o 9) (o 12) (o 13)
			(0 > 1) (1 > 2) (2 > 3) (0 v 4) (2 v 5) (3 v 6)
			(4 v 7) (5 > 6) (5 v 9) (6 v 10)
			(7 > 8) (8 > 9) (9 > 10) (7 v 11) (8 v 12) (9 v 13) (10 v 14)
			(11 > 12) (12 > 13) (13 > 14) (11 v 15) (12 v 16) (13 v 17) (14 v 18)
			(15 > 16) (16 > 17) (17 > 18)))

(defparameter *mapn* '((0 > 1) (1 > 2) (2 > 3) (3 > 4) (0 v 5) (2 v 7) (4 v 9)
		       (5 v 10) (7 v 12) (9 v 14) (10 > 11) (11 > 12) (12 > 13) (13 > 14)
		       (15 > 16) (16 > 17) (10 v 15) (11 v 16) (12 v 17)
		       (p 14) (b 13) (b 12) (o 13) (o 10)))

(defparameter *simple-map* '((p 0) (b 1) (o 2) (0 > 1) (2 < 1)))
(defparameter *simple-edge-directions* '((< >) (v ^)))

(defun pbs (map &optional (direction *simple-edge-directions*))
  (make-edge-directions direction)
  (setf *dead-positions* (dead-positions-on-map map))
  (format t "~{~A~%~}" (mapcar #'op-action (pushbox-solve map)))
  (values))

(defun dead-positions-on-map (map)
  (let* ((graph (get-graph map))
	 (all-positions (remove-duplicates (union (mapcar #'from-node graph) (mapcar #'to-node graph))))
	 (live-positions (close-live-positions (mapcar #'get-position (get-target map)) graph)))
    (set-difference all-positions live-positions)))

(defun close-live-positions (init graph)
  (let* ((count (length init))
	 (live-positions (union init (remove nil (do-close-live-positions init graph)))))
    (if (= count (length live-positions))
	live-positions
	(close-live-positions live-positions graph))))

(defun do-close-live-positions (init graph)
  (reduce #'union (mapcar #'(lambda (pos) (do-close-live-positions-1 pos graph)) init)))

(defun do-close-live-positions-1 (pos graph)
  (let ((edges (normalize-adjacent-edges pos graph)))
    (mapcar #'(lambda (edge) (live-node edge graph)) edges)))

(defun live-node (edge graph)
  (when (get-box-target (to-node edge) (edge-direction edge) graph)
    (to-node edge)))

(defstruct op "An Operation"
	   (action nil) (preconds nil) (add-list nil) (del-list nil))

(defun op-equal (op1 op2)
  (and (equal (op-action op1) (op-action op2))
       (equal (op-preconds op1) (op-preconds op2))
       (equal (op-add-list op1) (op-add-list op2))
       (equal (op-del-list op1) (op-del-list op2))))

(defun use-map (map direction)
  (setf *map* map
	*ops* (map-to-ops map)
	*directions* direction)
  (make-edge-directions direction))

(defun make-map (map)
  (let* ((person (get-person map))
	 (box (get-box map))
	 (non-empty-nodes (append (list (get-position person))
				  (mapcar #'get-position box)))
	 (graph (get-graph map))
	 (all-nodes (union (mapcar #'from-node graph)
			   (mapcar #'to-node graph)))
	 (empty-nodes (set-difference all-nodes non-empty-nodes)))
    (append map (mapcar #'(lambda (node)
			    (list node 'empty))
			empty-nodes))))

(defun pushbox-solve (map &optional states steps)
  (when (all-boxes-on-targets map)
    (return-from pushbox-solve (reverse steps)))
  (when (or (dead-state-p (get-box map) (get-graph map))
	    (member map states :test #'state-eql))
    (return-from pushbox-solve nil))
  (some #'(lambda (op)
	    (pushbox-solve (pushbox-one-step map op) (cons map states) (cons op steps)))
	(map-to-ops map)))

(defun all-boxes-on-targets (map)
  (equal (sort (mapcar #'get-position (get-box map)) #'<)
	 (sort (mapcar #'get-position (get-target map)) #'<)))

(defun pushbox-one-step (map op)
  (union (op-add-list op) (set-difference map (op-del-list op) :test #'equal)))

(defun person-p (list)
  (and (symbolp (first list)) (eql (first list) 'p)))

(defun box-p (list)
  (and (symbolp (first list)) (eql (first list) 'b)))

(defun target-p (list)
  (and (symbolp (first list)) (eql (first list) 'o)))

(defun map-to-ops (map)
  (let ((person (get-person map))
	(box (get-box map))
	(graph (get-graph map)))
    (remove nil (append (make-moving-person-ops person box graph)
			(make-pushing-box-ops person box graph)))))

(defun get-person (map)
  (dolist (element map)
    (when (person-p element)
      (return element))))

(defun get-box (map)
  (let ((boxes))
    (dolist (element map boxes)
      (when (box-p element)
	(setf boxes (cons element boxes))))))

(defun get-target (map)
  (let ((targets))
    (dolist (element map targets)
      (when (target-p element)
	(setf targets (cons element targets))))))

(defun get-graph (map)
  (let ((graph))
    (dolist (element map graph)
      (unless (or (person-p element) (box-p element) (target-p element))
	(setf graph (cons element graph))))))

(defun state-eql (m1 m2)
  (and (person-eql (get-person m1) (get-person m2))
       (box-eql (get-box m1) (get-box m2))))

(defun person-eql (p1 p2)
  (eql (get-position p1) (get-position p2)))

(defun box-eql (b1 b2)
  (equal (sort (mapcar #'get-position b1) #'<)
	 (sort (mapcar #'get-position b2) #'<)))

(defun find-all (item sequence &rest keyword-args
		 &key (test #'eql) test-not &allow-other-keys)
  (if test-not
      (apply #'remove item sequence
	     :test-not (complement test-not) keyword-args)
      (apply #'remove item sequence
	     :test (complement test) keyword-args)))

(defun get-position (thing)
  (when (or (person-p thing) (box-p thing) (target-p thing))
    (second thing)))

(defun from-node (edge)
  (first edge))

(defun to-node (edge)
  (third edge))

(defun make-edge-directions (directions)
  (dolist (dir-pair directions)
    (let ((dir (first dir-pair))
	  (opposite-dir (second dir-pair)))
      (setf (get dir 'opposite-direction) opposite-dir)
      (setf (get opposite-dir 'opposite-direction) dir))))

(defun edge-direction (edge)
  (second edge))

(defun opposite-edge-direction (direction)
  (get direction 'opposite-direction))

(defun make-moving-person-ops (person box graph)
  (let* ((pos (second person))
	 (adjacent-nodes (mapcar #'to-node
				 (normalize-adjacent-edges pos graph)))
	 (box-nodes (mapcar #'get-position box))
	 (empty-adjacent-nodes (set-difference adjacent-nodes box-nodes)))
    (mapcar #'(lambda (node)
		(make-op :action `(move person from ,pos to ,node)
			 :preconds `((p ,pos))
			 :add-list `((p ,node))
			 :del-list `((p ,pos))))
	    empty-adjacent-nodes)))

(defun get-adjacent-edges (pos graph)
  (append (find-all pos graph :key #'from-node) (find-all pos graph :key #'to-node)))

(defun normalize-edges (pos edges)
  (let ((new-edges))
    (dolist (edge edges new-edges)
      (if (eql pos (from-node edge))
	  (push edge new-edges)
	  (push (list pos (opposite-edge-direction (edge-direction edge)) (from-node edge)) new-edges)))))

(defun normalize-adjacent-edges (pos graph)
  (normalize-edges pos (get-adjacent-edges pos graph)))

(defun opposite-edge-p (edge1 edge2)
  (eql (edge-direction edge1) (opposite-edge-direction (edge-direction edge2))))

(defun empty-node-p (pos boxes)
  (not (find pos boxes :key #'get-position)))

(defun movable-box-p (box boxes graph)
  (let* ((pos (get-position box))
	 (edges (normalize-adjacent-edges pos graph)))
    (dolist (i edges)
      (dolist (j edges)
	(if (and (not (eql i j))
		 (opposite-edge-p i j)
		 (empty-node-p (to-node i) boxes)
		 (empty-node-p (to-node j) boxes))
	    (return-from movable-box-p t))))))

(defun dead-position-p (box)
  (member (get-position box) *dead-positions*))

(defun dead-state-p (boxes graph)
  (or (some #'dead-position-p boxes)
      (notany  #'(lambda (box)
		   (movable-box-p box boxes graph)) boxes)))

(defun make-pushing-box-ops (person box graph)
  (let* ((pos (second person))
	 (adjacent-nodes (mapcar #'to-node
				 (normalize-adjacent-edges pos graph)))
	 (box-nodes (mapcar #'get-position box))
	 (adjacent-box-nodes (intersection adjacent-nodes box-nodes))
	 (box-target-nodes
	  (mapcar
	   #'(lambda (box-pos)
	       (let ((direction (get-edge-direction pos box-pos graph)))
		 (get-box-target box-pos direction graph)))
	   adjacent-box-nodes)))
    (mapcar #'(lambda (node target)
		(if (and target (empty-node-p target box))
		    (make-op :action `(push box from ,node to ,target)
			     :preconds `((p ,pos) (b ,node))
			     :add-list `((p ,node) (b ,target))
			     :del-list `((p ,pos) (b ,node)))))
	    adjacent-box-nodes box-target-nodes)))

(defun get-edge-direction (person-pos box-pos graph)
  (or (edge-direction (find-if #'(lambda (node)
				   (and (eql person-pos (from-node node))
					(eql box-pos (to-node node))))
			       graph))
      (opposite-edge-direction (edge-direction (find-if #'(lambda (node)
							    (and (eql box-pos (from-node node))
								 (eql person-pos (to-node node))))
							graph)))))

(defun get-box-target (box-pos direction graph)
  (or (to-node (find-if #'(lambda (node)
			    (and (eql box-pos (from-node node))
				 (eql direction (edge-direction node)))) graph))
      (from-node (find-if #'(lambda (node)
			     (and (eql box-pos (to-node node))
				  (eql direction (opposite-edge-direction (edge-direction node))))) graph))))


;;; Only two directions:
;;;   (A - B) means A is on the left of B
;;;   (A | B) means A is on the top of B
;;; So not every vertical directions must be specified.

;;; And (A B C) is shortcut for ((A - B) (B - C))

;;; To ease map construction, only five letters are required.  They
;;; are P(erson), B(ox), O(target), E(mpty) and W(all).  Coordinate is
;;; only used internally.

;;; Solution direction uses words such as left, right, up and down,
;;; not explicit coordinates any more.

;;; Every position has its own properties.  Some of properties can be
;;; changed dynamically.

;;; For example,
;;;   (A P) means a person is on position A.
;;;   (A D) means position A is a dead state.
;;;   (A (- B) (C -)) means A is on the left of B but on the right of C.
;;;   (A (| B) (C |)) means A is on the top of B but on the bottom of C.