Skip to content

G
Guile Log
Commit 447a85c3 by Stefan Israelsson Tampe
Options

major set theory improvement

parent ae91a86d
Showing with 342 additions and 112 deletions
doc/guile-log/garbage_002dcollect.html
......@@ -57,7 +57,7 @@ Next: <a href="persistance.html#persistance" accesskey="n" rel="next">persistanc
</div>
<hr>
<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>
......
doc/guile-log/kanren.html
......@@ -57,13 +57,13 @@ Next: <a href="minikanren.html#minikanren" accesskey="n" rel="next">minikanren</
</div>
<hr>
<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.
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>
<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-fail"></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
<p><code>_</code>, produces a fress new logical variable in it&rsquo;s place.
</p>
<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-fact"></a>
<a name="index-extend_002drelation"></a>
......@@ -202,7 +202,7 @@ variables <code>id ...</code>. E.g.
</p>
<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-solve"></a>
......@@ -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>
<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-partially_002deval_002dsgl"></a>
......@@ -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>
<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,
(let* ((fact1 (fact () 'x1 'y1))
(fact2 (fact () 'x2 'y2))
......
doc/guile-log/prolog.html
......@@ -57,7 +57,7 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel="
</div>
<hr>
<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>
<table class="menu" border="0" cellspacing="0">
......@@ -75,9 +75,11 @@ Next: <a href="garbage_002dcollect.html#garbage_002dcollect" accesskey="n" rel="
</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
</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>
<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>
<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>
......
ice-9/set/set.scm
(define-module (ice-9 set set)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-9)
#: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))
#|
......@@ -75,10 +76,25 @@ Output: set operations and iteratables
(set-record-type-printer! <set>
(lambda (vl port)
(define (m x)
(if (pair? x)
(list (car x) (cdr x))
(list x '())))
(let ((n (set-n vl)))
(if (= n 0)
(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>
(make-append- x y)
......@@ -594,7 +610,16 @@ Output: set operations and iteratables
(define (for-each 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⊆
#:n- tripple
#:in in #:fold fold #:map map #:for-each for-each #:empty ∅
......
logic/guile-log/guile-prolog/set.scm
(define-module (logic guile-log guile-prolog set)
#: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 goal-functors)
#: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 vset)
#:use-module (srfi srfi-9)
......@@ -17,29 +19,38 @@
->
s a))
#:export
(∅ ∩ ∪ ∖ ∈ ⊕ ⊂ ⊆ ≡ ⊃ ⊇ ᶜ
set_to_list))
(∅ ∩ ∪ ∖ ∈ ⊕ ⊂ ⊆ ≡ ⊃ ⊇ ᶜ ∈
set_to_list set_to_kvlist to_set
complex_set_p
advanced-set-printer))
(<define> (ele1 x)
(<<match>> (#:mode -) (x)
(<define> (ele0 x)
(<<match>> (#:mode -) ((<lookup> x))
(#(("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))
(<and>
(<values> (x) (ele1 x))
(<values> (y) (ele1 y))
(<cc> (vosetx-union S x y))))
(<values> (x1 y1) (ele0 x))
(<values> (x2 y2) (ele1 y))
(<cc> (vosetx-union S x1 x2) (vosetx-union S y1 y2))))
(x (ele0 x))))
(x
(<cc> (mk-kx (<lookup> x))))))
(<define> (ele x)
(<<match>> (#:mode -) (x)
(<<match>> (#:mode -) ((<lookup> x))
(#(#:brace v)
(ele1 v))
(<and>
(<values> (a c) (ele1 v))
(<cc> (make-set- a vsetx-empty c #f #f))))
(x (<cc> x))))
......@@ -53,6 +64,13 @@
(<values> (x) (ele 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)
(make-2 s (lambda () #f) (lambda x #t) f x y))
......@@ -63,10 +81,20 @@
(define-syntax-rule (nm1 x y)
(make2 S nm2 (gp-lookup x S) (gp-lookup y S))))
(mk2 set_union_ vosetx-union )
(mk2 set_addition_ vosetx-addition )
(mk2 set_difference_ vosetx-difference )
(mk2 set_intersection_ vosetx-intersection )
(define complex_set_p (make-fluid #t))
(<wrap> add-fluid-dynamics complex_set_p)
(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_addition_ s s)
......@@ -77,25 +105,76 @@
(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)
(<define> (memb x y) (when (make2 S vsetx-in
(<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))))
(<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))))
(<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))))
(<define> (supset x y) (subset 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-⊂ ⊂ subset s s)
(mk-prolog-biop 'xfx "⊇" tr-⊇ ⊇ supseteq s s)
(mk-prolog-biop 'xfx "⊃" tr-⊃ ⊃ supset 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))))
logic/guile-log/guile-prolog/vm/vm-goal-model.scm
......@@ -296,7 +296,7 @@ compile_goal(call_(X,A0,Al,C0,Pre,Post,LP),Tail,V,[L,LL]) :- !,
CC = [Al|C],
set_C(V,CC),
compile_goal(X,#f,V,[LX,LLX]),
set_AA(V,A)
set_AA(V,A),
LLX = Post,
set_C(V,C),
(Tail=#t -> LP=[[cc]|LL] ; LP=LL).
......@@ -379,14 +379,14 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[['newframe-negation',Al,0]|LX],
get_QAESBB2(V,Q,A,E,S,B,B2),
set_QAE(V,[],[[0|_]],0),
new_var(VP,V,tagP1),
new_var(VS,V,tagS1),
new_var(VT,V,tagY1),
new_var(VP,V,TagP1),
new_var(VS,V,TagS1),
new_var(VT,V,TagY1),
compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
new_var(VP,V,tagP2),
new_var(VS,V,tagS2),
new_var(VT,V,tagT2),
set_QAESBB2(V,Q,A,E,S,B,B2).
new_var(VP,V,TagP2),
new_var(VS,V,TagS2),
new_var(VT,V,TagT2),
set_QAESBB2(V,Q,A,E,S,B,B2),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
Ad=[A0,Cut_p],
(
......@@ -398,7 +398,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
(
Pre = ['newframe-ps', A0, TagP1, TagS1],
Post = [['goto-inst' , Out],
[label , A0]
[label , A0],
['fail-psc' , TagP2, TagS2, C0],
[label , Out],
['unwind-psc', TagP2, TagS2, C0]|LP]
......@@ -410,7 +410,7 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
['fail-psc' , TagP2, TagS2, C0],
[label , Out],
['unwind-psct', TagP2, TagS2, TagT2, C0]|LP]
) ;
)
) ;
(
Tp == 0 ->
......@@ -441,14 +441,13 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
)
).
'newframe-negation','unwind-negation','post-s'),
compile_goal(\\+X,Tail,V,L) :- !,
check_tail(Tail),
new_var(VS,V,TagS1),
new_var(VP,V,TagP1),
new_var(VT,V,TagT1),
get_QAESB(V,Q,A,E,S,B),
ifc(
(
set_QAE(V,[],[[0|_]],0),
......@@ -464,8 +463,9 @@ compile_goal(\\+X,Tail,V,L) :- !,
new_var(VT,V,TagT2),
get_A(V,A1),
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],
(
A==#t ->
(
......@@ -500,7 +500,7 @@ compile_goal(\\+X,Tail,V,L) :- !,
['unwind-pst',TagP2,TagS2,TagT2]|LP]
)
)
) ;
);
(
Cut_p == #t ->
(
......@@ -517,7 +517,7 @@ compile_goal(\\+X,Tail,V,L) :- !,
)
)
)
).
)).
......
logic/guile-log/iso-prolog.scm
......@@ -55,7 +55,8 @@
accessify_predicate
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
foldofp sumofp prodofp countofp maxofp minofp lastofp
foldofs sumofs prodofs countofs maxofs minofs lastofs
......
logic/guile-log/prolog/fold.scm
......@@ -47,8 +47,10 @@
(let ()
(<define> (findall template g l)
(<code> (gp-var-set *call-expression* g S))
(<var> (r)
(<fold> kons knil (<lambda> () (goal-eval g)) template l)))
(<var> (t)
(<let> ((f (vector (list is t template))))
(<fold> kons knil (<lambda> () (goal-eval g) (goal-eval f))
t l))))
findall))
(define-syntax-rule (def-all x-all kons knil aggr)
......@@ -70,7 +72,7 @@
(<var> (t r)
(<let> ((f (vector (list is t template)))
(n (<lookup> n)))
(<fix-fold> (lambda (x s)
(<fold> (lambda (x s)
(cons (+ (car s) 1) (kons x (cdr s))))
(cons 0 knil)
(<lambda> ()
......@@ -83,6 +85,58 @@
(<=> (_ . ,l) ,r))))))))
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 x-all
(let ((f (mk-alln kons knil aggr)))
......@@ -107,7 +161,7 @@
(<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons (<lookup> X) q) (+ i 1))))
(<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 ...)))))
x-of)
......@@ -169,6 +223,44 @@
(<=> (,n . ,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)
(<=> (_ . ,l) ,r))))
(mk-mkof mk-valin def-valin-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)
(kons x 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)
......@@ -179,17 +271,17 @@
l)))
(syntax-case x ()
((_ def-val-of def-valn-of name kons knil)
((_ def-all def-alln def-val-of def-valn-of name kons knil)
(with-syntax ((countall (extend #'name 'all))
(countstp (extend #'name 'stp))
(countalln (extend #'name 'alln))
(countstpn (extend #'name 'stpn))
(countof #'name)
(countofp (extend #'name 'p))
(countofs (extend #'name 's))
(countofn (extend #'name 'n))
(countofpn (extend #'name 'pn))
(countofsn (extend #'name 'sn)))
(countof (extend #'name 'of))
(countofp (extend #'name 'ofp))
(countofs (extend #'name 'ofs))
(countofn (extend #'name 'ofn))
(countofpn (extend #'name 'ofpn))
(countofsn (extend #'name 'ofsn)))
#'(begin
(def-all countall kons knil <fold>)
(def-all countstp kons knil <fold-step>)
......@@ -203,40 +295,43 @@
(def-valn-of countofsn kons knil <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))
(mku def-all def-alln def-val-of def-valn-of countof sum1 0)
(mku def-all def-alln def-val-of def-valn-of sum + 0)
(mku def-all def-alln def-val-of def-valn-of prodof * 1)
(mku def-all def-alln def-val-of def-valn-of maxof max (- (inf)))
(mku def-all def-alln def-val-of def-valn-of minof min (inf))
(define (amax x s)
(let ((xx (car x)))
(if (> xx (car s))
x
s)))
(if (> x (car (cdr s)))
(cons (+ (car s) 1) (cons x (+ (car s) 1)))
(cons (+ (car s) 1) (cdr s))))
(define (amin x s)
(let ((xx (car x)))
(if (< xx (car s))
x
s)))
(mku def-val-of def-valn-of amaxof amax (cons (- (inf)) (if #f #f)))
(mku def-val-of def-valn-of aminof amin (cons (inf) (if #f #f)))
(if (< x (car (cdr s)))
(cons (+ (car s) 1) (cons x (+ (car s) 1)))
(cons (+ (car s) 1) (cdr s))))
(mku def-alli def-allin def-vali-of def-valin-of
amax amax (cons (- (inf)) 0))
(mku def-alli def-allin def-vali-of def-valin-of
amin amin (cons (inf) 0))
(define (bmax x s)
(let ((xx (car x)))
(if (>= xx (car s))
x
s)))
(if (>= x (car (cdr s)))
(cons (+ (car s) 1) (cons x (+ 1 (car s))))
(cons (+ (car s) 1) (cdr s))))
(define (bmin x s)
(let ((xx (car x)))
(if (<= xx (car s))
x
s)))
(if (<= x (car (cdr s)))
(cons (+ (car s) 1) (cons x (+ 1 (car s))))
(cons (+ (car s) 1) (cdr s))))
(mku def-alli def-allin def-vali-of def-valin-of
bmax bmax (cons (- (inf)) 0))
(mku def-val-of def-valn-of bmaxof bmax (cons (- (inf)) (if #f #f)))
(mku def-val-of def-valn-of bminof bmin (cons (inf) (if #f #f)))
(mku def-alli def-allin def-vali-of def-valin-of
bmin bmin (cons (inf) 0))
(define (laster x y) x)
(mku def-val-of def-valn-of lastof laster #f)
(mku def-all def-alln def-val-of def-valn-of lastof laster #f)
(<define> (gen update F X XX X0)
......@@ -294,6 +389,7 @@
x))
findall))
#;
(define-syntax-rule (def-all x-all lam aggr)
(define x-all
(let ((f (mk-fold-all lam aggr)))
......
logic/guile-log/prolog/goal-functors.scm
......@@ -107,6 +107,8 @@
(define (nm s a)
(set-object-propery nm 'prolog-functor-type #:exp))))
(define (scm-brace-eval s x) x)
(define-syntax-rule (scm-eval x) (scm-eval* S x))
(define (scm-eval* s x)
(umatch (#:mode - #:status s #:name scm-eval*) ((pp 'scm-eval x))
......@@ -120,6 +122,8 @@
(apply f s (map (lambda (a) (scm-eval* s a)) l)))
(else
(apply f (map (lambda (a) (scm-eval* s a)) l))))))
(#(#:brace _)
(scm-brace-eval s x))
(x
(let ((x (gp->scm x s)))
(cond
......
logic/guile-log/prolog/io.scm
......@@ -887,6 +887,10 @@
((struct? a)
(cond
((object-property (struct-vtable a) 'prolog-printer)
=> (lambda (printer)
(printer lp a quoted?)))
((prolog-closure? a)
(let* ((h first-map)
......
logic/guile-log/vset.scm
......@@ -9,7 +9,7 @@
#:use-module (srfi srfi-9)