--- a/advent.asd Sun Dec 16 22:50:57 2018 -0500
+++ b/advent.asd Sat Feb 02 14:41:20 2019 -0500
@@ -20,6 +20,7 @@
:1am
:alexandria
+ :beast
:cl-digraph
:cl-digraph.dot
:cl-interpol
@@ -27,6 +28,7 @@
:iterate
:losh
:named-readtables
+ :pileup
:split-sequence
:str
--- a/package.lisp Sun Dec 16 22:50:57 2018 -0500
+++ b/package.lisp Sat Feb 02 14:41:20 2019 -0500
@@ -43,6 +43,8 @@
:ring-insertf-after
:ring-insertf-before
+ :astar
+
))
(defparameter *advent-use* '(:use :cl :losh :iterate :advent :advent.quickutils))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2018/day-15.lisp Sat Feb 02 14:41:20 2019 -0500
@@ -0,0 +1,260 @@
+(defpackage :advent/2018/15 #.cl-user::*advent-use*)
+(in-package :advent/2018/15)
+
+;;;; Points -------------------------------------------------------------------
+(defun p (row col) (complex row col))
+(defun row (p) (realpart p))
+(defun col (p) (imagpart p))
+
+(defun p< (p1 p2)
+ (or (< (row p1) (row p2))
+ (and (= (row p1) (row p2))
+ (< (col p1) (col p2)))))
+
+(defun neighbors (p)
+ (list (+ p #c(0 1))
+ (+ p #c(1 0))
+ (+ p #c(0 -1))
+ (+ p #c(-1 0))))
+
+(defun distance (p1 p2)
+ (abs (- p1 p2)))
+
+
+;;;; Loc ----------------------------------------------------------------------
+(defvar *locations* nil)
+
+(beast:define-aspect loc p)
+
+(defun loc/row (entity) (row (loc/p entity)))
+(defun loc/col (entity) (col (loc/p entity)))
+
+
+(defun initialize-loc (rows cols)
+ (setf *locations* (make-array (list rows cols) :initial-element nil)))
+
+(defmethod beast:entity-created :after ((entity loc))
+ (setf (aref *locations* (loc/row entity) (loc/col entity)) entity))
+
+(defmethod beast:entity-destroyed :after ((entity loc))
+ (when (loc/p entity)
+ (setf (aref *locations* (loc/row entity) (loc/col entity)) nil)))
+
+
+(defun move (entity p)
+ (setf (aref *locations* (loc/row entity) (loc/col entity)) nil
+ (loc/p entity) p
+ (aref *locations* (loc/row entity) (loc/col entity)) entity))
+
+(defun loc (p)
+ (aref *locations* (row p) (col p)))
+
+(defun loc< (e1 e2)
+ (p< (loc/p e1) (loc/p e2)))
+
+
+;;;; Other Aspects ------------------------------------------------------------
+(beast:define-aspect living (hp :initform 200))
+(beast:define-aspect fighter (attack-power :initform 3))
+(beast:define-aspect renderable (glyph))
+
+
+;;;; Entities -----------------------------------------------------------------
+(defvar *dead* nil)
+
+(beast:define-entity elf (loc living fighter renderable))
+(beast:define-entity goblin (loc living fighter renderable))
+
+(defmethod print-object ((o elf) s)
+ (print-unreadable-object (o s :type t)
+ (format s "~A ~D" (loc/p o) (living/hp o))))
+
+(defmethod print-object ((o goblin) s)
+ (print-unreadable-object (o s :type t)
+ (format s "~A ~D" (loc/p o) (living/hp o))))
+
+
+(defun create-elf (p)
+ (beast:create-entity 'elf :loc/p p :renderable/glyph #\E))
+
+(defun create-goblin (p)
+ (beast:create-entity 'goblin :loc/p p :renderable/glyph #\G))
+
+
+(defun entities-to-move ()
+ (sort (beast:map-entities #'identity) #'loc<))
+
+(defun enemiesp (e1 e2)
+ (typep e2 (etypecase e1
+ (goblin 'elf)
+ (elf 'goblin))))
+
+(defun targets (entity)
+ (beast:map-entities #'identity (etypecase entity
+ (goblin 'elf)
+ (elf 'goblin))))
+
+(defun attack (attacker defender)
+ (decf (living/hp defender)
+ (fighter/attack-power attacker))
+ (unless (plusp (living/hp defender))
+ (push defender *dead*)
+ (beast:destroy-entity defender)))
+
+
+;;;; Terrain ------------------------------------------------------------------
+(defvar *terrain* nil)
+
+(defun initialize-terrain (rows cols)
+ (setf *terrain* (make-array (list rows cols)
+ :element-type 'character
+ :initial-element #\.)))
+
+
+(defun terrain (p)
+ (aref *terrain* (row p) (col p)))
+
+(defun (setf terrain) (new-value p)
+ (setf (aref *terrain* (row p) (col p)) new-value))
+
+
+(defun passablep (p)
+ (case (terrain p)
+ (#\# nil)
+ (t t)))
+
+
+;;;; World --------------------------------------------------------------------
+(defun openp (p)
+ (and (null (loc p))
+ (passablep p)))
+
+(defun in-bounds-p (p)
+ (array-in-bounds-p *terrain* (row p) (col p)))
+
+(defun open-neighbors (p)
+ (remove-if-not (alexandria:conjoin #'openp #'in-bounds-p)
+ (neighbors p)))
+
+(defun adjacent-enemies (mob)
+ (-<> mob
+ loc/p
+ neighbors
+ (mapcar #'loc <>)
+ (remove nil <>)
+ (remove-if-not (curry #'enemiesp mob) <>)))
+
+(defun adjacent-enemy (mob)
+ (first (sort (adjacent-enemies mob) #'loc<)))
+
+(defun target-squares (unit)
+ (-<> unit
+ targets
+ (mapcan (compose #'open-neighbors #'loc/p) <>)
+ (remove-duplicates <> :test #'=)))
+
+
+(defun step-cost (start from to)
+ ;; We adjust the cost of the first step of our path to account for the
+ ;; bullshit reading order tie breaking (but never enough to send us the wrong
+ ;; way).
+ (if (= from start)
+ (ecase (- to from)
+ (#c(-1 0) 1)
+ (#c(0 -1) 1.1)
+ (#c(0 1) 1.2)
+ (#c(1 0) 1.3))
+ 1))
+
+(defun action (mob)
+ (if-let ((enemy (adjacent-enemy mob)))
+ (values :attack enemy)
+ (iterate
+ (with goals = (target-squares mob))
+ (with start = (loc/p mob))
+ (with best-goal = nil)
+ (with best-path = nil)
+ (with best-cost = nil)
+ (for goal :in goals)
+ (for path = (astar :start start
+ :neighbors #'open-neighbors
+ :goalp (curry #'= goal)
+ :cost (curry #'step-cost start)
+ :limit best-cost
+ :heuristic (curry #'distance goal)
+ :test #'eql))
+ (when path
+ (for cost = (length path))
+ (when (or (null best-path) ; this is the first path
+ (< cost best-cost) ; this is a shorter path
+ (p< goal best-goal)) ; this is a better destination by reading order
+ (setf best-path path
+ best-goal goal
+ best-cost cost)))
+ (finally (return (if best-path
+ (values :move (second best-path))
+ (values :wait)))))))
+
+
+(defun tick-mob (mob)
+ (unless (member mob *dead*)
+ (multiple-value-bind (action target) (action mob)
+ (ecase action
+ (:attack
+ (pr mob 'attacking target)
+ (attack mob target))
+ (:move
+ (pr mob 'moving 'to target)
+ (move mob target))
+ (:wait
+ (pr mob 'waiting))))))
+
+
+(defun tick-world ()
+ (let ((*dead* nil))
+ (map nil #'tick-mob (entities-to-move))))
+
+
+;;;; World Generation ---------------------------------------------------------
+(defun generate-world (lines)
+ (removef lines "" :test #'string=)
+ (beast:clear-entities)
+ (let* ((rows (length lines))
+ (cols (length (first lines))))
+ (initialize-loc rows cols)
+ (initialize-terrain rows cols)
+ (iterate
+ (for line :in lines)
+ (for row :from 0)
+ (iterate
+ (for char :in-string line :with-index col)
+ (for p = (p row col))
+ (case char
+ (#\E (create-elf p))
+ (#\G (create-goblin p))
+ (#\# (setf (terrain p) #\#))
+ (t nil))))))
+
+(defun print-world (&optional path)
+ (iterate
+ (for (char row col) :in-array *terrain*)
+ (for p = (p row col))
+ (for mob = (loc p))
+ (when (zerop col)
+ (terpri))
+ (write-char (cond
+ ((member p path) #\x)
+ (mob (renderable/glyph mob))
+ (t char))))
+ (terpri)
+ (values))
+
+
+(define-problem (2018 15) (data read-lines)
+ (generate-world data)
+ (print-world))
+
+;; (1am:test test-2018/15
+;; (multiple-value-bind (part1 part2) (run)
+;; (1am:is (string= "3610281143" part1))
+;; (1am:is (= 20211326 part2))))
--- a/src/utils.lisp Sun Dec 16 22:50:57 2018 -0500
+++ b/src/utils.lisp Sat Feb 02 14:41:20 2019 -0500
@@ -383,3 +383,86 @@
(setf n remaining)
(until (zerop n))))
result-type))
+
+
+;;;; A* Search ----------------------------------------------------------------
+(defstruct path
+ state
+ (estimate 0)
+ (cost 0)
+ (previous nil))
+
+(defun path-to-list (path &aux result)
+ (recursively ((path path))
+ (unless (null path)
+ (push (path-state path) result)
+ (recur (path-previous path))))
+ result)
+
+(defun astar (&key start neighbors goalp cost heuristic test limit)
+ "Search for a path from `start` to a goal using A★.
+
+ The following parameters are all required:
+
+ * `start`: the starting state.
+
+ * `neighbors`: a function that takes a state and returns all states reachable
+ from it.
+
+ * `goalp`: a predicate that takes a state and returns whether it is a goal.
+
+ * `cost`: a function that takes two states `a` and `b` and returns the cost
+ to move from `a` to `b`.
+
+ * `heuristic`: a function that takes a state and estimates the distance
+ remaining to the goal.
+
+ * `test`: an equality predicate for comparing nodes. It must be suitable for
+ passing to `make-hash-table`.
+
+ If the heuristic function is admissable (i.e. it never overestimates the
+ remaining distance) the algorithm will find the shortest path.
+
+ Note that `test` is required. The only sensible default would be `eql`, but
+ if you were using states that need a different predicate and forgot to pass it
+ the algorithm would end up blowing the heap, which is unpleasant.
+
+ The following parameters are optional:
+
+ * `limit`: a maximum cost. Any paths that exceed this cost will not be
+ considered.
+
+ "
+ (let ((seen (make-hash-table :test test))
+ (frontier (pileup:make-heap #'< :key #'path-estimate)))
+ (labels ((mark-seen (path)
+ (setf (gethash (path-state path) seen) (path-cost path)))
+ (push-path (path)
+ (mark-seen path)
+ (pileup:heap-insert path frontier)))
+ (iterate
+ (initially (push-path (make-path :state start)))
+
+ (for (values current found) = (pileup:heap-pop frontier))
+ (unless found
+ (return (values nil nil)))
+
+ (for current-state = (path-state current))
+
+ (when (funcall goalp current-state)
+ (return (values (path-to-list current) t)))
+
+ (for current-cost = (path-cost current))
+
+ (iterate
+ (for next-state :in (funcall neighbors current-state))
+ (for next-cost = (+ current-cost (funcall cost current-state next-state)))
+ (for (values seen-cost previously-seen) = (gethash next-state seen))
+ (unless (and limit (> next-cost limit))
+ (when (or (not previously-seen)
+ (< next-cost seen-cost))
+ (for next-estimate = (+ next-cost (funcall heuristic next-state)))
+ (push-path (make-path :state next-state
+ :cost next-cost
+ :estimate next-estimate
+ :previous current)))))))))