State Machine for Ren-C (R3C)

state-machine.reb

Rebol [
    Title: "State Machine Dialect"
    Date: 3-Feb-2021
    Author: "Gabriele Santilli"
    File: %state-machine.reb

    Type: module
    Name: rgchris.state-machine
    Version: 1.8.1
    Exports: [state-machine]

    Notes: [
        "Adapted to R3C by Christopher Ross-Gill"
        "Original Documentation"
        http://www.colellachiara.com/soft/Misc/qml/fsm.html
    ]

    License: {
        Copyright (c) 2006, Gabriele Santilli
        All rights reserved.

        Redistribution and use in source and binary forms, with or without
        modification, are permitted provided that the following conditions
        are met:

        * Redistributions of source code must retain the above copyright
          notice, this list of conditions and the following disclaimer. 
      
        * Redistributions in binary form must reproduce the above
          copyright notice, this list of conditions and the following
          disclaimer in the documentation and/or other materials provided
          with the distribution. 

        * The name of Gabriele Santilli may not be used to endorse or
          promote products derived from this software without specific
          prior written permission.

        THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
        "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
        LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
        FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
        COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
        INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
        BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
        LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
        CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
        LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
        ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
        POSSIBILITY OF SUCH DAMAGE.
    }

    Version: 1.8.1
    History: [
        17-Feb-2006 1.1.0 "History start"
        17-Feb-2006 1.2.0 "Added override directive"
        20-Feb-2006 1.3.0 "Fixed a bug in init"
        22-Feb-2006 1.4.0 "Added rewind? directive, cleaned up parser a bit"
        17-Mar-2006 1.5.0 "Changed return directive to be able to return to n-th previous state"
        13-Feb-2021 1.8.1 "Port to Ren-C (R3C branch)"
    ]
]

state-machine: make object! [
    initial: _
    state: _

    state-stack: _

    goto-state: method [
        new-state [block!]
        retract [group! blank!]
    ][
        insert/only insert/only state-stack: tail state-stack :state :retract
        state: new-state
    ]

    return-state: method [
        <local> retact
    ][
        either empty? state-stack [
            state: initial
        ][
            set [state retact] state-stack
            do retact
            state-stack: skip clear state-stack -2
        ]
    ]

    rewind-state: method [
        up-to [block!]
        <local> retact stack
    ][
        if not empty? state-stack [
            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
        ]
    ]

    event: method [
        name [any-value!]
        <local> here value override retract done?
    ][
        if block? state [
            until [
                done?: yes

                here: try any [
                    find state name
                    find state to get-word! type-of name
                    find state [default:]
                ]

                if here [
                    parse here [
                        any [
                            any-string!
                            |
                            set-word!
                            |
                            get-word!
                        ]

                        opt [
                            set value group!
                            (do value)
                        ]

                        opt [
                            'continue
                            (done?: no)
                            |
                            'override
                            set override word!
                            (
                                name: to set-word! override
                                done?: no
                            )
                        ]

                        [
                            'return
                            (return-state)
                            |
                            'rewind?
                            copy value some word!
                            (
                                if not for-each word value [
                                    if block? get word [
                                        if rewind-state get word [
                                            break/return true
                                        ]
                                    ]

                                    false
                                ][
                                    done?: yes
                                ]
                            )
                            |
                            set value word!
                            [
                                set retract group!
                                |
                                (retract: _)
                            ]
                            (
                                either block? get :value [
                                    goto-state get value :retract
                                ][
                                    done?: yes
                                ]
                            )
                            |
                            (done?: yes)
                        ]
                    ]
                ]

                done?
            ]
        ]
    ]

    init: method [
        initial-state [word! block!]
    ][
        if word? initial-state [
            if not block? initial-state: get :initial-state [
                make error! "Not a valid state"
            ]
        ]

        state-stack: copy []
        initial: state: initial-state
    ]

    end: method [] [
        for-each [retact state] head reverse head state-stack [
            do retact
        ]
    ]
]