merge with upstream

aoc.asd

@@ -27,6 +27,7 @@
   :components ((:module "src"
 		:components
 		((:file "main")
+		 (:file "maze")
 		 (:file "2018/day06")
 		 (:file "2018/day07")
 		 (:file "2024/day01")
@@ -49,6 +50,7 @@
 		 (:file "2024/day18")
 		 (:file "2024/day19")
 		 (:file "2024/day20")
+		 (:file "2024/day21")
 		 )))
   :description "Advent of Code challenges and solutions."
   :long-description "Solutions for the AOC challenges."
@@ -85,6 +87,7 @@
 		 (:file "2024/day18-test")
 		 (:file "2024/day19-test")
 		 (:file "2024/day20-test")
+		 (:file "2024/day21-test")
 		 )))
   :description "Test system for aoc"
   :perform (test-op (op c) (symbol-call :parachute :test :aoc/tests)))

src/2024/day16.lisp

@@ -1,6 +1,5 @@
-
 (defpackage :aoc/2024/16
-  (:use :cl :aoc :alexandria :trivia :lla :queues)
+  (:use :cl :aoc :aoc/maze :alexandria :trivia :lla :queues)
   (:export
    #:parse-input
    #:best-score
@@ -42,86 +41,10 @@
 #S..#.....#...#
 ###############"))
 
-(defstruct pos
-  (x 0 :type fixnum)
-  (y 0 :type fixnum))
-
-(defun pos-move (pos dir)
-  (case dir
-    (#\^ (make-pos :x (pos-x pos) :y (1- (pos-y pos))))
-    (#\v (make-pos :x (pos-x pos) :y (1+ (pos-y pos))))
-    (#\< (make-pos :x (1- (pos-x pos)) :y (pos-y pos)))
-    (#\> (make-pos :x (1+ (pos-x pos)) :y (pos-y pos)))
-    ))
-
-(defun show-map (map &optional (dest t))
-  (let ((w (array-dimension map 1))
-	(h (array-dimension map 0)))
-    (format
-     dest "~{~A~}"
-     (loop
-       for row from 0 below h
-       collect (format nil "~A~%"
-		       (coerce
-			(loop for col from 0 below w
-			      collect (aref map row col))
-			'string))))))
-
-(defun get-pos (map pos)
-  (aref map (pos-y pos) (pos-x pos)))
-
-(defun set-pos (map pos tile)
-  (setf (aref map (pos-y pos) (pos-x pos)) tile))
-
-(defun find-tile (map char)
-  (let ((w (array-dimension map 1))
-	(h (array-dimension map 0)))
-    (loop
-      for row from 0 below h
-      for col = (loop
-		  for col from 0 below w
-		  if (eq (aref map row col) char) return col)
-      if col
-	return (make-pos :x col :y row)
-      )))
-
-(defun swap-pos (map p np)
-  "swaps content of map. returns np"
-  (let ((o (get-pos map p)))
-    (setf (aref map (pos-y p) (pos-x p)) (get-pos map np))
-    (setf (aref map (pos-y np) (pos-x np)) o)
-    np))
-
-
-(defun wet-finger-distance (a b)
-  "estimate the distance"
-  (+
-   (abs (- (pos-x a) (pos-x b)))
-   (abs (- (pos-y a) (pos-y b)))
-   (and
-    (eq (pos-x a) (pos-x b))
-    (eq (pos-y a) (pos-y b))
-    1000)))
-
-(defun rotate-left (dir)
-  (case dir
-    (#\^ #\<)
-    (#\v #\>)
-    (#\< #\v)
-    (#\> #\^)
-    ))
-(defun rotate-right (dir)
-  (case dir
-    (#\^ #\>)
-    (#\v #\<)
-    (#\< #\^)
-    (#\> #\v)
-    ))
-
 (defun valid-pos-p (map pos)
   (not (eq #\# (get-pos map pos))))
 
-(defstruct reindeer pos dir)
+(defstruct reindeer pos (dir #\>))
 
 (defstruct state path score)
 
@@ -136,59 +59,34 @@
       (cons (make-reindeer :pos p :dir (rotate-left d)) 1000)
       (cons (make-reindeer :pos p :dir (rotate-right d)) 1000)))))
 
-
+(defun heuristic (x finish)
-(defun distance-estimate-f (finish)
   "estimate the distance for a reindeer from given finish"
-  (let ((a finish))
+  (let* ((a (reindeer-pos finish))
-    (lambda (reindeer)
+	 (b (reindeer-pos x)))
-      (let ((b (reindeer-pos reindeer) ))
+    (+
-	(+
+     (manhattan-distance a b)
-	 (abs (- (pos-x a) (pos-x b)))
+     (if (or
-	 (abs (- (pos-y a) (pos-y b)))
+	  (eq (pos-x a) (pos-x b))
-	 (if (or
+	  (eq (pos-y a) (pos-y b)))
-	      (eq (pos-x a) (pos-x b))
+	 0
-	      (eq (pos-y a) (pos-y b)))
+	 1000))))
-	     0
-	     1000))))))
-
-(defun compare-states-f (finish)
-  (let ((dist-est (distance-estimate-f finish)))
-    (lambda (s1 s2)
-      (< (+ (state-score s1)
-	    (funcall dist-est (car (state-path s1))))
-	 (+ (state-score s2)
-	    (funcall dist-est (car (state-path s2))))))))
 
 (defun best-path (map)
-  (let* ((start (find-tile map #\S))
+  (let* ((start (make-reindeer :pos (find-tile map #\S)))
-	 (finish (find-tile map #\E))
+	 (finish (make-reindeer :pos (find-tile map #\E)))
-	 (state-comparison (compare-states-f finish))
+	 (path-finder (make-a-star
-	 (best (make-hash-table :test #'equalp))
+		       #'next-moves
-	 (todo (make-queue :priority-queue :compare state-comparison)))
+		       #'heuristic
-    (qpush todo (make-state
+		       :finished-p (lambda (a b)
-		 :path (list (make-reindeer :pos start :dir #\>))
+				     (equalp
-		 :score 0))    
+				      (reindeer-pos a)
-    (loop
+				      (reindeer-pos b)))
-      for s = (qpop todo)
+		       )))
-      until (or
+    (funcall path-finder map start finish))
-	     (null s)
+  )
-	     (equalp (reindeer-pos (first (state-path s))) finish))
-      finally (return s)
-      do (loop
-	   for next in (next-moves map (first (state-path s)))
-	   for score = (+ (state-score s) (cdr next))
-	   if (> (gethash (car next) best 1000000000) score)
-	     do (progn
-		  (qpush todo
-			 (make-state
-			  :path (cons (car next) (state-path s))
-			  :score score))
-		  (setf (gethash (car next) best) score)))
-
-      )))
 
 (defun best-score (map)
-  (state-score (best-path map)))
+  (caar (best-path map)))
 
 (defparameter sample-data 
   (parse-input sample-text))

src/2024/day17.lisp

@@ -198,7 +198,7 @@ Program: 0,1,5,4,3,0"))
 
 
 
-(defun disassemble (cpu)
+(defun my-disassemble (cpu)
   (let ((program (cpu-mem cpu))
 	(cpu (copy-cpu cpu)))
     (loop

src/2024/day18.lisp

@@ -1,38 +1,17 @@
 
 (defpackage :aoc/2024/18
-  (:use :cl :aoc :alexandria :trivia :lla :queues)
+  (:use :cl :aoc :aoc/maze :alexandria :trivia :lla :queues)
   (:export
    #:sample-data
    #:sample-data2
    #:part1
    #:part2
    #:in-bounds-p
-   #:make-pos
-   #:pos-x
-   #:pos-y
    #:next-moves
    ))
 
 (in-package :aoc/2024/18)
 
-(defstruct pos
-  (x 0 :type fixnum)
-  (y 0 :type fixnum))
-
-(defun pos-move (pos dir)
-  (case dir
-    (#\^ (make-pos :x (pos-x pos) :y (1- (pos-y pos))))
-    (#\v (make-pos :x (pos-x pos) :y (1+ (pos-y pos))))
-    (#\< (make-pos :x (1- (pos-x pos)) :y (pos-y pos)))
-    (#\> (make-pos :x (1+ (pos-x pos)) :y (pos-y pos)))
-    ))
-
-(defun get-pos (map pos)
-  (aref map (pos-y pos) (pos-x pos)))
-
-(defun set-pos (map pos tile)
-  (setf (aref map (pos-y pos) (pos-x pos)) tile))
-
 (defun parse-line (line)
   (let ((p (mapcar #'parse-integer (ppcre:split "," line))))
     (make-pos :x (first p) :y (second p))))
@@ -104,56 +83,19 @@
 	    (< tm (gethash p (memory-map mem) 1000000)))
 	  collect p))
 
-(defun distance-estimate-f (finish)
-  "estimate the distance for a reindeer from given finish"
-  (let ((a finish))
-    (lambda (b)
-      (+
-       (abs (- (pos-x a) (pos-x b)))
-       (abs (- (pos-y a) (pos-y b)))
-       ))))
-
-(defstruct state score path)
-
-(defun compare-states-f (finish)
-  (let ((dist-est (distance-estimate-f finish)))
-    (lambda (s1 s2)
-      (< (+ (state-score s1)
-	    (funcall dist-est (car (state-path s1))))
-	 (+ (state-score s2)
-	    (funcall dist-est (car (state-path s2))))))))
-
 (defun best-path (map time)
-  (let* ((start (make-pos :x 0 :y 0))
+  (let ((start (make-pos :x 0 :y 0))
-	 (finish (make-pos :x (memory-size map) :y (memory-size map)))
+	(finish (make-pos :x (memory-size map) :y (memory-size map)))
-	 (state-comparison (compare-states-f finish))
+	(path-finder (make-a-star
-	 (best (make-hash-table :test #'equalp))
+		      #'(lambda (map pos) (loop
-	 (todo (make-queue :priority-queue :compare state-comparison)))
+					    for p in (next-moves map pos time)
-    (qpush todo (make-state
+					    collect (cons p 1)))
-		 :path (list start)
+		      #'manhattan-distance)))
-		 :score 0))    
+    (funcall path-finder map start finish)))
-    (loop
-      for s = (qpop todo)
-      until (or
-	     (null s)
-	     (equalp (first (state-path s)) finish))
-      finally (return s)
-      do (loop
-	   for next in (next-moves map (first (state-path s)) time)
-	   for score = (+ (state-score s) 1)
-	   if (> (gethash next best 1000000000) score)
-	     do (progn
-		  (qpush todo
-			 (make-state
-			  :path (cons next (state-path s))
-			  :score score))
-		  (setf (gethash next best) score)))
-
-      )))
 
 (defun solve-part1 (data time)
   (let ((path (best-path data time)))
-    (state-score path))
+    (caar path))
   )
 
 (defun part1 (data &optional (time 1024))

src/2024/day20.lisp

@@ -1,6 +1,6 @@
 
 (defpackage :aoc/2024/20
-  (:use :cl :aoc :alexandria :trivia :lla)
+  (:use :cl :aoc :aoc/maze :alexandria :trivia :lla)
   (:export
    #:sample-data
    #:sample-data2
@@ -11,25 +11,82 @@
 (in-package :aoc/2024/20)
 
 
-(defun parse-line (line)
-  line)
-
-
-(defun parse-input (lines)
-  (mapcar #'parse-line lines))
-
 (defparameter input-text (test-input 2024 20))
-(defparameter input-data (parse-input input-text))
+(defparameter input-data (parse-maze input-text))
 
-(defparameter sample-text (aoc:split-lines ""))
+(defparameter sample-text (aoc:split-lines "###############
+#...#...#.....#
+#.#.#.#.#.###.#
+#S#...#.#.#...#
+#######.#.#.###
+#######.#.#...#
+#######.#.###.#
+###..E#...#...#
+###.#######.###
+#...###...#...#
+#.#####.#.###.#
+#.#...#.#.#...#
+#.#.#.#.#.#.###
+#...#...#...###
+###############
+"))
 (defparameter sample-data 
-              (parse-input sample-text))
+  (parse-maze sample-text))
 
-(defun part1 (data)
-  (length data))
 
-(defun part2 (data)
+(defun next-moves (map pos)
-  (length data))
+  "return conses of next pos and cost"
+  (loop for d in '(#\^ #\v #\> #\<)
+	for p = (pos-move pos d)
+	if (and
+	    (array-in-bounds-p map (pos-x p) (pos-y p))
+	    (not (eq #\# (aref map (pos-y p) (pos-x p)))))
+	  collect (cons p 1)))
+
+(defun best-path (map)
+  (let* ((start (find-tile map #\S))
+	 (finish (find-tile map #\E))
+	 (pathfinder (make-a-star #'next-moves
+				  #'manhattan-distance))
+	 )
+    (funcall pathfinder map start finish)))
+
+
+(defun find-shortcuts (map &optional (max-distance 2))
+  (let ((path (best-path map)))
+    (loop
+      for s1 in path
+      append (loop
+	       for s2 in path
+	       for dist = (manhattan-distance (cdr s1) (cdr s2)) 
+	       for saving = (- (car s2) (car s1) dist)
+	       if (and
+		   (plusp saving)
+		   (<= dist max-distance))
+		 collect (list saving (cdr s1) (cdr s2))))))
+
+(defun count-sc-groups (shortcuts &optional (min-savings))
+  ;; present results to make it easy to compare to challenge
+  (let ((count-map (make-hash-table)))
+    (loop
+      for s in shortcuts
+      do (incf (gethash (first s) count-map 0)))
+    (sort
+     (loop
+       for k being the hash-keys in count-map
+       for v being the hash-values in count-map
+       if (>= k min-savings)       
+	 collect (cons k v)
+       )
+     #'(lambda (a b) (< (car a) (car b)))
+     )))
+
+
+(defun part1 (map)
+  (loop for sc in (find-shortcuts map) count (>= (car sc) 100) ))
+
+(defun part2 (map)
+  (loop for sc in (find-shortcuts map 20) count (>= (car sc) 100) ))
 
 (defun solve-day ()
   (format t "part1: ~A~%" (part1 input-data))

src/maze.lisp

@@ -0,0 +1,160 @@
+(defpackage :aoc/maze
+  (:use :cl :alexandria :trivia :lla :queues)
+  (:export
+   #:parse-maze
+   #:make-a-star
+   #:pos
+   #:make-pos
+   #:pos-x
+   #:pos-y
+   #:pos-move
+   #:show-map
+   #:get-pos
+   #:set-pos
+   #:find-tile
+   #:manhattan-distance
+   ))
+
+(in-package :aoc/maze)
+
+(defun parse-line (line)
+  (coerce line 'list))
+
+
+(defun parse-maze (lines)
+  (make-array
+   (list (length lines) (length (first lines)))
+   :initial-contents (mapcar #'parse-line lines)))
+
+(defstruct pos
+  (x 0 :type fixnum)
+  (y 0 :type fixnum))
+
+(defun pos-move (pos dir)
+  (case dir
+    (#\^ (make-pos :x (pos-x pos) :y (1- (pos-y pos))))
+    (#\v (make-pos :x (pos-x pos) :y (1+ (pos-y pos))))
+    (#\< (make-pos :x (1- (pos-x pos)) :y (pos-y pos)))
+    (#\> (make-pos :x (1+ (pos-x pos)) :y (pos-y pos)))
+    ))
+
+(defun show-map (map &optional (dest t))
+  (let ((w (array-dimension map 1))
+	(h (array-dimension map 0)))
+    (format
+     dest "~{~A~}"
+     (loop
+       for row from 0 below h
+       collect (format nil "~A~%"
+		       (coerce
+			(loop for col from 0 below w
+			      collect (aref map row col))
+			'string))))))
+
+(defun get-pos (map pos)
+  (aref map (pos-y pos) (pos-x pos)))
+
+(defun set-pos (map pos tile)
+  (setf (aref map (pos-y pos) (pos-x pos)) tile))
+
+(defun find-tile (map char)
+  (let ((w (array-dimension map 1))
+	(h (array-dimension map 0)))
+    (loop
+      for row from 0 below h
+      for col = (loop
+		  for col from 0 below w
+		  if (eq (aref map row col) char) return col)
+      if col
+	return (make-pos :x col :y row)
+      )))
+
+(defun swap-pos (map p np)
+  "swaps content of map. returns np"
+  (let ((o (get-pos map p)))
+    (setf (aref map (pos-y p) (pos-x p)) (get-pos map np))
+    (setf (aref map (pos-y np) (pos-x np)) o)
+    np))
+
+
+(defun manhattan-distance (a b)
+  "estimate the distance"
+  (+
+   (abs (- (pos-x a) (pos-x b)))
+   (abs (- (pos-y a) (pos-y b)))
+   ))
+
+(defun rotate-left (dir)
+  (case dir
+    (#\^ #\<)
+    (#\v #\>)
+    (#\< #\v)
+    (#\> #\^)
+    ))
+(defun rotate-right (dir)
+  (case dir
+    (#\^ #\>)
+    (#\v #\<)
+    (#\< #\^)
+    (#\> #\v)
+    ))
+
+(defun state-score (s)
+  (caar s))
+
+(defun state-x (s)
+  (cdar s))
+
+(defun make-a-star (next-moves heuristic &key (finished-p #'equalp))
+  (lambda (map start finish)
+    (defun state-less-p (s1 s2)
+      (< (+ (state-score s1)
+	    (funcall heuristic (state-x s1) finish))
+	 (+ (state-score s2)
+	    (funcall heuristic (state-x s2) finish))))
+    (let* ((best (make-hash-table :test #'equalp))
+	   (todo (queues:make-queue :priority-queue :compare #'state-less-p)))
+      (queues:qpush todo (list (cons 0 start)))    
+      (loop
+	for s = (queues:qpop todo)
+	until (or
+	       (null s)
+	       (funcall finished-p (state-x s) finish))
+	finally (return s)
+	do (loop
+	     for next in (funcall next-moves map (state-x s))
+	     for score = (+ (state-score s) (cdr next))
+	     for next-x = (car next)	     
+	     if (> (gethash next-x best 1000000000) score)
+	       do (progn
+		    (queues:qpush todo (cons (cons score next-x) s))
+		    (setf (gethash next-x best) score)))
+
+	))))
+
+(defun make-a-star-all-best-paths (next-moves heuristic &key (finished-p #'equalp))
+  (lambda (map start finish)
+    (defun state-less-p (s1 s2)
+      (< (+ (state-score s1)
+	    (funcall heuristic (state-x s1) finish))
+	 (+ (state-score s2)
+	    (funcall heuristic (state-x s2) finish))))
+    (let* ((best (make-hash-table :test #'equalp))
+	   (todo (queues:make-queue :priority-queue :compare #'state-less-p)))
+      (queues:qpush todo (list (cons 0 start)))    
+      (loop
+	for s = (queues:qpop todo)
+	until (or
+	       (null s)
+	       (funcall finished-p (state-x s) finish))
+	finally (return s)
+	do (loop
+	     for next in (funcall next-moves map (state-x s))
+	     for score = (+ (state-score s) (cdr next))
+	     for next-x = (car next)	     
+	     if (>= (gethash next-x best 1000000000) score)
+	       do (progn
+		    (queues:qpush todo (cons (cons score next-x) s))
+		    (setf (gethash next-x best) score)))
+
+	))))