aoc 2019 day 20 factor

day20.factor

! Copyright (C) 2019 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ascii assocs hashtables
io.encodings.ascii io.files kernel math math.order math.vectors
path-finding sequences strings ;
IN: aoc.2019.20

: Mi,j ( pos mat -- el )
    [ first2 swap ] dip nth nth ;
: all-neighbours ( pos -- pos' )
    { { 1 0 } { -1 0 } { 0 1 } { 0 -1 } } [ v+ ] with map ;
: walk-neighbours ( pos maze -- neighbours )
    [ all-neighbours ] dip [ Mi,j CHAR: . = ] curry filter ;
: portal-neighbours ( pos portals -- neighbours )
    at ;
TUPLE: timemaze < astar maze portals ;
M: timemaze cost 3drop 1 ;
M: timemaze heuristic 3drop 0 ;
M: timemaze neighbours [ maze>> walk-neighbours ] [ portals>> portal-neighbours ] 2bi append ;
: find-horizontal-portals ( input -- portals )
    [
        [ dup rest zip ] dip 
        [
            swap 2array swap dup
            [ >string 2array ] dip
            [ LETTER? ] all? [ drop f ] unless
        ] curry map-index harvest
    ] map-index harvest concat ;
: find-vertical-portals ( input -- portals )
    dup rest zip
    [
        [ flip ] dip
        [
            swap 2array swap dup
            [ >string 2array ] dip
            [ LETTER? ] all? [ drop f ] unless
        ] curry map-index harvest
    ] map-index harvest concat  ;
CONSTANT: DOT-NEIGHBOURS { { -1 0 } { 2 0 } { 0 2 } { 0 -1 } }
: dot-around-label ( input pos -- pos' )
        DOT-NEIGHBOURS [ v+ ] with map [ swap Mi,j CHAR: . = ] with find nip ;
: find-portals ( input -- portals )
    [
        [ find-horizontal-portals ] [ find-vertical-portals ] bi append
    ] [ swap [ first2 [ dot-around-label ] dip 2array ] with map ] bi
    dup [ second ] collect-by [ [ first2 ] dip at [ first ] map over [ = not ] curry filter 2array ] curry map [ second empty? not ] filter >hashtable ;
: find-topleft-label ( input label -- pos )
    [ [ dup rest zip ] dip
    [ [ flip ] dip [ [ = ] curry all? ] curry find drop ] curry find drop
    ] [ rot [ rot nth index ] keep swap 2array ] 2bi ;
: find-label ( input label -- pos )
    [ find-topleft-label ] [ drop swap dot-around-label ] 2bi ;
  
: <timemaze> ( input -- maze )
    dup find-portals timemaze new swap >>portals swap >>maze ;
: aoc20-1 ( -- n )
"vocab:aoc/2019/20/input" ascii file-lines
[ CHAR: A CHAR: Z [ find-label ] bi-curry@ bi ] [ <timemaze> ] bi find-path length 1 - ;

: level-offset ( pos -- ? )
    [ first 20 100 between? ]
    [ second 20 100 between? ] bi and
    ! [ first 8 33 between? ]
    ! [ second 7 42 between? ] bi and
     1 -1 ? ;

TUPLE: recursive-timemaze < astar maze portals ;
M: recursive-timemaze cost 3drop 1 ;
M: recursive-timemaze heuristic 3drop 0 ;
M: recursive-timemaze neighbours
    [ [ first2 swap ] dip maze>> walk-neighbours swap [ 2array ] curry map ]
    [ [ dup first ] dip portals>> portal-neighbours swap first2 swap level-offset + [ 2array ] curry map [ second 0 >= ] filter ] 2bi append ;
: <recursive-timemaze> ( input -- maze )
    dup find-portals recursive-timemaze new swap >>portals swap >>maze ;

: aoc20-2 ( -- n )
"vocab:aoc/2019/20/input" ascii file-lines
[ CHAR: A CHAR: Z [ find-label 0 2array ] bi-curry@ bi ] [ <recursive-timemaze> ] bi find-path length 1 - ;