aboutsummaryrefslogtreecommitdiffstats
path: root/AoC2022/11/eg-in
blob: dc98f0ba298712f0d5f7dac19474af1464bd116b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Monkey 0:
  Starting items: 79, 98
  Operation: new = old * 19
  Test: divisible by 23
    If true: throw to monkey 2
    If false: throw to monkey 3

Monkey 1:
  Starting items: 54, 65, 75, 74
  Operation: new = old + 6
  Test: divisible by 19
    If true: throw to monkey 2
    If false: throw to monkey 0

Monkey 2:
  Starting items: 79, 60, 97
  Operation: new = old * old
  Test: divisible by 13
    If true: throw to monkey 1
    If false: throw to monkey 3

Monkey 3:
  Starting items: 74
  Operation: new = old + 3
  Test: divisible by 17
    If true: throw to monkey 0
    If false: throw to monkey 1
/* Comment */ .highlight .err { color: #FF5370 } /* Error */ .highlight .esc { color: #89DDFF } /* Escape */ .highlight .g { color: #EEFFFF } /* Generic */ .highlight .k { color: #BB80B3 } /* Keyword */ .highlight .l { color: #C3E88D } /* Literal */ .highlight .n { color: #EEFFFF } /* Name */ .highlight .o { color: #89DDFF } /* Operator */ .highlight .p { color: #89DDFF } /* Punctuation */ .highlight .ch { color: #546E7A; font-style: italic } /* Comment.Hashbang */ .highlight .cm { color: #546E7A; font-style: italic } /* Comment.Multiline */ .highlight .cp { color: #546E7A; font-style: italic } /* Comment.Preproc */ .highlight .cpf { color: #546E7A; font-style: italic } /* Comment.PreprocFile */ .highlight .c1 { color: #546E7A; font-style: italic } /* Comment.Single */ .highlight .cs { color: #546E7A; font-style: italic } /* Comment.Special */ .highlight .gd { color: #FF5370 } /* Generic.Deleted */ .highlight .ge { color: #89DDFF } /* Generic.Emph */ .highlight .ges { color: #FFCB6B } /* Generic.EmphStrong */ .highlight .gr { color: #FF5370 } /* Generic.Error */ .highlight .gh { color: #C3E88D } /* Generic.Heading */ .highlight .gi { color: #C3E88D } /* Generic.Inserted */ .highlight .go { color: #546E7A } /* Generic.Output */ .highlight .gp { color: #FFCB6B } /* Generic.Prompt */ .highlight .gs { color: #FF5370 } /* Generic.Strong */ .highlight .gu { color: #89DDFF } /* Generic.Subheading */ .highlight .gt { color: #FF5370 } /* Generic.Traceback */ .highlight .kc { color: #89DDFF } /* Keyword.Constant */ .highlight .kd { color: #BB80B3 } /* Keyword.Declaration */ .highlight .kn { color: #89DDFF; font-style: italic } /* Keyword.Namespace */ .highlight .kp { color: #89DDFF } /* Keyword.Pseudo */ .highlight .kr { color: #BB80B3 } /* Keyword.Reserved */ .highlight .kt { color: #BB80B3 } /* Keyword.Type */ .highlight .ld { color: #C3E88D } /* Literal.Date */ .highlight .m { color: #F78C6C } /* Literal.Number */ .highlight .s { color: #C3E88D } /* Literal.String */ .highlight .na { color: #BB80B3 } /* Name.Attribute */ .highlight .nb { color: #82AAFF } /* Name.Builtin */ .highlight .nc { color: #FFCB6B } /* Name.Class */ .highlight .no { color: #EEFFFF } /* Name.Constant */ .highlight .nd { color: #82AAFF } /* Name.Decorator */ .highlight .ni { color: #89DDFF } /* Name.Entity */ .highlight .ne { color: #FFCB6B } /* Name.Exception */ .highlight .nf { color: #82AAFF } /* Name.Function */ .highlight .nl { color: #82AAFF } /* Name.Label */ .highlight .nn { color: #FFCB6B } /* Name.Namespace */ .highlight .nx { color: #EEFFFF } /* Name.Other */ .highlight .py { color: #FFCB6B } /* Name.Property */ .highlight .nt { color: #FF5370 } /* Name.Tag */ .highlight .nv { color: #89DDFF } /* Name.Variable */ .highlight .ow { color: #89DDFF; font-style: italic } /* Operator.Word */ .highlight .pm { color: #89DDFF } /* Punctuation.Marker */ .highlight .w { color: #EEFFFF } /* Text.Whitespace */ .highlight .mb { color: #F78C6C } /* Literal.Number.Bin */ .highlight .mf { color: #F78C6C } /* Literal.Number.Float */ .highlight .mh { color: #F78C6C } /* Literal.Number.Hex */ .highlight .mi { color: #F78C6C } /* Literal.Number.Integer */ .highlight .mo { color: #F78C6C } /* Literal.Number.Oct */ .highlight .sa { color: #BB80B3 } /* Literal.String.Affix */ .highlight .sb { color: #C3E88D } /* Literal.String.Backtick */ .highlight .sc { color: #C3E88D } /* Literal.String.Char */ .highlight .dl { color: #EEFFFF } /* Literal.String.Delimiter */ .highlight .sd { color: #546E7A; font-style: italic } /* Literal.String.Doc */ .highlight .s2 { color: #C3E88D } /* Literal.String.Double */ .highlight .se { color: #EEFFFF } /* Literal.String.Escape */ .highlight .sh { color: #C3E88D } /* Literal.String.Heredoc */ .highlight .si { color: #89DDFF } /* Literal.String.Interpol */ .highlight .sx { color: #C3E88D } /* Literal.String.Other */ .highlight .sr { color: #89DDFF } /* Literal.String.Regex */ .highlight .s1 { color: #C3E88D } /* Literal.String.Single */ .highlight .ss { color: #89DDFF } /* Literal.String.Symbol */ .highlight .bp { color: #89DDFF } /* Name.Builtin.Pseudo */ .highlight .fm { color: #82AAFF } /* Name.Function.Magic */ .highlight .vc { color: #89DDFF } /* Name.Variable.Class */ .highlight .vg { color: #89DDFF } /* Name.Variable.Global */ .highlight .vi { color: #89DDFF } /* Name.Variable.Instance */ .highlight .vm { color: #82AAFF } /* Name.Variable.Magic */ .highlight .il { color: #F78C6C } /* Literal.Number.Integer.Long */
(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)))