macros for convenience and reification.

that's it. now i really want to know when those `pair?` calls are
needed. that's something i'd like to have an instarepl for, or maybe an
environment more like learnable programming? or maybe paper will do.
we'll see.

scm/mukanren.scm

@@ -94,15 +94,119 @@
;; 5 utilities
(define (expand n s)
  (if (> n 1)
    (cond
      ((null? s) s)
      ((procedure? (cdr s)) `(,(car s) . ,(expand (- n 1) ((cdr s)))))
      (else `(,(car s) . ,(expand (- n 1) (cdr s)))))
#|
(define (expand-deferred s)
  (if (procedure? s)
    (expand-deferred (s))
    s))
(define (expand-once s)
  (if (procedure? s)
    (s)
    s))
(define (expand n s)
  (if (and (> n 1) (not (null? s)))
    `(,(expand-deferred (car s)) . ,(expand (- n 1) (expand-once (cdr s))))
    (expand-deferred s)))
(expand 5 (fives-and-sixes empty-state))
(define (run n g)
  (expand n (g empty-state)))
  (expand n (g empty-state)))
|#
(define-syntax Zzz
  (syntax-rules ()
    ((_ g) (lambda (s/c) (lambda () (g s/c))))))
(define-syntax conj+
  (syntax-rules ()
    ((_ g) (Zzz g))
    ((_ g0 g ...) (conj (Zzz g0) (conj+ g ...)))))
(define-syntax disj+
  (syntax-rules ()
    ((_ g) (Zzz g))
    ((_ g0 g ...) (disj (Zzz g0) (disj+ g ...)))))
(define-syntax conde
  (syntax-rules ()
    ((_ (g0 g ...) ...) (disj+ (conj+ g0 g ...) ...))))
(define-syntax fresh
  (syntax-rules ()
    ((_ () g0 g ...) (conj+ g0 g ...))
    ((_ (x0 x ...) g0 g ...)
     (call/fresh (lambda (x0) (fresh (x ...) g0 g ...))))))
;(run 1 (fresh (x y z) (≡ x 7) (≡ y 8) (disj (≡ x z) (≡ y z))))
;; 5.2 from streams to lists
(define (pull $) (if (procedure? $) (pull ($)) $))
(define (take-all $)
  (let (($ (pull $)))
    (if (null? $) '() (cons (car $) (take-all (cdr $))))))
(define (take n $)
  (if (zero? n) '()
    (let (($ (pull $)))
      (cond
        ((null? $) '())
        (else (cons (car $) (take (- n 1) (cdr $))))))))
(take 10 ((fresh (x y z) (≡ x 7) (≡ y 8) (disj+ (≡ x z) (≡ y z) (≡ x y))) empty-state))
;; 5.3 recovering reification
(define (mK-reify s/c*)
  (map reify-state/1st-var s/c*))
(define (reify-state/1st-var s/c)
  (let ((v (walk* (var 0) (car s/c))))
    (walk* v (reify-s v '()))))
(define (reify-s v s)
  (let ((v (walk v s)))
    (cond
      ((var? v)
       (let ((n (reify-name (length s))))
         (cons `(,v . ,n) s)))
      ((pair? v) (reify-s (cdr v) (reify-s (car v) s)))
      (else s))))
(define (reify-name n)
  (string->symbol
    (string-append "_." (number->string n))))
(define (walk* v s)
  (let ((v (walk v s)))
    (cond
      ((var? v) v)
      ((pair? v) (cons (walk* (car v) s)
                       (walk* (cdr v) s)))
      (else v))))
(mK-reify (take 10 ((fresh (x y z) (≡ x 7) (≡ y 8) (disj+ (≡ x z) (≡ y z) (≡ x y))) empty-state)))
(mK-reify (take 100 (fives-and-sixes empty-state)))
;; 5.4 recovering the interface to scheme
(define (call/empty-state g) (g empty-state))
(define-syntax run
  (syntax-rules ()
    ((_ n (x ...) g0 g ...)
     (mK-reify (take n (call/empty-state
                         (fresh (x ...) g0 g ...)))))))
(define-syntax run*
  (syntax-rules ()
    ((_ (x ...) g0 g ...)
     (mK-reify (take-all (call/empty-state
                           (fresh (x ...) g0 g ...)))))))
(run 10 (y x z) (≡ x 7) (disj+ (≡ y 8) (≡ y 18) (≡ y 28)) (≡ z 9))