Paste: My attempt at AOC day 9

! day nine

TUPLE: fs-pair size space id ;
C: <fs-pair> fs-pair
: first-free-space ( fs-pairs -- index fs-pair ) [ space>> 0 > ] find ;
: add-same-id ( fs-pair -- fs-pair ) [ 1 + ] change-size [ 1 - ] change-space ;
: add-one-id ( fs-pair id -- fs-pairs ) 2dup [ id>> ] dip = [ drop add-same-id 1array ] [ [ dup space>> 1 - [ 0 >>space ] dip ] dip 1 -rot <fs-pair> 2array ] if ;
: remove-one-block ( fs-pair -- fs-pair/f ) dup size>> 1 > [ [ 1 - ] change-size [ 1 + ] change-space ] [ drop f ] if  ;
: move-one-block ( fs-pairs -- fs-pairs )
    unclip-last [ remove-one-block ] 1check [ dup id>> [ suffix! ] dip ] [ id>> ] if [ [ first-free-space ] dip ] keepd [ add-one-id ] dip swapd [ set-nth ] keep [ [ dup sequence? [ % ] [ , ] if ] each ] V{ } make ;
: done? ( fs-pairs -- done? ) [ first-free-space nip ] [ last ] bi eq? ;

: move-all ( fs-pairs -- fs-pairs ) [ dup done? not ] [ move-one-block ] while ;

: uncompact-pair ( fs-pair -- uncompacted ) dup [ size>> ] [ id>> ] bi <array> [ space>> f <array> ] dip swap append ;
: uncompact-pairs ( fs-pairs -- uncompacted ) [ [ uncompact-pair % ] each ] { } make ;

: print-pairs ( fs-pairs -- ) uncompact-pairs [ [ >dec write ] [ "." write ] if* ] each "\n" write ;

: get-checksum ( uncompacted -- checksum ) 0 [ swap [ * + ] [ drop ] if* ] reduce-index ;

: solve-day-nine ( fs-pairs -- checksum ) move-all uncompact-pairs get-checksum ;

: parse-day-nine-input ( string -- fs-pairs ) dup length odd? [ "0" append ] when V{ } clone -1 [ pick length 0 > ] [ [ 2 cut swap ] 2dip 1 + swapd [ first2 [ 1string dec> ] bi@ ] dip [ <fs-pair> suffix! ] keep ] while drop nip ;

: find-fittable-space ( fs-pairs size -- index/f fs-pair/f ) [ [ space>> ] dip >= ] curry find ;

: find-file-id ( fs-pairs id -- fs-pair ) [ [ id>> ] dip = ] curry find-last nip ;

: find-file-ind ( fs-pairs id -- ind ) [ [ id>> ] dip = ] curry find-last drop ;

: add-same-id-with-amount ( fs-pair amount -- fs-pair ) tuck [ + ] curry change-size swap [ - ] curry change-space ;

: add-one-id-with-amount ( fs-pair id amount -- fs-pairs ) -rot 2dup [ id>> ] dip = [ drop swap add-same-id-with-amount 1array ] [ [ dup space>> pick - [ 0 >>space ] dip swapd ] dip <fs-pair> 2array ] if ;
! ind fs-pairs fs-pair
: remove-at-ind ( fs-pairs ind -- fs-pairs ) [ swap nth ] 2keep swap [ remove-nth! ] keepd spin [ [ [ size>> ] [ space>> ] bi + + ] curry change-space ] curry [ [ 1 - ] 2dip change-nth ] keepd ;
! fs-pairs move-id size fs-pair index

: move-one-file ( fs-pairs move-id -- fs-pairs move-id )
    [
        [ dupd find-file-id size>> ] 2keep
        -rot over
        find-fittable-space swap
        [
            [ 2dup find-file-ind ] 3dip rotd [ > ] 1check [
                [ dupd [ find-file-ind remove-at-ind ] keep ] 3dip
                [ -rot add-one-id-with-amount ] dip
                rot [ set-nth ] keep [ [ dup sequence? [ % ] [ , ] if ] each ] V{ } make
            ] [ 4drop ] if
        ] [ 3drop ] if*
    ] keep 1 - ;

: p2-move-all ( fs-pairs -- fs-pairs ) dup length 1 - [ dup 0 >= ] [ move-one-file ] while drop ;

: solve-day-nine-part-two ( fs-pairs -- checksum ) p2-move-all uncompact-pairs get-checksum ;
Author:	Leo Mehraban
Mode:	factor
Date:	Fri, 13 Dec 2024 23:38:21