tools.scm 7.08 KB
Newer Older
1 2 3 4
(define-module (logic guile-log tools)
  #:use-module (logic guile-log umatch)
  #:use-module (logic guile-log macros)
  #:use-module (logic guile-log interleave)
5
  #:use-module (logic guile-log undovar)
6 7 8
  #:export (<f-vector> <vector> <fold> <fold-step> <fix-fold>
		       <fix-fold-pre> <fix-fold-sorted> <fix-fold-step> 
		       <member> <uniq> m= <yield-at-change>
9 10
		       <with-generators> <next-generator-value>
		       <fold-step-e>))
11

12

13 14 15 16 17 18 19 20 21 22 23 24 25
(define-guile-log <with-generators>
  (syntax-rules ()
    ((_ w ((x i) ...) code ...)
     (<let-with-lr-guard> w wind lg rg ((x i) ...)
	(lg (</.> code ...))))))

(define-guile-log <next-generator-value>
  (syntax-rules ()
    ((_ w kons v x)
     (begin
       (set! v (kons (<scm> x) v))
       (parse<> w <cc>)))))

26
(<define> (<member> X L)
27
  (<match> (#:name '<member>) (L)
28 29 30 31
    ((Y . _)  (<=> X Y))
    ((_  . U) (<cut> (<member> X U)))
    (_        (<cut> <fail>))))

32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
(define tag (gensym "eq-tagg"))


(define (m= s x y)
  (define i 0)
  (let* ((fr  (gp-newframe s))
         (ret ((</.>
                (<recur> lp ((x x) (y y))
                  (<match> (#:mode - #:name tools.u=) (x y)
                    ((? <var?> a) (? <var?> b)
                     (<cut>
                      (<and>
                       (<=> a b)
                       (<=> a ,(cons tag i))
                       (<code> (set! i (+ i 1))))))
       
                    ((x . l) (y . ll)
                     (<cut>
                      (<and>
                       (lp x y)
                       (lp l ll))))
53
                    ((? vector?) (? vector?)                     
54
                     (<cut> 
55 56
                      (lp (vector->list (gp-lookup x S))
                          (vector->list (gp-lookup y S)))))
57 58 59
                    (x y
                      (<cut> (<==> x y))))))
               s (lambda () #f) (lambda x #t))))
60
    (gp-unwind-tail fr)
61 62 63 64
    ret))
    

(<define> (<umember> X L)
65
  (<match> (#:name '<umember>) (L)
66
    ((Y . _)  (if (m= S X Y) <cc> <fail>))
67 68 69 70
    ((_  . U) (<cut> (<umember> X U)))
    (_        (<cut> <fail>))))
    

71 72
(<define> (new-machine) <cc>)

73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
(<define> (<yield-at-change> test code)
       (<let-with-lr-guard> wind lguard rguard 
			    ((old-state #f) 
			     (old-p     #f)
			     (change?   #f)
			     (start?    #t) 
			     (val       #f))
	 (lguard
	  (</.>
	   (<or>
	    (code (lambda (s) start?))
	    <cc>)
	   (if start?
	       (<and>
		(<code> (set! start?    #f) 
			(set! val       (<cp> test))
			(set! old-p     P)
			(set! old-state (gp-store-state S)))
		<fail>)	       
	       (if (m= S test val)
		   (<and> 
		    (<code> 
		     (set! old-p     P)
		     (set! old-state (gp-store-state S)))
		    <fail>)
		   (<and>
		    (<code> 
		     (set! start? #t)
101
		     (set! val (<cp> test)))
102 103 104 105 106 107 108 109 110
		    (<code> (gp-restore-wind old-state
					     (gp-rebased-level-ref wind)))
		    <cut>
		    (<or>
		     <cc>
		     (<ret> (old-p))))))
		     
	   (rguard
	    (</.> <cc>))))))
111

112
(<define> (<fold> kons knil Lam X L . E)
113
    (<let> ((p P))
114
    (<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
115 116 117 118
      (lguard
       (</.>
	(<or>
	 (<and>
119
	  (new-machine)
120
	  (<funcall> Lam)
121
	  (if (pair? E) ((car E) (cdr l)) <cc>)
122 123 124 125 126
	  (<code>
	   (let* ((a (<cp> X))
		  (b (ref-attribute-constructors S)))
	     (set! l (cons (append b (car l))
			   (kons   a (cdr l))))))
127 128 129 130
	  <fail>)
	 (rguard
	  (</.>
	   (<and>      
131
	    (do-attribute-constructors (car l))
132
	    (<with-fail> p (<=> ,(cdr l) L)))))))))))
133

134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
(<define> (<fold-e> kons knil Lam F X L . E)
    (<let> ((p P))
    (<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
      (lguard
       (</.>
	(<or>
	 (<and>
	  (new-machine)
	  (<funcall> Lam)
	  (if (pair? E) ((car E) (cdr l)) <cc>)
	  (<code>
	   (let* ((a (<cp> X))
		  (b (ref-attribute-constructors S)))
	     (set! l (cons (append b (car l))
			   (kons   a (cdr l))))))
	  (F))
	 (rguard
	  (</.>
	   (<and>      
	    (do-attribute-constructors (car l))
	    (<with-fail> p (<=> ,(cdr l) L)))))))))))



158
(<define> (<fold-step-e> kons knil Lam X L . E)
159 160 161 162 163 164 165 166 167 168 169 170
   (<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
      (lguard
       (</.>
	(<and>
	 (new-machine)
	 (<funcall> Lam)
	 (if (pair? E) ((car E) (cdr l)) <cc>)
	 (<code>
	   (let* ((a (<cp> X))
		  (b (ref-attribute-constructors S)))
	     (set! l 
		   (cons (append b (car l))
171
			 (kons  S a (cdr l))))))
172 173 174
	 (do-attribute-constructors (car l))
	 (<=> ,(cdr l) L)
	 (rguard (</.> <cc>)))))))
175

176
(<define> (<fold-step> kons knil Lam X L . E)
177
   (<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
178 179 180
      (lguard
       (</.>
	(<and>
181
	 (new-machine)
182
	 (<funcall> Lam)
183
	 (if (pair? E) ((car E) (cdr l)) <cc>)
184 185 186 187 188 189 190 191
	 (<code>
	   (let* ((a (<cp> X))
		  (b (ref-attribute-constructors S)))
	     (set! l 
		   (cons (append b (car l))
			 (kons   a (cdr l))))))
	 (do-attribute-constructors (car l))
	 (<=> ,(cdr l) L)
192
	 (rguard (</.> <cc>)))))))
193
       
194 195
(<define> (<uniq> Lam Y)
  (<let-with-lr-guard> wind lguard rguard ((l '()))
196 197 198
     (lguard 
      (</.> 
       (Lam)
199 200 201 202 203
       (<let> ((y (<cp> Y)))
          (<not> (<umember> y l))
          (<code> (set! l (cons y l)))
         (do-attribute-constructors)
         (rguard (</.> <cc>)))))))
204
            
205 206 207 208
;; This is a slow n² algorithm using the functional database
;; Indexing Framework, it can be designed to be essentially n¹
;; It has it merrits though in getting bagof for infinit sets.
;; But then a full prolog bagof algorithm is impossible without a major
209
;; rework of the underlying engine
210
(<define> (<fix-fold> kons knil Lam X Y L . E)
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
  (if (pair? (<lookup> Y))
      (<var> (Z)
       (<call> ((Z Y)) 
	  (<uniq> (<lambda> () (Lam)) Y))

       (<and!>   
	 (<apply> <fold> kons knil 
		  (<lambda> () 
		    (Lam)
		    (if (m= S Y Z) <cc> <fail>))
		  X L E))
       (<=> Y Z))
      (<var> (Z)
	 (<and!>
	  (<or>   
	   (<apply> <fold> kons knil Lam X L E)
	   (<=> knil L))))))
228

229 230 231 232 233 234 235 236 237 238 239 240
(<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))))))

241
(<define> (<fix-fold-sorted> kons knil Lam X Y L . E)
242 243 244 245 246 247 248 249 250 251 252 253 254 255
   (if (pair? (<lookup> Y))
     (<yield-at-change> Y 
       (<lambda> (start?)
         (<let> ((Kons (lambda (s x in)
			 (if (start? s)
			     (kons x knil)
			     (kons x in)))))
	    (<apply> <fold-step-e> Kons knil Lam X L E))))
     (<var> (Z)
       (<and!>
	(<or>   
	 (<apply> <fold> kons knil Lam X L E)
	 (<=> knil L))))))

256
   
257

258
(<define> (<fix-fold-step> kons knil Lam X Y L . E)
259 260 261
  (<var> (Z)
    (<call> ((Z Y)) 
       (<uniq> Lam Y))
262
    (<apply> <fold-step> kons knil 
263 264
		 (<lambda> ()
		    (Lam) 
265 266 267 268 269
		    (if (m= S Y Z) 
			<cc> 
			<fail>))
		 X L E)))

270 271 272 273 274 275 276 277 278 279 280 281 282 283
(<define> (<f-vector> f . x)
  (<recur> loop ((x x) (l '()))
    (if (pair? x)
	(<var> (y)
	  (<=> y ,(car x))
	  (loop (cdr x) (cons y l)))
	(f (apply vector (reverse l))))))

(<define> (<vector> r . x)
  (<recur> loop ((x x) (l '()))
    (if (pair? x)
	(<var> (y)
	  (<=> y ,(car x))
	  (loop (cdr x) (cons y l)))
284
	(<=> r ,(apply vector (reverse l))))))