projected attributes added

parent c67bf394
......@@ -726,6 +726,8 @@ project_attributes(QueryVars0, AttrVars) :-
sort(Roots0, Roots),
maplist(remove_hidden_variables(QueryVars), Roots).
:- add_project_attributes(clpb, project_attributes).
clpb_variable(Var) :- var_index(Var, _).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
......
......@@ -2,11 +2,15 @@
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (add-attribute-printer
attribute-printer-ref
get-all-attributed-variables
att-printer
delayed-attribute)
delayed-attribute
ref-attribute-projector
set-attribute-projector!)
#:re-export (
gp-attvar?
gp-attvar-raw?
......@@ -52,3 +56,7 @@
(define (delayed-attribute lam)
(set-object-property! lam (@@ (logic guile-log code-load) delayed-id) #t))
(define (set-attribute-projector! x f)
(set-object-property! x 'projector f))
(define (ref-attribute-projector x)
(object-property x 'projector))
(define-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog goal-functors)
......@@ -13,7 +14,8 @@
get_attr get_attrs del_attr del_attr_x raw_attvar
construct_attr attribute_cstor attach_attribute_cstor
call_residue_vars build_attribut_representation
attribute_prefix del_attrs del_attrs_x))
attribute_prefix del_attrs del_attrs_x
project_the_attributes))
(<define> (build_attribut_representation res tail x)
(<let> ((x (<lookup> x)))
......@@ -164,3 +166,44 @@
(<var> (v)
(<set!> x v))
<cc>)))
(compile-prolog-string
"
k(V,L,LL) :- var(V) -> (attvar(V) -> L=[V|LL] ; L=LL) ; fail.
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.
")
(<define> (project_the_attributes v)
(<var> (l)
(k v l '())
(<recur> lp ((v vlist-null) (l l))
(<<match>> (#:mode -) (l)
((x . l)
(<let> ((x (<lookup> x)))
(if (attvar? x)
(<recur> lp2 ((v v) (d (gp-att-data x S)))
(<match> (#:mode -) (d)
(((a . _) . d)
(<let*> ((a (<lookup> a))
(f (ref-attribute-projector a)))
(if (and a (not (vhashq-ref v a #f)))
(lp2 (vhash-consq a #t v) d)
(lp2 v d))))
(()
(lp v l))))
(lp v l))))
(()
(<recur> lp ((u (map car (vhash->assoc v))))
(<<match>> (#:mode -) (u)
((x . u)
(<and>
((<lookup> x) v l)
(lp u)))
(() <cc>))))))))
......@@ -6,6 +6,7 @@
<newframe> <=> <and> <lambda> <apply> <pp> S P))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 readline)
......@@ -478,6 +479,7 @@ empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
solve(V,N,X) :-
set_once,
(expand_term_0((?- X),(?- Y)) -> Y ; X),
project_the_attributes(V),
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
")
......
......@@ -76,6 +76,9 @@
;; guile-log
macro multibute extended
add_attribute_cstr
add_attribute_projector
;;Swi global variables
b_setval b_getval nb_setval nb_getval nb_current
......
......@@ -14,6 +14,7 @@
#:use-module (logic guile-log prolog order)
#:use-module (logic guile-log prolog var)
#:use-module (logic guile-log prolog symbols)
#:use-module (logic guile-log attributed)
#:use-module ((logic guile-log)
#:select (<define> <let> <scm> <var?>
<lookup> <match> <cut>
......@@ -39,6 +40,8 @@
add_goal_expansion
add_goal_expansion_temp
macro
add_attribute_cstr
add_attribute_projector
))
(define do-print #f)
......@@ -109,6 +112,19 @@
'#,(datum->syntax stx nm))
(fluid-ref *term-expansions*)))))))
(define-parser-directive (add_attribute_cstr stx l n m)
(match l
((_ (#:atom nm1 . _) (#:atom nm2 . _))
#`(set-attribute-cstor! #,(datum->syntax stx nm1)
#,(datum->syntax stx nm2)))))
(define-parser-directive (add_attribute_projector stx l n m)
(match l
((_ (#:atom nm1 . _) (#:atom nm2 . _))
#`(set-attribute-projector! #,(datum->syntax stx nm1)
#,(datum->syntax stx nm2)))))
(<define> (add_goal_expansion x)
(<code>
(fluid-set! *goal-expansions*
......
......@@ -809,7 +809,7 @@
(define (gp-cp . x)
(fluid-set! *cp-constructors* '())
(apply (fluid-ref *gp-cp*) x))
(define (attribute-cstor-ref id)
(let ((res (object-property id 'attribute-cstor)))
(if res
......@@ -822,7 +822,7 @@
(car res)
res)))
(define (set-attribute-cstor! id val)
(define (set-attribute-cstor! id . val)
(set-object-property! id 'attribute-cstor val))
(define do-attribute-constructors
......
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