scheme-test-programs/logic/t-microkanren.scm

;; import logic/microkanren.scm

(define a-and-b
  (conj 
   (call/fresh (lambda (a) (== a 7)))
   (call/fresh 
    (lambda (b) 
      (disj
       (== b 5)
       (== b 6))))))

(define fives
  (lambda (x)
    (disj
     (== x 5)      
     (lambda (a/c)
       (lambda ()
         ((fives x) a/c))))))

(define appendo
  (lambda (l s out)
    (disj
     (conj (== '() l) (== s out))
     (call/fresh
      (lambda (a)
        (call/fresh
         (lambda (d)
           (conj
            (== `(,a . ,d) l)
            (call/fresh
             (lambda (res)
               (conj
                (== `(,a . ,res) out)
                (lambda (s/c)
                  (lambda ()
                    ((appendo d s res) s/c))))))))))))))

(define appendo2
  (lambda (l s out)
    (disj
     (conj (== '() l) (== s out))
     (call/fresh
      (lambda (a)
        (call/fresh
         (lambda (d)
           (conj
            (== `(,a . ,d) l)
            (call/fresh
             (lambda (res)
               (conj
                (lambda (s/c)
                  (lambda ()
                    ((appendo2 d s res) s/c)))
                (== `(,a . ,res) out))))))))))))

(define call-appendo
  (call/fresh
   (lambda (q)
     (call/fresh
      (lambda (l)
        (call/fresh
         (lambda (s)
           (call/fresh
            (lambda (out)
              (conj
               (appendo l s out)
               (== `(,l ,s ,out) q)))))))))))

(define call-appendo2
  (call/fresh
   (lambda (q)
     (call/fresh
      (lambda (l)
        (call/fresh
         (lambda (s)
           (call/fresh
            (lambda (out)
              (conj
               (appendo2 l s out)
               (== `(,l ,s ,out) q)))))))))))

(define call-appendo3
  (call/fresh
   (lambda (q)
     (call/fresh
      (lambda (l)
        (call/fresh
         (lambda (s)
           (call/fresh
            (lambda (out)
              (conj
               (== `(,l ,s ,out) q)
               (appendo l s out)))))))))))

(define ground-appendo (appendo '(a) '(b) '(a b)))

(define ground-appendo2  (appendo2 '(a) '(b) '(a b)))

(define relo
  (lambda (x)
    (call/fresh
     (lambda (x1)
       (call/fresh
        (lambda (x2)
          (conj
           (== x `(,x1 . ,x2))
           (disj
            (== x1 x2)
            (lambda (s/c)
              (lambda () ((relo x) s/c)))))))))))

(define many-non-ans
  (call/fresh
   (lambda (x)
     (disj
      (relo `(5 . 6))
      (== x 3)))))

(define (test title val)
  (display title)
  (newline)
  (display val)
  (newline))

(test "second-set t1"
      (let (($ ((call/fresh (lambda (q) (== q 5))) empty-state)))
        (car $)))

(test "second-set t2"
      (let (($ ((call/fresh (lambda (q) (== q 5))) empty-state)))
        (cdr $)))

(test "second-set t3"
      (let (($ (a-and-b empty-state)))
        (car $)))

(test "second-set t3, take"
      (let (($ (a-and-b empty-state)))
        (take 1 $)))

(test "second-set t4"
      (let (($ (a-and-b empty-state)))
        (car (cdr $))))

(test "second-set t5"
      (let (($ (a-and-b empty-state)))
        (cdr (cdr $))))

(test "who cares"
      (let (($ ((call/fresh (lambda (q) (fives q))) empty-state)))
        (take 1 $)))

(test "take 2 a-and-b stream"
      (let (($ (a-and-b empty-state)))
        (take 2 $)))

(test "take-all a-and-b stream"
      (let (($ (a-and-b empty-state)))
        (take-all $)))

(test "ground appendo"
      (car ((ground-appendo empty-state))))

(test "ground appendo2"
      (car ((ground-appendo2 empty-state))))

(test "appendo"
      (take 2 (call-appendo empty-state)))

(test "appendo2"
      (take 2 (call-appendo2 empty-state)))

(test "reify-1st across appendo"
      (map reify-1st (take 2 (call-appendo empty-state))))

(test "reify-1st across appendo2"
      (map reify-1st (take 2 (call-appendo2 empty-state))))

(test "many non-ans"
      (take 1 (many-non-ans empty-state)))