(define-module (logic guile-log interleave)
  #:use-module (logic guile-log macros)
  #:use-module (logic guile-log umatch)
  #:use-module (logic guile-log undovar)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (syntax parse)
  #:re-export (<let-with-true-guard>
               <let-with-guard> <let-with-lr-guard> let-with-guard 
               let-with-lr-guard)
  #:export (<or-i> <or-union>  <and-i>
		   <//>  <update> <update-val> <zip> <call> 
		   <gc-call> <gc-scm-call> <gc-list-call>))

(define-guile-log <or-i>
  (syntax-rules ()
    ((_ w) 
     (parse<> w <fail>))

    ((_ w a) 
     (parse<> w a))

    ((_ w a ...)
     (parse<> w (f-interleave (list (</.> a) ...))))))

(define-guile-log <or-union>
  (syntax-rules ()
    ((_ w) 
     (parse<> w <fail>))

    ((_ w a) 
     (parse<> w a))

    ((_ w a ...)
     (parse<> w (f-interleave-union (list (</.> a) ...))))))

(define-guile-log <and-i>
  (syntax-rules ()
    ((_ w) 
     (parse<> w <cc>))

    ((_ w a) 
     (parse<> w a))

    ((_ w a ...)
     (parse<> w (and-interleave (list (</.> a) ...))))))

