t3x.org / sketchy / prog / zebra.html
SketchyLISP Stuff Copyright (C) 2006 Nils M Holm

zebra

Conformance: R5RS

Purpose: Solve the Zebra puzzle using Another Micro KANREN (AMK).

Implementation:

(require "amk.scm")

(define memb membero)

(define (left-of x y l)
  (let ((vh (var 'h))
        (vt (var 't))
        (vz (var 'z)))
    (any (all (conso vh vt l)
              (caro vt vz)
              (== vz y)
              (== vh x))
         (all (cdro l vt)
              (left-of x y vt)))))

(define (next-to x y l)
  (any (left-of x y l)
       (left-of y x l)))

(define (zebra)
  (run* vq
    (let ((h (var 'h)))
       (all
         (== h (list (list 'norwegian (_) (_) (_) (_))
                     (_)
                     (list (_) (_) 'milk (_) (_))
                     (_)
                     (_)))
         (memb (list 'englishman (_) (_) (_) 'red) h)
         (left-of (list (_) (_) (_) (_) 'green)
                  (list (_) (_) (_) (_) 'ivory) h)
         (next-to (list 'norwegian (_) (_) (_) (_))
                  (list (_) (_) (_) (_) 'blue) h)
         (memb (list (_) 'kools (_) (_) 'yellow) h)
         (memb (list 'spaniard (_) (_) 'dog (_)) h)
         (memb (list (_) (_) 'coffee (_) 'green) h) 
         (memb (list 'ukrainian (_) 'tea (_) (_)) h)
         (memb (list (_) 'luckystrikes 'orangejuice (_) (_)) h)
         (memb (list 'japanese 'parliaments (_) (_) (_)) h)
         (memb (list (_) 'oldgolds (_) 'snails (_)) h)
         (next-to (list (_) (_) (_) 'horse (_))
                  (list (_) 'kools (_) (_) (_)) h)
         (next-to (list (_) (_) (_) 'fox (_))
                  (list (_) 'chesterfields (_) (_) (_)) h)
         (memb (list (_) (_) 'water (_) (_)) h)
         (memb (list (_) (_) (_) 'zebra (_)) h)
         (== vq h)))))