Vocabulary
logic.private

Definition

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

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
[ f ] [ t ] if
] loop resolver yield?>> ;