resolver-gen

Vocabulary

logic.private

Definition

IN: logic.private

TUPLE: resolver-gen
    { state initial: s-start: } body env cut first-goal
    rest-goals d-head d-body defs trail d-env d-cut
    sub-resolver1 sub-resolver2 i loop-end yield? return? ;

Methods

USING: accessors combinators kernel logic logic.private math
namespaces quotations sequences ;

M:: resolver-gen next ( resolver -- yield? )
    [
        f resolver return?<< f resolver yield?<<
        resolver state>> {
            {
                s-start:
                [
                    resolver body>> empty? [
                        t resolver yield?<<
                        s-end: resolver state<<
                    ] [ s-not-empty: resolver state<< ] if
                ]
            }
            {
                s-not-empty:
                [
                    resolver body>> unclip
                    [ resolver rest-goals<< ]
                    [ resolver first-goal<< ] bi*
                    resolver first-goal>> !! =
                    [ s-cut: resolver state<< ]
                    [ s-not-cut: resolver state<< ] if
                ]
            }
            {
                s-cut:
                [
                    resolver
                    [ rest-goals>> ] [ env>> ] [ cut>> ] tri
                    <resolver> resolver sub-resolver1<<
                    s-cut/iter: resolver state<<
                ]
            }
            {
                s-cut/iter:
                [
                    resolver sub-resolver1>> next
                    [ t resolver yield?<< ] [
                        t resolver cut>> set-info
                        s-end: resolver state<<
                    ] if
                ]
            }
            {
                s-not-cut:
                [
                    resolver first-goal>> callable? [
                        resolver first-goal>> ( -- goal )
                        call-effect resolver first-goal<<
                    ] when *trace?* get-global [
                        resolver first-goal>> ~quotation~
                        ~quotation~ bi
                    ] when <env> resolver d-env<<
                    f <cut> resolver d-cut<<
                    resolver first-goal>> pred>> defs>> dup
                    resolver defs<< length 1 - dup 0 >= [
                        resolver loop-end<< 0 resolver i<<
                        s-defs-loop: resolver state<<
                    ] [ drop s-end: resolver state<< ] if
                ]
            }
            {
                s-defs-loop:
                [
                    resolver [ i>> ] [ defs>> ] bi nth first2
                    [ resolver d-head<< ] [ resolver d-body<< ]
                    bi*
                    resolver d-cut>> cut? resolver cut>> cut? or
                    [ s-end: resolver state<< ] [
                        ~vector~ clone resolver trail<<
                        resolver ~array~ cleave unify*
                        ~quotation~ ~quotation~ if
                    ] if
                ]
            }
            {
                s-callable:
                [
                    resolver [ d-env>> ] [ trail>> ] bi
                    <callback-env>
                    resolver d-body>> ( cb-env -- ? )
                    call-effect [
                        resolver ~quotation~ ~quotation~
                        ~quotation~ tri <resolver>
                        resolver sub-resolver1<<
                        s-callable/iter: resolver state<<
                    ] [ s-unify?-exit: resolver state<< ] if
                ]
            }
            {
                s-callable/iter:
                [
                    resolver sub-resolver1>> next
                    [ t resolver yield?<< ]
                    [ s-unify?-exit: resolver state<< ] if
                ]
            }
            {
                s-not-callable:
                [
                    resolver
                    [ d-body>> ] [ d-env>> ] [ d-cut>> ] tri
                    <resolver> resolver sub-resolver1<<
                    s-not-callable/outer-iter: resolver state<<
                ]
            }
            {
                s-not-callable/outer-iter:
                [
                    resolver sub-resolver1>> next [
                        resolver ~quotation~ ~quotation~
                        ~quotation~ tri <resolver>
                        resolver sub-resolver2<<
                        s-not-callable/inner-iter: resolver
                        state<<
                    ] [ s-unify?-exit: resolver state<< ] if
                ]
            }
            {
                s-not-callable/inner-iter:
                [
                    resolver sub-resolver2>> next
                    [ t resolver yield?<< ] [
                        resolver cut>> cut? resolver d-cut>>
                        set-info-if-f
                        s-not-callable/outer-iter: resolver
                        state<<
                    ] if
                ]
            }
            {
                s-unify?-exit:
                [
                    resolver trail>> [ first2 env-delete ] each
                    resolver d-env>> env-clear
                    s-defs-loop-end: resolver state<<
                ]
            }
            {
                s-defs-loop-end:
                [
                    resolver [ i>> ] [ loop-end>> ] bi >=
                    [ s-end: resolver state<< ] [
                        resolver ~quotation~ change-i drop
                        s-defs-loop: resolver state<<
                    ] if
                ]
            }
            { s-end: [ t resolver return?<< ] }
        } case resolver [ yield?>> ] [ return?>> ] bi or not
    ] loop resolver yield?>> ;