AoC 2018 day 4 in Factor

USING: accessors assocs calendar classes.tuple fry grouping
io.encodings.utf8 io.files kernel literals make math math.order
math.ranges math.statistics math.vectors parser prettyprint
regexp sequences sequences.extras sets sorting.slots splitting ;
IN: aoc2018.day4

: get-input ( -- seq ) "input4.txt" utf8 file-lines ;

TUPLE: entry ts event ;
C: <entry> entry

: parse-date ( str -- timestamp )
    "- :" split [ parse-number ] map ${ 0 0 hours } append
    timestamp slots>tuple ;

: parse-entry ( str -- entry )
    R/ \] / re-split "" map-like first2 [ rest parse-date ]
    [ <entry> ] bi* ;

: get-entries ( -- entries )
    get-input [ parse-entry ] map { { ts>> <=> } } sort-by ;

: parse-id ( str -- n ) R/ \d+/ first-match parse-number ;

! Is this entry the beginning of a shift?
: transition? ( entry -- ? ) event>> "G" head? ;

! Construct a sequence containing the indices at which a new
! guard takes over.
: find-transition-indices ( entries -- indices )
    [ [ swap transition? [ , ] [ drop ] if ] each-index ] { }
    make ;

! Group the entries that belong together in a single shift.
: separate-shifts ( -- shifts )
    get-entries dup find-transition-indices differences
    [ [ cut [ , ] dip ] each , ] { } make ;

! Convert a shift from { ~entry~ ~entry~ ... } to
! { sleep-time wake-time sleep-time wake-time ... } guard-id
: pare-shift ( seq -- sleep-times id )
    [ rest-slice [ ts>> minute>> ] map ]
    [ first event>> parse-id ] bi ;

! Build a hashtable of sleep and wake times by guard id.
: build-db ( -- ht )
    H{ } clone dup separate-shifts [ pare-shift rot push-at ]
    with each ;

: time-asleep ( minutes -- n )
    2 group [ first2 swap - ] map-sum ;

: total-time-asleep ( shifts -- n ) [ time-asleep ] map-sum ;

: max-index ( seq -- n ) [ supremum ] [ index ] bi ;

: find-sleepiest-guard ( db -- id )
    [ total-time-asleep ] assoc-map unzip max-index swap nth ;

: time-manifest ( db -- seq )
    dup find-sleepiest-guard swap at
    [ 2 group [ first2 [a,b) ] map ] map ;

: minute-sleepiness ( tm m -- n )
    '[ [ _ swap member? ] any? ] map [ t = ] count ;

: find-sleepiest-minute ( tm -- n )
    60 <iota> [ minute-sleepiness ] with map max-index ;

: part1 ( db -- )
    [ find-sleepiest-guard ]
    [ time-manifest find-sleepiest-minute * ] bi . ;

: expand ( seq -- seq' )
    [ 1 ] dip 2 <groups> [ first2 [a,b) ] map concat 60 [ 0 ]
    replicate [ set-nths ] keep ;

: occurrences ( seq -- seq' ) [ expand ] [ v+ ] map-reduce ;

: most-frequent-id ( db -- id )
    [ occurrences supremum ] assoc-map unzip max-index swap nth
    ;

: most-frequent-minute ( id db -- n ) at occurrences max-index ;

: part2 ( db -- )
    [ most-frequent-id dup ] [ most-frequent-minute ] bi * . ;

: main ( -- ) build-db [ part1 ] [ part2 ] bi ;