solved day 23

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))))

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)))