# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1549136480 18000
# Node ID d5468dc3769d32405aa72e17ecc7cfa61e587c4c
# Parent  5668f7ed5c2dc09ba172adcc898a9cdcc82e080a
Start day 15

diff -r 5668f7ed5c2d -r d5468dc3769d advent.asd
--- 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
 
diff -r 5668f7ed5c2d -r d5468dc3769d package.lisp
--- 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))
diff -r 5668f7ed5c2d -r d5468dc3769d src/2018/day-15.lisp
--- /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))))
diff -r 5668f7ed5c2d -r d5468dc3769d src/utils.lisp
--- 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)))))))))