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


(defun distance-1 (a b)
  (apply #'+
         (mapcar (lambda (e1 e2)
                   (abs (- e1 e2))) a b)))

(defun boundary-conditions (width height)
  "The boundary is a wall meaning 0 & (N-1) are never occupied."
  (lambda (x y dir)
    (list
     dir
     (cond
       ((zerop x) (- width 2))
       ((= x (- width 1)) 1)
       (x))
     (cond
       ((zerop y) (- height 2))
       ((= y (- height 1)) 1)
       (y)))))

(defun wall-p (width height)
  (lambda (point)
    (destructuring-bind (x y) point
      (cond
        ;; not entry - exit
        ((or (and (= x 1) (zerop y))
             (and (= x (- width 2)) (= y (1- height))))
         nil)
        ;; yes wall or out of map
        ((or (<= x 0) (<= y 0)
             (>= x (1- width))
             (>= y (1- height))))))))

(fiveam:test boundaries
  (let ((bc (boundary-conditions 6 9)))
    (fiveam:is (equal (funcall bc 5 3 t) '(t 1 3)))
    (fiveam:is (equal (funcall bc 5 8 t) '(t 1 1)))
    (fiveam:is (equal (funcall bc 0 8 t) '(t 4 1)))))

(defstruct valley
  blizzards
  boundaries
  wallp
  size)

(defun data-input (filename)
  (let* ((lines (uiop:read-file-lines filename))
         (width (length (car lines)))
         (height (length lines)))
    (make-valley
     :blizzards
     (loop for row in lines
           and y from 0
           nconc (loop for place across row
                       and x from 0
                       unless (or (eq #\# place) (eq #\. place))
                         collect (list (ecase place
                                         (#\> '>)
                                         (#\< '<)
                                         (#\v 'v)
                                         (#\^ '^))
                                       x y)))
     :boundaries (boundary-conditions width height)
     :wallp (wall-p width height)
     :size (list width height))))

(defun evolve (valley)
  (with-slots (blizzards boundaries) valley
    (mapcar
     (lambda (blizzard)
       (trivia:match blizzard
         ((list '> x y) (funcall boundaries (1+ x) y '>))
         ((list '< x y) (funcall boundaries (1- x) y '<))
         ((list 'v x y) (funcall boundaries x (1+ y) 'v))
         ((list '^ x y) (funcall boundaries x (1- y) '^))))
     blizzards)))


(defun elf-moves (elf valley)
  (with-slots (blizzards wallp) valley
    (destructuring-bind (x y) elf
      (arrows:-<>
       (list (list (1+ x)    y)
             (list x     (1+ y))
             (list (1- x)    y)
             (list x     (1- y))
             (list x         y))
       (delete-if wallp <>)
       (set-difference <> (mapcar #'cdr blizzards) :test #'equal)))))

(defun cutoff-distance (positions goal)
  (loop for p in positions
        for dist = (distance-1 goal p)
        maximize dist into ma
        minimize dist into mi
        finally (return (values (max (ceiling (+ ma mi) 2)
                                     (* 1.2 mi)
                                     (* 0.8 ma)
                                     30)
                                mi ma))))

(defun discard-hopeless-positions (positions goal cutoff-distance)
  (delete-if (lambda (p) (< cutoff-distance (distance-1 goal p))) positions))

(defun time-step! (time-left walkers goal valley)
  (if (or (zerop time-left) (member goal walkers :test #'equal))
      time-left
      (progn
        (setf (valley-blizzards valley) (evolve valley))
        (let* ((new-positions (reduce
                               (lambda (options point)
                                 (union options (elf-moves point valley) :test #'equal))
                               walkers
                               :initial-value nil))
               (shortened-positions (discard-hopeless-positions new-positions goal
                                                                (cutoff-distance new-positions goal))))
          (time-step! (1- time-left)
                      shortened-positions
                      goal valley)))))

(defun solver (filename repeats)
  (let ((valley (data-input filename)))
    (destructuring-bind (width height) (valley-size valley)
      (let ((exit (list (- width 2) (1- height)))
            (start (list 1 0))
            (max-time 500))
        (loop for (start goal) on (loop with l = (list start exit)
                                        repeat repeats
                                        append l)
              while goal
              sum (- max-time (time-step! max-time (list start) goal valley)))))))

(fiveam:test solutions
  (fiveam:is (= 18 (solver "eg-in" 1)))
  (fiveam:is (= 299 (solver "input" 1)))
  (fiveam:is (= 54 (solver "eg-in" 2)))
  (fiveam:is (= 899 (solver "input" 2))))