Paste: AoC day 15

USING: accessors arrays combinators combinators.short-circuit
grouping io.encodings.utf8 io.files kernel math math.functions
math.intervals math.order math.parser math.vectors
multiline peg.ebnf prettyprint sequences sets sorting ;
IN: aoc.15

: input ( -- lines ) "~/factor/aoc/15/15.in" utf8 file-lines ;
EBNF: parse [=[
    num   = "-"? [0-9]+ => [[ first2 dec> [ neg ] keep ? ]]
    parse = "Sensor at x="~ num ", y="~ num ": closest beacon is at x="~ num ", y="~ num => [[ 2 group ]]
]=]
TUPLE: sensor x y radius beacon ;
: sensor>point ( s -- pair     ) [ x>> ] [ y>> ] bi 2array ;
: destroy      ( s -- x    y r ) [ x>> ] [ y>> ] [ radius>> ] tri ;
: dist ( pair pair -- x ) v- vabs sum ;
: I ( -- input ) input [ parse first2 [ drop first2 ] [ dist ] [ nip ] 2tri sensor boa ] map ;

CONSTANT: Y 2000000
:: add-interval ( is i -- is ) is last i intervals-intersect? [ is unclip-last i interval-union ] [ is i ] if suffix ;
: merge-overlap ( is   -- is ) [ [ from>> ] bi@ <=> ] sort unclip 1array [ add-interval ] reduce ;
: at-y ( sensor y -- i ) [ destroy swap ] dip - abs - [ - ] [ + ] 2bi 1 + [a,b] ;
: num-at-y ( is y -- x ) '[ _ at-y ] map merge-overlap [ interval-length ] map-sum ;
: part1 ( -- n ) I [ Y num-at-y ] [ [ beacon>> last ] map members [ Y = ] count ] bi - ;

TUPLE: line m b ;
C: <line> line
: lineval          ( x  l  -- l[x] ) [ b>> ] [ m>> ] bi rot * + ;
: get-slope        ( p1 p2 -- m    ) swap v- first2 swap / ;
: get-y-int        ( m  p  -- b    ) first2 [ * ] dip swap - ;
: points>line      ( p1 p2 -- l    ) [ get-slope dup ] keep get-y-int <line> ;
: line-intersect-x ( l1 l2 -- x    ) [ [ b>> ] bi@ swap - ] [ [ m>> ] bi@ - ] 2bi / ;
: (line-intersect) ( l1 l2 -- p    ) [ line-intersect-x dup ] keep lineval 2array ;
: line-intersect   ( l1 l2 -- p/f  ) {
        { [ 2dup             = ] [ 2drop t ] }
        { [ 2dup [ m>> ] bi@ = ] [ 2drop f ] }
        [ (line-intersect) ]
    } cond ;

CONSTANT: max 4000000
: corners ( s -- seq   ) [let destroy :> ( x y r ) x y r + 2array x r + y 2array x y r - 2array x r - y 2array 4array  ] ;
: border  ( s -- lines ) [ 1 + ] change-radius corners 2 circular-clump [ first2 points>line ] map ;
: valid? ( p beacons -- ? ) swap '[ [ radius>> ] [ sensor>point ] bi _ dist < ] all? ;
: part2 ( -- n ) I [ border ] map concat dup [ line-intersect ] cartesian-map concat members
    [ { [ array? ] [ [ integer? ] all? ] [ [ 0 max between? ] all? ] } 1&& ] filter I '[ _ valid? ] find nip
    { 4000000 1 } vdot ;

: solve ( -- ) part1 . pat2 . ;