Paste: advent-of-code 22

! Copyright (C) 2016 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit kernel locals macros math math.order
path-finding quotations sequences ;
IN: advent-of-code.22

GENERIC: spell-cast ( wizard-world spell -- )
GENERIC: spell-cost ( spell -- cost )
GENERIC: spell-doeffect ( wizard-world spell -- )
GENERIC: spell-duration ( spell -- duration )

SINGLETON: missile
SINGLETON: drain
SINGLETON: shield
SINGLETON: poison
SINGLETON: recharge

CONSTANT: all-spells { missile drain shield poison recharge }

TUPLE: spell-effect spell duration ;
TUPLE: wizard-world player-hp player-mana boss-hp effects ;

C: <spell-effect> spell-effect

ERROR: effect-already-active wizard-world spell ;

: spell-effect-active? ( effects spell -- ? )
    [ swap spell>> = ] curry find drop >boolean ;

: spell-suffix ( effects spell -- effects' )
    2dup spell-effect-active?  [ 2drop f ]
    [ dup spell-duration <spell-effect> suffix ] if ;
: cast-effect ( wizard-world spell -- )
    [
        [ dup effects>> ] [ spell-suffix >>effects ] bi*
        effects>> not
    ]
    [ rot [ effect-already-active ] [ 2drop ] if ] 2bi ;

TUPLE: wizard-bfs < astar ;

M: missile spell-cost drop 53 ;
M: missile spell-cast drop [ 4 - ] change-boss-hp drop ;

M: drain spell-cost drop 73 ;
M: drain spell-cast drop 2
    [ [ + ] curry change-player-hp ]
    [ [ - ] curry change-boss-hp ] bi-curry
    [ call ] bi@ drop ;

M: shield spell-cost drop 113 ;
M: shield spell-doeffect 2drop ;
M: shield spell-cast cast-effect ;
M: shield spell-duration drop 6 ;

M: poison spell-cost drop 173 ;
M: poison spell-doeffect drop [ 3 - ] change-boss-hp drop ;
M: poison spell-cast cast-effect ;
M: poison spell-duration drop 6 ;

M: recharge spell-cost drop 229 ;
M: recharge spell-doeffect drop [ 101 + ] change-player-mana drop ;
M: recharge spell-cast cast-effect ;
M: recharge spell-duration drop 5 ;

: available-spells ( wizard-world -- spells )
    all-spells swap
    [ player-mana>> swap [ spell-cost < ] with reject ]
    [ effects>> swap [ spell-effect-active? ] with reject ] bi ;

: (apply-effects) ( wizard-world spell-effect -- )
    [ spell>> spell-doeffect ]
    [ nip [ 1 - ] change-duration drop ] 2bi ;

: apply-effects ( wizard-world -- )
    dup effects>> empty? [ drop ] [
        [ clone [ clone ] map ] change-effects
        [ dup effects>> [ (apply-effects) ] with each ]
        [ [ [ duration>> 0 > ] filter ] change-effects drop ] bi
    ] if ;

: boss-attack ( wizard-world -- )
    dup effects>>
    shield spell-effect-active? 2 9 ?
    [ - ] curry change-player-hp drop ;

SYMBOLS: +win+ +lose+ ;
: game-over? ( wizard-world -- ? )
    [ player-hp>> 0 <= [ +lose+ ] [ f ] if ]
    [ boss-hp>> 0 <= [ +win+ ] [ f ] if ] bi or ;

MACRO: with-gameover-check ( arr -- quot )
    [ [ [ game-over? ] bi ] curry ] map 1quotation ;
: cast-spell  ( wizard-world spell -- )
    [ spell-cost [ - ] curry change-player-mana ]
    [ spell-cast ] bi ;
:: (wizard-step) ( wizard-world spell -- )
    wizard-world {
        [ spell cast-spell ]
        [ apply-effects ]
        [ boss-attack ]
        [ [ 1 - ] change-player-hp drop ]
        [ apply-effects ]
    } with-gameover-check 1|| drop ;

: wizard-step ( wizard-world spell -- wizard-world' )
    over game-over? [ 2nip ] [
        [ clone ] dip [ (wizard-step) ] curry keep
    ] if* ;

: find-casted-spell ( wizard-world wizard-world' -- spell )
    [ [ player-mana>> ] bi@ - ] [
        drop effects>> [ spell>> recharge = ] filter
        [ 0 ] [ first duration>> 2 min 101 * ] if-empty
    ] 2bi +
    {
        { 53 missile }
        { -48 missile }
        { -149 missile }
        { 73 drain }
        { -28 drain }
        { -129 drain }
        { 113 shield }
        { 12 shield }
        { -89 shield }
        { 173 poison }
        { 72 poison }
        { -29 poison }
        { 229 recharge }
        { 128 recharge }
        { 27 recharge }
    } at ;
M: wizard-bfs cost drop
    2dup [ wizard-world? ] both?
    [ find-casted-spell [ spell-cost ] [ 0 ] if* ]
    [ 2drop 0 ] if ;
M: wizard-bfs heuristic 3drop 0 ;
M: wizard-bfs neighbours drop
    dup wizard-world? [
        dup available-spells [ wizard-step ] with map
    ] [ 1array ] if ;

: <wizard-world> ( -- world )
    49 500 51 V{ } wizard-world boa ;

: solve ( -- n )
    <wizard-world> +win+ wizard-bfs new [ find-path drop ] keep g>>
    +win+ swap at ;