Zebra logic in Scheme

zebra-logic.ss

; who owns the zebra

; 1  There are five houses.
; 2  The Englishman lives in the red house.
; 3  The Spaniard owns the dog.
; 4  Coffee is drunk in the green house.
; 5  The Ukrainian drinks tea.
; 6  The green house is immediately to the right of the ivory house.
; 7  The Old Gold smoker owns snails.
; 8  Kools are smoked in the yellow house.
; 9  Milk is drunk in the middle house.
; 10 The Norwegian lives in the first house.
; 11 The man who smokes Chesterfields lives in the house next to the man with the fox.
; 12 Kools are smoked in the house next to the house where the horse is kept.
; 13 The Lucky Strike smoker drinks orange juice.
; 14 The Japanese smokes Parliaments.
; 15 The Norwegian lives next to the blue house.

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009
; See the LICENSE file of the S9fES package for terms of use
;
; (run* (variable) query)  ==>  list
; (run* () query)          ==>  list
;
; Run the given AMK (Another Micro Kanren) query and return its
; result, if any. See the book "Logic Programming in Scheme"
; (http://www.t3x.org/nmh/book-pdfs/) for an introduction to AMK.
; If a variable is given, return all values for that variable
; that satisfy the query.
;
; Example:   (run* (vq) (appendo vq (_) '(a b c)))
;              ==>  (() (a) (a b) (a b c))

; ----- Core -----

(define (fail x) '())

(define (succeed x) (list x))

(define failed? null?)

(define (var x) (cons '? x))

(define (_) (var '_))

(define (var? x)
  (and (pair? x)
       (eq? (car x) '?)))

(define empty-s '())

(define _bottom_ (var 'bottom))

(define (atom? x) (not (pair? x)))

(define (ext-s x v s) (cons (cons x v) s))

(define (walk x s)
  (if (not (var? x))
      x
      (let ((v (assq x s)))
        (if v
            (walk (cdr v) s)
            x))))

(define (unify x y s)
  (let ((x (walk x s))
        (y (walk y s)))
    (cond ((eqv? x y) s)
          ((var? x) (ext-s x y s))
          ((var? y) (ext-s y x s))
          ((or (atom? x) (atom? y)) #f)
          (else (let ((s (unify (car x) (car y) s)))
                  (and s (unify (cdr x) (cdr y) s)))))))

(define (== x y)
  (lambda (s)
    (let ((s2 (unify x y s)))
      (if s2
          (succeed s2)
          (fail s)))))

(define (any* . g*)
  (lambda (s)
    (letrec
      ((try
         (lambda g*
           (if (null? g*)
               (fail s)
               (append ((car g*) s)
                       (apply try (cdr g*)))))))
      (apply try g*))))

(define-syntax any
  (syntax-rules ()
    ((_) fail)
    ((_ g ...)
       (any* (lambda (s) (g s)) ...))))

(define (all . g*)
  (lambda (s)
    (letrec
      ((try
         (lambda (g* s*)
           (if (null? g*)
               s*
               (try (cdr g*)
                    (apply append
                           (map (car g*) s*)))))))
      (try g* (succeed s)))))

(define (one* . g*)
  (lambda (s)
    (letrec
      ((try
         (lambda g*
           (if (null? g*)
               (fail s)
               (let ((out ((car g*) s)))
                 (if (failed? out)
                     (apply try (cdr g*))
                     out))))))
      (apply try g*))))

(define-syntax one
  (syntax-rules ()
    ((_) fail)
    ((_ g ...)
       (one* (lambda (s) (g s)) ...))))

(define (neg g)
  (lambda (s)
    (let ((out (g s)))
      (if (failed? out)
          (succeed s)
          (fail s)))))

(define (choice x lst)
  (if (null? lst)
      fail
      (any (== x (car lst))
           (choice x (cdr lst)))))

(define-syntax fresh
  (syntax-rules ()
    ((_ () g)
       (let () g))
    ((_ (v ...) g)
       (let ((v (var 'v)) ...) g))))

(define (occurs? x y s)
  (let ((v (walk y s)))
    (cond ((var? y) (eq? x y))
          ((var? v) (eq? x v))
          ((atom? v) #f)
          (else (or (occurs? x (car v) s)
                    (occurs? x (cdr v) s))))))

(define (circular? x s)
  (let ((v (walk x s)))
    (if (eq? x v)
        #f
        (occurs? x (walk x s) s))))

(define (walk* x s)
  (letrec
    ((w* (lambda (x s)
           (let ((x (walk x s)))
             (cond ((var? x) x)
                   ((atom? x) x)
                   (else (cons (w* (car x) s)
                               (w* (cdr x) s))))))))
    (cond ((circular? x s) _bottom_)
          ((eq? x (walk x s)) empty-s)
          (else (w* x s)))))

(define (preserve-bottom s)
  (if (occurs? _bottom_ s s)
      '()
      s))

(define (reify-name n)
  (string->symbol
    (string-append "_." (number->string n))))

(define (reify v)
  (letrec
    ((reify-s
       (lambda (v s)
         (let ((v (walk v s)))
           (cond ((var? v)
                   (ext-s v (reify-name (length s)) s))
                 ((atom? v) s)
                 (else (reify-s (cdr v)
                                (reify-s (car v) s))))))))
    (reify-s v empty-s)))

(define (run x g)
  (preserve-bottom
    (map (lambda (s)
           (walk* x (append s (reify (walk* x s)))))
         (g empty-s))))

(define-syntax run*
  (syntax-rules ()
    ((_ () goal) (run #f goal))
    ((_ (v) goal) (run v goal))))

; ----- Tools -----

(define vp (var 'p))
(define vq (var 'q))

(define (conso a d p) (== (cons a d) p))

(define (caro p a) (conso a (_) p))

(define (cdro p d) (conso (_) d p))

(define (pairo p) (conso (_) (_) p))

(define (eqo x y) (== x y))

(define (nullo a) (eqo a '()))

(define (memo x l)
  (fresh (d)
    (any (caro l x)
         (all (cdro l d)
              (memo x d)))))

(define (rmemo x l)
  (fresh (d)
    (any (all (cdro l d)
              (memo x d))
         (caro l x))))

(define (reverseo l r) (rmemo r l))

(define (appendo x y r)
  (any (all (== x '())
            (== y r))
       (fresh (hd tl app)
         (all (conso hd tl x)
              (conso hd app r)
              (appendo tl y app)))))

(define (memqo x l r)
  (fresh (d)
    (any (all (caro l x)
              (== l r))
         (all (cdro l d)
              (memqo x d r)))))

(define (rmemqo x l r)
  (fresh (d)
    (any (all (cdro l d)
              (rmemqo x d r))
         (all (caro l x)
              (== l r)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the zebra puzzle

(define (lefto x y l)
  (fresh (d)
    (any (all (caro l x)
              (cdro l d)
              (caro d y))
         (all (cdro l d)
              (lefto x y d)))))

(define (nexto x y l)
  (any (lefto x y l)
       (lefto y x l)))

(define (zebra)
  (fresh (h)
    (run* (h)
      (all (== h (list (list 'norwegian (_) (_) (_) (_)) ; 10
                       (_)
                       (list (_) (_) 'milk (_) (_)) ; 9
                       (_)
                       (_)))
           (memo (list 'englishman (_) (_) (_) 'red) h) ; 2
           (lefto (list (_) (_) (_) (_) 'green) ; 6
                  (list (_) (_) (_) (_) 'ivory) h) ; 6
           (nexto (list 'norwegian (_) (_) (_) (_)) ; 15
                  (list (_) (_) (_) (_) 'blue) h) ; 15
           (memo (list (_) 'kools (_) (_) 'yellow) h) ; 8
           (memo (list 'spaniard (_) (_) 'dog (_)) h) ; 3
           (memo (list (_) (_) 'coffee (_) 'green) h) ; 4
           (memo (list 'ukrainian (_) 'tea (_) (_)) h) ; 5
           (memo (list (_) 'luckystrikes 'orangejuice (_) (_)) h) ; 13
           (memo (list 'japanese 'parliaments (_) (_) (_)) h) ; 14
           (memo (list (_) 'oldgolds (_) 'snails (_)) h) ; 7
           (nexto (list (_) (_) (_) 'horse (_)) ; 12
                  (list (_) 'kools (_) (_) (_)) h) ; 12
           (nexto (list (_) (_) (_) 'fox (_)) ; 11
                  (list (_) 'chesterfields (_) (_) (_)) h) ; 11
           (memo (list (_) (_) 'water (_) (_)) h)
           (memo (list (_) (_) (_) 'zebra (_)) h)))))

(for-each (lambda (x) (display x) (newline)) (car (zebra)))