1 files changed, 102 insertions, 0 deletions
diff --git a/AoC2022/14/solver.lisp b/AoC2022/14/solver.lisp
new file mode 100644
index 0000000..bb32e0f
--- /dev/null
+++ b/AoC2022/14/solver.lisp
@@ -0,0 +1,102 @@
+(ql:quickload '(fiveam uiop str))
+
+(defun bounds (walls)
+  (loop for (ym x1 x0) on (loop for line in walls
+                                nconc (loop for (x y) in line
+                                            maximize y into ymax
+                                            maximize x into xmax
+                                            minimize x into xmin
+                                            finally (return (list ymax xmax xmin)))) by #'cdddr
+
+        maximize ym into ymax
+        maximize x1 into xmax
+        minimize x0 into xmin
+        finally (return (list ymax xmax xmin))))
+
+(defstruct grid
+  bounds
+  x-len
+  y-len
+  grid)
+
+(defun grid (bounds x-len y-len)
+  (make-grid :bounds bounds :x-len x-len :y-len y-len
+             :grid (make-array (* x-len y-len) :initial-element 0 :element-type '(unsigned-byte 2))))
+
+(defun make-abyss-grid (bounds)
+  (let ((y-len (1+ (car bounds)))
+        (x-len (1+ (- (cadr bounds) (caddr bounds)))))
+    (grid bounds x-len y-len)))
+
+(defun solver-finite-grid (bounds)
+  (let* ((y-len (+ 3 (car bounds)))
+         (x-len (* 2 y-len)))
+    (setf (car bounds) (+ 500 y-len))
+    (setf (elt bounds 1) (- 500 y-len))
+    (grid bounds x-len y-len)))
+
+(defun solver-point (x y grid)
+  (let ((x (- x (caddr (grid-bounds grid)))))
+    (when (and (< -1 x (grid-x-len grid))
+               (< -1 y (grid-y-len grid)))
+      (+ x (* y (grid-x-len grid))))))
+
+(defun solver--wall-line (grid walls)
+  (loop for line in walls
+        do (loop for ((startx starty) (fx fy)) on line until (null fx)
+                 :if (= startx fx)
+                   :do (loop for y from (min starty fy) to (max starty fy)
+                             :do (setf (aref (grid-grid grid) (solver-point startx y grid)) 1))
+                 :else
+                   :do (loop for x from (min startx fx) to (max startx fx)
+                             :do (setf (aref (grid-grid grid) (solver-point x starty grid)) 1)))))
+
+(defun draw-grid (grid)
+  (let ((out (make-string-output-stream)))
+    (loop for elt across (grid-grid grid)
+          for idx from 0
+          do (progn (when (= 0 (mod idx (grid-x-len grid))) (terpri out))
+                    (princ (case elt
+                             (0 ".")
+                             (1 "#")
+                             (2 "o")) out)))
+    (get-output-stream-string out)))
+
+(defun simulate (grid)
+  (let ((drops 0)
+        (x 500) (y 0))
+    (loop while
+          (ignore-errors ;; went out of grid
+           (cond
+             ((= 0 (aref (grid-grid grid) (solver-point x (1+ y) grid)))
+              (incf y)) ;; check next
+             ((= 0 (aref (grid-grid grid) (solver-point (1- x) (1+ y) grid)))
+              (incf y)
+              (decf x)) ;; check left
+             ((= 0 (aref (grid-grid grid) (solver-point (1+ x) (1+ y) grid)))
+              (incf y)
+              (incf x)) ;; check right
+             (t (setf (aref (grid-grid grid) (solver-point x y grid)) 2)
+                (incf drops)
+                (unless (= y 0)
+                  (setf x 500 y 0))))))
+    drops))
+
+(defun parse-location (list-str)
+  (mapcar (lambda (row)
+            (mapcar (lambda (pair)
+                      (mapcar #'parse-integer (str:split "," pair)))
+                    (str:split " -> " row)))
+          list-str))
+
+(defun solver (list-str)
+  (let* ((walls (parse-location list-str))
+         (grid (make-abyss-grid (bounds walls))))
+    (solver--wall-line grid walls)
+    (list (simulate grid)
+          (draw-grid grid))))
+
+(solver (uiop:split-string "498,4 -> 498,6 -> 496,6
+503,4 -> 502,4 -> 502,9 -> 494,9" :separator '(#\Newline)))
+
+(solver (uiop:read-file-lines #P"./input"))