variants of iterating

parent 15795827
......@@ -93,6 +93,7 @@ PSSOURCES = \
logic/guile-log/prolog/conversion.scm \
logic/guile-log/prolog/swi.scm \
logic/guile-log/prolog/global.scm \
logic/guile-log/prolog/fold.scm \
logic/guile-log/iso-prolog.scm \
logic/guile-log/prolog/goal-expand.scm \
logic/guile-log/guile-prolog/set.scm \
......
(define-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog persist)
#:use-module (logic guile-log prolog fold)
#:use-module (logic guile-log scmspace)
#:use-module (logic guile-log tools)
#:use-module (logic guile-log prolog symbols)
......@@ -52,10 +53,16 @@
load_persists
save_persists
accessify_predicate
sumof prodof countof maxof minof foldof
sumofn prodofn countofn maxofn minofn foldofn
lastof lastofn functor
uniq
foldof sumof prodof countof maxof minof lastof
foldofp sumofp prodofp countofp maxofp minofp lastofp
foldofs sumofs prodofs countofs maxofs minofs lastofs
foldofn sumofn prodofn countofn maxofn minofn lastofn
foldofpn sumofpn prodofpn countofpn maxofpn minofpn lastofpn
foldofsn sumofsn prodofsn countofsn maxofsn minofsn lastofsn)
functor
uniq yield_at_change
;;swi stuff
meta_predicate public
......
(define-module (logic guile-log prolog fold)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log tools)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog order)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (ice-9 match)
#:export (findall bagof setof
foldof sumof prodof countof maxof minof lastof
foldofp sumofp prodofp countofp maxofp minofp lastofp
foldofs sumofs prodofs countofs maxofs minofs lastofs
foldofn sumofn prodofn countofn maxofn minofn lastofn
foldofpn sumofpn prodofpn countofpn maxofpn minofpn lastofpn
foldofsn sumofsn prodofsn countofsn maxofsn minofsn lastofsn)
;;FINDALL
(<define> (findall template g l)
(<code> (gp-var-set *call-expression* g S))
(<var> (r)
(<fold> cons '() (<lambda> () (goal-eval g)) template r)
(<if>
(<=> ,l ,(reverse (<lookup> r)))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))
(define-syntax-rule (mk-mkof def-of args mk-args
(template-x g gg fixed)
code ...)
(begin
(define (mk . mk-args)
(<define> (x-of . args)
(<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-x '()))
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
code ...)))))
x-of)
(define-syntax-rule (def-of x-of . mk-args)
(define x-of
(let ((f (mk . mk-args)))
(set-procedure-property! f 'name 'x-of)
f)))))
(mk-mkof def-li-of
(template g l)
(kons knil <fix-fold>)
(template g gg fixed)
(<var> (r)
(<fix-fold> kons knil (<lambda> () (goal-eval gg))
template fixed r)
(<if> (<=> ,l ,(reverse (<lookup> r)))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))
(def-li-of bagof cons '() <fix-fold>)
(mk-mkof def-val-of
(template g l)
(kons knil <fix-fold>)
(template g gg fixed)
(<var> (t)
(<let> ((f (vector (list is t template))))
(<fix-fold> kons knil
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed l))))
(mk-mkof def-valn-of
(n template g l)
(kons knil <fix-fold>)
(template g gg fixed)
(<var> (t r)
(<recur> lp ((n n) (strict? #f))
(<<match>> (#:mode -) (n)
(#(("strict" n)) (lp n #t))
(_
(<let> ((f (vector (list is t template)))
(n (<lookup> n)))
(<fix-fold> (lambda (x s)
(cons (+ (car s) 1) (kons x (cdr s))))
(cons 0 knil)
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed r
(<lambda> (s) (when (< (car s) n))))
(if strict?
(<=> (,n . ,l) ,r)
(<=> (_ . ,l) ,r))))))))
(define-syntax mku
(lambda (x)
(define (extend x l)
(datum->syntax
x (string->symbol
(string-concat
(symbol->string
(syntax->datum x))
(symbol->string l)))))
(syntax-case x ()
((_ def-val-of def-valn-of name kons knil)
(with-syntax ((countof #'name)
(countofp (extend #'name 'p))
(countofs (extend #'name 's))
(countofn (extend #'name 'n))
(countofpn (extend #'name 'pn))
(countofsn (extend #'name 'sn)))
#'(begin
(def-val-of countof sum1 0 <fix-fold>)
(def-val-of countofp sum1 0 <fix-fold-pre>)
(def-val-of countofs sum1 0 <fix-fold-sorted>)
(def-valn-of countofn sum1 0 <fix-fold>)
(def-valn-of countofpn sum1 0 <fix-fold-pre>)
(def-valn-of countofsn sum1 0 <fix-fold-sorted>)))))))
(define (sum1 x s) (+ s 1))
(mku def-val-of def-valn-of countof sum1 0)
(mku def-val-of def-valn-of sumof + 0)
(mku def-val-of def-valn-of prodof * 1)
(mku def-val-of def-valn-of maxof max (- (inf)))
(mku def-val-of def-valn-of minof min (inf))
(define (laster x y) x)
(mku def-val-of def-valn-of lastof laster #f)
(<define> (gen update F X XX X0)
(<recur> lp ((Y X0))
(<var> (YY)
(<call> ((YY XX)) (<and> (<=> X Y) (F update)))
(<cut>
(<or> (<=> X YY) (lp YY))))))
(mk-mkof def-fold-of
( x xx x0 g lam)
(<fix-fold>)
((cons x xx) g gg fixed)
(<fix-fold>
(lambda (x s) x)
x0
(<lambda> () (gen gg lam x xx x0))
x
fixed
x))
(define-syntax-rule (mk-folder folder-of-fkn folderfn-fkn <fix-fold>)
(begin
(def-fold-of foldof-fkn0 <fix-fold>)
(<define> (foldof-fkn x xx x0 update)
(foldof-fkn0 x xx x0 update
(<lambda> (update) (goal-eval update))))
(<define> (foldofn-fkn m x xx x0 update)
(if (= (<lookup> m) 0)
(<=> x x0)
(<var> (n nn)
(foldof-fkn0 (cons n x) (cons nn xx) (cons 0 x0)
update
(<lambda> (update)
(<let> ((n (<lookup> n))
(m (<lookup> m)))
(when (< n m))
(<=> nn ,(+ n 1))
(goal-eval update)))))))))
(mk-folder foldof foldofn <fix-fold>)
(mk-folder foldofs foldofns <fix-fold-sort>)
(mk-folder foldofp foldofnp <fix-fold-pre>)
(define (filter s x)
(match x
((x y . l)
(if ((</.> (<==> x y)) s (lambda () #f) (lambda x #t))
(filter s (cons y l))
(cons x (filter s (cons y l)))))
(x x)))
(mk-mkof def-set-of
(template g l)
(kons knil <fix-fold>)
(template g gg fixed)
(<var> (r)
(<fix-fold> cons '() (<lambda> () (goal-eval gg))
template fixed r)
(<if> (<=> ,l ,(filter S
(stable-sort (<lookup> r)
(lambda (x y)
(term< S
(lambda () #f)
(lambda x #t) x y)))))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))
(def-set-of setof cons '() <fix-fold>)
......@@ -39,12 +39,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:replace (catch throw)
#:export ( unify_with_occurs_check copy_term
findall findall-fkn bagof setof
sumof countof prodof maxof minof foldof
sumofn countofn prodofn maxofn minofn foldofn
lastof lastofn functor arg
#:export ( unify_with_occurs_check copy_term functor arg
var atomic compound nonvar
directive
procedure_name
......@@ -52,7 +47,7 @@
-var -atom
halt
uniq
uniq yield_at_change
^ :- #{,}# #{,,}# -> #{\\+}# op2= == =@= | -i>
#{\\=}# #{\\==}# #{\\=@=}# @< @> @>= @=< is
......@@ -817,282 +812,12 @@ floor(x) (floor x)
(mk-prolog-term-2 tr-cp copy_term <copy_term> a a)
;;FINDALL
(<define> (findall-fkn template g l)
(<code> (gp-var-set *call-expression* g S))
(<var> (r)
(<fold> cons '() (<lambda> () (goal-eval g)) template r)
(<if>
(<=> ,l ,(reverse (<lookup> r)))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))
(<define-guile-log-rule> (findall-mac t g l)
(findall-fkn t g l))
(<define> (uniq X goal)
(<uniq> (</.> (goal-eval goal)) X))
(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)))
(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> cons '() (<lambda> () (goal-eval gg))
template fixed r)
(<if> (<=> ,l ,(reverse (<lookup> r)))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))))))
(<define-guile-log-rule> (bagof-mac t g l)
(bagof-fkn t g l))
(mk-prolog-term-3 tr-bagof bagof bagof-mac a a a)
(<define> (gen update F X XX X0)
(<recur> lp ((Y X0))
(<var> (YY)
(<call> ((YY XX)) (<and> (<=> X Y) (F update)))
(<cut>
(<or> (<=> X YY) (lp YY))))))
(<define> (foldof-fkn0 x xx x0 update lam)
(<recur> lp ((gg update) (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> (cons x xx) '()))
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
(<var> (template)
(<fix-fold>
(lambda (x s) x)
x0
(<lambda> () (gen gg lam x xx x0))
x
fixed
x)))))))
(<define> (foldof-fkn x xx x0 update)
(foldof-fkn0 x xx x0 update
(<lambda> (update) (goal-eval update))))
(<define> (foldofn-fkn m x xx x0 update)
(if (= (<lookup> m) 0)
(<=> x x0)
(<var> (n nn)
(foldof-fkn0 (cons n x) (cons nn xx) (cons 0 x0)
update
(<lambda> (update)
(<let> ((n (<lookup> n))
(m (<lookup> m)))
(when (< n m))
(<=> nn ,(+ n 1))
(goal-eval update)))))))
(<define-guile-log-rule> (foldof-mac x xx x0 update)
(foldof-fkn x xx x0 update))
(<define-guile-log-rule> (foldofn-mac n x xx x0 update)
(foldofn-fkn n x xx x0 update))
(mk-prolog-term-4 tr-foldof foldof foldof-mac a a a a)
(mk-prolog-term-5 tr-foldofn foldofn foldofn-mac a a 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> (t)
(<let> ((f (vector (list is t template))))
(<fix-fold> kons knil
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed l)))))))))
(define-syntax-rule (mkofn sumof-fkn kons knil)
(<define> (sumof-fkn n template g l)
(<recur> lp ((n n) (strict? #f))
(<<match>> (#:mode -) (n)
(#(("strict" n)) (lp n #t))
(_
(<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> (t r)
(<let> ((f (vector (list is t template)))
(n (<lookup> n)))
(<fix-fold> (lambda (x s)
(cons (+ (car s) 1) (kons x (cdr s))))
(cons 0 knil)
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed r
(<lambda> (s) (when (< (car s) n))))
(if strict?
(<=> (,n . ,l) ,r)
(<=> (_ . ,l) ,r)))))))))))))
(define (sum1 x s) (+ s 1))
(mkof countof-fkn sum1 0)
(mkofn countofn-fkn sum1 0)
(<define-guile-log-rule> (countof-mac t g l)
(countof-fkn t g l))
(<define-guile-log-rule> (countofn-mac n t g l)
(countofn-fkn n t g l))
(mk-prolog-term-3 tr-countof countof countof-mac a a a)
(mk-prolog-term-4 tr-countof countofn countofn-mac a a a a)
(mkof sumof-fkn + 0)
(mkofn sumofn-fkn + 0)
(<define-guile-log-rule> (sumof-mac t g l)
(sumof-fkn t g l))
(<define-guile-log-rule> (sumofn-mac n t g l)
(sumofn-fkn n t g l))
(mk-prolog-term-3 tr-sumof sumof sumof-mac a a a)
(mk-prolog-term-4 tr-sumofn sumofn sumofn-mac a a a a)
(mkof prodof-fkn * 1)
(mkofn prodofn-fkn * 1)
(<define-guile-log-rule> (prodof-mac t g l)
(prodof-fkn t g l))
(<define-guile-log-rule> (prodofn-mac n t g l)
(prodofn-fkn n t g l))
(mk-prolog-term-3 tr-prodof prodof prodof-mac a a a)
(mk-prolog-term-4 tr-prodofn prodofn prodofn-mac a a a a)
(mkof maxof-fkn max (- (inf)))
(mkofn maxofn-fkn max (- (inf)))
(<define-guile-log-rule> (maxof-mac t g l)
(maxof-fkn t g l))
(<define-guile-log-rule> (maxofn-mac n t g l)
(maxofn-fkn n t g l))
(mk-prolog-term-3 tr-maxof maxof maxof-mac a a a)
(mk-prolog-term-4 tr-maxofn maxofn maxofn-mac a a a a)
(mkof minof-fkn max (inf))
(mkofn minofn-fkn max (inf))
(<define-guile-log-rule> (minof-mac t g l)
(minof-fkn t g l))
(<define-guile-log-rule> (minofn-mac n t g l)
(minofn-fkn n t g l))
(mk-prolog-term-3 tr-minof minof minof-mac a a a)
(mk-prolog-term-4 tr-minofn minofn minofn-mac a a a a)
(define (laster x y) x)
(mkof lastof-fkn laster #f)
(mkofn lastofn-fkn laster #f)
(<define-guile-log-rule> (lastof-mac t g l)
(lastof-fkn t g l))
(<define-guile-log-rule> (lastofn-mac n t g l)
(lastofn-fkn n t g l))
(mk-prolog-term-3 tr-lastof lastof lastof-mac a a a)
(mk-prolog-term-4 tr-lastofn lastofn lastofn-mac a a a a)
(define (filter s x)
(match x
((x y . l)
(if ((</.> (<==> x y)) s (lambda () #f) (lambda x #t))
(filter s (cons y l))
(cons x (filter s (cons y l)))))
(x x)))
(<define> (setof-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> cons '() (<lambda> () (goal-eval gg))
template fixed r)
(<if> (<=> ,l ,(filter S
(stable-sort (<lookup> r)
(lambda (x y)
(term< S
(lambda () #f)
(lambda x #t) x y)))))
<cc>
(<let> ((ll (<lookup> l)))
(<if> (<not> (list/plist? ll))
(type_error list l)
<fail>)))))))))
(<define-guile-log-rule> (setof-mac t g l)
(setof-fkn t g l))
(mk-prolog-term-3 tr-setof setof setof-mac a a a)
(<define> (yield_at_change x x0 test l action)
(<yield-at-change> x x0 test l
(</.> (goal-eval action))))
(define-syntax-rule (mk-test tr-nm fk-nm -nm x code)
(begin
......
......@@ -3,8 +3,9 @@
#:use-module (logic guile-log macros)
#:use-module (logic guile-log interleave)
#:use-module (logic guile-log undovar)
#:export (<f-vector> <vector> <fold> <fold-step> <fix-fold> <fix-fold-step>
<member> <uniq> m=
#:export (<f-vector> <vector> <fold> <fold-step> <fix-fold>
<fix-fold-pre> <fix-fold-sorted> <fix-fold-step>
<member> <uniq> m= <yield-at-change>
<with-generators> <next-generator-value>))
......@@ -68,6 +69,26 @@
(<define> (new-machine) <cc>)
(<define> (<yield-at-change> x x0 test l code)
(<let-with-lr-guard> wind lguard rguard ((start? x) (val #f) (old x0))
(lguard
(</.>
(<or>
(code)
(<=> l old))
(if start?
(<code> (set! start? #f)
(set! old (<cp> x))
(set! val (<cp> test)))
(if (m= S x val)
(<and> (<code> (set! old (<cp> x))) <fail>)
(<and> (<=> l old)
(<code>
(set! old (<cp> x))
(set! val (<cp> test))))))
(rguard
(</.> <cc>))))))
(<define> (<fold> kons knil Lam X L . E)
(<let> ((p P))
(<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
......@@ -144,6 +165,35 @@
(<apply> <fold> kons knil Lam X L E)
(<=> knil L))))))
(<define> (<fix-fold-pre> kons knil Lam X Y L . E)
(if (pair? (<lookup> Y))
(<var> (Z)
(<call> ((Y Y))
(<uniq> (<lambda> () (Lam)) Y))
(<and!> (<apply> <fold> kons knil Lam X L E)))
(<var> (Z)
(<and!>
(<or>
(<apply> <fold> kons knil Lam X L E)
(<=> knil L))))))
(if (pair? (<lookup> Y))
(<var> (Z)
(<call> ((Y Y))
(<uniq> (<lambda> () (Lam)) Y))
(<and!>
(<apply> <fold> kons knil
(<lambda> ()
(Lam)
X L E)))
(<var> (Z)
(<and!>
(<or>
(<apply> <fold> kons knil Lam X L E)
(<=> knil L))))))
(<define> (<fix-fold-step> kons knil Lam X Y L . E)
......@@ -158,6 +208,12 @@
<fail>))
X L E)))
(<define> (<fix-fold-sorted> kons knil Lam X Y L . E)
(<var> (l)
(<yield-at-change> l knil Y L code
(</.>
(<apply> <fold-step> kons knil Lam X l E)))))
(<define> (<f-vector> f . x)
(<recur> loop ((x x) (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