REBOL [
    Title: "Finite State Machine Interpreter"
    Date: 22-Feb-2006
    Author: "Gabriele Santilli"
    Version: 
]

fsm!: context [
    initial: state: none
    state-stack: [ ]

    goto-state: func [new-state [block!] retact [paren! none!]] [
        insert/only insert/only state-stack: tail state-stack :state :retact
        state: bind new-state 'hold
    ]

    return-state: has [retact [paren! none!]] [
        set [state retact] state-stack
        state: any [state initial]
        do retact
        state-stack: skip clear state-stack -2
    ]

    rewind-state: func [up-to [block!] /local retact stack] [
        if empty? state-stack [return false]
        stack: tail state-stack
        retact: make block! 128
        until [
            stack: skip stack -2
            append retact stack/2
            if same? up-to stack/1 [
                state: up-to
                do retact
                state-stack: skip clear stack -2
                return true
            ]
            head? stack
        ]
        false
    ]

    values: []
    hold: func [value][insert/only values value value]
    release: does [take values]

    event: func [
        event [any-word! any-string! number! money! path! lit-path! set-path!]
        /with data [any-type!]
        /local value override retact done?
    ][
        if not block? state [exit]
        until [
            done?: yes
            local: any [
                find state event
                find state to-get-word type?/word event
                find state quote default:
            ]
            if local [
                parse local [
                    any [any-string! | set-word! | get-word!]
                    set value opt paren! (do value) [
                        'continue (done?: no)
                        |
                        'override set override word!
                        (event: to set-word! override done?: no)
                        |
                        none
                    ][
                        'return (return-state)
                        |
                        'rewind? copy value some word! (
                            if not foreach word value [
                                if block? get/any word [
                                    if rewind-state get word [break/return true]
                                ]
                                false
                            ] [
                                done?: yes
                            ]
                        )
                        |
                        set value word! set retact opt paren! (
                            either block? get/any value [goto-state get value :retact][
                                done?: yes
                            ]
                        )
                        |
                        none (done?: yes)
                    ]
                ]
            ]
            done?
        ]
    ]

    init: func [initial-state [word! block!]] [
        ; _t_ "fsm_init"
        if word? initial-state [
            unless block? initial-state: get/any :initial-state [
                make error! "Not a valid state"
            ]
        ]
        clear state-stack: head state-stack
        clear values
        initial: state: initial-state
    ]

    end: does [
        ; _t_ "fsm_end"
        foreach [retact state] head reverse head state-stack [do retact]
    ]
]