! day 6
TUPLE: coord x y ;
TUPLE: guard x y facing ;
C: <guard> guard
C: <coord> coord
TUPLE: game-state obstructions width height covered guard moved ;
M: game-state clone { [ obstructions>> ] [ width>> ] [ height>> ] [ covered>> ] [ guard>> clone ] [ moved>> ] } cleave game-state boa ;
SYMBOLS: up down left right ;
ERROR: wasted-time-error ;
: <game-state> ( obstructions width height guardx guardy -- game-state ) up <guard> [ 1array ] keep clone 0 game-state boa ;


: valid-coord? ( x y game-state -- ? ) [ width>> ] [ height>> ] bi swapd [ [ < ] keepd 0 >= and ] 2bi@ and ;
: get-next-coord ( game-state -- x y ) [ guard>> x>> ] [ guard>> y>> ] [ guard>> facing>> ] tri { { up [ 0 -1 ] } { down [ 0 1 ] } { left [ -1 0 ] } { right [ 1 0 ] } } case swapd [ + ] 2bi@  ;
: can-move? ( game-state -- ? ) [ get-next-coord ] keep obstructions>> [ [ x>> ] [ y>> ] bi swapd [ = ] 2bi@ and ] 2with none? ;
: next-move-valid? ( game-state -- ? ) [ get-next-coord ] keep valid-coord? ;
: turn ( game-state -- game-state ) [ [ { { up [ right ] } { right [ down ] } { down [ left ] } { left [ up ] } } case ] change-facing ] change-guard ;
: add-covered ( game-state -- game-state )
    dup guard>> clone [ [ covered>> ] dip [ [ [ x>> ] [ y>> ] bi ] bi@ swapd [ = ] 2bi@ and ] curry find drop ] 2check
    [ drop ] [ [ suffix ] curry change-covered ] if ;
: deja-vu? ( game-state -- ? ) [ guard>> ] [ covered>> ] bi index ;
: move-one ( game-state -- game-state ) add-covered dup get-next-coord [ [ >>x ] curry change-guard ] dip [ >>y ] curry change-guard [ 1 + ] change-moved ;

: move ( game-state -- game-state finished? )
    dup can-move?
    [
        dup next-move-valid? not [ move-one ] dip
    ]
    [ turn f ] if
    ;

: print-single-tile ( game-state x y -- )
    [ rot [ guard>> x>> ] [ guard>> y>> ] bi swapd [ = ] 2bi@ and ] 3check
    [ 2drop guard>> facing>> { { up [ "^" write ] } { down [ "v" write ] } { left [ "<" write ] } { right [ ">" write ] } } case ]
    [
        [ rot obstructions>> [ <coord> ] dip index ] 3check
        [ 3drop "#" write ] [
            rot covered>> [ [ x>> ] [ y>> ] bi swapd [ = ] 2bi@ and ] 2with find drop [ "X" write ] [ "." write ] if
        ] if
    ] if
    ;

: print-game-state ( game-state -- )
    "Covered: " write dup covered>> length .
    dup width>>
    [
        over height>> [
            swap print-single-tile
        ] 2with each-integer
        "\n" write
    ] with each-integer
    ;
: maybe-wasted-time ( game-state -- game-state ) [ dup [ width>> ] [ height>> ] bi * 4 * [ moved>> ] dip >= [ wasted-time-error ] when ] keep ;
: silent-game-loop ( game-state -- covered ) [ move not ] loop covered>> length ;
: loud-game-loop ( game-state -- covered ) dup print-game-state [ move [ dup print-game-state ] dip not ] loop "Done!" print covered>> length ;
: parse-day-six-input ( string -- game-state )
    [
        0 0 rot
        [ dup length 0 = not ]
        [
            unclip
            {
                { CHAR: \n [ [ nip 0 swap 1 + ] dip ] }
                { CHAR: # [ 2over <coord> , [ 1 + ] 2dip ] }
                { CHAR: ^ [ 2over 2array , [ 1 + ] 2dip ] }
                { CHAR: . [ [ 1 + ] 2dip ] }
            } case
        ] while drop 1 +
    ] { } make
    [ [ coord? ] filter ] [ [ sequence? ] find nip first2 ] bi
    [ -rot ] 2dip <game-state> ;

: is-loop? ( game-state x y -- ? )
    ! [
    [ clone ] 2dip <coord> [ suffix ] curry change-obstructions
    f [ drop move [ maybe-wasted-time dup deja-vu? ] dip dupd or not ] loop
    nip ! ] [ dup wasted-time-error? [ 4drop "wasted time" print t ] [ rethrow ] if ] recover
    ;


: count-loops ( game-state -- loops )
    0 swap [ clone ] [ clone ] bi [ silent-game-loop drop ] keep covered>>
    [ [ x>> ] [ y>> ] bi is-loop? [ 1 + ] when ] with each
    ;