merge with upstream
This commit is contained in:
parent
529747fd7e
commit
49fb61ef7f
6 changed files with 271 additions and 211 deletions
3
aoc.asd
3
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)))
|
||||
|
|
|
|||
|
|
@ -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 distance-estimate-f (finish)
|
||||
(defun heuristic (x finish)
|
||||
"estimate the distance for a reindeer from given finish"
|
||||
(let ((a finish))
|
||||
(lambda (reindeer)
|
||||
(let ((b (reindeer-pos reindeer) ))
|
||||
(let* ((a (reindeer-pos finish))
|
||||
(b (reindeer-pos x)))
|
||||
(+
|
||||
(abs (- (pos-x a) (pos-x b)))
|
||||
(abs (- (pos-y a) (pos-y b)))
|
||||
(manhattan-distance a b)
|
||||
(if (or
|
||||
(eq (pos-x a) (pos-x b))
|
||||
(eq (pos-y a) (pos-y b)))
|
||||
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))))))))
|
||||
1000))))
|
||||
|
||||
(defun best-path (map)
|
||||
(let* ((start (find-tile map #\S))
|
||||
(finish (find-tile map #\E))
|
||||
(state-comparison (compare-states-f finish))
|
||||
(best (make-hash-table :test #'equalp))
|
||||
(todo (make-queue :priority-queue :compare state-comparison)))
|
||||
(qpush todo (make-state
|
||||
:path (list (make-reindeer :pos start :dir #\>))
|
||||
:score 0))
|
||||
(loop
|
||||
for s = (qpop todo)
|
||||
until (or
|
||||
(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)))
|
||||
|
||||
(let* ((start (make-reindeer :pos (find-tile map #\S)))
|
||||
(finish (make-reindeer :pos (find-tile map #\E)))
|
||||
(path-finder (make-a-star
|
||||
#'next-moves
|
||||
#'heuristic
|
||||
:finished-p (lambda (a b)
|
||||
(equalp
|
||||
(reindeer-pos a)
|
||||
(reindeer-pos b)))
|
||||
)))
|
||||
(funcall path-finder map start finish))
|
||||
)
|
||||
|
||||
(defun best-score (map)
|
||||
(state-score (best-path map)))
|
||||
(caar (best-path map)))
|
||||
|
||||
(defparameter sample-data
|
||||
(parse-input sample-text))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(state-comparison (compare-states-f finish))
|
||||
(best (make-hash-table :test #'equalp))
|
||||
(todo (make-queue :priority-queue :compare state-comparison)))
|
||||
(qpush todo (make-state
|
||||
:path (list start)
|
||||
:score 0))
|
||||
(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)))
|
||||
|
||||
)))
|
||||
(path-finder (make-a-star
|
||||
#'(lambda (map pos) (loop
|
||||
for p in (next-moves map pos time)
|
||||
collect (cons p 1)))
|
||||
#'manhattan-distance)))
|
||||
(funcall path-finder map start finish)))
|
||||
|
||||
(defun solve-part1 (data time)
|
||||
(let ((path (best-path data time)))
|
||||
(state-score path))
|
||||
(caar path))
|
||||
)
|
||||
|
||||
(defun part1 (data &optional (time 1024))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(length data))
|
||||
(defun next-moves (map pos)
|
||||
"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))
|
||||
|
|
|
|||
160
src/maze.lisp
Normal file
160
src/maze.lisp
Normal file
|
|
@ -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)))
|
||||
|
||||
))))
|
||||
Loading…
Reference in a new issue