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 [ ] 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 ;