-
Notifications
You must be signed in to change notification settings - Fork 0
/
14.factor
55 lines (46 loc) · 1.59 KB
/
14.factor
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
USING: arrays assocs combinators generalizations grouping kernel
math math.parser math.vectors multiline peg.ebnf ranges
sequences sets ;
IN: 2022.14
! Regolith Reservoir
! part 1: count units of sand that come to rest
! part 2: count units of sand until sand source is blocked
EBNF: parse [=[
n = [0-9]+ => [[ dec> ]]
pair = n ","~ n
line = (pair (" -> "?)~)+
]=]
: parse* ( seq -- pairs )
[ HS{ } clone ] dip [
2 <clumps> [
first2 [ first2 ] bi@ swapd [ [a..b] ] 2bi@
2dup max-length dup '[
dup length _ = [ first _ swap <array> ] unless
] bi@ [ 2array over adjoin ] 2each
] each
] each ;
MACRO: (sand) ( quot -- quot )
dup dup '[ {
{ [ dup dup @ not ] [ nip t ] }
{ [ drop dup { 1 0 } v- dup @ not ] [ nip t ] }
{ [ drop dup { 1 0 } v+ dup @ not ] [ nip t ] }
[ drop { 0 1 } v- f ]
} cond ] ;
: sand ( pairs ymax -- settled? )
{ 500 0 } f [
drop { 0 1 } v+ dup second pick <= [ [
[ 5 npick in? ] (sand)
] [ f ] if ] keep swap
] loop [ [ nip swap adjoin ] [ 3drop ] if ] keep ;
: sand* ( pairs ymax -- not-blocked? )
{ 500 0 } [
{ 0 1 } v+ dup second pick <= [ [
[ 5 npick in? ] [ second 5 npick = ] bi or
] (sand) ] [ f ] if
] loop [ nip swap adjoin ] [ { 500 0 } = not ] bi ;
MACRO: (part) ( quot quot -- quot )
'[ dup clone dup members values supremum @ [
2dup @
] loop drop swap diff cardinality ] ;
: part-1 ( pairs -- n ) [ ] [ sand ] (part) ;
: part-2 ( pairs -- n ) [ 2 + ] [ sand* ] (part) ;