project.scm 1.54 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(define-module (logic guile-log guile-prolog project)
  #:use-module (logic guile-log) 
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log umatch)
  #:use-module (logic guile-log prolog error)
  #:use-module (logic guile-log prolog names)
  #:use-module (logic guile-log prolog goal-functors)
  #:use-module (logic guile-log attributed)
  #:use-module (logic guile-log guile-prolog attribute)
  #:use-module (logic guile-log dynamic-features)
  #:use-module (logic guile-log vlist)
  #:re-export (multibute)
  #:export (project_the_attributes))

(compile-prolog-string
"
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
17 18 19 20 21 22
k(V,L,LL)     :- (var(V),!) -> (attvar(V) -> L=[V|LL] ; L=LL).
k([A|B],L,LL) :- !,k(A,L,LX),k(B,LX,LL).
k([],L,L).
k(X,L,LL)     :- atomic(X) -> L=LL          ; 
                 X=..[X|U] -> k([Q|U],L,LL) ; 
                 L=LL. 
23 24
")

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
25
(<define> (project_the_attributes q)
26
  (<var> (l) 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
27
    (k q l '())
28 29 30 31
    (<recur> lp ((v vlist-null) (l l))
       (<<match>> (#:mode -) (l)
         ((x . l)
	  (<let> ((x (<lookup> x)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
32
	    (if (gp-attvar-raw? x S)
33 34 35 36 37
		(<recur> lp2 ((v v) (d (gp-att-data x S)))
		  (<match> (#:mode -) (d)
		    (((a . _) . d)
		     (<let*> ((a (<lookup> a))
			      (f (ref-attribute-projector a)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
38 39
		       (if (and f (not (vhashq-ref v f #f)))
			   (lp2 (vhash-consq f #t v) d)
40 41 42 43 44
			   (lp2 v d))))
		    (()
		     (lp v l))))
		(lp v l))))
	 (()
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
45
	  (<recur> lp ((u  (map car (vhash->assoc v))))	    
46 47 48
	    (<<match>> (#:mode -) (u)
	     ((x . u)
	      (<and>
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
49
	       (<or> (<and> ((<lookup> x) q l) <cut>) <cc>)
50 51
	       (lp u)))
	     (() <cc>))))))))