Paste: My attempt at AOC day 7

TUPLE: equa result ins ;
C: <equa> equa


TUPLE: operation operand n1 n2 ;
C: <operation> operation
: preform ( operation -- result ) [ n1>> ] [ n2>> ] [ operand>> ] tri execute( n1 n2 -- n3 ) ;

: parse-day-seven-input ( string -- equas ) split-lines [ ":" split first2 [ dec> ] dip " " split harvest [ dec> ] map >vector reverse <equa> ] map ;
: || ( n1 n2 -- n3 ) swap [ >dec ] bi@ append dec> ;
: next-operator ( op -- op ) { { \ * [ \ + ] } { \ + [ \ || ] } { \ || [ \ || ] } } case  ;

: push-operation ( equa op opstack -- equa op opstack )
    pick [ 2 cut* swap ] change-ins drop overd first2 <operation> swap [ push ] 2keep [ swap [ [ preform swap [ push ] keep ] curry change-ins ] dip ] dip ;

: pop-operation ( equa op opstack -- equa op opstack done? )
    dup length 0 > [ [ pop ] keep [ nip [ \ + ] dip [ n1>> ] [ n2>> ] bi rot [ swap [ rot [ pop drop ] keep [ [ push ] [ push ] bi ] keep ] 2curry change-ins ] dip ] dip f ] [ t ] if ;

: pop-retry ( equa op opstack -- equa op opstack done? ) dup length 0 > [ f [ [ not [ dup length 0 > [ last operand>> \ + = ] [ drop f ] if ] dip and ] 2check ] [ drop pop-operation ] while [ pop-operation ] unless* ] [ t ] if ;

: (equa-solution) ( equa op opstack -- equa op opstack done? )
    {
        ! { [ pick too-big? ] [ t t ] }
        ! { [ pick too-small? ] [ t t ] }
        { [ pick ins>> length 1 = ] [ pick [ result>> ] [ ins>> first ] bi = not t ] }
        ! { [ pick ins>> length 2 = ] [ pick [ result>> ] [ ins>> [ first2 + ] [ first2 * ] bi ] bi overd [ = ] 2bi@ or not t ] }
        [ push-operation [ drop \ * ] dip f f ]
    } cond
    swap [ drop pop-retry ] when ;

: p2-push-operation ( equa op opstack -- equa op opstack )
    pick [ 2 cut* swap ] change-ins drop overd first2 <operation> swap [ push ] 2keep [ swap [ [ preform swap [ push ] keep ] curry change-ins ] dip ] dip ;

: p2-pop-operation ( equa op opstack -- equa op opstack done? )
    dup length 0 > [ [ pop ] keep [ nip [ operand>> next-operator ] [ n1>> ] [ n2>> ] tri rot [ swap [ rot [ pop drop ] keep [ [ push ] [ push ] bi ] keep ] 2curry change-ins ] dip ] dip f ] [ t ] if ;

: p2-pop-retry ( equa op opstack -- equa op opstack done? )
    dup length 0 >
    [ f [ [ not [ dup length 0 > [ last operand>> \ || = ] [ drop f ] if ] dip and ] 2check ] [ drop p2-pop-operation ] while [ p2-pop-operation ] unless* ] [ t ] if ;

: (p2-equa-solution) ( equa op opstack -- equa op opstack done? )
    {
        { [ pick ins>> length 1 = ] [ pick [ result>> ] [ ins>> first ] bi = not t ] }
        [ p2-push-operation [ drop \ * ] dip f f ]
    } cond
    swap [ drop p2-pop-retry ] when ;

: opstack>solution ( opstack -- solution ) unclip-last [ [ [ n1>> ] [ operand>> ] bi 2array ] map concat ] dip [ n1>> suffix ] [ operand>> suffix ] [ n2>> suffix ] tri ;

: equa-solution ( equa -- solution/f ) \ * V{ } clone [ (equa-solution) not ] loop nip dup empty? [ 2drop f ] [ nip opstack>solution ] if ;

: solve-day-seven ( equas -- calibration-num )  [ dup equa-solution [ result>> ] [ drop f ] if ] map sift sum  ;

: p2-equa-solution ( equa -- solution/f ) \ * V{ } clone [ (p2-equa-solution) not ] loop nip dup empty? [ 2drop f ] [ nip opstack>solution ] if ;

: solve-day-seven-part-two ( equas -- calibration-num )  [ dup p2-equa-solution [ result>> ] [ drop f ] if ] map sift sum  ;
Author:	Leo Mehraban
Mode:	factor
Date:	Tue, 10 Dec 2024 15:55:11