commit 2751d509133258a8b67747495679e2ee5cecae0b
parent 4c97f41a6e21cb9fa1c1d9aa0ad1f2e25bb8ad20
Author: Natasha Kerensikova <natgh@instinctive.eu>
Date: Sun, 10 Dec 2023 10:22:22 +0000
Add day 10 references and solution
Diffstat:
7 files changed, 230 insertions(+), 0 deletions(-)
diff --git a/2023/day10.scm b/2023/day10.scm
@@ -0,0 +1,182 @@
+; Copyright (c) 2023, Natacha Porté
+;
+; Permission to use, copy, modify, and distribute this software for any
+; purpose with or without fee is hereby granted, provided that the above
+; copyright notice and this permission notice appear in all copies.
+;
+; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(import (chicken io) (chicken string)
+ comparse
+ srfi-1
+ srfi-14)
+
+;;;;;;;;;;;;;;;;;
+;; Input parsing
+
+(define symbol
+ (in #\| #\- #\L #\J #\7 #\F #\. #\S))
+
+(define line
+ (sequence* ((data (zero-or-more symbol))
+ (_ (is #\newline)))
+ (result data)))
+
+(define all-data
+ (zero-or-more line))
+
+(define data (parse all-data (read-string)))
+
+(define (draw-map prefix m)
+ (unless (null? m)
+ (write-line (conc prefix (list->string (car m))))
+ (draw-map prefix (cdr m))))
+
+;(write-line "Input:")
+;(draw-map " " data)
+
+;;;;;;;;;;;;;;;;;
+;; First Puzzle
+
+(define (up xy) (cons (car xy) (sub1 (cdr xy))))
+(define (down xy) (cons (car xy) (add1 (cdr xy))))
+(define (left xy) (cons (sub1 (car xy)) (cdr xy)))
+(define (right xy) (cons (add1 (car xy)) (cdr xy)))
+
+(define (valid? m xy)
+ (and (< -1 (car xy) (length (car m)))
+ (< -1 (cdr xy) (length m))))
+
+(define start-xy
+ (let y-loop ((y 0) (lines data))
+ (if (null? lines)
+ (cons -1 -1)
+ (let x-loop ((x 0) (line (car lines)))
+ (cond ((null? line) (y-loop (add1 y) (cdr lines)))
+ ((eqv? #\S (car line)) (cons x y))
+ (else (x-loop (add1 x) (cdr line))))))))
+
+(define (read-cell m xy)
+ (assert (valid? m xy))
+ (list-ref (list-ref m (cdr xy)) (car xy)))
+
+(define (neighbors m xy)
+ (case (read-cell m xy)
+ ((#\|) (list (up xy) (down xy)))
+ ((#\-) (list (left xy) (right xy)))
+ ((#\L) (list (up xy) (right xy)))
+ ((#\J) (list (up xy) (left xy)))
+ ((#\7) (list (down xy) (left xy)))
+ ((#\F) (list (down xy) (right xy)))
+ ((#\.) '())
+ ((#\S) '())
+ (else (assert #f "Invalid cell data at " xy))))
+
+(define (connected? m xy1 xy2)
+ (any (lambda (xy) (equal? xy xy2)) (neighbors m xy1)))
+
+(define data-width (length (car data)))
+(define start-tile 0)
+(define dist-from-start
+ (let* ((result (make-vector (* data-width (length data)) -1))
+ (get-index (lambda (xy) (+ (car xy) (* (cdr xy) data-width))))
+ (get-dist (lambda (xy) (vector-ref result (get-index xy))))
+ (set-dist! (lambda (xy d) (assert (= (get-dist xy) -1))
+ (vector-set! result (get-index xy) d)))
+ (start-neighbors (filter (lambda (xy) (and (valid? data xy)
+ (connected? data xy start-xy)))
+ (list (up start-xy) (down start-xy)
+ (left start-xy) (right start-xy)))))
+ (set-dist! start-xy 0)
+ (assert (= 2 (length start-neighbors)))
+ (set! start-tile
+ (cond ((= (caar start-neighbors) (caadr start-neighbors)) #\|)
+ ((= (cdar start-neighbors) (cdadr start-neighbors)) #\-)
+ ((and (or (= (caar start-neighbors) (sub1 (car start-xy)))
+ (= (caadr start-neighbors) (sub1 (car start-xy))))
+ (or (= (cdar start-neighbors) (sub1 (cdr start-xy)))
+ (= (cdadr start-neighbors) (sub1 (cdr start-xy))))) #\J)
+ ((and (or (= (caar start-neighbors) (sub1 (car start-xy)))
+ (= (caadr start-neighbors) (sub1 (car start-xy))))
+ (or (= (cdar start-neighbors) (add1 (cdr start-xy)))
+ (= (cdadr start-neighbors) (add1 (cdr start-xy))))) #\7)
+ ((and (or (= (caar start-neighbors) (add1 (car start-xy)))
+ (= (caadr start-neighbors) (add1 (car start-xy))))
+ (or (= (cdar start-neighbors) (sub1 (cdr start-xy)))
+ (= (cdadr start-neighbors) (sub1 (cdr start-xy))))) #\L)
+ ((and (or (= (caar start-neighbors) (add1 (car start-xy)))
+ (= (caadr start-neighbors) (add1 (car start-xy))))
+ (or (= (cdar start-neighbors) (add1 (cdr start-xy)))
+ (= (cdadr start-neighbors) (add1 (cdr start-xy))))) #\F)
+ (else (assert #f))))
+ (let loop ((todo start-neighbors)
+ (steps 1))
+ (if (apply equal? todo)
+ (begin
+ (set-dist! (car todo) steps)
+ (write-line (conc "First puzzle: " steps)))
+ (begin
+; (write-line (conc "Step " steps ": " todo))
+ (for-each (lambda (xy)
+ (set-dist! xy steps))
+ todo)
+ (loop (filter (lambda (xy) (= (get-dist xy) -1))
+ (apply append (map (lambda (xy) (neighbors data xy))
+ todo)))
+ (add1 steps)))))
+ result))
+
+(write-line (conc "Start tile: " start-tile))
+
+;;;;;;;;;;;;;;;;;
+;; Second Puzzle
+
+(define data-height (length data))
+
+(define (vec-ref-xy* vec x y)
+ (vector-ref vec (+ x (* y data-width))))
+
+(define (vec-ref-xy vec x y)
+ (let ((result (vec-ref-xy* vec x y)))
+; (write-line (conc "vec-ref-xy " x " " y " -> " result))
+ result))
+
+(define (tile-at x y)
+ (if (equal? start-xy (cons x y))
+ start-tile
+ (read-cell data (cons x y))))
+
+(define answer-2
+ (let loop ((x 0) (y 0) (vert-before 0) (horiz-before 0) (acc 0))
+ (cond ((>= y data-height) acc)
+ ((>= x data-width) (loop 0 (add1 y) 0 0 acc))
+ ((>= (vec-ref-xy dist-from-start x y) 0)
+ (case (tile-at x y)
+ ((#\|) (loop (add1 x) y (add1 vert-before) 0 acc))
+ ((#\-) (assert (or (eqv? horiz-before #\F)
+ (eqv? horiz-before #\L)))
+ (loop (add1 x) y vert-before horiz-before acc))
+ ((#\L) (loop (add1 x) y vert-before #\L acc))
+ ((#\F) (loop (add1 x) y vert-before #\F acc))
+ ((#\7) (loop (add1 x) y
+ (if (eqv? horiz-before #\L)
+ (add1 vert-before)
+ vert-before)
+ 0 acc))
+ ((#\J) (loop (add1 x) y
+ (if (eqv? horiz-before #\F)
+ (add1 vert-before)
+ vert-before)
+ 0 acc))
+ (else (assert #f))))
+ ((= 1 (remainder vert-before 2))
+ (loop (add1 x) y vert-before 0 (add1 acc)))
+ (else (loop (add1 x) y vert-before 0 acc)))))
+
+(write-line (conc "Second puzzle: " answer-2))
diff --git a/2023/ref/day10a.txt b/2023/ref/day10a.txt
@@ -0,0 +1,5 @@
+.....
+.S-7.
+.|.|.
+.L-J.
+.....
diff --git a/2023/ref/day10b.txt b/2023/ref/day10b.txt
@@ -0,0 +1,5 @@
+..F7.
+.FJ|.
+SJ.L7
+|F--J
+LJ...
diff --git a/2023/ref/day10c.txt b/2023/ref/day10c.txt
@@ -0,0 +1,9 @@
+...........
+.S-------7.
+.|F-----7|.
+.||.....||.
+.||.....||.
+.|L-7.F-J|.
+.|..|.|..|.
+.L--J.L--J.
+...........
diff --git a/2023/ref/day10d.txt b/2023/ref/day10d.txt
@@ -0,0 +1,9 @@
+..........
+.S------7.
+.|F----7|.
+.||....||.
+.||....||.
+.|L-7F-J|.
+.|..||..|.
+.L--JL--J.
+..........
diff --git a/2023/ref/day10e.txt b/2023/ref/day10e.txt
@@ -0,0 +1,10 @@
+.F----7F7F7F7F-7....
+.|F--7||||||||FJ....
+.||.FJ||||||||L7....
+FJL7L7LJLJ||LJ.L-7..
+L--J.L7...LJS7F-7L7.
+....F-J..F7FJ|L7L7L7
+....L7.F7||L7|.L7L7|
+.....|FJLJ|FJ|F7|.LJ
+....FJL-7.||.||||...
+....L---J.LJ.LJLJ...
diff --git a/2023/ref/day10f.txt b/2023/ref/day10f.txt
@@ -0,0 +1,10 @@
+FF7FSF7F7F7F7F7F---7
+L|LJ||||||||||||F--J
+FL-7LJLJ||||||LJL-77
+F--JF--7||LJLJ7F7FJ-
+L---JF-JLJ.||-FJLJJ7
+|F|F-JF---7F7-L7L|7|
+|FFJF7L7F-JF7|JL---7
+7-L-JL7||F7|L7F-7F7|
+L.L7LFJ|||||FJL7||LJ
+L7JLJL-JLJLJL--JLJ.L
