;; -*- lexical-binding: t; -*-
(require 'cl-lib)
(require 'seq)

(defconst solver-chamber-width 7)

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

(defun solver-coords (point)
  (list (floor point solver-chamber-width)
        (mod point solver-chamber-width)))

(defconst *rocks*
  (vector (list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0) (solver-point 3 0))
          (list (solver-point 1 0)
                (solver-point 0 1) (solver-point 1 1) (solver-point 2 1)
                (solver-point 1 2))
          (list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0)
                (solver-point 2 1)
                (solver-point 2 2))
          (list (solver-point 0 0) (solver-point 0 1) (solver-point 0 2) (solver-point 0 3))
          (list (solver-point 0 0) (solver-point 1 0)
                (solver-point 0 1) (solver-point 1 1))))

(cl-defun solver-no-collision-move (object direction obstacles)
  (mapcar
   (lambda (current)
     (let ((next (funcall
                  (cl-ecase direction
                    (?> #'1+)
                    (?< #'1-)
                    (?v (lambda (p) (- p solver-chamber-width))))
                  current)))
       (if (and (>= next 0)
                ;; no rolling boundaries
                (seq-let (y x) (solver-coords current)
                  (seq-let (y2 x2) (solver-coords next)
                    (= 1 (+ (abs (- x x2)) (abs (- y y2))))))
                (not (memq next obstacles)))
           next (cl-return-from solver-no-collision-move object))))
   object))

(defun solver-gen-object (seq)
  (let ((len (length seq))
        (index 0))
    (lambda ()
      (prog1 (elt seq index)
        (setf index (mod (1+ index) len))))))

(defun solver-place-rock (rock highpoint)
  (let ((left-pad 2)
        (altitude (* solver-chamber-width highpoint)))
    (mapcar (lambda (point)
              (+ point left-pad altitude))
            rock)))

(defun solver-next-move (rock next-move obstacles)
  (let* ((shift (solver-no-collision-move rock next-move obstacles))
         (drop (solver-no-collision-move shift ?v obstacles)))
    (cl-values drop (equal shift drop))))

(defun solver-highpoint (obstacles)
  (1+ (car (solver-coords (cl-reduce #'max obstacles)))))

(defun solver-simulate (chamber rock next-shift)
  (seq-let (new-place done-falling-p)
      (solver-next-move rock (funcall next-shift) chamber)
    (if done-falling-p
        (cl-values (append new-place chamber) (solver-highpoint new-place))
      (solver-simulate chamber new-place next-shift))))


(defun solver (drops-left highpoint raise-history obstacles next-rock next-shift)
  (if (zerop drops-left)
      raise-history
    (seq-let (new-obstacles posible-high)
        (solver-simulate obstacles
                         (solver-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
                    (seq-subseq new-obstacles 0 (min 128 (length new-obstacles)))
                  new-obstacles)
                next-rock next-shift)))))

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

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

(defun solver-find-period (history max-window)
  (let ((len (1- (length history))))
    (cl-loop for size from 1 to max-window
             for raises = (cl-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 = (solver-occurrences raises)
             for test = (and (<= (hash-table-count periods) 3)
                             (car (cl-find-if (lambda (f) (< 1 (cdr f))) (solver-to-alist periods))))
             until test
             finally (return (cl-values size test)))))

(defun solver-height-reached (max-drops history max-window)
  (seq-let (period block-height) (solver-find-period history max-window)
    (seq-let (cycles left) (list (floor max-drops period) (mod max-drops period))
      (let ((offset (aref history period))
            (remaining (- (aref history (+ left period)) (aref history period))))
        (+ offset (* (1- cycles) block-height) remaining)))))

(defun solver-input-directions (filename)
  (with-current-buffer (find-file-noselect filename)
    (solver-gen-object (string-trim (buffer-string)))))

(ert-deftest solutions ()
  ;; part 1
  (let ((max-specpdl-size 18000)
        (max-lisp-eval-depth 18000))

    (should
     (= 3068 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "eg-in")))))
    (should
     (= 3141 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "input")))))

    ;; part 2
    (let* ((drops 1000000000000)
           (quick-run 10000)
           (max-period-window 3620)
           (history-eg (apply #'vector
                              (nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*)
                                                (solver-input-directions "eg-in")))))
           (history-my (apply #'vector
                              (nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*)
                                                (solver-input-directions "input"))))))
      (should (= 1514285714288
                 (solver-height-reached drops history-eg
                                        max-period-window)))
      (should (= 1561739130391
                 (solver-height-reached drops history-my
                                        max-period-window))))))