src/day12.lisp

   1 (asdf:load-system :adventofcode2020)
   2 (in-package #:adventofcode2020)
   3 (named-readtables:in-readtable :adventofcode2020)
   4
   5 (defun parse-action (str)
   6   (cl-ppcre:register-groups-bind
   7     ((λ(char _ 0) action) (#'parse-integer scalar)) ("([NSEWLRF])([0-9]+)" str)
   8     (list action scalar)))
   9
  10 (defstruct ship
  11   (heading #\E)
  12   (ns-coord 0)
  13   (ew-coord 0)
  14   (waypoint-ns 1)
  15   (waypoint-ew 10))
  16
  17 (defun apply-turn-heading (heading degree)
  18   (let ((directions #(#\N #\E #\S #\W))
  19         (heading-delta (/ degree 90)))
  20     (-<>
  21       (position heading directions)
  22       (+ heading-delta)
  23       (mod 4)
  24       (aref directions <>))))
  25
  26 (defun apply-turn-space (x y degree)
  27   (if (= degree 0) (list x y)
  28       (destructuring-bind (x y) (apply-turn-space x y (- degree (* (signum degree) 90)))
  29         (if (> degree 0)
  30             (list y (* -1 x))
  31             (list (* -1 y) x)))))
  32
  33 (defun apply-action-ship (ship act-pair)
  34   (destructuring-bind (action scalar) act-pair
  35     (let ((new-ship (copy-structure ship)))
  36       (case action
  37         (#\N (setf (ship-ns-coord new-ship) (+ (ship-ns-coord ship) scalar)))
  38         (#\S (setf (ship-ns-coord new-ship) (- (ship-ns-coord ship) scalar)))
  39         (#\E (setf (ship-ew-coord new-ship) (+ (ship-ew-coord ship) scalar)))
  40         (#\W (setf (ship-ew-coord new-ship) (- (ship-ew-coord ship) scalar)))
  41         (#\L (setf (ship-heading new-ship) (apply-turn-heading (ship-heading ship) (* -1 scalar))))
  42         (#\R (setf (ship-heading new-ship) (apply-turn-heading (ship-heading ship) (* +1 scalar))))
  43         (#\F (setf new-ship (apply-action-ship new-ship (list (ship-heading ship) scalar)))))
  44       new-ship)))
  45
  46 (defun apply-action-waypoint (ship act-pair)
  47   (destructuring-bind (action scalar) act-pair
  48     (let ((new-ship (copy-structure ship)))
  49       (case action
  50         (#\N (setf (ship-waypoint-ns new-ship) (+ (ship-waypoint-ns ship) scalar)))
  51         (#\S (setf (ship-waypoint-ns new-ship) (- (ship-waypoint-ns ship) scalar)))
  52         (#\E (setf (ship-waypoint-ew new-ship) (+ (ship-waypoint-ew ship) scalar)))
  53         (#\W (setf (ship-waypoint-ew new-ship) (- (ship-waypoint-ew ship) scalar)))
  54         (#\L (destructuring-bind (x y) (apply-turn-space (ship-waypoint-ew ship) (ship-waypoint-ns ship) (* -1 scalar))
  55                (setf (ship-waypoint-ew new-ship) x)
  56                (setf (ship-waypoint-ns new-ship) y)))
  57         (#\R (destructuring-bind (x y) (apply-turn-space (ship-waypoint-ew ship) (ship-waypoint-ns ship) (* +1 scalar))
  58                (setf (ship-waypoint-ew new-ship) x)
  59                (setf (ship-waypoint-ns new-ship) y)))
  60         (#\F (setf (ship-ns-coord new-ship) (+ (ship-ns-coord ship) (* scalar (ship-waypoint-ns ship))))
  61              (setf (ship-ew-coord new-ship) (+ (ship-ew-coord ship) (* scalar (ship-waypoint-ew ship))))))
  62       new-ship)))
  63
  64
  65 (day 12 input
  66   (let ((actions (mapcar #'parse-action (list-from input))))
  67     (part1 (let ((final-ship (reduce #'apply-action-ship actions :initial-value (make-ship))))
  68              (manhattan-distance (list 0 0) (list (ship-ew-coord final-ship)
  69                                                   (ship-ns-coord final-ship)))))
  70     (part2 (let ((final-ship (reduce #'apply-action-waypoint actions :initial-value (make-ship))))
  71              (manhattan-distance (list 0 0) (list (ship-ew-coord final-ship)
  72                                                   (ship-ns-coord final-ship)))))))
  73
  74 (def-suite day12)
  75 (in-suite day12)
  76
  77 (defvar *simple-actions*
  78   '("F10" "N3" "F7" "R90" "F11"))
  79
  80 (test apply-turns-heading
  81   (is (equal #\S (apply-turn-heading #\E 90)))
  82   (is (equal #\W (apply-turn-heading #\E 180)))
  83   (is (equal #\N (apply-turn-heading #\E 270)))
  84   (is (equal #\N (apply-turn-heading #\E -90)))
  85   (is (equal #\W (apply-turn-heading #\E -180))))
  86
  87 (test apply-actions-ship
  88   (is (equalp
  89         (make-ship :heading #\S :ns-coord -8 :ew-coord 17)
  90         (reduce #'apply-action-ship (mapcar #'parse-action *simple-actions*)
  91                 :initial-value (make-ship)))))
  92
  93 (run! 'day12)