Paste: AoC Day 08

USING: accessors advent-of-code.utils arrays assocs combinators
combinators.smart generalizations io.backend io.encodings.utf8
io.files kernel math math.matrices math.parser math.statistics
sequences sequences.deep sets splitting strings ;
IN: advent-of-code.day-08

: get-input-one ( -- seq )
    "vocab:advent-of-code/day-08/_input/one.txt" 
        normalize-path utf8 file-contents ;

! Words for constructing grids used to process input
: make-grid ( input -- grid )
    split-lines [ [ 1string dec> ] { } map-as ] map ;

: grid-dims ( grid -- x y )
    [ first length ] [ length ] bi ;

: position-grid ( grid -- grid )
    grid-dims [ <iota> ] bi@ cartesian-product ;

: 2d-pair ( grid grid -- grid )
    swap [ zip [ rest-slice ] map ] 2map ;

: paired-grid ( grid -- grid )
    dup position-grid 2d-pair ;

! Words for computing how many trees can be seen from the outside.
: visible-trees ( row -- visible )
    cum-max reverse fast-set ;

: left   ( grid -- left   ) [ visible-trees ]         map ;
: right  ( grid -- right  ) [ reverse visible-trees ] map ;
: top    ( grid -- top    ) transpose  left ;
: bottom ( grid -- bottom ) transpose right ;

: tree-lines ( grid -- trees )
    { [ left ] [ right ] [ top ] [ bottom ] } cleave 4array ;

: all-members ( seq -- seq )
    flatten [ members ] map flatten1 ;

: get-positions ( seq -- seq )
    [ seq>> first ] map ;

: unique-trees ( trees -- unique )
    all-members get-positions fast-set members ;


! Solve problem one
: solve-part-one ( -- solution )
    get-input-one make-grid 
    paired-grid   tree-lines
    unique-trees  length 
;

! Implement solution for part two
! Not much I did in part one could be reused

! Find trees in row
: look-left ( grid position -- seq )
    first2 exhume nth swap 1 + head reverse ;

: look-right ( grid position -- seq )
    first2 exhume nth swap tail ;

: look-up ( grid position -- seq )
    [ transpose ] [ reverse ] bi* look-left ;

: look-down ( grid position -- seq )
    [ transpose ] [ reverse ] bi* look-right ;

: look ( grid position -- left right up down )
    { 
        [ look-left ] 
        [ look-right ] 
        [ look-up ] 
        [ look-down ] 
    } 2cleave ;

! Comput scores 
: fix-length ( seq ? -- length )
    [ nip ] [ length 1 - ] if* ;

: run-length ( row -- n )
    dup [ 1 ] dip dup first '[ _ >= ] find-from drop fix-length ;

: score ( left right up down -- score )
    [ run-length ] 4 napply * * * ;

: scenic-score ( grid position -- score )
    look score ;

: scenic-scores ( grid -- scores ) 
    dup position-grid flatten1 [ scenic-score ] with map ;

! Solve puzzle
: solve-part-two ( -- solution )
    get-input-one make-grid 
    scenic-scores supremum 
;