sumof etc added to the prolog environment

parent 68c8a967
......@@ -116,6 +116,7 @@ PSSOURCES = \
logic/guile-log/guile-prolog/coroutine.scm \
logic/guile-log/guile-prolog/attributator.scm \
logic/guile-log/examples/kanren/type-inference.scm \
logic/guile-log/imatch.scm \
prolog-user.scm \
language/prolog/install.scm \
language/prolog/spec.scm \
......
......@@ -1704,7 +1704,7 @@ add/run * vlist *
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn 'f (lambda (x) (set! f x))))
(wrap-u s (apply dynamic-append s f
(wrapu s (apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...
f)))))
......@@ -1719,7 +1719,7 @@ add/run * vlist *
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn-ii 'f (lambda (x) (set! f x))))
(wrap-u s (apply dynamic-append s f
(wrapu s (apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...
f)))))
......
......@@ -565,7 +565,7 @@ from c-land in the indexer.
(define fold-matching-sets
(case-lambda
((f seed set tree)
(fold-matching-sets f seed (fluid-ref *current-theory* set tree)))
(fold-matching-sets f seed (fluid-ref *current-set-theory*) set tree))
((f seed theory set tree)
(let ((ih (get-i (get-i->subs theory) (lookup theory set))))
(fold-dynlist-lr
......
......@@ -51,6 +51,8 @@
load_persists
save_persists
accessify_predicate
sumof prodof
maxof minof lastof functor
;;swi stuff
meta_predicate public
......
......@@ -62,7 +62,7 @@
(define (persist-set! log tag val) (register-tag log tag val))
(define (persist-ref log tag) (log 'get-tag tag))
(define (make-shallow val)
(set-object-property! val 'shallow)
(set-object-property! val 'shallow val)
val)
(define (associate-getter-setter o set get)
......
......@@ -40,7 +40,8 @@
#:use-module (ice-9 pretty-print)
#:replace (catch throw)
#:export ( unify_with_occurs_check copy_term
findall findall-fkn bagof setof functor arg
findall findall-fkn bagof setof sumof prodof
maxof minof lastof functor arg
var atomic compound nonvar
directive
procedure_name
......@@ -824,7 +825,6 @@ floor(x) (floor x)
(findall-fkn t g l))
(mk-prolog-term-3 tr-findall findall findall-mac a a a)
(<define> (bagof-fkn template g l)
(<recur> lp ((gg g) (q '()) (i 0))
(<let> ((gg (<lookup> gg)))
......@@ -834,7 +834,7 @@ floor(x) (floor x)
(else <cc>))
(<or>
(<var> (X A)
(<=> gg ,(vector (list ^ X A)))
(<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons X q) (+ i 1))))
(<let*> ((t (<get-fixed> template '()))
(q (<get-fixed> q '()))
......@@ -855,6 +855,66 @@ floor(x) (floor x)
(mk-prolog-term-3 tr-bagof bagof bagof-mac a a a)
(define-syntax-rule (mkof sumof-fkn kons knil)
(<define> (sumof-fkn template g l)
(<recur> lp ((gg g) (q '()) (i 0))
(<let> ((gg (<lookup> gg)))
(cond
((<var?> gg)
(instantiation_error))
(else <cc>))
(<or>
(<var> (X A)
(<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons X q) (+ i 1))))
(<let*> ((t (<get-fixed> template '()))
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
(<var> (r)
(<fix-fold> kons knil (<lambda> () (goal-eval gg))
template fixed r)
(<=> ,l ,r))))))))
(mkof sumof-fkn + 0)
(<define-guile-log-rule> (sumof-mac t g l)
(sumof-fkn t g l))
(mk-prolog-term-3 tr-sumof sumof sumof-mac a a a)
(mkof prodof-fkn * 1)
(<define-guile-log-rule> (prodof-mac t g l)
(prodof-fkn t g l))
(mk-prolog-term-3 tr-prodof prodof prodof-mac a a a)
(mkof maxof-fkn max (- (inf)))
(<define-guile-log-rule> (maxof-mac t g l)
(maxof-fkn t g l))
(mk-prolog-term-3 tr-maxof maxof maxof-mac a a a)
(mkof minof-fkn max (inf))
(<define-guile-log-rule> (minof-mac t g l)
(minof-fkn t g l))
(mk-prolog-term-3 tr-minof minof minof-mac a a a)
(define (laster x y) x)
(mkof lastof-fkn laster #f)
(<define-guile-log-rule> (lastof-mac t g l)
(lastof-fkn t g l))
(mk-prolog-term-3 tr-lastof lastof lastof-mac a a a)
(define (filter s x)
(match x
((x y . l)
......
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