some small bugfixes and forward_chaining is working

parent 1d3ced4b
......@@ -125,6 +125,7 @@ PSSOURCES = \
language/prolog/modules/library/ordsets.pl \
language/prolog/modules/library/oset.pl \
language/prolog/modules/library/rbtrees.pl \
language/prolog/modules/library/forward_chaining.pl \
language/prolog/modules/ex/att.pl \
language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
......
......@@ -16,27 +16,28 @@
(fluid-set! (@@ (logic guile-log prolog modules) relative-path) #t)
(define sources
'(
(language prolog modules boot expand)
(language prolog modules boot dcg)
(language prolog modules library error)
(language prolog modules library pairs)
(language prolog modules library lists)
(language prolog modules library assoc)
(language prolog modules library rbtrees)
(language prolog modules library oset)
(language prolog modules library ordsets)
(language prolog modules library option)
(language prolog modules library optparse)
(language prolog modules library sort)
(language prolog modules library apply)
(language prolog modules library heaps)
(language prolog modules library gensym)
(language prolog modules library apply_macros)
(language prolog modules library ugraphs)
(language prolog modules library dcg_basics)
(language prolog modules ex att)
(language prolog modules test)
(language prolog modules test2)
(#:boot (language prolog modules boot expand))
(#:boot (language prolog modules boot dcg))
(#:boot (language prolog modules library error))
(#:boot (language prolog modules library pairs))
(#:boot (language prolog modules library lists))
(#:boot (language prolog modules library assoc))
(#:boot (language prolog modules library rbtrees))
(#:boot (language prolog modules library oset))
(#:boot (language prolog modules library ordsets))
(#:boot (language prolog modules library option))
(#:boot (language prolog modules library optparse))
(#:boot (language prolog modules library sort))
(#:boot (language prolog modules library apply))
(#:boot (language prolog modules library heaps))
(#:boot (language prolog modules library gensym))
(#:boot (language prolog modules library apply_macros))
(#:boot (language prolog modules library ugraphs))
(#:boot (language prolog modules library dcg_basics))
(#:boot (language prolog modules library forward_chaining))
(#:boot (language prolog modules ex att))
(#:boot (language prolog modules test))
(#:boot (language prolog modules test2))
(language prolog modules library clpb)
(language prolog modules library clpfd)
(language prolog modules swi term_macro)))
......@@ -46,5 +47,8 @@
(system* "pwd")
(for-each
(lambda (pth)
((@@ (logic guile-log prolog modules) pre-compile-prolog-file) pth))
(if (and (pair? pth) (eq? (car pth) #:boot))
((@@ (logic guile-log prolog modules) pre-compile-prolog-file)
(cadr pth) #:boot? #t)
((@@ (logic guile-log prolog modules) pre-compile-prolog-file) pth)))
sources))
......@@ -337,3 +337,9 @@ dcg_special([]).
dcg_special([_|_]).
dcg_special(\+_).
% Wire in the dcg expansion
:- scm[
((@ (guile) set!)
(@@ (logic guile-log prolog parser) expand_term_dcg)
expand_term_dcg)
].
......@@ -2,11 +2,16 @@
(define-module (language prolog modules boot dcg)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-expand)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (logic guile-log guile-prolog set)
#:use-module (language prolog modules boot dcg)
#:use-module (logic guile-log guile-prolog interpreter)
#:pure
#:duplicates (last replace)
#:replace (dcg_translate_rule dcg_translate_rule phrase phrase expand_term_dcg))
(clear-directives)
((@ (guile) eval-when) (compile load eval)
......
:- module(forward_chaining,
[term(compile),
term(directive_macro),
op(1200,xfx,'=f>'),
fire/3,
set_trigger/1,
database/1]).
/*
This is a small library of forward chaining mechanism. The forward chaining
is using a database that is a dynamic variable marked through
:- dynamic(db/1).
:- database(db).
And to define the trigger goal do,
:- dynamic(trigger/1).
:- trigger_func(trigger).
With this system one can use the =f> operator to define rules
f(X,Y),g(Y,Z) =f> f(X,Z).
To add to the database use
?- new(db,f(X,Y)),
To look into the database use, db
?- db(f(X,Y)).
To fire an action do,
?- trigger(f(1,2))
?
*/
:- use_module(library(apply)).
:- dynamic(chain/2).
trigger.
ret(X) :- chain(X,_) -> retract(chain(X,_)) ; true.
directive_macro((:- set_trigger(X)),[]) :-
ret(trigger),
asserta(chain(trigger,X)).
directive_macro((?- set_trigger(X)),[?- true]) :-
ret(trigger),
asserta(chain(trigger,X)).
fand(Y,[X,W],[X,(W,Y)]).
compile_head((X,Y),Z) :- !,
compile_head(X,ZX), maplist(fand(Y),ZX,ZZX),
compile_head(Y,ZY), maplist(fand(X),ZY,ZZY),
append(ZZX,ZZY,Z).
compile_head((X;Y),Z) :- !,
compile_head(X,ZX),
compile_head(Y,ZY),
append(ZX,ZY,Z).
compile_head({X},[[true,true]]) :- !.
compile_head(X ,[[X ,true]]).
compile_code((X,Y),(ZX,ZY)) :- !,
compile_code(X,ZX),
compile_code(Y,ZY).
compile_code((X;Y),(ZX;ZY)) :- !,
compile_code(X,ZX),
compile_code(Y,ZY).
compile_code({X},X) :- !.
compile_code(X,Z) :- chain(trigger, T), Z = fire(T,X).
compile_b((X,Y),(ZX,ZY)) :- !,
compile_b(X,ZX),
compile_b(Y,ZY).
compile_b((X,Y),(ZX;ZY)) :- !,
compile_b(X,ZX),
compile_b(Y,ZY).
compile_b({X},X) :- !.
compile_b(X ,X).
for_each(X) :- (X,fail);true.
new(H) :- H -> fail ; assertz(H).
g(_,[true,_],true).
g(Code,[H,B],Z) :-
chain(trigger,T),
compile_b(B,BB),
Z = (T(H) :- ((BB,Code,fail) ; true)).
h([true|X],L ) :- h(X,L).
h([X |L],(assertz(X),LL)) :- h(L,LL).
h([],true).
hh([true|X],L ) :- hh(X,L).
hh([X |L],[X|LL] ) :- hh(L,LL).
hh([],[]).
fire(Trig,H) :- write(fire(H)),nl,new(H),((Trig(H), fail) ; true).
compile((Head =f> Code), Z) :-
compile_head(Head,ZZ),
compile_code(Code,Code2),
maplist(g(Code2),ZZ,ZZZ),
hh(ZZZ,Z).
compile(?- (Head =f> Code), [?- Z]) :-
compile_head(Head,ZZ),
compile_code(Code,Code2),
maplist(g(Code2),ZZ,ZZZ),
h(ZZZ,Z).
(define-module (language prolog modules library forward_chaining)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-expand)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (logic guile-log guile-prolog set)
#:use-module (language prolog modules boot dcg)
#:use-module (logic guile-log guile-prolog interpreter)
#:pure
#:duplicates (last replace)
#:replace (fire set_trigger database =f>))
(clear-directives)
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
*prolog-ops* *swi-standard-operators*))
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
(@ (logic guile-log prolog parser) *term-expansions*)
'()))
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
(@ (logic guile-log prolog parser) *goal-expansions*)
'()))
(compile-prolog-string "
:- op(1200,xfx,'=f>').
")
((@ (guile) define) *public-module-operators* (list '(1200 xfx =f>) ))
(compile-prolog-file "/home/stis/src/guile-log/language/prolog/modules/library/forward_chaining.pl")
((@ (guile) define) *public-module-term-expansions* (list compile directive_macro ))
((@ (guile) define) *optable-save-first* #t)
((@ (guile) when) *optable-save-first*
((@ (guile) set!) *optable-save-first* #f)
(module-optable-set! (save-operator-table)))
((@ (guile) define) *prolog-scm-path* "./")
((@ (guile) define) *prolog-reverse-path* "../forward_chaining.pl")
......@@ -35,10 +35,10 @@
(define =..tag (cons '=.. 'tag))
(define not-tag (list-ref tags 1))
(define predicate-tag (list-ref tags 2))
(define (=..tag? x) (eq? x =..tag))
(define (or-tag? x) (eq? x or-tag))
(define (and-tag? x) (eq? x and-tag))
(define (not-tag? x) (eq? x not-tag))
(define (=..tag? x) (eq? x =..tag))
(define (or-tag? x) (eq? x or-tag))
(define (and-tag? x) (eq? x and-tag))
(define (not-tag? x) (eq? x not-tag))
(define (predicate-tag? x) (eq? x predicate-tag))
(define (has-not-predicate-tag a)
......@@ -431,7 +431,7 @@ add/run * vlist *
(lp (cdr l) (bitmap-indexer-add s f (car l) dlink))
dlink)))
(((? and-tag) x y)
(((? and-tag?) x y)
(match (dive dlink and-tag)
(((? and-tag?) a b c)
(list and-tag a
......@@ -1163,15 +1163,15 @@ add/run * vlist *
(define-syntax <lambda-dyn>
(syntax-rules ()
((_ (pat ...) code)
(list (mk-varpat (pat ...))
((_ (pat ...) code)
(list (begin (mk-varpat (pat ...)))
(lambda (a b c cut x)
(apply (<<lambda>> (pat ... (<with-cut> cut code)))
a b c x))
'true))
((_ (pat ...) code y)
(list (mk-varpat (pat ...))
(list (begin (mk-varpat (pat ...)))
(lambda (a b c cut x)
(apply (<<lambda>> (pat ... (<with-cut> cut code)))
a b c x))
......@@ -1185,7 +1185,8 @@ add/run * vlist *
(syntax-case x ()
((_ (pat ...) code)
(with-syntax (((pat2 ...) (pp (parse-pat-extended #'(pat ...)))))
(pp #`(list #,(pp (mk-varpat-extended #'(pat ...)))
(pp #`(list (begin
#,(pp (mk-varpat-extended #'(pat ...))))
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x))
......@@ -1193,7 +1194,8 @@ add/run * vlist *
((_ (pat ...) code y)
(with-syntax (((pat2 ...) (pp (parse-pat-extended #'(pat ...)))))
(pp #`(list #,(mk-varpat-extended #'(pat ...))
(pp #`(list (begin
#,(mk-varpat-extended #'(pat ...)))
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x))
......
......@@ -169,7 +169,7 @@
(compile-prolog-string
"
k(V,L,LL) :- var(V) -> (attvar(V) -> L=[V|LL] ; L=LL) ; fail.
k(V,L,LL) :- var(V) -> (attvar(V) -> L=[V|LL] ; L=LL) ; L=LL.
k([A|B],L,LL) :- k(A,L,LX),k(B,LX,LL).
k(X,L,LL) :- X=..[Q|U] -> k([Q|U],L,LL) ; L=LL.
")
......
......@@ -476,9 +476,12 @@ more :-
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
h([(?- X)|L],(X,LL)) :- h(L,LL).
h([],true).
solve(V,N,X) :-
set_once,
(expand_term_0((?- X),(?- Y)) -> Y ; X),
(expand_term_0((?- X),Y) -> (h(Y,YY),YY) ; X),
project_the_attributes(V),
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
......
......@@ -103,7 +103,7 @@
(if (<= lev trace-level )
(<and>
(<pp-dyn> `(,b enter ,f) `(,b leave ,f))
((@ (logic guile-log iso-prolog) write) (list b 'trace f #;l))
((@ (logic guile-log iso-prolog) write) (list b 'trace f l))
((@ (logic guile-log iso-prolog) nl)))
<cc>))
......@@ -689,6 +689,11 @@
((((loc ...) ...) ...) loc)
((((v ...) ...) ...) v-new)
(fstx (datum->syntax stx f)))
(when (member f (string->list ",;"))
(warn "redifing , or ;, mayby . => , is needed"))
(if lam?
(begin
(nm-store f)
......@@ -702,7 +707,7 @@
rhs))) ...)
...))))))
(let* ((fuu (syntax-case fu (eval_when unquote)
(let* ((fuu (syntax-case fu (eval_when unquote)
(((,eval_when . a) . f)
#'f)
(x #'x)))
......
......@@ -17,7 +17,7 @@
#:use-module (logic guile-log attributed)
#:use-module ((logic guile-log)
#:select (<define> <let> <scm> <var?>
<lookup> <match> <cut>
<lookup> <match> <<match>> <cut>
<or> <=> <recur> <code> <cc>))
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
......@@ -42,8 +42,20 @@
macro
add_attribute_cstr
add_attribute_projector
translate-directive
))
(define-syntax-rule (id stx x)
(datum->syntax stx (procedure-name (<lookup> x))))
(<define> (translate-directive stx head)
(<<match>> (#:mode -) (head)
(#("add_attribute_cstr" x y)
(<cc> #`(set-attribute-cstor! #,(id stx x) #,(id stx y))))
(#("add_attribute_projector" x y)
(<cc> #`(set-attribute-projector! #,(id stx x) #,(id stx y))))))
(define do-print #f)
(define pp
(case-lambda
......
......@@ -98,8 +98,11 @@
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
(#((,fact Head Body ))
(#((,fact Head))
(translate-directive stx Head))
(#(((and Op ,fact) Head Body ))
(<recur> lp ((Head Head))
(<<match>> (#:mode - #:name subassert) (Head)
((? <var?>)
......@@ -168,9 +171,10 @@
(mk-assert+source assertz-source <append-dynamic>)
(<define> (asserta x . l)
(once-f (vector (list asserta_ x l))))
(asserta_ x (if (null? l) #f l)))
(<define> (assertz x . l)
(once-f (vector (list assertz_ x l))))
(assertz_ x (if (null? l) #f l)))
(<define> (clause Head Body)
(<let> ((Head (<lookup> Head)))
......
......@@ -7,49 +7,55 @@
(compile-prolog-string
"
goal_expand(+{X},Exps,Res) :- !,
goal_expand(X,Exps,XX),
Res = (+{XX}).
goal_expand((X :- Y),Exps,Res) :- !,
goal_expand(Y,Exps,YY),
goal_exp(Y,Exps,YY),
Res = (X :- YY).
goal_expand((X --> Y),Exps,Res) :- !,
goal_expand(Y,Exps,YY),
goal_exp(Y,Exps,YY),
Res = (X --> YY).
goal_expand((:- Y),Exps,Res) :- !,
goal_expand(Y,Exps,YY),
goal_exp(Y,Exps,YY),
Res = (:- YY).
goal_expand((?- Y),Exps,Res) :- !,
goal_expand(Y,Exps,YY),
goal_exp(Y,Exps,YY),
Res = (?- YY).
-trace.
goal_exp(+{X},Exps,Res) :- !,
goal_exp(X,Exps,XX),
Res = (+{XX}).
goal_expand((X,Y),Exps,Res) :- !,
goal_expand(X,Exps,XX),
goal_expand(Y,Exps,YY),
goal_exp((X,Y),Exps,Res) :- !,
goal_exp(X,Exps,XX),
goal_exp(Y,Exps,YY),
Res = (XX,YY).
goal_expand((X;Y),Exps,Res) :- !,
goal_expand(X,Exps,XX),
goal_expand(Y,Exps,YY),
goal_exp((X;Y),Exps,Res) :- !,
goal_exp(X,Exps,XX),
goal_exp(Y,Exps,YY),
Res = (XX;YY).
goal_expand((X->Y),Exps,Res) :- !,
goal_expand(X,Exps,XX),
goal_expand(Y,Exps,YY),
goal_exp((X->Y),Exps,Res) :- !,
goal_exp(X,Exps,XX),
goal_exp(Y,Exps,YY),
Res = (XX->YY).
goal_expand(\\+X,Exps,Res) :- !,
goal_expand(X,Exps,XX),
goal_exp(\\+X,Exps,Res) :- !,
goal_exp(X,Exps,XX),
Res = (\\+XX).
goal_expand(X,[] ,Res) :- !, X=Res.
goal_exp(X,[],Res) :- !, fail.
goal_exp(X,E,Res) :- goal_exp(X,E,E,Res), var(Res) -> fail ; true.
goal_expand(X,[E|EE],Res) :- call(E,X,XX), goal_expand(XX,EE,Res).
goal_exp(X,[E|EE],EEE, Res) :-
call(E,X,Res2) -> (goal_exp(Res2,EEE,EEE,Res) -> true ; Res=Res2) ;
goal_expand(X,EE,EEE,Res).
")
(set! (@@ (logic guile-log prolog parser) goal-expand) goal_expand)
......@@ -70,7 +70,7 @@
'()))))
(define relative-path (make-fluid #f))
(define (write-module fpl fscm path)
(define* (write-module fpl fscm path #:key (boot? #f))
(define (m p) p)
(define module-data-opdata
......@@ -98,7 +98,7 @@
(define module-termdata (let lp ((l module-data-opdata))
(if (pair? l)
(let ((x (pk (car l))))
(let ((x (car l)))
(if (and (pair? x) (eq? (car x) #:term))
(cons (cadr x) (lp (cdr l)))
(lp (cdr l))))
......@@ -172,20 +172,22 @@
'()))~%")
(if (not boot?)
(format #t
"
(compile-prolog-string
\"
:- use_module(boot(dcg)).
:- use_module(user).
:- use_module(swi(term_macro)).
\")
")
"))
(when (pair? module-opdata)
(format #t "(compile-prolog-string \"~%")
(map (lambda (x)
(format #t ":- op(~a,~a,~a).~%"
(format #t ":- op(~a,~a,'~a').~%"
(car x) (cadr x) (h (symbol->string (caddr x)))))
module-opdata)
(format #t "~%\")~%")
......@@ -260,9 +262,9 @@
(scm? (is-scm-path? pth)))
(if scm?
(if (equal? (car scm?) pl)
(apply check #t pth) ;; equal paths, check timestamps
(apply check #f (list pl pth))) ;; always clobber
(apply check #f (list pl pth))) ;; always clobber
(apply check #f #t pth) ;; equal paths, check timestamps
(apply check #f #f (list pl pth))) ;; always clobber
(apply check #f #f (list pl pth))) ;; always clobber
(map string->symbol (map str-it (append '(language prolog modules) path)))))
(define (lpath x) (string-split x #\/))
......@@ -394,7 +396,7 @@
#`(eval-when (eval load compile)
(define *prolog-current-module* '#,(datum->syntax stx nm)))))))
(define (check chk? fpl fscm path)
(define (check boot? chk? fpl fscm path)
(when (or (not chk?)
(not (file-exists? fscm))
(let* ((mpl (stat:mtime (stat fpl)))
......@@ -402,7 +404,7 @@
(< (+ mscm 10) mpl)))
(pk `(write-scm ,fscm))
(with-output-to-file fscm
(write-module fpl fscm path))))
(write-module fpl fscm path #:boot? boot?))))
(define (mk-file f ext)
(let ((r (reverse f)))
......@@ -462,13 +464,13 @@
(lp (cdr l))))
#f))))
(define (pre-compile-prolog-file f)
(define* (pre-compile-prolog-file f #:key (boot? #f))
(let ((pth (find-path f)))
(if pth
(apply check #t (append pth (list f)))
(apply check boot? #t (append pth (list f)))
(let ((pth (search-prolog-source f)))
(if pth
(apply check #t (append pth (list f)))
(apply check boot? #t (append pth (list f)))
(if #f #f))))))
(define ref '*prolog-modules*)
......@@ -650,7 +652,7 @@
(<define> (get-mod x y)
(<match> (#:mode -) (x)
(<<match>> (#:mode -) (x)
(#((a b))
(<cut>
(<let> ((aa (<lookup> a)))
......@@ -704,9 +706,6 @@
'())))))
(define *once* #f)
(<define> (use_module . l)
(<apply> use_module_ l))
(define (modspec x)
(let* ((fx (cadr x))
(fx (if (symbol? fx)
......@@ -735,7 +734,7 @@
(lp (cdr l))))))))
(define (use-pub-term-expansions mod s)
(with-s s
(with-s s
(if (module-defined? mod '*public-module-term-expansions*)
(let lp ((l (module-ref
mod
......@@ -760,6 +759,10 @@
(fluid-ref *goal-expansions*)))
(lp (cdr l))))))))
(<define> (use_module . l)
(<let> ((p P))
(<apply> use_module_ l)
(<with-fail> p <cc>)))
(define use_module_
(<case-lambda>
......@@ -775,7 +778,7 @@
(<cc> (list (procedure-name syms))))
(else
(<recur> lp ((syms syms) (r '()))
(<match> (#:mode -) (syms)
(<<match>> (#:mode -) (syms)
((x . l)
(<cut>
(<values> (xx) (lp x '()))
......@@ -802,11 +805,10 @@
(with-fluids ((*current-stack* S))
(wrap-* (pre-compile-prolog-file f1)))
(undef-symbols syms)
(let ((mod (module-public-interface
(with-fluids
(let ((mod (with-fluids
((*current-language*
(lookup-language 'scheme)))
(resolve-module f2)))))
(resolve-module f2))))
(begin
(set-module! mname (resolve-module f2))
(with-fluids ((*ops*
......@@ -824,7 +826,7 @@
((x)
(<match> (#:mode -) (x)
(<<match>> (#:mode -) (x)
((a)
(<cut>
(use_module_ a)))
......@@ -848,11 +850,10 @@
(<code>
(with-fluids ((*current-stack* S))
(wrap-* (pre-compile-prolog-file f1)))
(let ((mod (module-public-interface
(with-fluids
(let ((mod (with-fluids
((*current-language*
(lookup-language 'scheme)))
(resolve-module f2)))))
(resolve-module f2))))
(set-module! mname (resolve-module f2))
(module-for-each (lambda x
((undef-symbols mod)
......
......@@ -956,31 +956,37 @@
(lp (cdr l)))
(<and> (type_error "expandable" x)))))
(<define> (expand_term_0 x z)
(<var> (y)
(<recur> lp ((l (fluid-ref *term-expansions*)))
(if (pair? l)
(<if> ((car l) x y)
(if (and goal-expand (pair? (fluid-ref *goal-expansions*)))
(<var> (z)
(goal-expand y (fluid-ref *goal-expansions*) z))
(<=> y z))
(lp (cdr l)))
(if (and goal-expand (pair? (fluid-ref *goal-expansions*)))
(goal-expand x (fluid-ref *goal-expansions*) z)
<fail>)))))