aoc18/day7.lisp -rw-r--r-- 3.9 KiB View raw
                                                                                
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
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
(in-package :aoc18)

(defstruct edge
  (from nil)
  (to nil))

(defun parse-edge (line)
  (cl-ppcre:register-groups-bind (from to)
      ("Step (.*) must be finished before step (.*) can begin." line)
    (make-edge :from from :to to)))

(defun parse-day7-input (path)
  (let ((map (make-hash-table :test #'equal))
	(starts nil)
	(edges (mapcar #'parse-edge (read-lines path))))
    (loop for edge in edges do
	 (push (edge-to edge) (gethash (edge-from edge) map nil)))
    (setf starts (set-difference
		  (remove-duplicates (mapcar #'edge-from edges) :test #'equal)
		  (remove-duplicates (mapcar #'edge-to edges) :test #'equal)
		  :test #'equal))
    (values map (sort starts #'string-lessp))))

(defun invert-rels (g)
  (let ((map (make-hash-table :test #'equal)))
    (loop for from being the hash-key of g using (hash-value tos) do
	 (loop for to in tos do
	      (push from (gethash to map))))
    map))

(defun next-ready (cand reqs done)
  (find-if
   #'(lambda (c) (empty-p (set-difference (gethash c reqs) done :test #'equal)))
   cand))

(defun solve-day7-part1 (g starts)
  (let ((visited nil)
	(reqs (invert-rels g)))
    (loop while (not (empty-p starts)) do
	 (let* ((next (next-ready starts reqs visited))
		(cand (sort (gethash next g) #'string-lessp)))
	   (setf starts (remove next starts :test #'equal))
	   (push next visited)
	   (when cand
	     (setf starts (sort (append starts cand) #'string-lessp)))))
    (apply #'concatenate 'string (reverse  visited))))

(test day7-part1
  (is (string-equal "GKPTSLUXBIJMNCADFOVHEWYQRZ"
		    (multiple-value-bind (g starts) (parse-day7-input "day7.input") (solve-day7-part1 g starts)))))

(defun time-needed (task)
  (apply #'+ (mapcar #'(lambda (c) (- c 4))
		     (mapcar #'char-code (coerce task 'list)))))

(defun timed-task (current-time task)
  (cons (+ current-time (time-needed task)) task))

(defun next-ready-many (cand reqs done max)
  (let ((ret nil))
    (loop for c in cand do
	 (let ((req (gethash c reqs)))
	   (when (null (set-difference req done :test #'equal))
	     (push c ret))))
    (let* ((sorted (sort ret #'string-lessp))
	   (end (min (length sorted) max)))
      (subseq sorted 0 end))))

(defun insert-timed-tasks (tasks pool current-time)
  (let ((timed (mapcar #'(lambda (x) (timed-task current-time x)) tasks)))
    (loop for i from 0 below (length pool) do
	 (when (not (aref pool i))
	   (setf (aref pool i) (pop timed))))))

(defun find-next-time (pool)
  (let* ((best most-positive-fixnum))
    (loop for timed-task across pool do
	 (when timed-task
	   (setf best (min best (car timed-task)))))
    (if (= most-positive-fixnum best) 0 best)))

(defun empty-pool-p (pool)
  (= (loop for task across pool when task counting t) 0))

(defun remove-matured (pool time)
  (let ((matured '()))
    (loop for i from 0 below (length pool) do
	 (let ((element (elt pool i)))
	   (when (and element (= time (car element)))
	     (push (cdr element) matured)
	     (setf (elt pool i) nil))))
    matured))

(defun solve-day7-part2 (g starts &optional (workers 2))
  (let* ((pool (make-array workers :initial-element nil))
	 (possible starts)
	 (current-time 0)
	 (visited nil)
	 (reqs (invert-rels g)))
    (loop while (or (not (empty-p possible)) (not (empty-pool-p pool))) do
	 (let* ((next-time (find-next-time pool))
		(matured (remove-matured pool next-time)))
	   (setf visited (append visited matured)
		 current-time next-time)
	   (loop for m in matured do
		(setf possible
		      (sort (remove-duplicates
			     (append possible (gethash m g)) :test #'equal)
			    #'string-lessp)))
	   (let* ((free-slots (count nil pool))
		  (cands (next-ready-many possible reqs visited free-slots)))
	     (insert-timed-tasks cands pool current-time)
	     (loop for c in cands do
		  (setf possible (remove c possible :test #'equal))))))
    current-time))

(test day7-part2
  (is (= 920 (multiple-value-bind (g starts)
		 (parse-day7-input "day7.input")
	       (solve-day7-part2 g starts 5)))))