Paste: AoC Day 05

USING: accessors arrays grouping io.backend io.encodings.utf8
io.files kernel math math.matrices math.parser prettyprint
sequences sequences.extras sets splitting unicode ;
IN: advent-of-code.day-05

! Helper words to give nice names to shuffles and array
! access operations.
: snth         ( array n         -- nth   ) swap nth         ;
: move         ( _     instr     -- move  ) first nip        ;
: from         ( array instr     -- from  ) second snth      ;
: to           ( array instr     -- to    ) third snth       ;
: update-state ( state index row --       ) swap rot set-nth ;

! Helper words for parsing and stripping text
: strip         ( seq -- seq ) [ blank? ] trim ;
: strip-each    ( seq -- seq ) [ strip  ] map ;
: make-base-zero? ( fixnum index -- fixnum ) 0 > [ 1 - ] when ;


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


! Word for parsing the program
: parse-header-row ( string -- seq )
    4 group strip-each ;

: parse-state ( seq -- seq )
    [ parse-header-row ] map but-last
        transpose [ harvest ] map ;

: parse-value ( string index -- fixnum )
    [ dec> ] dip make-base-zero? ;

: parse-instruction ( string -- seq )
    [ blank? ] split-when <odds> [ parse-value ] map-index ;

: parse-instructions ( seq -- seq )
    [ parse-instruction ] map ;

: split-header-and-body ( string -- seq )
    split-lines [ empty? ] split-when ;

: parse-program ( string -- state instr )
    split-header-and-body
        [ first parse-state ] 
        [ second parse-instructions ] bi ;


! words for moving boxes around
: grab-boxes ( state instruction -- seq seq )
    [ to ] [ from ] [ move ] 2tri head ;

: add-boxes ( state instruction row -- )
    [ third ] dip update-state ;

: remove-from-row ( state instruction -- new-row )
    [ from ] [ move ] 2bi tail ;

: remove-boxes ( state instruction -- )
    2dup remove-from-row [ second ] dip update-state ;


! Words for running the program
: run-with ( state instruction quot -- state )
    [ remove-boxes ] [ drop ] 2tri ; inline

: prep-data ( string -- array )
    parse-program [ 2array ] with map ;

: anwser ( seq -- string )
    [ first [ "[]" in? ] trim ] map "" join ;

: solve-with ( program quot -- result )
    [ prep-data ] dip 
    '[ first2 [ _ call( x x -- ) ] run-with ] map first anwser ;


! Implement the crate-movers
: crate-mover-9000 ( state instruction -- )
    2dup grab-boxes reverse prepend add-boxes ;

: crate-mover-9001 ( state instruction -- )
    2dup grab-boxes prepend add-boxes ;


! Solve the problems
: solve-part-one ( -- solution )
    get-input-one [ crate-mover-9000 ] solve-with ;

: solve-part-two ( -- solution )
    get-input-one [ crate-mover-9001 ] solve-with ;