Paste: aoc 2018 day 13

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+ } <circular> ]
TUPLE: cart x y dir turn-state tick ;
C: <cart> 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 <cart> , ] [ 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 <cart> [ 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 ;