path: root/day19.lisp

(defstruct problem workflows parts)

(defstruct rule var op value res)

(defun read-rule (string)
  (if (not (position #\: string))
      (make-rule :res (subseq string 0 (1- (length string))))
      (multiple-value-bind (value ind) (parse-integer string :start 2 :junk-allowed t)
        (make-rule :var (aref string 0)
                   :op (aref string 1)
                   :value value
                   :res (subseq string (1+ ind))))))

(defun split-by-char (char string &key (start 0))
  (loop for i = start then (1+ j)
        as j = (position char string :start i)
        collect (subseq string i j)
        while j))

(defun read-workflow (string)
  (let* ((aux (position #\{ string))
         (name (subseq string 0 aux))
         (rules (mapcar #'read-rule (split-by-char #\, string :start (1+ aux)))))
    (cons name rules)))

(defun read-workflows (stream)
  (let ((ht (make-hash-table :test #'equalp))) 
    (loop for line = (read-line stream nil)
          while (> (length line) 0)
          do (let ((workflow (read-workflow line)))
               (setf (gethash (car workflow) ht) (cdr workflow))))
    ht))

(defun read-part (string)
  (loop for i = 0 then (1+ j)
        as j = (position #\= string :start i)
        while j
        collect (let ((num (parse-integer string :start (1+ j) :junk-allowed t))
                      (chr (aref string (1- j))))
                  (cons chr num))))

(defun read-parts (stream)
  (loop for line = (read-line stream nil)
        while line
        collect (read-part line)))

(defun read-problem (filespec)
  (with-open-file (stream filespec)
    (make-problem :workflows (read-workflows stream) :parts (read-parts stream))))

(defun part-accepted-p (part workflows &optional (entry "in"))
  (let ((rules (gethash entry workflows)))
    (loop for rule in rules
          as rvar = (rule-var rule)
          as rop = (rule-op rule)
          as rvalue = (rule-value rule)
          as rres = (rule-res rule)
          as pvalue = (assoc rvar part)
          if (or (not rvar)
                 (and (equal rop #\<) (< (cdr pvalue) rvalue))
                 (and (equal rop #\>) (> (cdr pvalue) rvalue)))
            return (cond ((equalp rres "A") t)
                         ((equalp rres "R") nil)
                         (t (part-accepted-p part workflows rres))))))

(defun solve1 (filespec)
  (let ((problem (read-problem filespec)))
    (loop for p in (problem-parts problem)
          if (part-accepted-p p (problem-workflows problem))
            sum (reduce #'+ (mapcar #'cdr p)))))

(defun range-size (range)
  (assert (<= (car range) (cdr range)))
  (1+ (- (cdr range) (car range))))

(defun subrange (value op range)
  (if
   (equal op #\<)
   (when (< (car range) value)
     (cons (car range) (min (cdr range) (1- value))))
   (when (> (cdr range) value)
     (cons (max (car range) (1+ value)) (cdr range)))))

(defun inv-subrange (value op range)
  (if
   (equal op #\<)
   (subrange (1- value) #\> range)
   (subrange (1+ value) #\< range)))

(defun range-combinations (workflows rulename ranges)
  (cond ((equalp rulename "A") (reduce #'* (mapcar #'range-size (mapcar #'cdr ranges))))
        ((equalp rulename "R") 0)
        (t (let ((rules (gethash rulename workflows)))
             (loop for rule in rules
                   as rvar = (rule-var rule)
                   as rop = (rule-op rule)
                   as rvalue = (rule-value rule)
                   as rres = (rule-res rule)
                   as range = (cdr (assoc rvar ranges))
                   as sub = (when rvalue (subrange rvalue rop range))
                   if sub 
                     sum (range-combinations workflows rres
                                             (mapcar
                                              (lambda (range)
                                                (if (equal rvar (car range))
                                                    (cons rvar sub)
                                                    range))
                                              ranges))
                   if (not rvar)
                     sum (range-combinations workflows rres ranges)
                   ;; update subrange
                   do (when rvar
                        (setf ranges (copy-tree ranges))
                        (setf (cdr (assoc rvar ranges)) (inv-subrange rvalue rop range))))))))

(defun solve2 (filespec)
  (let* ((problem (read-problem filespec))
         (workflows (problem-workflows problem)))
    (range-combinations workflows "in"
                        '((#\x . (1 . 4000))
                          (#\m . (1 . 4000))
                          (#\a . (1 . 4000))
                          (#\s . (1 . 4000))))))

(print (solve1 "data/19/example.txt")) ;; 19114
(print (solve1 "data/19/input.txt"))   ;; 495298
(print (solve2 "data/19/example.txt")) ;; 167409079868000
(print (solve2 "data/19/input.txt"))   ;; 132186256794011