[ create a new paste ] login | about

Link: http://codepad.org/408Ehwhb    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Jun 12:
; 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))
      (let ((v (assq x s)))
        (if v
            (walk (cdr v) s)

(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)
         (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)
         (lambda (g* s*)
           (if (null? g*)
               (try (cdr g*)
                    (apply append
                           (map (car g*) s*)))))))
      (try g* (succeed s)))))

(define (one* . g*)
  (lambda (s)
         (lambda g*
           (if (null? g*)
               (fail s)
               (let ((out ((car g*) s)))
                 (if (failed? out)
                     (apply try (cdr g*))
      (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)
      (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)
        (occurs? x (walk x s) s))))

(define (walk* x s)
    ((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)

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

(define (reify v)
       (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)
    (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)))

(norwegian kools water fox yellow)
(ukrainian chesterfields tea horse blue)
(englishman oldgolds milk snails red)
(japanese parliaments coffee zebra green)
(spaniard luckystrikes orangejuice dog ivory)

Create a new paste based on this one