Paste: AOC 2021, day 18

USING: accessors io.encodings.utf8 io.files kernel math
math.combinatorics math.parser math.ranges multiline peg.ebnf
prettyprint sequences sequences.extras ;
IN: 2021.18

TUPLE: n n d ; 
C: <n> n

EBNF: parse [=[ 
    number = [0-9]+ => [[ dec> ]]
    pair = "["~ ( number | pair ) ","~ ( number | pair ) "]"~
]=] 

:: tree>stack ( tree depth -- stack )
    V{ } clone :> stack
    tree [
        dup number? [
            depth <n> stack push
        ] [ 
            depth 1 + tree>stack stack push-all
        ] if
    ] each stack ;

:: explode ( stack -- stack' )
    stack reverse :> stack
    V{ } clone :> stack'
    [ stack empty? ] [ 
        stack pop dup d>> 4 = [ 
            stack' empty? [ drop ] [ 
                n>> stack' pop [ + ] with change-n stack' push
            ] if stack pop n>> stack empty? [ drop ] [ 
                stack pop [ + ] with change-n stack push
            ] if 0 3 <n> stack' push
        ] [ stack' push ] if
    ] until stack' ;

:: split ( stack -- stack' )
    stack clone :> stack'
    stack' [ n>> 10 >= ] find swap [
        [   
            [ n>> [ 1 + ] keep [ 2/ ] bi@ ]
            [ d>> 1 + tuck ] bi [ <n> ] 2bi@
        ] [ dup stack' remove-nth! ] bi* 
        [ insert-nth! ] 2curry bi@ 
    ] [ drop ] if* stack' ;

: reduce* ( stack -- stack' )
    [ dup explode split tuck = not ] loop ;

:: (magnitude) ( stack d -- stack' )
    stack reverse :> stack
    V{ } clone :> stack'
    [ stack empty? ] [ 
        stack pop dup d>> d = [ 
            n>> 3 * stack pop n>> 2 * + 
            d 1 - <n> stack' push
        ] [ stack' push ] if
    ] until stack' ;

: magnitude ( stack -- n ) 
    4 0 [a,b] [ (magnitude) ] each first n>> ;

: add ( a b -- c ) 
    append [ clone [ 1 + ] change-d ] map reduce* ;

"input18" utf8 file-lines [ parse 0 tree>stack ] map 
[ unclip [ add ] reduce magnitude . ] 
[   
    2 all-combinations dup [ reverse ] map append
    [ first2 add magnitude ] map supremum .
] bi