day05 try with ranges fail to solve

1 files changed, 121 insertions, 37 deletions

diff --git a/AoC2023/day05/solver.lisp b/AoC2023/day05/solver.lisp
index be9008e..47eb491 100644
--- a/AoC2023/day05/solver.lisp
+++ b/AoC2023/day05/solver.lisp
@@ -1,4 +1,4 @@
-(ql:quickload '(fiveam str))
+(ql:quickload '(fiveam str arrows))
 
 (defparameter eg-input "seeds: 79 14 55 13
 
@@ -34,39 +34,30 @@ humidity-to-location map:
 60 56 37
 56 93 4")
 
+(defun parse-rules (rule)
+  (destructuring-bind (dest source span) rule
+    (list source (+ source span) (- dest source))))
 
 (defun translate (rules value)
   (dolist (rule rules)
-    (destructuring-bind (dest source span) rule
-      (when (<= source value (+ source (1- span)))
-        (return-from translate (+ (- value source) dest)))))
+    (destructuring-bind (start end offset) rule
+      (when (<= start value (1- end))
+        (return-from translate (+ value offset)))))
   value)
 
-(defun segment-translate (rules segments)
-  (let ((sorted-rules (sort rules #'< :key #'cadr)))
-    (mapcan
-     (lambda (segment)
-       (destructuring-bind (start . end) segment
-         (loop for (dest-start source-start span) in sorted-rules
-
-               )))
-     segments)))
-
-(sort '((50 98 2) (52 50 48)) #'< :key #'cadr)
+(defun transformation-in-order-p (names)
+  (loop for (one two) on names
+        for start = (cadr (str:split "-TO-" (symbol-name one)))
+        for end = (car (str:split "-TO-" (symbol-name two)))
+        always (or (string-equal start end) (null two))))
 
 (fiveam:test parts
-  (let ((rules '((50 98 2) (52 50 48))))
+  (let ((rules (mapcar #'parse-rules '((50 98 2) (52 50 48)))))
     (fiveam:is (= 9 (translate rules 9)))
     (fiveam:is (= 61 (translate rules 59)))
-    (fiveam:is (= 51 (translate rules 99)))))
-
-(defun translator (translate-chain translator-rules)
-  (lambda (value)
-    (reduce
-     (lambda (acc fn)
-       (translate (gethash fn translator-rules) acc))
-     translate-chain
-     :initial-value value)))
+    (fiveam:is (= 51 (translate rules 99))))
+  (fiveam:is-true
+   (transformation-in-order-p '(a-to-b b-to-c c-to-goal))))
 
 (defun parser (lines)
   (let (seeds
@@ -80,23 +71,91 @@ humidity-to-location map:
                (mapcar #'parse-integer (cdr (str:split-omit-nulls #\Space line)))))
         ((str:ends-with-p "map:" line)
          (push (read-from-string line) maps-stack))
-        ((push (mapcar #'parse-integer (str:split-omit-nulls #\Space line))
+        ((push (parse-rules (mapcar #'parse-integer (str:split-omit-nulls #\Space line)))
                (gethash (car maps-stack) translators)))))
-    (values (translator
-             (nreverse maps-stack)
-             translators)
-            seeds)))
+
+    (loop for rule-name being the hash-key of translators do
+      (setf (gethash rule-name translators)
+            (sort (gethash rule-name translators) #'< :key #'car)))
+    (setf maps-stack (nreverse maps-stack))
+    (transformation-in-order-p maps-stack)
+    (values maps-stack translators seeds)))
+
+
+(defun translate-range (rules ranges &optional translated-ranges)
+  "It assumes rules are in order."
+  (if (or (endp rules) (endp ranges))
+      (sort (append ranges translated-ranges) #'< :key #'car)
+      (destructuring-bind (rule-start rule-end rule-offset) (car rules)
+        (destructuring-bind (element-start element-end) (car ranges)
+          (cond
+            ;; element right sided to rule range thus move to next rule
+            ((<= rule-end element-start)
+             (translate-range (cdr rules) ranges translated-ranges))
+            ;; element is left sided to rule, thus identity map the range
+            ((<= element-end rule-start)
+             (translate-range rules
+                              (cdr ranges)
+                              (cons (car ranges) translated-ranges)))
+            ;; element range is fully contained, thus map offset
+            ((<= rule-start element-start element-end rule-end)
+             (translate-range rules
+                              (cdr ranges)
+                              (cons (list (+ rule-offset element-start)
+                                          (+ rule-offset element-end))
+                                    translated-ranges)))
+            ;; element overlaps on the left of range, thus slice it,
+            ;; identity map first part, pass the overlap for it to translate on next level
+            ((< element-start rule-start)
+             (translate-range rules
+                              (cons (list rule-start element-end)
+                                    (cdr ranges))
+                              (cons (list element-start rule-start)
+                                    translated-ranges)))
+            ;; element overlaps on the right of the range, thus slice it,
+            ;; offset map first part, transfer remainder for next rule
+            ((< rule-end element-end)
+             (translate-range (cdr rules)
+                              (cons (list rule-end element-end)
+                                    (cdr ranges))
+                              (cons (list (+ rule-offset element-start)
+                                          (+ rule-offset element-end))
+                                    translated-ranges)))
+            ((assert nil nil "Not all cases processed")))))))
+
+
+(defun translator (translate-chain translator-rules)
+  (lambda (value)
+    (reduce
+     (lambda (acc fn)
+       (print (list fn acc))
+       (translate (gethash fn translator-rules) acc))
+     translate-chain
+     :initial-value value)))
 
 (defun solver1 (lines)
-  (multiple-value-bind (translator seeds) (parser lines)
-    (apply #'min (mapcar translator seeds))))
+  (multiple-value-bind (maps-stack translator seeds) (parser lines)
+    (apply #'min (mapcar (translator maps-stack translator) seeds))))
 
+(defun seed-to-ranges (seeds)
+  (arrows:->
+   (loop for (start span) on seeds by #'cddr
+         collect (list start (+ start span)))
+   (sort #'< :key #'car)))
 
 (defun solver2 (lines)
-  (multiple-value-bind (translator seeds) (parser lines)
-    (loop for (start span) on seeds by #'cddr
-          minimize (loop for i from start below (+ start span)
-                         minimize (funcall translator i)))))
+  (multiple-value-bind (maps-stack translator seeds) (parser lines)
+    (print (list 'seeds (seed-to-ranges seeds)))
+    (arrows:-<>
+     (reduce
+      (lambda (acc fn)
+        (let ((res
+                (translate-range (gethash fn translator) acc)))
+          (print (list fn res))
+          res))
+      maps-stack
+      :initial-value (seed-to-ranges seeds))
+     (reduce #'min <> :key #'car))))
 
 (fiveam:test solutions
   (fiveam:is
@@ -114,4 +173,29 @@ humidity-to-location map:
   (fiveam:is
    (= 52510809
       (solver2
-       (uiop:read-file-lines "input")))))
+       (uiop:read-file-lines "input"))))
+  )
+
+;; (multiple-value-bind (maps-stack translator seeds) (parser
+;;                                                     ;; (uiop:split-string eg-input :separator '(#\Newline))
+;;                                                     (uiop:read-file-lines "input")
+;;                                                     )
+;;   (arrows:-<>
+;;    (reduce
+;;     (lambda (acc fn)
+;;       (let ((res
+;;               (translate-range (gethash fn translator) acc)))
+;;         (print (list fn res))
+;;         res))
+;;     maps-stack
+;;     :initial-value (mapcar
+;;                     (lambda (s) (list s (1+ s)))
+;;                     seeds))
+;;    ;; (reduce #'min <> :key #'car)
+;;    ))
+
+(multiple-value-bind (maps-stack translator seeds) (parser
+                                                    ;; (uiop:split-string eg-input :separator '(#\Newline))
+                                                    (uiop:read-file-lines "input")
+                                                    )
+  (sort (mapcar (translator maps-stack translator) seeds) #'<))