usr_zip works (again)
[gule-log:guile-log.git] / logic / guile-log / interleave.scm
1 (define-module (logic guile-log interleave)
2   #:use-module (logic guile-log macros)
3   #:use-module (logic guile-log umatch)
4   #:use-module (ice-9 match)
5   #:use-module (ice-9 pretty-print)
6   #:use-module (syntax parse)
7   #:export (<or-i> <or-union>  <and-i>
8                    <//>  <update> <update-val> <zip> <call> 
9                    <let-with-true-guard>
10                    <let-with-guard> <let-with-lr-guard> let-with-guard 
11                    let-with-lr-guard <set!>))
12
13 (define-guile-log <let-with-guard>
14   (lambda (x)
15     (syntax-case x ()
16       ((_ (cut state p cc) wind guard ((s v) ...) code ...)
17       #'(let ((s (make-variable v)) ...)
18            (call-with-values 
19                (lambda () (gp-new-wind-level state))
20              (lambda (sstate wind)
21                (let ((guard 
22                       (lambda (sstate p cc f)
23                         (gp-undo-safe-variable-guard s 
24                                                      (gp-rebased-level-ref
25                                                       (- wind 1))
26                                                      sstate)
27                         ...
28                         (f sstate p cc))))
29                  (let-syntax ((s  (make-variable-transformer
30                                    (lambda (x)
31                                      (syntax-case x (set!)
32                                        ((set! _ w)
33                                         #'(variable-set! s w))
34                                        ((_ a (... ...))
35                                         #'((variable-ref s) a (... ...)))
36                                        (var
37                                         (identifier? #'var)
38                                         #'(variable-ref s))))))
39                               ...)                        
40                (parse<> (cut sstate p cc) (<and> code ...)))))))))))
41
42 (define-guile-log <let-with-true-guard>
43   (lambda (x)
44     (syntax-case x ()
45       ((_ (cut state p cc) wind guard ((s v) ...) code ...)
46       #'(let ((s (make-variable v)) ...)
47            (call-with-values 
48                (lambda () (gp-new-wind-level state))
49              (lambda (sstate wind)
50                (let ((guard 
51                       (lambda (sstate p cc f)
52                         (gp-undo-safe-variable-guard s #t sstate)
53                         ...
54                         (f sstate p cc))))
55                  (let-syntax ((s  (make-variable-transformer
56                                    (lambda (x)
57                                      (syntax-case x (set!)
58                                        ((set! _ w)
59                                         #'(variable-set! s w))
60                                        ((_ a (... ...))
61                                         #'((variable-ref s) a (... ...)))
62                                        (var
63                                         (identifier? #'var)
64                                         #'(variable-ref s))))))
65                               ...)                        
66                (parse<> (cut sstate p cc) (<and> code ...)))))))))))
67
68 (define-guile-log <let-with-lr-guard>
69   (lambda (x)
70     (syntax-case x ()
71       ((_ (cut state p cc) wind lguard rguard ((s v) ...) code ...)
72        (with-syntax (((ss ...) (reverse #'(s ...))))       
73       #`(let ((s (make-variable v)) ...)
74            (call-with-values 
75                (lambda () (gp-new-wind-level state))
76              (lambda (sstate wind)
77                (let ((rguard 
78                       (lambda (sstate p cc f)
79                         (gp-undo-safe-variable-rguard ss 
80                           (gp-rebased-level-ref (- wind 1))
81                           sstate)
82                         ...
83                         (gp-undo-safe-variable-guard  ss (gp-rebased-level-ref
84                                                           (- wind 1))
85                                                       sstate)
86                         ...
87                         (f sstate p cc)))
88
89                      (lguard 
90                       (lambda (sstate p cc f)                   
91                         (gp-undo-safe-variable-lguard s (gp-rebased-level-ref
92                                                          (- wind 1)) sstate)
93                         ...
94                         (f sstate p cc))))
95                  (let-syntax ((s  (make-variable-transformer
96                                    (lambda (x)
97                                      (syntax-case x (set!)
98                                        ((set! _ w)
99                                         #'(variable-set! s w))
100                                        ((_ a (... ...))
101                                         #'((variable-ref s) a (... ...)))
102                                        (var
103                                         (identifier? #'var)
104                                         #'(variable-ref s))))))
105                               ...)                        
106                (parse<> (cut sstate p cc) (<and> code ...))))))))))))
107
108 (define-syntax let-with-guard
109   (lambda (x)
110     (syntax-case x ()
111       ((_ state wind guard ((s v) ...) code ...)
112        #'(let ((s (make-variable v)) ...)
113            (call-with-values 
114                (lambda () (gp-new-wind-level state))
115              (lambda (state wind)              
116                (let-syntax ((guard 
117                              (syntax-rules ()
118                                ((_ stat codee (... ...))
119                                 (begin
120                                   (gp-undo-safe-variable-guard 
121                                    s 
122                                    (gp-rebased-level-ref (- wind 1)) 
123                                    stat)
124                                   ...                             
125                                   codee (... ...))))))
126                             
127                  (let-syntax ((s  (make-variable-transformer
128                                (lambda (x)
129                                  (syntax-case x (set!)
130                                    ((set! _ w)
131                                     #'(variable-set! s w))
132                                    ((_ a (... ...))
133                                     #'((variable-ref s) a (... ...)))
134                                    (var
135                                     (identifier? #'var)
136                                     #'(variable-ref s))))))
137                               ...)
138                           
139                    (let () code ...))))))))))
140
141 (define-syntax let-with-lr-guard
142   (lambda (x)
143     (syntax-case x ()
144       ((_ state wind lguard rguard ((s v) ...) code ...)
145        (with-syntax (((ss ...) (reverse #'(s ...))))
146        #'(let ((s (make-variable v)) ...)
147            (call-with-values
148                (lambda () (gp-new-wind-level state))
149              (lambda (state wind)              
150                (let-syntax ((lguard 
151                              (syntax-rules ()
152                                ((_ stat codee (... ...))
153                                 (begin
154                                   (gp-undo-safe-variable-lguard 
155                                    s (gp-rebased-level-ref (- wind 1)) 
156                                    stat)
157                                   ...                             
158                                   codee (... ...)))))
159
160                             (rguard 
161                              (syntax-rules ()
162                                ((_ stat codee (... ...))
163                                 (begin
164                                   (gp-undo-safe-variable-rguard 
165                                    ss (gp-rebased-level-ref (- wind 1))
166                                    stat)
167                                   ...                             
168                                   (gp-undo-safe-variable-guard 
169                                    ss (gp-rebased-level-ref (- wind 1))
170                                    stat)
171                                   ...
172                                   codee (... ...))))))
173                             
174                  (let-syntax ((s  (make-variable-transformer
175                                (lambda (x)
176                                  (syntax-case x (set!)
177                                    ((set! _ w)
178                                     #'(variable-set! s w))
179                                    ((_ a (... ...))
180                                     #'((variable-ref s) a (... ...)))
181                                    (var
182                                     (identifier? #'var)
183                                     #'(variable-ref s))))))
184                               ...)
185                           
186                (let () code ...)))))))))))
187
188
189 (define-guile-log <or-i>
190   (syntax-rules ()
191     ((_ w) 
192      (parse<> w <fail>))
193
194     ((_ w a) 
195      (parse<> w a))
196
197     ((_ w a ...)
198      (parse<> w (f-interleave (list (</.> a) ...))))))
199
200 (define-guile-log <or-union>
201   (syntax-rules ()
202     ((_ w) 
203      (parse<> w <fail>))
204
205     ((_ w a) 
206      (parse<> w a))
207
208     ((_ w a ...)
209      (parse<> w (f-interleave-union (list (</.> a) ...))))))
210
211 (define-guile-log <and-i>
212   (syntax-rules ()
213     ((_ w) 
214      (parse<> w <cc>))
215
216     ((_ w a) 
217      (parse<> w a))
218
219     ((_ w a ...)
220      (parse<> w (and-interleave (list (</.> a) ...))))))
221
222 (define (f-interleave sin p cc as)
223   (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()))
224     (lguard sin
225     (let ((sin (gp-newframe sin)))
226       (define fail
227         (lambda ()
228           (gp-unwind sin)
229           (let loop ((ll l) (rr r))
230             (if (null? ll)
231                 (if (null? rr)
232                     (p)
233                     (loop (reverse rr) '()))
234                 (let ((thunk (car ll)))
235                   (set! l (cdr ll))
236                   (set! r rr)
237                   (thunk))))))
238       
239       (define (mk-cont p ss)
240         (let ((state (gp-store-state ss)))
241           (lambda ()
242             (gp-restore-wind state (gp-rebased-level-ref wind))
243             (p))))
244       
245       (set! l
246             (map (lambda (a)
247                    (lambda ()
248                      (a sin
249                         fail                
250                         (lambda (ss p2)
251                           (set! r (cons (mk-cont p2 ss) r))
252                           (rguard ss (cc ss fail))))))
253                  as))
254       (set! r '())
255       (fail)))))
256
257 (define (f-interleave-union sin p cc as)
258   (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()) (gs '()) (gr '()))
259     (lguard sin
260     (let ((s (gp-newframe sin)))
261       (define fail
262         (lambda ()
263           (gp-unwind s)
264           (let loop ((ll l) (rr r) (ggs gs) (ggr gr))
265             (if (null? ll)
266                 (if (null? rr)
267                     (p)
268                     (loop (reverse rr) '() (reverse ggr) '()))
269                 (let ((thunk (car ll)))
270                   (set! l (cdr ll))
271                   (set! r  rr)
272                   (set! gs (cdr ggs))
273                   (set! gr ggr)
274                   (thunk))))))
275
276       (define (mk-cont p s)
277         (let ((state (gp-store-state s)))
278           (lambda ()
279             (gp-restore-wind state (gp-rebased-level-ref wind))
280             (p))))
281         
282        (set! l
283         (map 
284          (lambda (a)
285            (lambda ()
286              (a sin fail                
287                 (lambda (ss p2)
288                   (let check ((ggs gs))
289                     (if (pair? ggs)
290                         (let ((fr (gp-newframe ss)))
291                           ((car ggs)
292                            ss
293                            (lambda ()
294                              (gp-unwind fr)
295                              (check (cdr ggs)))
296                            (lambda (sss p) 
297                              (gp-unwind fr)
298                              (set! r  (cons (mk-cont p2 ss) r))
299                              (set! gr (cons a gr))
300                              (fail))))
301                         (begin
302                           (set! r  (cons (mk-cont p2 ss) r))
303                           (set! gr (cons a gr))
304                           (rguard ss (cc ss fail)))))))))
305          as))
306       (set! r '())
307       (set! gs as)
308       (set! gr '())
309       (fail)))))
310       
311
312 #|
313 and-interleave
314 --------------
315
316 (define (f p cc g1 g2)
317   (g1 p (lambda (p) 
318           (let ((f (lambda (pp ccc) (p))))
319             (with-guile-log (p cc)
320                (<or> (g2 p cc)
321                      f))))))
322
323 |#
324
325 (define (and-interleave sin p cc gs)
326   (match gs
327     (()       
328      (cc sin p))
329     ((g)      
330      (g sin p cc))
331     ((g . gl) 
332      (alli sin p cc g gl))))
333
334 (define (alli sin p cc g1 gs)
335   (let-with-lr-guard sin wind lg rg ((l '()) (r '()))
336     (define fail
337       (lambda ()
338         (let loop ((ll l) (rr r))
339           (if (null? ll)
340               (if (null? rr)
341                   (p)
342                   (loop (reverse rr) '()))
343               (let ((thunk (car ll)))
344                 (set! l (cdr ll))
345                 (set! r rr)
346                 (thunk))))))
347         
348     (define (mk-cont p s)
349       (let ((state (gp-store-state s)))
350         (lambda ()
351           (gp-restore-wind state (gp-rebased-level-ref wind))
352           (p))))
353
354     (lg sin
355         (let loop ((sin sin) (p p) (g1 g1) (gs gs))   
356           (match gs
357              ((g2)
358               (g1 sin fail
359                   (lambda (ss p2)
360                     (set! r (cons (mk-cont p2 ss) r))
361                     (g2 ss fail
362                         (lambda (sss p3)
363                         (let ((fr (gp-newframe sss)))
364                           (set! r (cons (mk-cont p3 sss) r))
365                           (rg sss (cc sss (lambda ()
366                                             (gp-unwind fr)
367                                             (fail))))))))))
368              ((g2 . gs)
369               (g1 sin fail  
370                   (lambda (ss p2)
371                     (set! r (cons (mk-cont p2 ss) r))
372                     (loop ss p2 g2 gs)))))))))
373
374 (define-guile-log <set!>
375   (syntax-rules ()
376     ((_ meta s v)
377      (parse<> meta (<code> (set! s v))))))
378
379
380 (define-syntax-rule (cont-set! g p sin wind)
381   (let ((cont #f))
382     (set! g (lambda () (cont)))
383     (set! cont (let ((s (gp-store-state sin)))
384                  (lambda () 
385                    (gp-restore-wind s (gp-rebased-level-ref wind))
386                    (p))))))
387
388 (define-syntax-rule (cont2-set! g p sin wind)
389   (let ((cont #f))
390     (set! g (lambda (s p cc) (cont)))
391     (set! cont (let ((s (gp-store-state sin)))
392                  (lambda () 
393                    (gp-restore-wind s (gp-rebased-level-ref wind))
394                    (p))))))
395
396
397 (define-syntax-class vars
398   (pattern (aa:id a:id ...) 
399            #:with (s ...) #'(aa a ...)
400            #:with id      (datum->syntax #'aa (gensym "id")))
401
402   (pattern b:id 
403            #:with (s ...) #'(b)
404            #:with id      (datum->syntax #'b (gensym "id"))))
405
406
407 (define-guile-log <zip>
408   (lambda (x)
409     (syntax-parse x
410       ((_ (cut s p cc) (v:vars code ...)  (vs:vars codes ...) ...)
411        (with-syntax ((((vvs ...) ...) (map generate-temporaries 
412                                            #'((vs.s ...) ...)))
413                      ((vv ...)        (generate-temporaries #'(v.s ...)))
414                      ((gs ...)        (generate-temporaries #'(vs.id ...)))
415                      ((ggs ...)       (generate-temporaries #'(vs.id ...))))
416
417         #'(let ((g (</.> code ...)) (gs (</.> codes ...)) ...)
418              #;(use-logical s)
419              (let-with-lr-guard s wind lguard rguard
420                  ((gg #f) (ggs gs) ... (vv #f) ... (vvs #f) ... ...)
421               (lguard s
422                (let ((fr (gp-newframe s)))
423                  (g s p 
424                     (lambda (ss pp)
425                       (cont-set! gg pp ss wind)
426                       (set! vv (gp-cp v.s ss)) ...
427                       (gp-unwind fr)
428                       (zip-aux (s p fr) wind rguard 
429                                ((vvs ...) ...) ((vs.s ...) ...) 
430                                (ggs ...) 
431                                (begin
432                                  #;(leave-logical s)
433                                  (<with-guile-log> (s gg cc)
434                                     (<and> (<=> v.s  vv ) ...
435                                            (<=> vs.s vvs) ... 
436                                            ...)))))))))))))))
437
438 (define-syntax zip-aux
439   (syntax-rules ()
440     ((_ (s p fr) wind guard ((vv ...) . vvs) ((v ...) . vs) (g . gs) code)
441      (g s p
442         (lambda (ss pp)
443           (cont2-set! g pp ss wind)
444           (set! vv (gp-cp v ss)) ...
445           (gp-unwind fr)
446           (zip-aux (s p fr) wind guard vvs vs gs code))))
447
448     ((_ (s p fr) wind guard () () () code)
449      (guard s code))))
450
451   
452 (define (call s p cc lam x l)
453   #;(use-logical s)
454   (let ((s    (gp-newframe s))
455         (wind (gp-windlevel-ref s)))
456     ((gp-lookup lam s)
457      s p (lambda (ss pp)
458            (let ((state (gp-store-state ss)))
459              (let ((xx (gp-cp x ss)))
460                (gp-unwind s)
461                (let ((ppp (lambda ()
462                             (gp-restore-wind state (gp-rebased-level-ref wind))
463                             (pp))))
464                  #;(leave-logical s)
465                  (<with-guile-log> (s ppp cc)
466                    (<=> xx l)))))))))
467              
468
469 (define-guile-log <call>          
470   (syntax-rules ()
471     ((_ w ((l x) ...) code ...)
472      (parse<> w
473        (call (</.> code ...) (list x ...) (list l ...))))))
474
475
476 (define-syntax-rule (fcall-m nm)
477   (define (nm s p cc lam x l f)
478     (let-with-lr-guard s wind lguard rguard ((cc cc))
479      (lguard s 
480        (let ((s (gp-newframe s)))
481         ((gp-lookup lam s)
482          s p (lambda (ss pp)
483                (let ((state (gp-store-state ss)))
484                  (let ((xx (gp-cp x ss)))
485                    (gp-unwind s)
486                    (letrec ((ppp (case-lambda 
487                                    ((cc-new)
488                                     (set! cc cc-new)
489                                     (gp-restore-wind 
490                                      state (gp-rebased-level-ref wind))
491                                     (pp))
492                                    ((cc-new pp)
493                                     (set! cc cc-new)
494                                     (gp-restore-wind 
495                                      state (gp-rebased-level-ref wind))
496                                     (pp)))))
497                      (for-each (lambda (l x) (l x)) l xx)
498                      (f ppp)
499                      (cc s 
500                          (lambda () 
501                            (error 
502                             "Bug, should not be exevcuted in <//>")))))))))))))
503
504 (fcall-m fcall)
505
506 (define-syntax-parameter CC2 (lambda (x) (error "CC2 should be bound by fluid-let")))
507
508 (define-guile-log <//>
509   (lambda (x)
510     (syntax-case x ()
511       ((<//> w ((fail ((xx x) ... ) code ...) ...) body ...)
512        (with-syntax ((((xx2 ...) ...) 
513                       (map generate-temporaries #'((xx ...) ...)))
514                      ((fail2 ...)     
515                       (generate-temporaries #'(fail ...))))
516          #'(parse<> w
517             (<let-with-lr-guard> wind lguard rguard
518                               ((xx #f) ... ... (fail #f) ...)
519              (lguard
520               (</.>
521                (<let> ((xx2   (lambda (v) 
522                                 (set! xx v))) ... ... 
523                        (fail2 (lambda (v) 
524                                 (set! fail v))) ...
525                        (allfail P))
526                  (<with-fail> allfail
527                     (fcall (</.> code ...) (list x ...) (list xx2 ...) 
528                            fail2))
529                  ...      
530                  (rguard
531                     (</.> 
532                      (<let*> ((cc  CC)
533                               (ccx (lambda (s p) (cc s p)))
534                               (p   (lambda () 
535                                      (error "BUG we should be here in <//>")))
536                               (s   S))                       
537                         (<syntax-parameterize> ((CC2 (lambda z #'ccx))) 
538                           (<with-fail> (lambda ()
539                                          ((<lambda> ()
540                                                     (<update> (fail) ...))
541                                           s p ccx))
542                                 ((lambda (s p cccc)
543                                    (let ((ccc (lambda (ss pp)
544                                                 ((</.> body ...) s p cccc))))
545                                      (set! cc ccc)
546                                      (ccc s p)))))))))))))))))))
547
548 (define (pp x) 
549   #;(pretty-print (syntax->datum x)) x)
550
551 (define-guile-log <update>
552   (lambda (x)
553     (pp x)
554     (syntax-case x ()
555       ((_ (cut s p cc) (fail . l))
556        (pp #'(fail CC2 . l)))
557       ((_ w x ... y)
558        #'(parse<> w (<and> (<update-val> x) ... (<update> y)))))))
559
560 ;;preferably do not use this as a user
561 (define-guile-log <update-val>
562   (syntax-rules ()
563     ((_ (cut s p cc) (fail . l))
564      (fail (lambda (ss pp) (cc ss p))  . l))
565     ((_ w x ... y)
566      (parse<> w (<and> (<update-val> x) ... (<update> y))))))