diff options
| -rw-r--r-- | AoC2022/17/solver.el | 148 | ||||
| -rw-r--r-- | AoC2022/makefile | 2 |
2 files changed, 149 insertions, 1 deletions
diff --git a/AoC2022/17/solver.el b/AoC2022/17/solver.el new file mode 100644 index 0000000..0a7dfd4 --- /dev/null +++ b/AoC2022/17/solver.el @@ -0,0 +1,148 @@ +;; -*- lexical-binding: t; -*- +(require 'cl-lib) +(require 'seq) + +(defconst solver-chamber-width 7) + +(defun solver-point (x y) + (+ x (* y solver-chamber-width))) + +(defun solver-coords (point) + (list (floor point solver-chamber-width) + (mod point solver-chamber-width))) + +(defconst *rocks* + (vector (list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0) (solver-point 3 0)) + (list (solver-point 1 0) + (solver-point 0 1) (solver-point 1 1) (solver-point 2 1) + (solver-point 1 2)) + (list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0) + (solver-point 2 1) + (solver-point 2 2)) + (list (solver-point 0 0) (solver-point 0 1) (solver-point 0 2) (solver-point 0 3)) + (list (solver-point 0 0) (solver-point 1 0) + (solver-point 0 1) (solver-point 1 1)))) + +(cl-defun solver-no-collision-move (object direction obstacles) + (mapcar + (lambda (current) + (let ((next (funcall + (cl-ecase direction + (?> #'1+) + (?< #'1-) + (?v (lambda (p) (- p solver-chamber-width)))) + current))) + (if (and (>= next 0) + ;; no rolling boundaries + (seq-let (y x) (solver-coords current) + (seq-let (y2 x2) (solver-coords next) + (= 1 (+ (abs (- x x2)) (abs (- y y2)))))) + (not (memq next obstacles))) + next (cl-return-from solver-no-collision-move object)))) + object)) + +(defun solver-gen-object (seq) + (let ((len (length seq)) + (index 0)) + (lambda () + (prog1 (elt seq index) + (setf index (mod (1+ index) len)))))) + +(defun solver-place-rock (rock highpoint) + (let ((left-pad 2) + (altitude (* solver-chamber-width highpoint))) + (mapcar (lambda (point) + (+ point left-pad altitude)) + rock))) + +(defun solver-next-move (rock next-move obstacles) + (let* ((shift (solver-no-collision-move rock next-move obstacles)) + (drop (solver-no-collision-move shift ?v obstacles))) + (cl-values drop (equal shift drop)))) + +(defun solver-highpoint (obstacles) + (1+ (car (solver-coords (cl-reduce #'max obstacles))))) + +(defun solver-simulate (chamber rock next-shift) + (seq-let (new-place done-falling-p) + (solver-next-move rock (funcall next-shift) chamber) + (if done-falling-p + (cl-values (append new-place chamber) (solver-highpoint new-place)) + (solver-simulate chamber new-place next-shift)))) + + +(defun solver (drops-left highpoint raise-history obstacles next-rock next-shift) + (if (zerop drops-left) + raise-history + (seq-let (new-obstacles posible-high) + (solver-simulate obstacles + (solver-place-rock (funcall next-rock) (+ highpoint 3)) + next-shift) + (let ((new-high (max highpoint posible-high))) + (solver (1- drops-left) new-high (cons new-high raise-history) + ;; new-obstacles + (if (zerop (mod drops-left 100)) ;; arbitrarily chop list + (seq-subseq new-obstacles 0 (min 128 (length new-obstacles))) + new-obstacles) + next-rock next-shift))))) + +(defun solver-occurrences (lst) + (let ((table (make-hash-table :test #'eq))) + (cl-loop for e in lst + do (cl-incf (gethash e table 0))) + table)) + +(defun solver-to-alist (table) + (cl-loop for k being the hash-key of table using (hash-value v) + collect (cons k v))) + +(defun solver-find-period (history max-window) + (let ((len (1- (length history)))) + (cl-loop for size from 1 to max-window + for raises = (cl-loop + for start from 0 to len by size + for end from size by size + collect (- (aref history (min end len)) (aref history start))) + for periods = (solver-occurrences raises) + for test = (and (<= (hash-table-count periods) 3) + (car (cl-find-if (lambda (f) (< 1 (cdr f))) (solver-to-alist periods)))) + until test + finally (return (cl-values size test))))) + +(defun solver-height-reached (max-drops history max-window) + (seq-let (period block-height) (solver-find-period history max-window) + (seq-let (cycles left) (list (floor max-drops period) (mod max-drops period)) + (let ((offset (aref history period)) + (remaining (- (aref history (+ left period)) (aref history period)))) + (+ offset (* (1- cycles) block-height) remaining))))) + +(defun solver-input-directions (filename) + (with-current-buffer (find-file-noselect filename) + (solver-gen-object (string-trim (buffer-string))))) + +(ert-deftest solutions () + ;; part 1 + (let ((max-specpdl-size 18000) + (max-lisp-eval-depth 18000)) + + (should + (= 3068 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "eg-in"))))) + (should + (= 3141 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "input"))))) + + ;; part 2 + (let* ((drops 1000000000000) + (quick-run 10000) + (max-period-window 3620) + (history-eg (apply #'vector + (nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*) + (solver-input-directions "eg-in"))))) + (history-my (apply #'vector + (nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*) + (solver-input-directions "input")))))) + (should (= 1514285714288 + (solver-height-reached drops history-eg + max-period-window))) + (should (= 1561739130391 + (solver-height-reached drops history-my + max-period-window)))))) diff --git a/AoC2022/makefile b/AoC2022/makefile index d30a711..95062ff 100644 --- a/AoC2022/makefile +++ b/AoC2022/makefile @@ -9,7 +9,7 @@ clean: emacs: ${PWD}/solver.el - cd ${PWD} && emacs -batch -l ert -l solver.el -f ert-run-tests-batch-and-exit + cd ${PWD} && emacs -batch -l ert -l solver.elc -f ert-run-tests-batch-and-exit lisp: ${PWD}/solver.lisp cd ${PWD} && time sbcl --load ~/.sbclrc --load solver.lisp --eval '(fiveam:run-all-tests)' --non-interactive |