major set theory improvement

parent ae91a86d
...@@ -57,7 +57,7 @@ Next: <a href="persistance.html#persistance" accesskey="n" rel="next">persistanc ...@@ -57,7 +57,7 @@ Next: <a href="persistance.html#persistance" accesskey="n" rel="next">persistanc
</div> </div>
<hr> <hr>
<a name="Garbage-Collection"></a> <a name="Garbage-Collection"></a>
<h2 class="chapter">19 Garbage Collection</h2> <h2 class="chapter">17 Garbage Collection</h2>
<p>Guile log sports full garbage collection of logical variables which makes it suitable to run server like prolog code. It is experimental but working. Unfourtunately the bdw-gc that guile uses does not allow this to work effectively and hence you need to download and replace the standard bdw-gc with a modified version of it. You may find it at <p>Guile log sports full garbage collection of logical variables which makes it suitable to run server like prolog code. It is experimental but working. Unfourtunately the bdw-gc that guile uses does not allow this to work effectively and hence you need to download and replace the standard bdw-gc with a modified version of it. You may find it at
</p> </p>
......
...@@ -57,13 +57,13 @@ Next: <a href="minikanren.html#minikanren" accesskey="n" rel="next">minikanren</ ...@@ -57,13 +57,13 @@ Next: <a href="minikanren.html#minikanren" accesskey="n" rel="next">minikanren</
</div> </div>
<hr> <hr>
<a name="Kanren"></a> <a name="Kanren"></a>
<h2 class="chapter">15 Kanren</h2> <h2 class="chapter">14 Kanren</h2>
<p>Almost all of the kanren interface is implemented ontop of guile-log to use it import <code>logic guile-log kanren</code>. One could say that the kanren interface is the functional sister to guile-log which is more a macro framework as such guile-log is about 2x faster the kanren, but kanren has more beutifull semantics. <p>Almost all of the kanren interface is implemented ontop of guile-log to use it import <code>logic guile-log kanren</code>. One could say that the kanren interface is the functional sister to guile-log which is more a macro framework as such guile-log is about 2x faster the kanren, but kanren has more beutifull semantics.
E.g. the kanren operation maps function arguments to functions. The kanren interface is divided into two categories of functionals, facts and relations. One combine facts into relations. The main difference is that fact functions have standardized arguments and relations have customized arguments. Also conversely evaluating the relation will return back a fact. E.g. the kanren operation maps function arguments to functions. The kanren interface is divided into two categories of functionals, facts and relations. One combine facts into relations. The main difference is that fact functions have standardized arguments and relations have customized arguments. Also conversely evaluating the relation will return back a fact.
</p> </p>
<a name="The-fact-building-blocks"></a> <a name="The-fact-building-blocks"></a>
<h3 class="section">15.1 The fact building blocks</h3> <h3 class="section">14.1 The fact building blocks</h3>
<a name="index-succeed"></a> <a name="index-succeed"></a>
<a name="index-fail"></a> <a name="index-fail"></a>
<a name="index-sfail"></a> <a name="index-sfail"></a>
...@@ -134,7 +134,7 @@ skipp multiples of similar sucesses e.g. if <code>(all f1 f2)</code> is a succes ...@@ -134,7 +134,7 @@ skipp multiples of similar sucesses e.g. if <code>(all f1 f2)</code> is a succes
<p><code>_</code>, produces a fress new logical variable in it&rsquo;s place. <p><code>_</code>, produces a fress new logical variable in it&rsquo;s place.
</p> </p>
<a name="relations"></a> <a name="relations"></a>
<h3 class="section">15.2 relations</h3> <h3 class="section">14.2 relations</h3>
<a name="index-relation"></a> <a name="index-relation"></a>
<a name="index-fact"></a> <a name="index-fact"></a>
<a name="index-extend_002drelation"></a> <a name="index-extend_002drelation"></a>
...@@ -202,7 +202,7 @@ variables <code>id ...</code>. E.g. ...@@ -202,7 +202,7 @@ variables <code>id ...</code>. E.g.
</p> </p>
<a name="Queries"></a> <a name="Queries"></a>
<h3 class="section">15.3 Queries</h3> <h3 class="section">14.3 Queries</h3>
<a name="index-query"></a> <a name="index-query"></a>
<a name="index-solve"></a> <a name="index-solve"></a>
...@@ -215,7 +215,7 @@ variables <code>id ...</code>. E.g. ...@@ -215,7 +215,7 @@ variables <code>id ...</code>. E.g.
<p><code>(solution (v ...) g ...</code>, This is the same as <code>(solve 1 (v ...) g ...)</code>. <p><code>(solution (v ...) g ...</code>, This is the same as <code>(solve 1 (v ...) g ...)</code>.
</p> </p>
<a name="Misc"></a> <a name="Misc"></a>
<h3 class="section">15.4 Misc</h3> <h3 class="section">14.4 Misc</h3>
<a name="index-trace_002dvars"></a> <a name="index-trace_002dvars"></a>
<a name="index-partially_002deval_002dsgl"></a> <a name="index-partially_002deval_002dsgl"></a>
...@@ -224,7 +224,7 @@ variables <code>id ...</code>. E.g. ...@@ -224,7 +224,7 @@ variables <code>id ...</code>. E.g.
<p><code>partially-eval-sgl</code>, not implemented, because guile-log is also directed towards stacks and assq lists and hence usually uses another kind of implementation for the interleaving constructs. <p><code>partially-eval-sgl</code>, not implemented, because guile-log is also directed towards stacks and assq lists and hence usually uses another kind of implementation for the interleaving constructs.
</p> </p>
<a name="Examples"></a> <a name="Examples"></a>
<h3 class="section">15.5 Examples</h3> <h3 class="section">14.5 Examples</h3>
<pre class="verbatim">Example 1, any-union, <pre class="verbatim">Example 1, any-union,
(let* ((fact1 (fact () 'x1 'y1)) (let* ((fact1 (fact () 'x1 'y1))
(fact2 (fact () 'x2 'y2)) (fact2 (fact () 'x2 'y2))
......
...@@ -57,7 +57,7 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel=" ...@@ -57,7 +57,7 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel="
</div> </div>
<hr> <hr>
<a name="Prolog"></a> <a name="Prolog"></a>
<h2 class="chapter">18 Prolog</h2> <h2 class="chapter">16 Prolog</h2>
<p>Guile log also sports an iso-prolog interface as a logic programming interface besides kanren. The interface is pretty complete at this point appart a few points that have not yet been resolved but sure it is currently alpha software and help is very very much appriciated. With this most programs written in iso prolog should probably work. The intention is to enhance this interface so that the bulk of already written prolog programs should be able to run on guile. We will also add the fetures unique to guile-log and hence enhance the prolog experience. Featurewise guile-log prolog is taking over many properties of scheme like closures, continuations, delimeted continuations, the interleaving constructs of kanren and a delicate system to treat dynamic objects like dynamic functions, dynamic hashes and a library to tell how you want the dynamism to work at a fine grained level. <p>Guile log also sports an iso-prolog interface as a logic programming interface besides kanren. The interface is pretty complete at this point appart a few points that have not yet been resolved but sure it is currently alpha software and help is very very much appriciated. With this most programs written in iso prolog should probably work. The intention is to enhance this interface so that the bulk of already written prolog programs should be able to run on guile. We will also add the fetures unique to guile-log and hence enhance the prolog experience. Featurewise guile-log prolog is taking over many properties of scheme like closures, continuations, delimeted continuations, the interleaving constructs of kanren and a delicate system to treat dynamic objects like dynamic functions, dynamic hashes and a library to tell how you want the dynamism to work at a fine grained level.
</p> </p>
<table class="menu" border="0" cellspacing="0"> <table class="menu" border="0" cellspacing="0">
...@@ -75,9 +75,11 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel=" ...@@ -75,9 +75,11 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel="
</td></tr> </td></tr>
<tr><td align="left" valign="top">&bull; <a href="closures.html#closures" accesskey="7">closures</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Using closures in prolog <tr><td align="left" valign="top">&bull; <a href="closures.html#closures" accesskey="7">closures</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Using closures in prolog
</td></tr> </td></tr>
<tr><td align="left" valign="top">&bull; <a href="prolog_002ddynamic_002dfunctions.html#prolog_002ddynamic_002dfunctions" accesskey="8">prolog-dynamic-functions</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A discussion of guile log&rsquo;s version of this <tr><td align="left" valign="top">&bull; <a href="extended-matching.html#extended-matching" accesskey="8">extended matching</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Matching extensions deviating from normal prolog
</td></tr> </td></tr>
<tr><td align="left" valign="top">&bull; <a href="dynamic_002dfeatures.html#dynamic_002dfeatures" accesskey="9">dynamic-features</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Special construct to manage dynamic objects <tr><td align="left" valign="top">&bull; <a href="prolog_002ddynamic_002dfunctions.html#prolog_002ddynamic_002dfunctions" accesskey="9">prolog-dynamic-functions</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A discussion of guile log&rsquo;s version of this
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="dynamic_002dfeatures.html#dynamic_002dfeatures">dynamic-features</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Special construct to manage dynamic objects
</td></tr> </td></tr>
<tr><td align="left" valign="top">&bull; <a href="prolog_002dlibraries.html#prolog_002dlibraries">prolog-libraries</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Libraries that exposes guile-log features <tr><td align="left" valign="top">&bull; <a href="prolog_002dlibraries.html#prolog_002dlibraries">prolog-libraries</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Libraries that exposes guile-log features
</td></tr> </td></tr>
......
(define-module (ice-9 set set) (define-module (ice-9 set set)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:export (<set> set? set-hash #:export (<set> set? set-hash set-n
make-set-from-assoc make-set-from-assoc-mac set-size)) make-set-from-assoc make-set-from-assoc-mac set-size))
#| #|
...@@ -75,10 +76,25 @@ Output: set operations and iteratables ...@@ -75,10 +76,25 @@ Output: set operations and iteratables
(set-record-type-printer! <set> (set-record-type-printer! <set>
(lambda (vl port) (lambda (vl port)
(define (m x)
(if (pair? x)
(list (car x) (cdr x))
(list x '())))
(let ((n (set-n vl))) (let ((n (set-n vl)))
(if (= n 0) (if (= n 0)
(format port "∅") (format port "∅")
(format port "#<set ~a>" ((car (set-meta vl)) vl)))))) (apply format port "{~a~{,~a~}}" (m ((car (set-meta vl)) vl)))))))
(set-object-property! <set> 'prolog-printer
(lambda (lp vl avanced)
(define (m lp x)
(list (lp (car x)) (map lp (cdr x))))
(let ((n (set-n vl)))
(if (= n 0)
(format #f "∅")
(apply format #f "{~a~{,~a~}}" (m lp ((car (set-meta vl)) vl)))))))
(define-record-type <append> (define-record-type <append>
(make-append- x y) (make-append- x y)
...@@ -594,7 +610,16 @@ Output: set operations and iteratables ...@@ -594,7 +610,16 @@ Output: set operations and iteratables
(define (for-each f set) (define (for-each f set)
(reverse (fold (lambda (k seed) (f k) seed) (if #f #f) set))) (reverse (fold (lambda (k seed) (f k) seed) (if #f #f) set)))
(values #:= #:u u #:n n #:- s- #:+ s+ #:< #:<= (define (member x s)
(let ((r (assoc (mk-kv x) (set-assoc s))))
(if r
(if (kv? r)
(cons (kv-key r) (kv-val r))
r)
r)))
(values #:member member
#:= #:u u #:n n #:- s- #:+ s+ #:< #:<=
#:o= o #:ou ou #:on on #:o- o- #:o+ o+ #:o< o #:o<= o #:o= o #:ou ou #:on on #:o- o- #:o+ o+ #:o< o #:o<= o
#:n- tripple #:n- tripple
#:in in #:fold fold #:map map #:for-each for-each #:empty #:in in #:fold fold #:map map #:for-each for-each #:empty
......
(define-module (logic guile-log guile-prolog set) (define-module (logic guile-log guile-prolog set)
#:use-module (logic guile-log iso-prolog) #:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log prolog names) #:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog goal-functors) #:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log) #:use-module (logic guile-log)
#:use-module (ice-9 set complement)
#:use-module ((logic guile-log umatch) #:select (gp-lookup gp->scm)) #:use-module ((logic guile-log umatch) #:select (gp-lookup gp->scm))
#:use-module (logic guile-log vset) #:use-module (logic guile-log vset)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
...@@ -17,29 +19,38 @@ ...@@ -17,29 +19,38 @@
-> ->
s a)) s a))
#:export #:export
( (
set_to_list)) set_to_list set_to_kvlist to_set
complex_set_p
advanced-set-printer))
(<define> (ele0 x)
(<define> (ele1 x) (<<match>> (#:mode -) ((<lookup> x))
(<<match>> (#:mode -) (x)
(#(("op2-" k v)) (#(("op2-" k v))
(<cc> (mk-kvx (<lookup> k) (<lookup> v)))) (<cc> (vosetx-union S (mk-kvx (<scm> k) (<lookup> v)))
vsetx-empty))
(x
(<cc> vsetx-empty
(vosetx-union S (mk-kx (<scm> x)))))))
(<define> (ele1 x)
(<<match>> (#:mode -) ((<lookup> x))
(#((,prolog-and x y)) (#((,prolog-and x y))
(<and> (<and>
(<values> (x) (ele1 x)) (<values> (x1 y1) (ele0 x))
(<values> (y) (ele1 y)) (<values> (x2 y2) (ele1 y))
(<cc> (vosetx-union S x y)))) (<cc> (vosetx-union S x1 x2) (vosetx-union S y1 y2))))
(x (x (ele0 x))))
(<cc> (mk-kx (<lookup> x))))))
(<define> (ele x) (<define> (ele x)
(<<match>> (#:mode -) (x) (<<match>> (#:mode -) ((<lookup> x))
(#(#:brace v) (#(#:brace v)
(ele1 v)) (<and>
(<values> (a c) (ele1 v))
(<cc> (make-set- a vsetx-empty c #f #f))))
(x (<cc> x)))) (x (<cc> x))))
...@@ -53,6 +64,13 @@ ...@@ -53,6 +64,13 @@
(<values> (x) (ele x)) (<values> (x) (ele x))
(<ret> (f S x))) (<ret> (f S x)))
(set! (@@ (logic guile-log prolog goal-functors) scm-brace-eval)
(lambda (s x)
(ele s
(lambda () #f)
(lambda (s p x) x)
x)))
(define (make2 s f x y) (define (make2 s f x y)
(make-2 s (lambda () #f) (lambda x #t) f x y)) (make-2 s (lambda () #f) (lambda x #t) f x y))
...@@ -63,10 +81,20 @@ ...@@ -63,10 +81,20 @@
(define-syntax-rule (nm1 x y) (define-syntax-rule (nm1 x y)
(make2 S nm2 (gp-lookup x S) (gp-lookup y S)))) (make2 S nm2 (gp-lookup x S) (gp-lookup y S))))
(mk2 set_union_ vosetx-union ) (define complex_set_p (make-fluid #t))
(mk2 set_addition_ vosetx-addition ) (<wrap> add-fluid-dynamics complex_set_p)
(mk2 set_difference_ vosetx-difference )
(mk2 set_intersection_ vosetx-intersection ) (define (wrap f fo)
(lambda x
(apply (if (fluid-ref complex_set_p)
fo
f)
x)))
(mk2 set_union_ (wrap vsetx-union vosetx-union ))
(mk2 set_addition_ (wrap vsetx-addition vosetx-addition ))
(mk2 set_difference_ (wrap vsetx-difference vosetx-difference ))
(mk2 set_intersection_ (wrap vsetx-intersection vosetx-intersection ))
(mk-scheme-biop 'yfx "∪" tr- set_union_ s s) (mk-scheme-biop 'yfx "∪" tr- set_union_ s s)
(mk-scheme-biop 'yfx "⊕" tr- set_addition_ s s) (mk-scheme-biop 'yfx "⊕" tr- set_addition_ s s)
...@@ -77,25 +105,76 @@ ...@@ -77,25 +105,76 @@
(define-syntax-rule (nm1 x) (make1 S nm2 (gp-lookup x S)))) (define-syntax-rule (nm1 x) (make1 S nm2 (gp-lookup x S))))
(mk1 set_complement vosetx-complement) (mk1 set_complement (wrap vsetx-complement vosetx-complement))
(mk-scheme-unop 'xf "ᶜ" tr- set_complement s) (mk-scheme-unop 'xf "ᶜ" tr- set_complement s)
(<define> (memb x y) (when (make2 S vsetx-in (<define> (memb x y) (when (make2 S vsetx-in
(<lookup> x) (<lookup> y)))) (<lookup> x) (<lookup> y))))
(<define> (equiv x y) (when (make2 S vosetx-equal? (<define> (equiv x y) (when (make2 S (wrap vsetx-equal? vosetx-equal?)
(<lookup> x) (<lookup> y)))) (<lookup> x) (<lookup> y))))
(<define> (subset x y) (when (make2 S vosetx-subset< (<define> (subset x y) (when (make2 S (wrap vsetx-subset< vosetx-subset<)
(<lookup> x) (<lookup> y)))) (<lookup> x) (<lookup> y))))
(<define> (subseteq x y) (when (make2 S vosetx-subset<= (<define> (subseteq x y) (when (make2 S (wrap vsetx-subset<= vosetx-subset<=)
(<lookup> x) (<lookup> y)))) (<lookup> x) (<lookup> y))))
(<define> (supset x y) (subset y x)) (<define> (supset x y) (subset y x))
(<define> (supseteq x y) (subseteq y x)) (<define> (supseteq x y) (subseteq y x))
(define (mq x)
(if (pair? x)
(if (equal? (cdr x) '(nonvalue))
(cons (car x) #f)
x)
(if x
(cons (get-k x) (get-v x))
x)))
(<define> (member x y)
(<match> (#:mode -) ((<lookup> x))
(#(("op2-" key val))
(<cut>
(<let> ((key (<lookup> key)))
(if (<var?> key)
(<recur> lp ((l (vsetx->assoc S (<lookup> y))))
(if (pair? l)
(<or>
(<=> (key . val) ,(mq (car l)))
(lp (cdr l)))
<fail>))
(<=> (_ . val) ,(mq (vsetx-member (mk-kx key) (<lookup> y))))))))
(key
(if (<var?> key)
(<recur> lp ((l (vsetx->assoc S (<lookup> y))))
(if (pair? l)
(<or>
(<=> (key . _) ,(mq (car l)))
(lp (cdr l)))
<fail>))
(if (vsetx-member (mk-kx key) (<lookup> y))
<cc>
<fail>)))))
(mk-prolog-biop 'xfx "⊆" tr- subseteq s s) (mk-prolog-biop 'xfx "⊆" tr- subseteq s s)
(mk-prolog-biop 'xfx "⊂" tr- subset s s) (mk-prolog-biop 'xfx "⊂" tr- subset s s)
(mk-prolog-biop 'xfx "⊇" tr- supseteq s s) (mk-prolog-biop 'xfx "⊇" tr- supseteq s s)
(mk-prolog-biop 'xfx "⊃" tr- supset s s) (mk-prolog-biop 'xfx "⊃" tr- supset s s)
(mk-prolog-biop 'xfx "≡" tr- equiv s s) (mk-prolog-biop 'xfx "≡" tr- equiv s s)
(mk-prolog-biop 'xfx "∈" tr- member a a)
(mk-prolog-biop 'xfx "≡" tr- equiv s s)
(<define> (set_to_list x y) (<=> y ,(make1 S vsetx->list (<lookup> x))))
(<define> (set_to_kvlist x y)
(<=> y ,(make1 S
(lambda (s x)
((@ (guile) map)
(lambda (x)
(vector (list "-" (get-k x) (get-v x))))
(vsetx->kvlist s x)))
(<lookup> x))))
(<define> (set_to_list x y) (<=> y ,(make1 S vsetx->list x))) (<define> (to_set x y) (<=> y ,(make1 S ->vsetx (<lookup> x))))
...@@ -296,7 +296,7 @@ compile_goal(call_(X,A0,Al,C0,Pre,Post,LP),Tail,V,[L,LL]) :- !, ...@@ -296,7 +296,7 @@ compile_goal(call_(X,A0,Al,C0,Pre,Post,LP),Tail,V,[L,LL]) :- !,
CC = [Al|C], CC = [Al|C],
set_C(V,CC), set_C(V,CC),
compile_goal(X,#f,V,[LX,LLX]), compile_goal(X,#f,V,[LX,LLX]),
set_AA(V,A) set_AA(V,A),
LLX = Post, LLX = Post,
set_C(V,C), set_C(V,C),
(Tail=#t -> LP=[[cc]|LL] ; LP=LL). (Tail=#t -> LP=[[cc]|LL] ; LP=LL).
...@@ -379,14 +379,14 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !, ...@@ -379,14 +379,14 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[['newframe-negation',Al,0]|LX], L=[['newframe-negation',Al,0]|LX],
get_QAESBB2(V,Q,A,E,S,B,B2), get_QAESBB2(V,Q,A,E,S,B,B2),
set_QAE(V,[],[[0|_]],0), set_QAE(V,[],[[0|_]],0),
new_var(VP,V,tagP1), new_var(VP,V,TagP1),
new_var(VS,V,tagS1), new_var(VS,V,TagS1),
new_var(VT,V,tagY1), new_var(VT,V,TagY1),
compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]), compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
new_var(VP,V,tagP2), new_var(VP,V,TagP2),
new_var(VS,V,tagS2), new_var(VS,V,TagS2),
new_var(VT,V,tagT2), new_var(VT,V,TagT2),
set_QAESBB2(V,Q,A,E,S,B,B2). set_QAESBB2(V,Q,A,E,S,B,B2),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1), (A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
Ad=[A0,Cut_p], Ad=[A0,Cut_p],
( (
...@@ -398,7 +398,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !, ...@@ -398,7 +398,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
( (
Pre = ['newframe-ps', A0, TagP1, TagS1], Pre = ['newframe-ps', A0, TagP1, TagS1],
Post = [['goto-inst' , Out], Post = [['goto-inst' , Out],
[label , A0] [label , A0],
['fail-psc' , TagP2, TagS2, C0], ['fail-psc' , TagP2, TagS2, C0],
[label , Out], [label , Out],
['unwind-psc', TagP2, TagS2, C0]|LP] ['unwind-psc', TagP2, TagS2, C0]|LP]
...@@ -410,7 +410,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !, ...@@ -410,7 +410,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
['fail-psc' , TagP2, TagS2, C0], ['fail-psc' , TagP2, TagS2, C0],
[label , Out], [label , Out],
['unwind-psct', TagP2, TagS2, TagT2, C0]|LP] ['unwind-psct', TagP2, TagS2, TagT2, C0]|LP]
) ; )
) ; ) ;
( (
Tp == 0 -> Tp == 0 ->
...@@ -438,17 +438,16 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !, ...@@ -438,17 +438,16 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
Pre = [true], Pre = [true],
Post = LP Post = LP
) )
) )
). ).
'newframe-negation','unwind-negation','post-s'),
compile_goal(\\+X,Tail,V,L) :- !, compile_goal(\\+X,Tail,V,L) :- !,
check_tail(Tail), check_tail(Tail),
new_var(VS,V,TagS1), new_var(VS,V,TagS1),
new_var(VP,V,TagP1), new_var(VP,V,TagP1),
new_var(VT,V,TagT1), new_var(VT,V,TagT1),
get_QAESB(V,Q,A,E,S,B), get_QAESB(V,Q,A,E,S,B),
ifc( ifc(
( (
set_QAE(V,[],[[0|_]],0), set_QAE(V,[],[[0|_]],0),
...@@ -464,8 +463,9 @@ compile_goal(\\+X,Tail,V,L) :- !, ...@@ -464,8 +463,9 @@ compile_goal(\\+X,Tail,V,L) :- !,
new_var(VT,V,TagT2), new_var(VT,V,TagT2),
get_A(V,A1), get_A(V,A1),
set_QAESB(V,Q,A,E,S,B), set_QAESB(V,Q,A,E,S,B),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1) (A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
Ad=[A0,Cut_p], Ad=[A0,Cut_p],
( (
A==#t -> A==#t ->
( (
...@@ -500,7 +500,7 @@ compile_goal(\\+X,Tail,V,L) :- !, ...@@ -500,7 +500,7 @@ compile_goal(\\+X,Tail,V,L) :- !,
['unwind-pst',TagP2,TagS2,TagT2]|LP] ['unwind-pst',TagP2,TagS2,TagT2]|LP]
) )
) )
) ; );
( (
Cut_p == #t -> Cut_p == #t ->
( (
...@@ -515,9 +515,9 @@ compile_goal(\\+X,Tail,V,L) :- !, ...@@ -515,9 +515,9 @@ compile_goal(\\+X,Tail,V,L) :- !,
[label,Al], [label,Al],
['restore-p',TagP2]|LP] ['restore-p',TagP2]|LP]
) )
)
) )
) )).
).
......
...@@ -55,7 +55,8 @@ ...@@ -55,7 +55,8 @@
accessify_predicate accessify_predicate
foldall sumall prodall countall maxall minall lastall foldall sumall prodall countall maxall minall lastall
foldstp sumstp prodstp countstp maxstp minstp laststp foldalln sumalln prodalln countalln maxalln minalln
foldstp sumstp prodstp countstp maxstp minstp
foldof sumof prodof countof maxof minof lastof foldof sumof prodof countof maxof minof lastof
foldofp sumofp prodofp countofp maxofp minofp lastofp foldofp sumofp prodofp countofp maxofp minofp lastofp
foldofs sumofs prodofs countofs maxofs minofs lastofs foldofs sumofs prodofs countofs maxofs minofs lastofs
......
...@@ -47,8 +47,10 @@ ...@@ -47,8 +47,10 @@
(let () (let ()
(<define> (findall template g l) (<define> (findall template g l)
(<code> (gp-var-set *call-expression* g S)) (<code> (gp-var-set *call-expression* g S))
(<var> (r) (<var> (t)
(<fold> kons knil (<lambda> () (goal-eval g)) template l))) (<let> ((f (vector (list is t template))))
(<fold> kons knil (<lambda> () (goal-eval g) (goal-eval f))
t l))))
findall)) findall))
(define-syntax-rule (def-all x-all kons knil aggr) (define-syntax-rule (def-all x-all kons knil aggr)
...@@ -70,7 +72,7 @@ ...@@ -70,7 +72,7 @@
(<var> (t r) (<var> (t r)
(<let> ((f (vector (list is t template))) (<let> ((f (vector (list is t template)))
(n (<lookup> n))) (n (<lookup> n)))
(<fix-fold> (lambda (x s) (<fold> (lambda (x s)
(cons (+ (car s) 1) (kons x (cdr s)))) (cons (+ (car s) 1) (kons x (cdr s))))
(cons 0 knil) (cons 0 knil)
(<lambda> () (<lambda> ()
...@@ -83,6 +85,58 @@ ...@@ -83,6 +85,58 @@
(<=> (_ . ,l) ,r)))))))) (<=> (_ . ,l) ,r))))))))
findall)) findall))
(define (mk-alli kons knil <fold>)
(let ()
(<define> (aminall template g l)
(<code> (gp-var-set *call-expression* g S))
(<var> (t r)
(<let> ((f (vector (list is t template))))
(<fold> (lambda (x s)
(kons x s))
(cons 0 knil)
(<lambda> ()
(goal-eval g)
(goal-eval f))
t r)
(<=> (_ . ,l) ,r))))
aminall))
(define (mk-allin kons knil <fold>)
(let ()
(<define> (findall n template g l)
(<code> (gp-var-set *call-expression* g S))
(<recur> lp ((n n) (strict? #f))
(<<match>> (#:mode -) (n)
(#(("strict" n)) (lp n #t))
(_
(<var> (t r)
(<let> ((f (vector (list is t template)))
(n (<lookup> n)))
(<fold> (lambda (x s)
(kons x s))
(cons 0 knil)
(<lambda> ()
(goal-eval g)
(goal-eval f))
t r
(<lambda> (s) (when (< (car s) n))))
(if strict?
(<=> (,n . ,l) ,r)
(<=> (_ . ,l) ,r))))))))
findall))
(define-syntax-rule (def-alli x-all kons knil aggr)
(define x-all
(let ((f (mk-alli kons knil aggr)))
(set-procedure-property! f 'name 'x-all)
f)))
(define-syntax-rule (def-allin x-all kons knil aggr)
(define x-all
(let ((f (mk-allin kons knil aggr)))
(set-procedure-property! f 'name 'x-all)
f)))
(define-syntax-rule (def-alln x-all kons knil aggr) (define-syntax-rule (def-alln x-all kons knil aggr)
(define x-all (define x-all
(let ((f (mk-alln kons knil aggr))) (let ((f (mk-alln kons knil aggr)))
...@@ -107,7 +161,7 @@ ...@@ -107,7 +161,7 @@
(<=> gg ,(vector (list "^" X A))) (<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons (<lookup> X) q) (+ i 1)))) (<cut> (lp A (cons (<lookup> X) q) (+ i 1))))
(<let*> ((t (<get-idfixed> template-x '())) (<let*> ((t (<get-idfixed> template-x '()))
(fixed (<get-idfixed> gg (append t q)))) (fixed (<get-idfixed> gg (append q))))
(<code> (gp-var-set *call-expression* gg S)) (<code> (gp-var-set *call-expression* gg S))
code ...))))) code ...)))))
x-of) x-of)
...@@ -169,6 +223,44 @@ ...@@ -169,6 +223,44 @@
(<=> (,n . ,l) ,r) (<=> (,n . ,l) ,r)
(<=> (_ . ,l) ,r)))))))) (<=> (_ . ,l) ,r))))))))
(mk-mkof mk-vali def-vali-of
(template g l)
(kons knil <fix-fold>)
(template g gg fixed)
(<var> (t r)
(<let> ((f (vector (list is t template))))
(<fix-fold> (lambda (x s)
(kons x s))
(cons 0 knil)
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed r)