major set theory improvement

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)