day-14.lisp

(defpackage :advent.2019.14
  (:use :cl :alexandria :cl-ppcre)
  (:import-from :series #:collect #:map-fn #:scan-stream))

(in-package :advent.2019.14)

(defun parse-reactions (stream)
  (labels ((reaction (line)
	     (destructuring-bind (in out) (split " => " line)
	       (mapcar #'compound (list* out (split ", " in)))))
	   (compound (s)
	     (register-groups-bind (amount (#'intern unit)) ("(\\d+) (\\w+)" s)
	       (export unit *package*)
	       (cons  unit (parse-integer amount)))))
    (collect 'list (map-fn t #'reaction (scan-stream stream #'read-line)))))

(defmacro with-rule ((unit quantity deps) rule &body body)
  (loop
     for s in (list unit quantity deps)
     for i = (or (null s) (starts-with #\_ (string s)))
     for v = (if i (copy-symbol s) s)
     collect v into variables
     when i collect v into ignored
     finally 
       (return 
	 (destructuring-bind (unit quantity deps) variables
	   `(destructuring-bind ((,unit . ,quantity) . ,deps) ,rule
	      ,@(and ignored `((declare (ignore ,@ignored))))
	      ,@body)))))

(defmacro quantity (unit state)
  `(gethash ,unit ,state 0))

(defmacro state (&rest plist)
  `(plist-hash-table (list ,@plist)))

(defun cleanup (hash)
  (maphash (lambda (u q) (when (zerop q) (remhash u hash))) hash))

(defun show (state)
  (print (hash-table-plist state)))

(defun backward-apply-rule (state rule)
  (with-rule (u q deps) rule
    (let ((avail (quantity u state)))
      (dotimes (i (if (> q avail) 1 (floor avail q)) (cleanup state))
	(decf (quantity u state) q)
	(loop for (u . q) in deps do (incf (quantity u state) q))))))

(defun find-rules (unit rules)
  (remove unit rules :test-not #'eq :key #'caar))

(defun rule-quantity (rule)
  (with-rule (_ q _) rule q))

(defun backward-sort-rules (state rules &aux waste normal)
  (maphash (lambda (unit quantity)
	     (when (plusp quantity)
	       (dolist (rule (find-rules unit rules))
		 (with-rule (_ need _) rule
		   (if (> need quantity)
		       (push rule waste)
		       (push rule normal))))))
	   state)
  (nconc (sort normal #'> :key #'rule-quantity)
	 (sort waste #'< :key #'rule-quantity)))

(defun backward (state rules callback)
  (declare (type function callback) (optimize (speed 3)))
  (when-let (rule (first (backward-sort-rules state rules)))
    (funcall callback (backward-apply-rule state rule))))

(defun visit (state rules next cb sp)
  (declare (type function cb sp next) (optimize (speed 3)))
  (flet ((visit% (s) (visit s rules next cb sp)))
    (if (funcall sp state)
	(funcall cb state)
	(funcall next state rules #'visit%))))

(defun solve/1 (rules &optional (state (state 'fuel 1)))
  (block nil
    (flet ((solutionp (state)
	     (loop
		for u being the hash-keys of state using (hash-value q)
		always (case u (ore (plusp q)) (t (minusp q)))))
	   (leaf (state) (return (quantity 'ore state))))
      (visit state rules #'backward #'leaf #'solutionp))))

(solve/1 *test* (state 'fuel 1)) 

(solve/1 (with-open-file (in #P"14.in") (parse-reactions in)) (state 'fuel 1))
198984

(floor 1000000000000 198984)
5025529

(solve/1 (with-open-file (in #P"14.in") (parse-reactions in))
	 (state 'fuel 5025529))

=> 656097240338

(defvar *step1* (copy-hash-table *))

(floor (- (* 5025529 (/ 1000000000000 656097240338))
	  5025529))

2634202
314584285461/328048620169

(defmacro state* (original &rest more)
  (with-gensyms (cp k v)
    `(let ((,cp (copy-hash-table ,original)))
       (prog1 ,cp
	 (maphash (lambda (,k ,v) (setf (gethash ,k ,cp) ,v))
		  (state ,@more))))))

(solve/1 (with-open-file (in #P"14.in") (parse-reactions in))
	 (state* *step1* 'fuel 2634202))

999999830210

(solve/1 (with-open-file (in #P"14.in") (parse-reactions in))
	 (state* *step2* 'fuel 1))

999999960130
T

(solve/1 (with-open-file (in #P"14.in") (parse-reactions in))
	 (state* *step2* 'fuel 2))
1000000107196
T

(+ 5025529 1 2634202)
7659732