(ql:quickload '(fiveam cl-ppcre uiop arrows))

(defun data (filename)
  (with-open-file (in filename)
    (loop for line = (read-line in nil nil)
          while line
          collect (cl-ppcre:register-groups-bind (val (#'parse-integer flow) others)
                      ("Valve (\\w+) has flow rate=(\\d+); tunnels? leads? to valves? (.+)" line)
                    `(,(intern val) ,flow ,@(mapcar #'intern (cl-ppcre:split ", " others)))))))

(defun next-steps (current graph paths)
  (flet ((appropriate (next)
           (and (not (gethash next paths)) ;; not visited
                (setf (gethash next paths) (cons next (gethash current paths))))))
    (remove-if-not #'appropriate
                   ;; name flow connections -> cddr
                   (cddr (assoc current graph :test #'eq)))))

(defun shortest-path (graph from to)
  (let ((paths (make-hash-table :test #'eq)))
    (setf (gethash from paths) (list from))
    (labels ((traverse (queue paths)
               (unless (null queue)
                 (let ((next (next-steps (car queue) graph paths)))
                   (unless (member to next :test #'eq)
                     (traverse (append (cdr queue) next) paths))))))
      (traverse (list from) paths))
    (gethash to paths)))

(defun worthwhile-graph (graph)
  (let ((interesting (remove-if #'zerop graph :key #'cadr)))
    (loop for (from flow) in (cons '(aa 0) interesting)
          for label from 0
          collect (apply #'list (ash 1 label) from flow
                         (loop for (to) in interesting
                               for target-label from 1
                               when (not (eq from to))
                                 collect (cons (ash 1 target-label) (1- (length (shortest-path graph from to)))))))))

(defun accumulated-flow (actor-paths)
  (reduce #'+ actor-paths :key #'caddr))

(defun max-possible-flow (graph actors open)
  (let ((actors-min-time-left (reduce #'max actors :key #'cadr)))
    (+ (accumulated-flow actors)
       (loop for (node name flow) in graph
             :when (not (logtest node open))
             :sum (* flow actors-min-time-left)))))

(defun traverse (graph actors open best-flow all-valves)
  (if (or (zerop (logxor open all-valves))
          (zerop (cadar actors))
          (< (max-possible-flow graph actors open) (accumulated-flow best-flow)))
      (mapcar (lambda (a) (cons (reverse (car a)) (cdr a))) actors)
      (destructuring-bind (current-actor . others) actors
        (destructuring-bind (path time-left previous-flow) current-actor
          (let ((next
                  (loop for (next-node . time-there) in (cdddr (assoc (car path) graph :test #'=))
                        :when (and (not (logtest next-node open))
                                   (let ((time-left (- time-left time-there 1)))
                                     (when (plusp time-left)
                                       (let* ((flow-there (caddr (assoc next-node graph :test #'=)))
                                              (next-flow (+ previous-flow (* flow-there time-left))))
                                         (cons next-node (list (list (cons next-node path) time-left next-flow)))))))
                          :collect it)))
            (if (null next)
                  ;; for performance reasons I don't understand separating this
                  ;; no-op option to move to next actor is faster that preparing
                  ;; the identity move within next before
                  ;; (format t "hit open ~a actors: ~a~%" open actors)
                  (traverse graph
                            (append others
                                    (list (list path 0 previous-flow)))
                            open best-flow all-valves)
                (reduce
                 (lambda (acc term)
                   (let* ((acc-flow (accumulated-flow acc))
                          (new-flow
                            (destructuring-bind (node . actors-next-move) term
                              (traverse graph
                                        (append (cdr actors) actors-next-move)
                                        (logior node open)
                                        acc all-valves))))
                     (if (> acc-flow (accumulated-flow new-flow))
                         acc new-flow)))
                 next
                 :initial-value best-flow)))))))

(defun solver (filename start-time actors)
  (let* ((action-graph (worthwhile-graph (data filename)))
         (actor (loop repeat actors collect `((1) ,start-time 0)))
         (all-valves (loop for (idx) in action-graph sum idx)))
    (traverse action-graph actor 1 nil all-valves)))

;; Auxiliary functions for inspection
(defun path->symbols (path graph)
  (loop for node in path
        collect (cadr (assoc node graph :test #'=))))

(defun path<-symbols (path graph)
  (loop for node in path
        collect (car (rassoc node graph :key #'car :test #'eq))))

(defun travel-time (path graph)
  (if (every #'symbolp path)
      (travel-time (path<-symbols path graph) graph)
      (loop for (from to) on path
            while to
            for neighbors = (cdddr (assoc from graph :test #'eq))
            for distance = (cdr (assoc to neighbors :test #'eq))
            sum (1+ distance) into runtime
            collect runtime)))

(defun path-release (path graph start-time)
  (if (every #'symbolp path)
      (path-release (path<-symbols path graph) graph start-time)
      (loop for (from to) on path
            for node-from = (assoc from graph) then node-to
            and node-to   = (assoc to graph)
            while node-to
            for neighbors = (cdddr node-from)
            for flow = (caddr node-to)
            for distance = (cdr (assoc to neighbors :test #'eq))
            sum (1+ distance) into runtime
            sum (* flow (- start-time runtime)) into release
            finally (return release))))

(defun many-path-release (paths graph start-time)
  (reduce #'+ paths
          :key (lambda (path) (path-release path graph start-time))))

(fiveam:test paths
  (let ((graph-eg (worthwhile-graph (data "eg-in")))
        (test-path '(1 8 32)))
    (arrows:->
     (path->symbols test-path graph-eg)
     (path<-symbols graph-eg)
     (equal test-path)
     (fiveam:is))
    (fiveam:is (equal (travel-time '(AA CC DD JJ) graph-eg) '(3 5 9)))

    (fiveam:is
     (= 1648 (path-release '(AA DD JJ BB CC HH EE) graph-eg 30)))
    (fiveam:is
     (= 1651 (path-release '(AA DD BB JJ HH EE CC) graph-eg 30)))
    (fiveam:is (= 480 (path-release '(AA DD) graph-eg 26)))
    (fiveam:is (= 560 (path-release '(AA DD) graph-eg 30)))
    (fiveam:is (= 546 (path-release '(AA DD EE) graph-eg 26)))
    (fiveam:is (= 313 (path-release '(AA DD HH EE) graph-eg 12)))
    (fiveam:is (= 312 (path-release '(AA DD EE HH) graph-eg 12))))
  (let ((graph-input (worthwhile-graph (data "input"))))
    (fiveam:is (= 2473 (many-path-release '((AA NU WK NC ZG EA CX QC) (AA RA XK YH NM YP XS)) graph-input 26)))
    (fiveam:is (= 2474 (many-path-release '((AA NU WK NC ZG EA CX QC) (AA XK YH NM YP XS)) graph-input 26)))))

(fiveam:test partial-sections
  (let* ((graph (worthwhile-graph (data "eg-in")))
         (path '(1 64 8 32 2 16 4)))
    (fiveam:is (= 1595 (path-release path graph 30)))
    (fiveam:is (equal '(3 7 12 19 23 26) (travel-time path graph)))
    (fiveam:is (= 78 (max-possible-flow graph (list (list path 26 0)) 111))))

  (let* ((graph (worthwhile-graph (data "input")))
         (path '(1 1024 32768 128 8192 2 2048 64 4096)))
    (list
     (fiveam:is (= 1754 (path-release path graph 30)))
     (fiveam:is (equal '(3 6 9 12 19 22 25 28) (travel-time path graph)))
     (fiveam:is (= 3588 (max-possible-flow graph (list (list path 26 0)) 111))))))

(fiveam:test solutions
  (fiveam:is
   (= 1651 (accumulated-flow (solver "eg-in" 30 1))))
  (fiveam:is
   (= 1754 (accumulated-flow (solver "input" 30 1))))
  (fiveam:is
   (= 1707 (accumulated-flow (solver "eg-in" 26 2))))
  (fiveam:is
   (= 2474 (accumulated-flow (solver "input" 26 2)))))

;; (require :sb-sprof)

;; (sb-sprof:with-profiling (:max-samples 1000
;;                           :report :flat
;;                           :loop t
;;                           :show-progress t)
;;    (solver "input" 19 2))

;; (time (solver "input" 19 2))
;; (length (worthwhile-graph (data "input")))

;; (loop for (name flow . neighbors) in (worthwhile-graph (data "input"))
;;       do (loop for (nn . dist) in neighbors
;;                do (format t "~a -> ~a [label=\"~d\"]~%" name nn dist)))