From fd4cadde61979c4fc35223c1ede2025acdd7da4a Mon Sep 17 00:00:00 2001
From: Oscar Najera <hi@oscarnajera.com>
Date: Fri, 6 Jan 2023 18:21:15 +0100
Subject: some typing hoping speedup
---
AoC2022/17/solver.lisp | 96 +++++++++++++++++++++++++++++++++++---------------
1 file changed, 67 insertions(+), 29 deletions(-)
diff --git a/AoC2022/17/solver.lisp b/AoC2022/17/solver.lisp
index 0be6c02..bad968a 100644
--- a/AoC2022/17/solver.lisp
+++ b/AoC2022/17/solver.lisp
@@ -1,12 +1,14 @@
(ql:quickload '(:fiveam :uiop :arrows))
-(defparameter *chamber-width* 7)
+(defconstant +chamber-width+ (the fixnum 7))
(defun point (x y)
- (+ x (* y *chamber-width*)))
+ (+ x (* y +chamber-width+)))
(defun coords (point)
- (floor point *chamber-width*))
+ (declare (optimize (speed 3)))
+ (declare (type fixnum point))
+ (floor point +chamber-width+))
(defparameter *rocks*
(vector (list (point 0 0) (point 1 0) (point 2 0) (point 3 0))
@@ -22,9 +24,10 @@
(defun left (point) (1- point))
(defun right (point) (1+ point))
-(defun down (point) (- point *chamber-width*))
+(defun down (point) (- point +chamber-width+))
(defun no-collision-move (object direction obstacles)
+ (declare (optimize (speed 3)))
(mapcar
(lambda (current)
(let ((next (funcall
@@ -34,14 +37,21 @@
(#\v #'down))
current)))
(multiple-value-bind (y2 x2) (coords next)
- (and (>= y2 0)
- ;; no rolling boundaries
- (multiple-value-bind (y x) (coords current)
- (= 1 (+ (abs (- x x2)) (abs (- y y2)))))
- (not (member next obstacles :test #'=))
- next))))
+ (declare (type fixnum y2 x2))
+ (if (and (>= y2 0)
+ ;; no rolling boundaries
+ (multiple-value-bind (y x) (coords current)
+ (declare (type fixnum y x))
+ (= 1 (+ (abs (- x x2)) (abs (- y y2)))))
+ (not (member next obstacles :test #'eq)))
+ next (return-from no-collision-move object)))))
object))
+(fiveam:test moves
+ (fiveam:is (equal '(6) (no-collision-move '(6) #\v nil)))
+ (fiveam:is (equal '(6) (no-collision-move '(6) #\> nil)))
+ (fiveam:is (equal '(6) (no-collision-move '(6) #\< '(5)))))
+
(defun gen-object (seq)
(let ((len (length seq))
(index 0))
@@ -50,36 +60,51 @@
(setf index (mod (1+ index) len))))))
(defun place-rock (rock highpoint)
- (let ((left-pad 2))
- (mapcar (lambda (point) (+ point left-pad (* *chamber-width* highpoint))) rock)))
-
-(defun advance (chamber next-move rock)
- (let ((next-place (no-collision-move rock next-move chamber)))
- (if (every #'integerp next-place)
- next-place rock)))
+ (declare (optimize (speed 3)))
+ (declare (type fixnum highpoint))
+ (let ((left-pad 2)
+ (altitude (* +chamber-width+ highpoint)))
+ (declare (type fixnum altitude))
+ (mapcar (lambda (point)
+ (declare (type fixnum point))
+ (the fixnum (+ point left-pad altitude))) rock)))
-(defun next-move (chamber next-move rock)
- (let* ((shift (advance chamber next-move rock))
- (drop (advance chamber #\v shift)))
+(defun next-move (rock next-move obstacles)
+ (let* ((shift (no-collision-move rock next-move obstacles))
+ (drop (no-collision-move shift #\v obstacles)))
(values drop (equal shift drop))))
+(defun highpoint (obstacles)
+ (1+ (coords (reduce #'max obstacles))))
+
(defun simulate (chamber rock next-shift)
+ (declare (optimize (speed 3)))
+ (declare (type function next-shift))
(multiple-value-bind (new-place done-falling-p)
- (next-move chamber (funcall next-shift) rock)
+ (next-move rock (funcall next-shift) chamber)
(if done-falling-p
- (append new-place chamber)
+ (values (append new-place chamber) (highpoint new-place))
(simulate chamber new-place next-shift))))
-(defun highpoint (obstacles)
- (1+ (coords (reduce #'max obstacles))))
(defun solver (drops-left highpoint obstacles next-rock next-shift)
+ (declare (optimize (speed 3)))
+ (declare (type fixnum drops-left highpoint))
+ (declare (type function next-rock))
(if (zerop drops-left)
- (values highpoint obstacles)
- (let ((obstacles (simulate obstacles
- (place-rock (funcall next-rock) (+ highpoint 3))
- next-shift)))
- (solver (1- drops-left) (highpoint obstacles) obstacles next-rock next-shift))))
+ ;; (values highpoint obstacles)
+ highpoint
+ (multiple-value-bind (new-obstacles posible-high)
+ (simulate obstacles
+ (place-rock (funcall next-rock) (the fixnum (+ highpoint 3)))
+ next-shift)
+
+ (declare (type fixnum posible-high))
+ (solver (1- drops-left) (max highpoint posible-high)
+ (if (zerop (mod drops-left 100)) ;; arbitrarily chop list
+ (subseq new-obstacles 0 (min 128 (length new-obstacles)))
+ new-obstacles)
+ next-rock next-shift))))
(fiveam:test solutions
(fiveam:is
@@ -88,3 +113,16 @@
(= 3141 (solver 2022 0 nil (gen-object *rocks*) (gen-object (uiop:read-file-line "input"))))))
;; (print (solver 1000000000000 0 nil (gen-object *rocks*) (gen-object (uiop:read-file-line "eg-in"))))
+(time (solver 40000 0 nil (gen-object *rocks*) (gen-object (uiop:read-file-line "eg-in"))))
+;; (require :sb-sprof)
+;; (sb-sprof::start-profiling)
+;; (sb-sprof:report :type :flat)
+
+;; (let ((a (make-array 5 :fill-pointer 0 :adjustable t)))
+;; (vector-push-extend 2 a)
+;; (vector-push-extend 6 a)
+;; (vector-push-extend 8 a)
+;; ;; (vector-push-extend 2 a)
+;; ;; (vector-push-extend 6 a)
+;; ;; (vector-push-extend 5 a)
+;; (vector-push-extend 5 a))
--
cgit v1.2.3