USING: accessors arrays circular combinators combinators.extras continuations inverse io.encodings.ascii io.files kernel literals locals make math math.functions math.order math.trig math.vectors namespaces pair-rocket prettyprint sequences sorting sorting.slots ; IN: aoc2018.day13 SYMBOLS: +left+ +straight+ +right+ ; CONSTANT: state $[ { +left+ +straight+ +right+ } ] TUPLE: cart x y dir turn-state tick ; C: cart M: cart <=> { { y>> <=> } { x>> <=> } } compare-slots ; << SYMBOL: carts : get-input ( -- seq ) "input13.txt" ascii file-lines ; ! Carts always start on straight sections of track. : infer-track ( n -- m ) { CHAR: > => [ CHAR: - ] CHAR: v => [ CHAR: | ] CHAR: < => [ CHAR: - ] CHAR: ^ => [ CHAR: | ] } case ; : cart-char? ( n -- ? ) ">v<^" member? ; : get-track ( seq -- seq' ) [ [ dup cart-char? [ infer-track ] when ] "" map-as ] map ; : initial-dir ( n -- seq ) { CHAR: > => [ { 1 0 } ] CHAR: v => [ { 0 1 } ] CHAR: < => [ { -1 0 } ] CHAR: ^ => [ { 0 -1 } ] } case ; : get-carts ( seq -- seq ) [ [ swap [ rot dup cart-char? [ initial-dir swapd 0 0 , ] [ 3drop ] if ] with each-index ] each-index ] V{ } make ; get-input get-carts carts set-global >> CONSTANT: track $[ get-input get-track ] ERROR: collision x y ; : (move-cart) ( cart -- cart' ) dup [ x>> ] [ y>> 2array ] [ dir>> v+ ] tri first2 [ >>x ] dip >>y ; :: turn ( dir θ! -- dir' ) dir first2 :> ( x y ) θ deg>rad θ! θ cos x * θ sin y * - θ sin x * θ cos y * + [ round >fixnum ] bi@ 2array ; : turn-intersection ( cart -- cart' ) dup [ dir>> ] [ turn-state>> ] bi state nth { +left+ => [ -90 turn ] +straight+ => [ ] +right+ => [ 90 turn ] } case >>dir ; : (turn-cart) ( dir char -- dir' ) { [ 2array CHAR: \ ] => [ swap 2array ] [ 2array CHAR: / ] => [ [ -1 * ] bi@ swap 2array ] [ drop ] } switch ; : turn-cart ( cart -- cart' ) dup [ dir>> ] [ x>> ] [ y>> ] tri track nth nth dup CHAR: + = [ 2drop turn-intersection [ 1 + ] change-turn-state ] [ (turn-cart) >>dir ] if ; : same-pos ( cart1 cart2 -- ? ) [ [ x>> ] [ y>> ] bi ] bi@ swapd [ = ] 2bi@ and ; : check-collision ( cart -- ) dup [ carts get ] dip [ same-pos ] curry count 1 > [ [ x>> ] [ y>> ] bi collision ] [ drop ] if ; : move-cart ( cart -- cart' ) (move-cart) turn-cart [ 1 + ] change-tick dup check-collision ; : do-tick ( carts -- carts' ) natural-sort [ move-cart ] map ; : part1 ( -- x ) carts get [ do-tick ] forever ; ! Part 2 doesn't work... :( But I am through fighting this. : reject-collided ( x y -- ) { 1 0 } 0 0 [ same-pos ] curry [ carts get ] dip reject! drop ; : part2 ( -- x ) get-input get-carts carts set-global [ carts get length 1 > ] [ [ carts get do-tick drop ] [ [ x>> ] [ y>> ] bi reject-collided ] recover ] while carts get ;