solved day 23
This commit is contained in:
parent
669e47f572
commit
739ee1ba53
2 changed files with 318 additions and 0 deletions
255
src/2024/day23.lisp
Normal file
255
src/2024/day23.lisp
Normal file
|
|
@ -0,0 +1,255 @@
|
|||
|
||||
(defpackage :aoc/2024/23
|
||||
(:use :cl :aoc :alexandria :arrow-macros :lla :queues)
|
||||
(:export
|
||||
#:sample-data
|
||||
#:sample-data2
|
||||
#:part1
|
||||
#:part2
|
||||
#:find-loops-n
|
||||
#:find-lan-party-groups
|
||||
#:format-groups
|
||||
#:find-historian-groups
|
||||
))
|
||||
|
||||
(in-package :aoc/2024/23)
|
||||
|
||||
|
||||
(defun parse-line (line)
|
||||
(let ((parts (ppcre:split "-" line)))
|
||||
(cons (first parts) (second parts))))
|
||||
|
||||
|
||||
(defun parse-input (lines)
|
||||
(mapcar #'parse-line lines))
|
||||
|
||||
(defparameter input-text (test-input 2024 23))
|
||||
(defparameter input-data (parse-input input-text))
|
||||
|
||||
(defparameter sample-text (aoc:split-lines "kh-tc
|
||||
qp-kh
|
||||
de-cg
|
||||
ka-co
|
||||
yn-aq
|
||||
qp-ub
|
||||
cg-tb
|
||||
vc-aq
|
||||
tb-ka
|
||||
wh-tc
|
||||
yn-cg
|
||||
kh-ub
|
||||
ta-co
|
||||
de-co
|
||||
tc-td
|
||||
tb-wq
|
||||
wh-td
|
||||
ta-ka
|
||||
td-qp
|
||||
aq-cg
|
||||
wq-ub
|
||||
ub-vc
|
||||
de-ta
|
||||
wq-aq
|
||||
wq-vc
|
||||
wh-yn
|
||||
ka-de
|
||||
kh-ta
|
||||
co-tc
|
||||
wh-qp
|
||||
tb-vc
|
||||
td-yn
|
||||
"))
|
||||
|
||||
|
||||
(defun edges-to-graph (data)
|
||||
(let ((node-map (make-hash-table :test #'equal)))
|
||||
(loop
|
||||
for edge in data
|
||||
do (let ((n1 (car edge))
|
||||
(n2 (cdr edge)))
|
||||
(setf
|
||||
(gethash n1 node-map)
|
||||
(cons n2 (gethash n1 node-map nil)))
|
||||
(setf
|
||||
(gethash n2 node-map)
|
||||
(cons n1 (gethash n2 node-map nil)))))
|
||||
node-map))
|
||||
|
||||
|
||||
(defun find-loops-n (network max-len)
|
||||
|
||||
(let ((nodes (hash-table-keys network))
|
||||
(seen (make-hash-table :test #'equal))
|
||||
(node-queue (make-queue :simple-queue))
|
||||
(loops nil))
|
||||
|
||||
(loop
|
||||
for root in nodes
|
||||
unless (gethash root seen)
|
||||
do
|
||||
(qpush
|
||||
node-queue
|
||||
(cons root (list (list root))))
|
||||
|
||||
(format t "nq: ~A~%" node-queue)
|
||||
|
||||
(loop
|
||||
for next = (qpop node-queue)
|
||||
for node = (car next)
|
||||
for paths = (cdr next)
|
||||
while next
|
||||
do (format t "next:~A, node: ~A, paths:~A, neighbors: ~A~%" next node paths (gethash node network))
|
||||
do (incf (gethash node seen 0))
|
||||
(loop
|
||||
for neighbor in (gethash node network)
|
||||
for next-paths = (cons
|
||||
(list neighbor)
|
||||
(loop
|
||||
for path in paths
|
||||
for np = (cons neighbor path)
|
||||
for start = (car (last path))
|
||||
for next-neighbors = (remove-if
|
||||
#'(lambda (n) (string-equal n node))
|
||||
(gethash neighbor network))
|
||||
do (format t " add ~A to path ~A, start ~A, next-neighbors:~A, loops:~A~%" neighbor path start next-neighbors (member start next-neighbors :test #'string-equal))
|
||||
if (member start next-neighbors :test #'string-equal)
|
||||
do (format t " *** found loop ~A~%" np)
|
||||
(if (= (length np) max-len)
|
||||
(progn
|
||||
(format t " *** pushed ~A to loops~%" np)
|
||||
(push np loops)))
|
||||
if (<= (length np) max-len)
|
||||
collect np
|
||||
))
|
||||
unless (gethash neighbor seen)
|
||||
do
|
||||
(format t "pushing ~A with ~A~%" neighbor next-paths)
|
||||
(qpush node-queue (cons neighbor next-paths)))
|
||||
))
|
||||
|
||||
loops
|
||||
))
|
||||
|
||||
(defun group-lessp (as bs)
|
||||
(loop
|
||||
for a in as
|
||||
for b in bs
|
||||
until (string-lessp a b)
|
||||
finally (return (string-lessp a b))))
|
||||
|
||||
(defun clean-groups (groups)
|
||||
(sort
|
||||
(remove-duplicates
|
||||
(loop
|
||||
for group in groups
|
||||
collect (sort (copy-seq group) #'string-lessp))
|
||||
:test #'equalp)
|
||||
#'group-lessp
|
||||
))
|
||||
|
||||
(defun format-groups (groups)
|
||||
(format nil "~{~{~A~^,~}~%~}" groups)
|
||||
)
|
||||
|
||||
(defun group-has-computer-with-prefix (group prefix)
|
||||
(loop
|
||||
for computer in group
|
||||
thereis (uiop:string-prefix-p prefix computer)))
|
||||
|
||||
(defun find-groups-with-computer-with-prefix(groups prefix)
|
||||
(loop
|
||||
for group in groups
|
||||
if (group-has-computer-with-prefix group prefix)
|
||||
collect group))
|
||||
|
||||
(defun find-lan-party-groups (data)
|
||||
(-> data
|
||||
(edges-to-graph)
|
||||
(find-loops-n 3)
|
||||
(clean-groups)))
|
||||
|
||||
|
||||
(defun find-historian-groups (data)
|
||||
(let ((network (edges-to-graph data)))
|
||||
(clean-groups
|
||||
(loop
|
||||
for node in (hash-table-keys network)
|
||||
if (uiop:string-prefix-p "t" node) ;; could be historian
|
||||
append (loop
|
||||
for n1 in (gethash node network)
|
||||
append (loop
|
||||
for n2 in (gethash n1 network)
|
||||
unless (equal node n2)
|
||||
append (loop
|
||||
for n3 in (gethash n2 network)
|
||||
do (format t "~A ~A ~A ~A ~%" node n1 n2 n3)
|
||||
if (equal n3 node)
|
||||
collect (list node n1 n2))
|
||||
))))))
|
||||
|
||||
|
||||
(defun find-groups (data)
|
||||
(let ((network (edges-to-graph data)))
|
||||
(clean-groups
|
||||
(loop
|
||||
for node in (hash-table-keys network)
|
||||
do (format t "~A ~%" node)
|
||||
append (loop
|
||||
for n1 in (gethash node network)
|
||||
append (loop
|
||||
for n2 in (gethash n1 network)
|
||||
unless (member n2 (list node))
|
||||
append (loop
|
||||
for n3 in (gethash n2 network)
|
||||
if (equal n3 node)
|
||||
collect (list node n1 n2))
|
||||
))))))
|
||||
|
||||
(defun expand-group (network group)
|
||||
(let ((node (first group)))
|
||||
(loop
|
||||
for next in (gethash node network)
|
||||
for next-neighbors = (gethash next network)
|
||||
unless (member next group :test #'equal)
|
||||
if (loop
|
||||
for m in group
|
||||
always (member m next-neighbors :test #'equal))
|
||||
collect (append (list next) group)
|
||||
)))
|
||||
|
||||
(defun expand-groups (network groups)
|
||||
(clean-groups
|
||||
(loop for group in groups
|
||||
for egroup = (expand-group network group)
|
||||
if egroup
|
||||
append egroup)))
|
||||
|
||||
((defparameter sample-data
|
||||
(parse-input sample-text))
|
||||
|
||||
(defun part1 (data)
|
||||
(length (find-historian-groups data))))
|
||||
|
||||
(defun largest-group (data)
|
||||
(let ((network (edges-to-graph data))
|
||||
(seeds (find-groups data)))
|
||||
(loop
|
||||
for size from 3
|
||||
for last = groups
|
||||
for groups = (expand-groups network (or groups seeds))
|
||||
do (format t "~A : ~A~%" size (length groups))
|
||||
until (null groups)
|
||||
finally (return (first last)))))
|
||||
|
||||
(defun part2 (data)
|
||||
(format nil "~{~A~^,~}" (largest-group data)))
|
||||
|
||||
(defun solve-day ()
|
||||
(format t "part1: ~A~%" (part1 input-data))
|
||||
(format t "part2: ~A~%" (part2 input-data)))
|
||||
|
||||
(defun submit ()
|
||||
(let ((p1 (part1 input-data))
|
||||
(p2 (part2 input-data)))
|
||||
(if p1 (submit-part1 2024 23 p1))
|
||||
(if p2 (submit-part2 2024 23 p2))))
|
||||
63
tests/2024/day23-test.lisp
Normal file
63
tests/2024/day23-test.lisp
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
(defpackage :aoc/2024/23/tests
|
||||
(:use :cl :aoc :aoc/tests :aoc/2024/tests :parachute :aoc/2024/23))
|
||||
|
||||
(in-package :aoc/2024/23/tests)
|
||||
|
||||
(define-test suite-2024-23
|
||||
;:parent suite-2024
|
||||
)
|
||||
|
||||
(define-test test-find-loops-n
|
||||
:parent suite-2024-23
|
||||
|
||||
(let ((network (make-hash-table :test #'equal)))
|
||||
(setf (gethash "ab" network) '("cd" "ef"))
|
||||
(setf (gethash "cd" network) '("ab" "ef"))
|
||||
(setf (gethash "ef" network) '("ab" "cd"))
|
||||
(is equal '(("ab" "cd" "ef") ("cd" "ab" "ef")) (find-loops-n network 3))
|
||||
)
|
||||
)
|
||||
|
||||
(defparameter expected-groups "aq,cg,yn
|
||||
aq,vc,wq
|
||||
co,de,ka
|
||||
co,de,ta
|
||||
co,ka,ta
|
||||
de,ka,ta
|
||||
kh,qp,ub
|
||||
qp,td,wh
|
||||
tb,vc,wq
|
||||
tc,td,wh
|
||||
td,wh,yn
|
||||
ub,vc,wq")
|
||||
|
||||
(define-test test-find-groups
|
||||
:parent suite-2024-23
|
||||
|
||||
(is equal expected-groups (format-groups (find-lan-party-groups sample-data)))
|
||||
|
||||
)
|
||||
|
||||
(defparameter historian-groups "co,de,ta
|
||||
co,ka,ta
|
||||
de,ka,ta
|
||||
qp,td,wh
|
||||
tc,td,wh
|
||||
tb,vc,wq
|
||||
td,wh,yn
|
||||
")
|
||||
|
||||
(define-test test-historian-groups
|
||||
:parent suite-2024-23
|
||||
(is string-equal historian-groups (format-groups (find-historian-groups sample-data)))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define-test+run test-part1
|
||||
:parent suite-2024-23
|
||||
(is equal nil (part1 sample-data)))
|
||||
|
||||
(define-test+run test-part2
|
||||
:parent suite-2024-23
|
||||
(is equal nil (part2 sample-data)))
|
||||
Loading…
Reference in a new issue