(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 raise-history obstacles next-rock next-shift)
  (declare (optimize (speed 3)))
  (declare (type fixnum drops-left highpoint))
  (declare (type function next-rock))
  (if (zerop drops-left)
      raise-history
      ;; 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))
        (let ((new-high (max highpoint posible-high)))
          (vector-push new-high  raise-history)
          (solver (1- drops-left) new-high raise-history
                  ;; new-obstacles
                  (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"))))

(length (uiop:read-file-line "eg-in"))

(let ((drops 2065))
  (multiple-value-bind (hi hist) (solver drops 0 (make-array drops :initial-element 0 :fill-pointer 1) nil (gen-object *rocks*) (gen-object (uiop:read-file-line "eg-in")))
    (length hi)
    (find-period hi 620)))
(+ 22 37)
;; (require :sb-sprof)
;; (sb-sprof::start-profiling)
;; (sb-sprof:report :type :flat)
(defun occurrences (lst)
  (let ((table (make-hash-table :test #'eq)))
    (loop for e in lst
          do (incf (gethash e table 0)))
    (loop for k being the hash-key of table using (hash-value v)
          collect (cons k v))))
(* 59 35)
(length '(60 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53
   53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53 53
   53 53 53 53 53 53 53 53 53 ))
(defun find-period (history max-window)
  (let* ((len (1- (length history))))
    (loop for size from 1 to max-window
          for raises = (loop
                         for start from 0 to len by size
                         for end from size by size
                         collect (- (aref history (min end len)) (aref history start))
                         ;; collect (reduce #'+ (subseq history start (min end len)))
                         )
          for periods = (occurrences raises)
          when (<= (length periods) 3)
            collect (list size periods raises)
          ;; finally (return (list size periods raises))

                  ;; collect (list size (length periods) periods)
          )))