blob: 53668c0f8c933cebbb092a5fc990ac7930f391ed (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
#lang racket
(require advent-of-code
threading
data/applicative
data/monad
megaparsack
megaparsack/text
racket/hash)
(struct posn (x y z))
(struct block (n from to))
(define input (fetch-aoc-input (find-session) 2023 22 #:cache #true))
(define coordinate/p
(do [coords <- (many/p integer/p #:sep (char/p #\,) #:min 3 #:max 3)]
(pure (apply posn coords))))
(define block/p
(do [from <- coordinate/p]
(char/p #\~)
[to <- coordinate/p]
(pure (cons from to))))
(define starting-blocks
(~> (for/list ([line (in-list (string-split input "\n"))]
[n (in-naturals)])
(match-define (cons from to) (parse-result! (parse-string block/p line)))
(block n from to))
(sort < #:key (λ~> block-from posn-z))))
(define (all-in-cross-section-at-level b z)
(match-define (block _ (posn x1 y1 _) (posn x2 y2 _)) b)
(for*/list ([x (in-inclusive-range x1 x2)]
[y (in-inclusive-range y1 y2)])
(posn x y z)))
(define (place-block-at-level b h dz)
(match-define (block n (posn x1 y1 z1) (posn x2 y2 z2)) b)
(define now-occupied
(for*/hash ([x (in-inclusive-range x1 x2)]
[y (in-inclusive-range y1 y2)]
[z (in-inclusive-range dz (+ dz (- z2 z1)))])
(values (posn x y z) n)))
(hash-union h now-occupied))
(define (find-lowest-level b h [z (~> b block-from posn-z)])
(cond
[(= z 0)
(place-block-at-level b h 1)]
[(findf (curry hash-has-key? h) (all-in-cross-section-at-level b z))
(place-block-at-level b h (add1 z))]
[else
(find-lowest-level b h (sub1 z))]))
(define blocks-in-space (foldl find-lowest-level (hash) starting-blocks))
(define block-positions
(for/fold ([placed-blocks (hash)])
([(p n) (in-hash blocks-in-space)])
(hash-update placed-blocks n (curryr set-add p) (set))))
(define (down-one p)
(match p
[(posn x y z) (posn x y (sub1 z))]))
(define supporting-blocks
(for/hash ([(n-id n-posns) (in-hash block-positions)])
(values n-id
(for*/set ([(m-id m-posns) (in-hash block-positions)]
#:unless (= n-id m-id)
[m-posn (in-set m-posns)]
#:when (set-member? n-posns (down-one m-posn)))
m-id))))
(define supported-by-blocks
(for/hash ([n-id (in-hash-keys supporting-blocks)])
(define supporters
(~> (for*/set
([(m-id m-supporting) (in-hash supporting-blocks)]
#:unless (= n-id m-id)
#:when (set-member? m-supporting n-id))
m-id)
((λ (s) (if (set-empty? s) (set 'ground) s)))))
(values n-id supporters)))
;; part 1
(define vulnerable-blocks
(for/list ([n-id (in-range (length starting-blocks))]
#:when (for/or ([m-supported-by (in-hash-values supported-by-blocks)])
(set-empty? (set-remove m-supported-by n-id))))
n-id))
(- (length starting-blocks) (length vulnerable-blocks))
;; part 2
(for/sum ([n (in-list vulnerable-blocks)])
(for/fold ([fallen (set n)]
[bricks (set n)]
#:result (~> fallen set-count sub1))
([_ (in-naturals)])
#:break (set-empty? bricks)
(define bricks-above
(for*/set
([brick (in-set bricks)]
[supporting (in-set (hash-ref supporting-blocks brick))]
#:when (for/and ([supports (in-set (hash-ref supported-by-blocks supporting))])
(set-member? fallen supports)))
supporting))
(values (set-union fallen bricks-above) bricks-above)))
|
