From 2bea07a804dde0fe90a26b9dc725d9d289ec338a Mon Sep 17 00:00:00 2001
From: Oscar Najera <hi@oscarnajera.com>
Date: Tue, 24 Jan 2023 18:38:39 +0100
Subject: Day 24

---
 AoC2022/24/solver.lisp | 128 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 128 insertions(+)
 create mode 100644 AoC2022/24/solver.lisp

(limited to 'AoC2022/24/solver.lisp')

diff --git a/AoC2022/24/solver.lisp b/AoC2022/24/solver.lisp
new file mode 100644
index 0000000..0961b6f
--- /dev/null
+++ b/AoC2022/24/solver.lisp
@@ -0,0 +1,128 @@
+(ql:quickload '(fiveam uiop trivia arrows))
+
+
+(defun distance-1 (a b)
+  (apply #'+
+         (mapcar (lambda (e1 e2)
+                   (abs (- e1 e2))) a b)))
+
+(defun boundary-conditions (width height)
+  "The boundary is a wall meaning 0 & (N-1) are never occupied."
+  (lambda (x y dir)
+    (list
+     dir
+     (cond
+       ((zerop x) (- width 2))
+       ((= x (- width 1)) 1)
+       (x))
+     (cond
+       ((zerop y) (- height 2))
+       ((= y (- height 1)) 1)
+       (y)))))
+
+(defun wall-p (width height)
+  (lambda (point)
+    (destructuring-bind (x y) point
+      (cond
+        ;; not entry - exit
+        ((or (and (= x 1) (zerop y))
+             (and (= x (- width 2)) (= y (1- height))))
+         nil)
+        ;; yes wall or out of map
+        ((or (<= x 0) (<= y 0)
+             (>= x (1- width))
+             (>= y (1- height))))))))
+
+(fiveam:test boundaries
+  (let ((bc (boundary-conditions 6 9)))
+    (fiveam:is (equal (funcall bc 5 3 t) '(1 3 t)))
+    (fiveam:is (equal (funcall bc 5 8 t) '(1 1 t)))
+    (fiveam:is (equal (funcall bc 0 8 t) '(4 1 t)))))
+
+(defun data-input (filename)
+  (let ((lines (uiop:read-file-lines filename)))
+    (list
+     (loop for row in lines
+           and y from 0
+           nconc (loop for place across row
+                       and x from 0
+                       unless (or (eq #\# place) (eq #\. place))
+                         collect (list (ecase place
+                                         (#\> '>)
+                                         (#\< '<)
+                                         (#\v 'v)
+                                         (#\^ '^))
+                                       x y)))
+     (list (length (car lines))
+           (length lines)))))
+
+(defun evolve (blizzards boundary)
+  (mapcar
+   (lambda (blizzard)
+     (trivia:match blizzard
+       ((list '> x y) (funcall boundary (1+ x) y '>))
+       ((list '< x y) (funcall boundary (1- x) y '<))
+       ((list 'v x y) (funcall boundary x (1+ y) 'v))
+       ((list '^ x y) (funcall boundary x (1- y) '^))))
+   blizzards))
+
+
+(defun elf-moves (elf wallp blizzards)
+  (destructuring-bind (x y) elf
+    (arrows:-<>
+     (list (list (1+ x)    y)
+           (list x     (1+ y))
+           (list (1- x)    y)
+           (list x     (1- y))
+           (list x         y))
+     (delete-if wallp <>)
+     (set-difference <> (mapcar #'cdr blizzards) :test #'equal))))
+
+(defun cutoff-distance (positions goal)
+  (loop for p in positions
+        for dist = (distance-1 goal p)
+        maximize dist into ma
+        minimize dist into mi
+        finally (return (values (max (ceiling (+ ma mi) 2)
+                                     (* 1.2 mi)
+                                     (* 0.8 ma)
+                                     30)
+                                mi ma))))
+
+(defun discard-hopeless-positions (positions goal cutoff-distance)
+  (delete-if (lambda (p) (< cutoff-distance (distance-1 goal p))) positions))
+
+(defun time-step (time-left walkers goal blizzards bc wallp)
+  (if (or (zerop time-left) (member goal walkers :test #'equal))
+      (values time-left blizzards)
+      (let* ((new-blizzards (evolve blizzards bc))
+             (new-positions (reduce
+                             (lambda (options point)
+                               (union options (elf-moves point wallp new-blizzards)
+                                      :test #'equal))
+                             walkers
+                             :initial-value nil))
+             (shortened-positions (discard-hopeless-positions new-positions goal
+                                               (cutoff-distance new-positions goal))))
+        (time-step (1- time-left)
+                   shortened-positions
+                   goal new-blizzards bc wallp))))
+
+(destructuring-bind (blizzards (width height)) (data-input "input")
+  (let ((bc (boundary-conditions width height))
+        (wallp (wall-p width height))
+        (goal (list (- width 2) (1- height)))
+        (elf (list 1 0))
+        (max-time 400))
+    (multiple-value-bind (time-left-g blizzards) (time-step max-time (list elf) goal blizzards bc wallp)
+      (multiple-value-bind (time-left-b blizzards) (time-step max-time (list goal) elf blizzards bc wallp)
+        (multiple-value-bind (time-left-e blizzards) (time-step max-time (list elf) goal blizzards bc wallp)
+          (list (- max-time time-left-g)
+                (- max-time time-left-b)
+                (- max-time time-left-e)))))
+
+    )
+
+  )
+(+ 299 348 252)
+(+ 299 323 277)
-- 
cgit v1.2.3