From 739ee1ba536692b0220f7dde968f914f3ad8a2ef Mon Sep 17 00:00:00 2001 From: Peter Tillemans Date: Mon, 23 Dec 2024 13:17:39 +0100 Subject: [PATCH] solved day 23 --- src/2024/day23.lisp | 255 +++++++++++++++++++++++++++++++++++++ tests/2024/day23-test.lisp | 63 +++++++++ 2 files changed, 318 insertions(+) create mode 100644 src/2024/day23.lisp create mode 100644 tests/2024/day23-test.lisp diff --git a/src/2024/day23.lisp b/src/2024/day23.lisp new file mode 100644 index 0000000..fed2d56 --- /dev/null +++ b/src/2024/day23.lisp @@ -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)))) diff --git a/tests/2024/day23-test.lisp b/tests/2024/day23-test.lisp new file mode 100644 index 0000000..34c6aa2 --- /dev/null +++ b/tests/2024/day23-test.lisp @@ -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)))