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

(defconstant +chamber-width+ 7)

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

(defun coords (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 no-collision-move (object direction obstacles)
  (mapcar
   (lambda (current)
     (let ((next (funcall
                  (ecase direction
                    (#\> #'1+)
                    (#\< #'1-)
                    (#\v #'(lambda (p) (- p +chamber-width+))))
                  current)))
       (if (and (>= next 0)
                ;; no rolling boundaries
                (multiple-value-bind (y x) (coords current)
                  (multiple-value-bind (y2 x2) (coords next)
                    (= 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)
  (let ((left-pad 2)
        (altitude (* +chamber-width+ highpoint)))
    (mapcar (lambda (point)
              (+ 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)
  (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)
  (if (zerop drops-left)
      raise-history
      (multiple-value-bind (new-obstacles posible-high)
          (simulate obstacles
                    (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
                      (subseq new-obstacles 0 (min 128 (length new-obstacles)))
                      new-obstacles)
                  next-rock next-shift)))))

(defun occurrences (lst)
  (let ((table (make-hash-table :test #'eq)))
    (loop for e in lst
          do (incf (gethash e table 0)))
    table))

(defun to-alist (table)
  (loop for k being the hash-key of table using (hash-value v)
        collect (cons k v)))

(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)))
          for periods = (occurrences raises)
          for test = (and (<= (hash-table-count periods) 3)
                          (car (find-if (lambda (f) (< 1 (cdr f))) (to-alist periods))))
          until test
          finally (return (values size test)))))

(defun height-reached (max-drops history max-window)
  (multiple-value-bind (period block-height) (find-period history max-window)
    (multiple-value-bind (cycles left) (floor max-drops period)
      (let ((offset (aref history period))
            (remaining (- (aref history (+ left period)) (aref history period))))
        (+ offset (* (1- cycles) block-height) remaining)))))

(fiveam:test solutions
  ;; part 1
  (fiveam:is
   (= 3068 (car (solver 2022 0 '(0) nil (gen-object *rocks*) (gen-object (uiop:read-file-line "eg-in"))))))
  (fiveam:is
   (= 3141 (car (solver 2022 0 '(0) nil (gen-object *rocks*) (gen-object (uiop:read-file-line "input"))))))

  ;; part 2
  (let* ((drops 1000000000000)
         (quick-run 10000)
         (max-period-window 3620)
         (history-eg (nreverse (solver quick-run 0 '(0) nil (gen-object *rocks*)
                                    (gen-object (uiop:read-file-line "eg-in")))))
         (history-my (nreverse (solver quick-run 0 '(0) nil (gen-object *rocks*)
                                    (gen-object (uiop:read-file-line "input"))))))
    (fiveam:is (= 1514285714288
                  (height-reached drops (make-array (length history-eg) :initial-contents history-eg)
                                  max-period-window)))
    (fiveam:is (= 1561739130391
                  (height-reached drops (make-array (length history-my) :initial-contents history-my)
                                  max-period-window)))))