(define (f-interleave sin p cc as)
  (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()))
    (lguard sin
    (let ((sin (gp-newframe-choice sin)))
      (define fail
        (lambda ()
	  (let ((sin (gp-unwind sin)))
          (let loop ((ll l) (rr r))
            (if (null? ll)
                (if (null? rr)
                    (p)
                    (loop (reverse rr) '()))
                (let ((thunk (car ll)))
                  (set! l (cdr ll))
		  (set! r rr)
                  (thunk)))))))
      
      (define (mk-cont p ss)
	(let ((state (gp-store-state ss)))
	  (lambda ()
	    (gp-restore-wind state (gp-rebased-level-ref wind))
	    (p))))
      
      (set! l
	    (map (lambda (a)
		   (lambda ()
		     (a sin
			fail                
			(lambda (ss p2)
			  (set! r (cons (mk-cont p2 ss) r))
			  (rguard ss (cc ss fail))))))
		 as))
      (set! r '())
      (fail)))))

(define (f-interleave-union sin p cc as)
  (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()) (gs '()) (gr '()))
    (lguard sin
    (let ((s (gp-newframe-choice sin)))
      (define fail
        (lambda ()
	  (let ((s (gp-unwind s)))
          (let loop ((ll l) (rr r) (ggs gs) (ggr gr))
            (if (null? ll)
                (if (null? rr)
                    (p)
                    (loop (reverse rr) '() (reverse ggr) '()))
                (let ((thunk (car ll)))
                  (set! l (cdr ll))
		  (set! r  rr)
		  (set! gs (cdr ggs))
		  (set! gr ggr)
                  (thunk)))))))

      (define (mk-cont p s)
        (let ((state (gp-store-state s)))
          (lambda ()
            (gp-restore-wind state (gp-rebased-level-ref wind))
            (p))))
        
       (set! l
	(map 
	 (lambda (a)
	   (lambda ()
	     (a sin fail                
		(lambda (ss p2)
		  (let check ((ggs gs))
		    (if (pair? ggs)
			(let ((fr (gp-newframe ss)))
			  ((car ggs)
			   ss
			   (lambda ()
			     (gp-unwind fr)
			     (check (cdr ggs)))
			   (lambda (sss p) 
			     (gp-unwind fr)
			     (set! r  (cons (mk-cont p2 ss) r))
			     (set! gr (cons a gr))
			     (fail))))
			(begin
			  (set! r  (cons (mk-cont p2 ss) r))
			  (set! gr (cons a gr))
			  (rguard ss (cc ss fail)))))))))
	 as))
      (set! r '())
      (set! gs as)
      (set! gr '())
      (fail)))))
      

#|
and-interleave
--------------

(define (f p cc g1 g2)
  (g1 p (lambda (p) 
          (let ((f (lambda (pp ccc) (p))))
            (with-guile-log (p cc)
               (<or> (g2 p cc)
                     f))))))

|#

(define (and-interleave sin p cc gs)
  (match gs
    (()       
     (cc sin p))
    ((g)      
     (g sin p cc))
    ((g . gl) 
     (alli sin p cc g gl))))

(define (alli sin p cc g1 gs)
  (let-with-lr-guard sin wind lg rg ((l '()) (r '()))
    (define fail
      (lambda ()
        (let loop ((ll l) (rr r))
          (if (null? ll)
              (if (null? rr)
                  (p)
                  (loop (reverse rr) '()))
              (let ((thunk (car ll)))
                (set! l (cdr ll))
		(set! r rr)
                (thunk))))))
        
    (define (mk-cont p s)
      (let ((state (gp-store-state s)))
        (lambda ()
          (gp-restore-wind state (gp-rebased-level-ref wind))
          (p))))

    (lg sin
	(let loop ((sin sin) (p p) (g1 g1) (gs gs))   
	  (match gs
	     ((g2)
	      (g1 sin fail
		  (lambda (ss p2)
		    (set! r (cons (mk-cont p2 ss) r))
		    (g2 ss fail
			(lambda (sss p3)
			(let ((fr (gp-newframe-choice sss)))
			  (set! r (cons (mk-cont p3 sss) r))
			  (rg sss (cc sss (lambda ()
					    (gp-unwind fr)
					    (fail))))))))))
	     ((g2 . gs)
	      (g1 sin fail  
		  (lambda (ss p2)
		    (set! r (cons (mk-cont p2 ss) r))
		    (loop ss p2 g2 gs)))))))))

(define-syntax-rule (cont-set! g p sin wind)
  (let ((cont #f))
    (set! g (lambda () (cont)))
    (set! cont (let ((s (gp-store-state sin)))
		 (lambda () 
		   (gp-restore-wind s (gp-rebased-level-ref wind))
		   (p))))))

(define-syntax-rule (cont2-set! g p sin wind)
  (let ((cont #f))
    (set! g (lambda (s p cc) (cont)))
    (set! cont (let ((s (gp-store-state sin)))
		 (lambda () 
		   (gp-restore-wind s (gp-rebased-level-ref wind))
		   (p))))))


(define-syntax-class vars
  (pattern (aa:id a:id ...) 
	   #:with (s ...) #'(aa a ...)
	   #:with id      (datum->syntax #'aa (gensym "id")))

  (pattern b:id 
	   #:with (s ...) #'(b)
	   #:with id      (datum->syntax #'b (gensym "id"))))


(define-guile-log <zip>
  (lambda (x)
    (syntax-parse x
      ((_ (cut s p cc) (v:vars code ...)  (vs:vars codes ...) ...)
       (with-syntax ((((vvs ...) ...) (map generate-temporaries 
					   #'((vs.s ...) ...)))
		     ((vv ...)        (generate-temporaries #'(v.s ...)))
		     ((gs ...)        (generate-temporaries #'(vs.id ...)))
		     ((ggs ...)       (generate-temporaries #'(vs.id ...))))

	#'(let ((g (</.> code ...)) (gs (</.> codes ...)) ...)
	     #;(use-logical s)
	     (let-with-lr-guard s wind lguard rguard
		 ((gg #f) (ggs gs) ... (vv #f) ... (vvs #f) ... ...)
	      (lguard s
               (let ((fr (gp-newframe-choice s)))
		 (g s p 
		    (lambda (ss pp)
		      (cont-set! gg pp ss wind)
		      (set! vv (gp-cp v.s ss)) ...
                      (gp-unwind fr)
                      (zip-aux (s p fr) wind rguard 
			       ((vvs ...) ...) ((vs.s ...) ...) 
                               (ggs ...) 
                               (begin
                                 #;(leave-logical s)
                                 (<with-guile-log> (s gg cc)
				    (<and> (<=> v.s  vv ) ...
					   (<=> vs.s vvs) ... 
					   ...)))))))))))))))

(define-syntax zip-aux
  (syntax-rules ()
    ((_ (s p fr) wind guard ((vv ...) . vvs) ((v ...) . vs) (g . gs) code)
     (g s p
	(lambda (ss pp)
	  (cont2-set! g pp ss wind)
	  (set! vv (gp-cp v ss)) ...
          (gp-unwind fr)
          (zip-aux (s p fr) wind guard vvs vs gs code))))

    ((_ (s p fr) wind guard () () () code)
     (guard s code))))

  
(define (call s p cc lam x l)
  #;(use-logical s)
  (let ((s    (gp-newframe-choice s))
	(wind (gp-windlevel-ref s)))
    ((gp-lookup lam s)
     s p (lambda (ss pp)
	   (let ((state (gp-store-state ss)))
	     (let ((xx (gp-cp x ss)))
	       (gp-unwind s)
	       (let ((ppp (lambda ()
			    (gp-restore-wind state (gp-rebased-level-ref wind))
			    (pp))))
		 #;(leave-logical s)
		 (<with-guile-log> (s ppp cc)
		   (<=> xx l)))))))))
             

(define-guile-log <call>          
  (syntax-rules ()
    ((_ w ((l x) ...) code ...)
     (parse<> w
       (call (</.> code ...) (list x ...) (list l ...))))))

(<define> (<gc-call> X L Lam)
   (<let> ((p P)
	   (pr (<newframe>)))
      (Lam)
      (<let> ((res (<cp> X L)))
	 (<code> (<unwind-tail> pr))
	 (<with-fail> p (<=> X res)))))

(<define> (<gc-scm-call> X Lam)
   (<let> ((p P)
	   (pr (<newframe>)))
      (Lam)
      (<let> ((res (<scm> X)))
	 (<code> (<unwind-tail> pr))
	 (<with-fail> p (<=> X res)))))

(<define> (<gc-list-call> X Lam)
   (<let> ((p  P)
	   (pr (<newframe>)))
      (Lam)
      (<let> ((res (->list S X)))
	 (<code> (<unwind-tail> pr))
	 (<with-fail> p (<=> X res)))))

(define-syntax-rule (fcall-m nm)
  (define (nm s p cc lam x l f)
    (let-with-lr-guard s wind lguard rguard ((cc cc))
     (lguard s 
       (let ((s (gp-newframe-choice s)))
        ((gp-lookup lam s)
         s p (lambda (ss pp)
               (let ((state (gp-store-state ss)))
                 (let ((xx (gp-cp x ss)))
                   (gp-unwind s)
                   (letrec ((ppp (case-lambda 
                                   ((cc-new)
                                    (set! cc cc-new)
                                    (gp-restore-wind 
				     state (gp-rebased-level-ref wind))
                                    (pp))
                                   ((cc-new pp)
                                    (set! cc cc-new)
                                    (gp-restore-wind 
				     state (gp-rebased-level-ref wind))
                                    (pp)))))
                     (for-each (lambda (l x) (l x)) l xx)
                     (f ppp)
		     (cc s 
                         (lambda () 
                           (error 
                            "Bug, should not be exevcuted in <//>")))))))))))))

(fcall-m fcall)

(define-syntax-parameter CC2 (lambda (x) (error "CC2 should be bound by fluid-let")))

(define-guile-log <//>
  (lambda (x)
    (syntax-case x ()
      ((<//> w ((fail ((xx x) ... ) code ...) ...) body ...)
       (with-syntax ((((xx2 ...) ...) 
		      (map generate-temporaries #'((xx ...) ...)))
                     ((fail2 ...)     
		      (generate-temporaries #'(fail ...))))
         #'(parse<> w
	    (<let-with-lr-guard> wind lguard rguard
	                      ((xx #f) ... ... (fail #f) ...)
             (lguard
	      (</.>
	       (<let> ((xx2   (lambda (v) 
				(set! xx v))) ... ... 
		       (fail2 (lambda (v) 
				(set! fail v))) ...
		       (allfail P))
		 (<with-fail> allfail
                    (fcall (</.> code ...) (list x ...) (list xx2 ...) 
			   fail2))
		 ...      
	         (rguard
		    (</.> 
                     (<let*> ((cc  CC)
                              (ccx (lambda (s p) (cc s p)))
                              (p   (lambda () 
                                     (error "BUG we should be here in <//>")))
                              (s   S))                       
                        (<syntax-parameterize> ((CC2 (lambda z #'ccx))) 
                          (<with-fail> (lambda ()
                                         ((<lambda> ()
                                                    (<update> (fail) ...))
                                          s p ccx))
                                ((lambda (s p cccc)
                                   (let ((ccc (lambda (ss pp)
                                                ((</.> body ...) s p cccc))))
                                     (set! cc ccc)
                                     (ccc s p)))))))))))))))))))

(define (pp x) 
  #;(pretty-print (syntax->datum x)) x)

(define-guile-log <update>
  (lambda (x)
    (pp x)
    (syntax-case x ()
      ((_ (cut s p cc) (fail . l))
       (pp #'(fail CC2 . l)))
      ((_ w x ... y)
       #'(parse<> w (<and> (<update-val> x) ... (<update> y)))))))

;;preferably do not use this as a user
(define-guile-log <update-val>
  (syntax-rules ()
    ((_ (cut s p cc) (fail . l))
     (fail (lambda (ss pp) (cc ss p))  . l))
    ((_ w x ... y)
     (parse<> w (<and> (<update-val> x) ... (<update> y))))))