swi prolog engine implementation

parent 9e627588
...@@ -100,6 +100,7 @@ PSSOURCES = \ ...@@ -100,6 +100,7 @@ PSSOURCES = \
logic/guile-log/iso-prolog.scm \ logic/guile-log/iso-prolog.scm \
logic/guile-log/prolog/goal-expand.scm \ logic/guile-log/prolog/goal-expand.scm \
logic/guile-log/guile-prolog/set.scm \ logic/guile-log/guile-prolog/set.scm \
logic/guile-log/guile-prolog/engine.scm \
logic/guile-log/guile-prolog/delay.scm \ logic/guile-log/guile-prolog/delay.scm \
logic/guile-log/guile-prolog/foldarg.scm \ logic/guile-log/guile-prolog/foldarg.scm \
logic/guile-log/guile-prolog/ops.scm \ logic/guile-log/guile-prolog/ops.scm \
......
(define-module (logic guile-log guile-prolog engine)
#:use-module (logic guile-log)
#:use-module ((logic code-load) #:select
())
#:use-module (logic guile-log iso-prolog)
#:export (engine_create
engine_next
engine_next_reified
engine_post
engine_yield
engine_fetch
is_engine
engine_self
current_engine)
(<define> (engine_yield term) (<ret> (list #yield S P CC term)))
(<define> (stub-scm goal box engine)
(<with-postbox> (cons box engine)
(goal)))
(<define> (engine_fetch term)
(copy_term (variable-ref (car (<postbox-ref>))) term))
(define postbox (make-variable #f))
(define (generate-engine s size name template goal)
(let ((engine (make-engine size)))
(letrec ((state #f)
(postbox (make-variable #f))
(on-result
(lambda ()
(match state
(#:exit
(set! engine #f))
((#:throw e)
(set! engine #f))
(_ #t))))
(start-f
(lambda (s)
(set! start-f next)
(let ((s2 (gp-new-engine s engine)))
(set! state
(stub-scm
(lambda () (list #:exit))
(lambda (s p . x)
(cons* #:finish s p x))
goal
postbox
(lambda () ret)))
(on-result)
(gp-pop-engine)
state)))
(next
(lambda (s term)
(match state
(#:exit
state)
((#:throw e)
state)
((#:yield s p cc x)
(let ((s (gp-old-engine s engine)))
(set! state (cc s p))
(gp-pop-engine)
(cons x state)))
((#:finish s p)
(let ((s (gp-old-engine s engine)))
(set! state (p))
(gp-pop-engine)
(cons template state))))))
(ret
(lambda (kind s term)
(match kind
(#:run (start-f s term))
(#:post (variable-set! postbox term))
(#:exist
(match state
(((#:throw) . _) #f)
(#exit #f)
(_ #f)))))))
(procedure-property-set! ret 'engine #t)
(procedure-property-set! ret 'name (name-it name))
ret)))
(<define> (is_engine term)
(if (procedure-property (<lookup> term))))
(<define> (engine_next engine term)
(let* ((engine (<lookup> engine))
(res (engine #:run S term)))
(<<match>> (#:mode -) (res)
(#:exit
<fail>)
((#:throw e)
(<var> (ee)
(copy_term e ee)
(throw ee)))
((template #:finish s p)
(copy_term template term))
((template #:yield s p cc)
(copy_term template term)))))
(<define> (engine_next_reified engine term)
(let* ((engine (<lookup> engine))
(res (engine #:run S term)))
(<<match>> (#:mode -) (res)
(#:exit
(<=> "no" trem))
((#:throw e)
(copy_term (vector (list "exception" e))
term))
((template #:finish s p (x))
(copy_term (vector (list "the" template)) term))
((template #:yield s p cc (x))
(copy_term (vector (list "the" template)) term)))))
(define engine_post
(case-lambda
((engine term)
(let ((engine (<lookup> engine)))
(<var> (t)
(copy_term term t)
(<code> (engine #:post S (<lookup> t))))))
((engine term reply)
(engine_post engine term)
(engine_next engine reply))))
(<define> (engine_self engine) (<=> engine (cdr (<postbox-ref>))))
(<define> (current_engine engine)
(is_engine engine)
(if ((<lookup> engine) #:exist #f #f)))
(define (name-it x)
(if (procedure? x)
(procedure-name x)
(if (string? x)
(string->symbol x)
x)))
(<define> (create-engine-scm t g name size engine)
(let ((e (generate-engine S (<lookup> size) (<lookup> name) t
(<lambda> ()
(stub g)))))
(<=> engine e)))
(compile-prolog-string "
stub(Goal) :- catch(Goal,E,set_e(E)).
parse_ops([],Ops,[]) :- !.
parse_ops([],Ops,Defaults) :- !.
parse_ops(Defaults,Ops,[]).
parse_ops([X|L],Ops,Defaults) :-
(member(X,Ops) -> true ; true),
parse_ops(L,Ops,Defaults).
defaults([alias(noname),global(100),local(100),trail(100)]).
engine_create(Template, Goal, Engine, Ops) :-
default(Default),
parse_ops(Ops, [alias(Name),local(Size)], Defaults),
copy_term([Template,Goal],[T,G]),
'create-engine-scm'(T,G,Name,Size,Engine).
")
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment