(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.