;;;; schelog-macros.scm


;%let introduces new logic variables

(define-macro (%let xx . ee)
  `(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx)
     ,@ee))


;disjunction

(define-macro (%or . gg)
  `(lambda (__fk)
     (call-with-current-continuation
      (lambda (__sk)
	,@(map (lambda (g)
		 `(call-with-current-continuation
		   (lambda (__fk)
		     (__sk ((schelog:deref* ,g) __fk)))))
	       gg)
	(__fk 'fail)))))

;conjunction

(define-macro (%and . gg)
  `(lambda (__fk)
     (let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg)
       __fk)))

;cut

(define-macro (%cut-delimiter g)
    `(lambda (__fk)
       (let ((! (lambda (__fk2) __fk)))
         ((schelog:deref* ,g) __fk))))


;Prolog-like sugar

(define-macro (%rel vv . cc)
    `(lambda __fmls
       (lambda (__fk)
         (call-with-current-continuation
          (lambda (__sk)
            (let ((! (lambda (fk1) __fk)))
              (%let ,vv
                    ,@(map (lambda (c)
                             `(call-with-current-continuation
                               (lambda (__fk)
                                 (let* ((__fk ((%=/2 __fmls (list ,@(car c))) __fk))
                                        ,@(map (lambda (sg)
                                                 `(__fk ((schelog:deref* ,sg) __fk)))
                                               (cdr c)))
                                   (__sk __fk)))))
                           cc)
                    (__fk 'fail))))))))


;for structures ("functors"), use Scheme's list and vector
;functions and anything that's built using them.

;arithmetic

(define-macro (%is/2 v e)
    (letrec ((%is-help (lambda (e fk)
                         (cond ((pair? e)
                                (cond ((eq? (car e) 'quote) e)
                                      (else
                                       (map (lambda (e1)
                                              (%is-help e1 fk)) e))))
                               (else
                                `(if (and (schelog:ref? ,e)
                                          (schelog:unbound-ref? ,e))
                                     (,fk 'fail) (schelog:deref* ,e)))))))
      `(lambda (__fk)
         ((%=/2 ,v ,(%is-help e '__fk)) __fk))))

(define-macro (%assert rel-name vv . cc)
    `(set! ,rel-name
           (let ((__old-rel ,rel-name)
                 (__new-addition (%rel ,vv ,@cc)))
             (lambda __fmls
               (%or (apply __old-rel __fmls)
                    (apply __new-addition __fmls))))))

(define-macro (%assert-a rel-name vv . cc)
    `(set! ,rel-name
           (let ((__old-rel ,rel-name)
                 (__new-addition (%rel ,vv ,@cc)))
             (lambda __fmls
               (%or (apply __new-addition __fmls)
                    (apply __old-rel __fmls))))))

(define-macro (%free-vars vv g)
    `(cons 'schelog:goal-with-free-vars
           (cons (list ,@vv) ,g)))

;user interface

;(%which (v ...) query) returns #f if query fails and instantiations
;of v ... if query succeeds.  In the latter case, type (%more) to
;retry query for more instantiations.

(define-macro (%which vv g)
    `(%let ,vv
           (call-with-current-continuation
            (lambda (__qk)
              (set! schelog:*more-k* __qk)
              (set! schelog:*more-fk*
                    ((schelog:deref* ,g)
                     (lambda (d)
                       (set! schelog:*more-fk* #f)
                       (schelog:*more-k* #f))))
              (schelog:*more-k*
               (map (lambda (nam val) (list nam (schelog:deref* val)))
                    ',vv
                    (list ,@vv)))))))

; deprecated names -- retained here for backward-compatibility

(define-macro (%cut . e)
    `(%cut-delimiter ,@e))

(define-macro (%exists vv g) g)
