Refactor 2023/25

- Use DEFINE-SOLUTION, DEFINE-TEST
iamFIREcracker · Feb 2, 2024 · eaeb362 · eaeb362
1 parent 64338f7
commit eaeb362
Show file tree

Hide file tree

Showing 3 changed files with 194 additions and 209 deletions.
diff --git a/src/2023/day25.lisp b/src/2023/day25.lisp
@@ -2,72 +2,50 @@
 (in-package :aoc/2023/25)
 
 
-(defun parse-connections (&optional (strings (uiop:read-file-lines #P"src/2023/day25.txt")))
+(defun parse-connections (&optional (strings (aoc::read-problem-input 2023 25)))
   (bnd1 (adj (make-hash-table))
     (dolist (s strings)
       (destructuring-bind (a . rest) (mapcar #'as-keyword (cl-ppcre:all-matches-as-strings "\\w+" s))
         (dolist (b rest)
           (push b (gethash a adj))
           (push a (gethash b adj)))))
     adj))
-#+#:excluded (parse-connections)
 
-(defun edges (adj)
-  (looping
-    (dohash (a connected adj)
-      (dolist (b connected)
-        (collect! (cons a b))))))
-#+#:excluded (length (edges (parse-connections)))
 
+(defun random-edge (nodes adj)
+  ;; TODO: is the below truly uniform?!
+  (bnd* ((a (random-elt nodes))
+         (b (random-elt (gethash a adj))))
+    (cons a b)))
 
-(defun karger-min-cut (adj)
-  (setf adj (copy-hash-table adj))
-  (bnd1 (contracted-into)
-    (labels ((contract (a b)
-               (dolist (c (gethash b adj))
-                 (removef (gethash c adj) b)
-                 (unless (eq c a)
-                   (push c (gethash a adj))
-                   ;; TODO what if c was already linked to a?
-                   (push a (gethash c adj))))
-               (remhash b adj)
-               (setf  (getf contracted-into a) (append (getf contracted-into a)
-                                                       (list b)
-                                                       (getf contracted-into b))) ))
-      (while (> (hash-table-count adj) 2)
-        (bnd* (((a . b) (random-elt (edges adj))))
-          (contract a b))))
-    (destructuring-bind (a b) (hash-table-keys adj)
-      (values (cons a (getf contracted-into a))
-              (cons b (getf contracted-into b))
-              (length (gethash a adj))))))
-(defun karger-min-cut (adj)
+
+(defun karger-min-cut (&optional (adj (parse-connections)))
   (setf adj (copy-hash-table adj))
-  (bnd1 (contracted-into)
+  (bnd* ((nodes (hash-table-keys adj))
+         contracted-into)
     (labels ((contract (a b)
                (dolist (c (gethash b adj))
                  (removef (gethash c adj) b)
                  (unless (eq c a)
                    (push c (gethash a adj))
-                   ;; TODO what if c was already linked to a?
                    (push a (gethash c adj))))
                (remhash b adj)
-               (setf  (getf contracted-into a) (append (getf contracted-into a)
-                                                       (list b)
-                                                       (getf contracted-into b))) ))
+               (removef nodes b)
+               (appendf (getf contracted-into a) (list b) (getf contracted-into b))))
       (while (> (hash-table-count adj) 2)
-        ;; is the below truly uniform?!
-        (bnd* ((a (random-elt (hash-table-keys adj)))
-               (b (random-elt (gethash a adj))))
+        (destructuring-bind (a . b) (random-edge nodes adj)
           (contract a b))))
-    (destructuring-bind (a b) (hash-table-keys adj)
-      (values (cons a (getf contracted-into a))
-              (cons b (getf contracted-into b))
-              (length (gethash a adj))))))
-#+#:excluded (bnd1 (adj (parse-connections))
-               (while t
-                 (multiple-value-bind (l r cut) (karger-min-cut adj)
-                   (when (= cut 3)
-                     (pr (* (length l) (length r)))
-                     (assert nil)))))
-; 544523
+    (destructuring-bind (a b) nodes
+      (values (length (gethash a adj))
+              (cons a (getf contracted-into a))
+              (cons b (getf contracted-into b))))))
+
+
+(define-solution (2023 25) (adj parse-connections)
+  (recursively ()
+    (multiple-value-bind (cut l r) (karger-min-cut adj)
+      (if (= cut 3)
+        (* (length l) (length r))
+        (recur)))))
+
+(define-test (2023 25) (544523))
diff --git a/vendor/make-quickutils.lisp b/vendor/make-quickutils.lisp
@@ -20,6 +20,7 @@
                :aif
                :alist-keys
                :alist-values
+               :appendf
                :assoc-value
                :awhen
                :bnd*
@@ -53,9 +54,11 @@
                :ncycle
                :plist-keys
                :plist-values
+               :random-elt
                :recursively
                :removef
                :repeat
+               :shuffle
                :string-ends-with-p
                :string-starts-with-p
                :subdivide
@@ -67,9 +70,7 @@
                :while
                :while-not
                :with-gensyms
+               :xor
 
-:shuffle
-:random-elt
-:xor
                )
   :package "AOC.QUICKUTILS")