Paste: My attempt at AOC day 6
Author: | Leo Mehraban |
Mode: | factor |
Date: | Sun, 8 Dec 2024 18:53:43 |
Plain Text |
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
;
: 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
;
New Annotation