sumof etc added to the prolog environment

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