(ql:quickload '(:fiveam :uiop :arrows))

(defconstant +chamber-width+ (the fixnum 7))

(defun point (x y)
  (+ x (* y +chamber-width+)))

(defun coords (point)
  (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))
          (list (point 1 0)
                (point 0 1) (point 1 1) (point 2 1)
                (point 1 2))
          (list (point 0 0) (point 1 0) (point 2 0)
                (point 2 1)
                (point 2 2))
          (list (point 0 0) (point 0 1) (point 0 2) (point 0 3))
          (list (point 0 0) (point 1 0)
                (point 0 1) (point 1 1))))

(defun left (point) (1- point))
(defun right (point) (1+ point))
(defun down (point) (- point +chamber-width+))

(defun no-collision-move (object direction obstacles)
  (declare (optimize (speed 3)))
  (mapcar
   (lambda (current)
     (let ((next (funcall
                  (ecase direction
                    (#\> #'right)
                    (#\< #'left)
                    (#\v #'down))
                  current)))
       (multiple-value-bind (y2 x2) (coords 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))
    (lambda ()
      (prog1 (aref seq index)
        (setf index (mod (1+ index) len))))))

(defun place-rock (rock highpoint)
  (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 (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 rock (funcall next-shift) chamber)
    (if done-falling-p
        (values (append new-place chamber) (highpoint new-place))
        (simulate chamber new-place next-shift))))


(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)
      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
   (= 3068 (solver 2022 0 nil (gen-object *rocks*) (gen-object (uiop:read-file-line "eg-in")))))
  (fiveam:is
   (= 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))