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(-)

(limited to 'AoC2022')

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