Logic based system in Scheme

gistfile1.scm

(define (amb-fail f)
  (error "amb" "Unable to satisfy conditions"))

(define (amb . it)
  (define old amb-fail)
  (call/cc (lambda (top)
             (map (lambda (val)
                        (call/cc (lambda (cont)
                                   (set! amb-fail cont)
                                   (top val))))
                      it)
             (old #f))))

(define (rule stmt)
  (if stmt
      #t
      (amb-fail #f)))

(define (lookup l ls)
  (let ((res (assoc l ls)))
    (if res
        (cdr res)
        l)))

(define (substitute term table)
  (map
   (lambda (t)
     (lookup t table))
   term))


(define-syntax resolve
  (syntax-rules ()
    [(_ ((v1 vs ...)
         r1 rs ...)
        ((ps ...)
         f1 fs ...))
     (let* ((v1 (amb ps ...))
           (vs (amb ps ...))
           ...
           (sym-table (list (cons (quote v1) v1)
                            (cons (quote vs) vs)
                            ...))
           (facts '(f1 fs ...))
           (rules '(r1 rs ...)))
       (map rule (map
                  (lambda (rule)
                    (member (substitute rule sym-table)
                            facts))
                  rules))
       sym-table)]))
(printf "~a\n" (resolve
                ((x y)
                 (x likes  y) (y is a hard sport) (x is rich))
                (('Mike 'Rachel 'rugby 'tennis)
                 (Mike likes rugby)
                 (Rachel likes tennis)
                 (rugby is a hard sport)
                 (tennis is easy)
                 (Mike is rich)
                 (Rachel is rich))))