aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorOscar Najera <hi@oscarnajera.com>2023-01-07 00:16:45 +0100
committerOscar Najera <hi@oscarnajera.com>2023-01-07 00:16:45 +0100
commitd606533fb72fe3df2c69f3df9f74c5a7ccdf6dd2 (patch)
tree8f01ea53d8c0fc5fb0bbfc9f0021c3c672fff425
parentb7ecf7861469c5eb8efccf82c449d60aae66b699 (diff)
downloadscratch-d606533fb72fe3df2c69f3df9f74c5a7ccdf6dd2.tar.gz
scratch-d606533fb72fe3df2c69f3df9f74c5a7ccdf6dd2.tar.bz2
scratch-d606533fb72fe3df2c69f3df9f74c5a7ccdf6dd2.zip
Day 17 do it in emacs too slow
-rw-r--r--AoC2022/17/solver.el148
-rw-r--r--AoC2022/makefile2
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