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

(defun parse-instructions (str &optional (start 0))
  (multiple-value-bind (action str-pos)
      (case (aref str start)
        (#\R 'right)
        (#\L 'left)
        (t (parse-integer str :start start :junk-allowed t)))
    (let ((next (or str-pos (1+ start))))
      (if (= next (length str))
          (list action)
          (cons action (parse-instructions str next))))))

(defun create-field (filename)
  (let* ((data (uiop:read-file-lines filename))
         (map (butlast data 2))
         (instructions (car (last data)))
         (rows (length map))
         (columns (loop for r in map maximize (length r)))
         (field (make-array (list rows columns) :initial-element nil)))
    (loop for row in map
          for i from 0
          do (loop for entry across row
                   for j from 0
                   do (setf (aref field i j)
                            (ecase entry
                              (#\. 'free)
                              (#\# 'wall)
                              (#\Space nil)))))
    (list field (parse-instructions instructions))))

(defstruct state
  x-pos y-pos direction)

(defun wrap-step (state field)
  (destructuring-bind (height width) (array-dimensions field)
    (with-slots (direction x-pos y-pos) state
      (destructuring-bind (new-x new-y)
          (ecase direction
            (^ (list x-pos (mod (1- y-pos) height)))
            (v (list x-pos (mod (1+ y-pos) height)))
            (> (list (mod (1+ x-pos) width) y-pos))
            (< (list (mod (1- x-pos) width) y-pos)))
        (let ((new-state (make-state :x-pos new-x :y-pos new-y :direction direction)))
          (if (aref field new-y new-x)
              new-state
              (wrap-step new-state field)))))))

(defun new-direction (current-direction turn &aux (directions #(^ > v <)))
  (svref directions
         (mod
          (+
           (ecase turn
             (left -1)
             (right 1))
           (position current-direction directions))
          4)))

(defun walk (field state steps advance-fn)
  (if (zerop steps)
      state
      (let ((new-state (funcall advance-fn state field)))
        (with-slots (x-pos y-pos) new-state
            (ecase (aref field y-pos x-pos)
              (free (walk field new-state (1- steps) advance-fn))
              (wall state))))))

(defun traverse (field instructions origin advance-fn)
  (let ((state (copy-structure origin)))
    (dolist (move instructions state)
      (if (numberp move)
          (setf state (walk field state move advance-fn))
          (setf (state-direction state) (new-direction (state-direction state) move))))))

(defun decode-state (state)
  (with-slots (x-pos y-pos direction) state
    (+ (* 1000 (1+ y-pos))
       (* 4 (1+ x-pos))
       (ecase direction
         (> 0)
         (v 1)
         (< 2)
         (^ 3)))))

(defun get-start (field)
  (loop for i from 0
        until (aref field 0 i)
        finally (return i)))

(defun solver (filename advance-fn)
  (destructuring-bind (field instructions) (create-field filename)
    (decode-state
     (traverse field instructions (make-state :x-pos (get-start field) :y-pos 0 :direction '>) advance-fn))))

;;; part 2
;;; Cube face layout
;;;   1
;;; 234
;;;   56
;;; face coords
;;; 1=2 0
;;; 2=0 1
;;; 3=1 1
;;; 4=2 1
;;; 5=2 2
;;; 6=3 2

(defparameter *example-faces*
  '((1 . (2 0))
    (2 . (0 1))
    (3 . (1 1))
    (4 . (2 1))
    (5 . (2 2))
    (6 . (3 2))))


(defun coord->face (x-face y-face faces)
  (car (rassoc (list x-face y-face) faces :test #'equal)))

(defun face->coord (face faces)
  (cdr (assoc face faces :test #'eq)))

(defun reduced-coords (state face-length faces)
  (with-slots (x-pos y-pos) state
    (multiple-value-bind (x-face x-coord)
        (floor x-pos face-length)
      (multiple-value-bind (y-face y-coord)
          (floor y-pos face-length)
        (list (coord->face x-face y-face faces) x-coord y-coord)))))

(defun place-state (face x y direction face-length faces)
  (destructuring-bind (x-face y-face) (face->coord face faces)
    (make-state :x-pos (+ x (* x-face face-length))
                :y-pos (+ y (* y-face face-length)) :direction direction)))

;; The one direction from each face
;; The transitions are symetric on the position operation
;; ↱→↴
;; ↑↱1→↴
;;⬐234↴|
;;||↳56↲
;;|↳→⬏↑
;;↳→→→⬏

(defun compose (&rest funcs)
  (reduce (lambda (f g)
            (lambda (&rest args)
              (apply f (apply g args))))
          funcs))

(defun face-jump (face direction fl)
  "fl is face-length"
  (flet ((rot-ccw (x y) (list y  (- fl 1 x)))
         (rot-cw  (x y) (list (- fl 1 y) x))
         (cross-x (x y) (list (- fl 1 x) y))
         (cross-y (x y) (list x  (- fl 1 y))))
    (ecase face
      (1 (case direction
           (> (list 6 '< (compose #'rot-cw #'rot-cw #'cross-x)))
           (< (list 3 'v (compose #'rot-ccw #'cross-x)))
           (v (list 4 'v #'cross-y))
           (^ (list 2 'v (compose #'rot-cw #'rot-cw #'cross-y)))))
      (2 (case direction
           (> (list 3 '> #'cross-x))
           (< (list 6 '^ (compose #'rot-cw #'cross-x)))
           (v (list 5 '^ (compose #'rot-ccw #'rot-ccw #'cross-y)))
           (^ (list 1 'v (compose #'rot-cw #'rot-cw #'cross-y)))))
      (3 (case direction
           (> (list 4 '> #'cross-x))
           (< (list 2 '< #'cross-x))
           (v (list 5 '> (compose #'rot-ccw #'cross-y)))
           (^ (list 1 '> (compose #'rot-cw #'cross-y)))))
      (4 (case direction
           (> (list 6 'v (compose #'rot-cw #'cross-x)))
           (< (list 3 '< #'cross-x))
           (v (list 5 'v #'cross-y))
           (^ (list 1 '^ #'cross-y))))
      (5 (case direction
           (> (list 6 '> #'cross-x))
           (< (list 3 '^ (compose #'rot-cw #'cross-x)))
           (v (list 2 '^ (compose #'rot-cw #'rot-cw #'cross-y)))
           (^ (list 4 '^ #'cross-y))))
      (6 (case direction
           (> (list 1 '< (compose #'rot-ccw #'rot-ccw #'cross-x)))
           (< (list 5 '< #'cross-x))
           (v (list 2 '> (compose #'rot-ccw #'cross-y)))
           (^ (list 4 '< (compose #'rot-ccw #'cross-y))))))))

;;; Cube face layout
;;  36
;;  4
;; 15
;; 2

(defparameter *problem-faces*
  '((1 . (0 2))
    (2 . (0 3))
    (3 . (1 0))
    (4 . (1 1))
    (5 . (1 2))
    (6 . (2 0))))

(defun problem-face-jump (face direction fl)
  "fl is face-length"
  (flet ((rot-ccw (x y) (list y  (- fl 1 x)))
         (rot-cw  (x y) (list (- fl 1 y) x))
         (cross-x (x y) (list (- fl 1 x) y))
         (cross-y (x y) (list x  (- fl 1 y))))
    (ecase face
      (1 (case direction
           (> (list 5 '> #'cross-x))
           (< (list 3 '> (compose #'rot-cw #'rot-cw #'cross-x)))
           (v (list 2 'v #'cross-y))
           (^ (list 4 '> (compose #'rot-cw #'cross-y)))))
      (2 (case direction
           (> (list 5 '^ (compose #'rot-ccw #'cross-x)))
           (< (list 3 'v (compose #'rot-cw #'rot-cw #'rot-cw #'cross-x)))
           (v (list 6 'v #'cross-y))
           (^ (list 1 '^ #'cross-y))))
      (3 (case direction
           (> (list 6 '> #'cross-x))
           (< (list 1 '> (compose #'rot-cw #'rot-cw #'cross-x)))
           (v (list 4 'v #'cross-y))
           (^ (list 2 '> (compose #'rot-ccw #'rot-ccw #'rot-ccw #'cross-y)))))
      (4 (case direction
           (> (list 6 '^ (compose #'rot-ccw #'cross-x)))
           (< (list 1 'v (compose #'rot-ccw #'cross-x)))
           (v (list 5 'v #'cross-y))
           (^ (list 3 '^ #'cross-y))))
      (5 (case direction
           (> (list 6 '< (compose #'rot-ccw #'rot-ccw #'cross-x)))
           (< (list 1 '< #'cross-x))
           (v (list 2 '< (compose #'rot-cw #'cross-y)))
           (^ (list 4 '^ #'cross-y))))
      (6 (case direction
           (> (list 5 '< (compose #'rot-cw #'rot-cw #'cross-x)))
           (< (list 3 '< #'cross-x))
           (v (list 4 '< (compose #'rot-cw #'cross-y)))
           (^ (list 2 '^  #'cross-y)))))))

(defun cube-step (state face-length jumper faces)
  (destructuring-bind (face x-coord y-coord) (reduced-coords state face-length faces)
    (with-slots (direction) state
      (let ((new-x (+ x-coord (case direction (< -1) (> 1) (t 0))))
            (new-y (+ y-coord (case direction (^ -1) (v 1) (t 0)))))
        (if (and
             (< -1 new-x face-length)
             (< -1 new-y face-length))
            (place-state face new-x new-y direction face-length faces)
            (destructuring-bind (new-face new-direction pos-fn) (funcall jumper face direction face-length)
              (destructuring-bind (new-x new-y) (funcall pos-fn x-coord y-coord)
                (place-state new-face new-x new-y new-direction face-length faces))))))))

(defun copy-clear-field (field)
  (destructuring-bind (height width) (array-dimensions field)
    (let ((new-field (make-array (list height width) :initial-element nil)))
      (loop for y below height
            do (loop for x below width when (aref field y x) do (setf (aref new-field y x) 'free)))
      new-field)))

(fiveam:test preparation
  (fiveam:is (eq 'v (new-direction '> 'right)))
  (fiveam:is (eq '< (new-direction '^ 'left)))
  (fiveam:is (equal
              (parse-instructions "10R5L5R10L4R5L5" )
              '(10 RIGHT 5 LEFT 5 RIGHT 10 LEFT 4 RIGHT 5 LEFT 5)))

  (fiveam:is (= 1 (coord->face 2 0 *example-faces*)))
  (fiveam:is (= 6 (apply #'coord->face (append (face->coord 6 *example-faces*) (list *example-faces*))))))

(defun cube-stepper (jumper faces face-length)
  (lambda (state field) (declare (ignore field))
    (cube-step state face-length jumper faces)))

(fiveam:test around-cube
  (loop for (field jumper faces face-length) in (list (list (copy-clear-field (car (create-field "eg-in")))
                                                            #'face-jump *example-faces* 4)
                                                      (list (copy-clear-field (car (create-field "input")))
                                                            #'problem-face-jump *problem-faces* 50))
        do (flet ((check (origin moves advance-fn)
                    (equalp origin
                            (traverse field moves
                                      origin advance-fn))))
             (dotimes (i 6) ;; on each face
               (let ((origin (place-state (1+ i) 0 0 '^ face-length faces))
                     (stepper (cube-stepper jumper faces face-length)))
                 ;; around corners
                 (fiveam:is (check origin '(1 left 1 left 1 left) stepper))
                 ;; walk all dirs straight
                 (dolist (dir '(> v < ^))
                   (fiveam:is (check origin (list (* 4 face-length)) stepper))))))))

(fiveam:test solutions
  (fiveam:is (= 6032 (solver "eg-in" #'wrap-step)))
  (fiveam:is (= 159034 (solver "input" #'wrap-step)))
  ;; part 2
  (fiveam:is (= 5031 (solver "eg-in" (cube-stepper #'face-jump *example-faces* 4))))
  (fiveam:is (= 147245 (solver "input" (cube-stepper #'problem-face-jump *problem-faces* 50)))))