zebra.scm

(load "mk.scm")

(define membero
  (lambda (elt ls)
    (fresh (d a)
      (conde
        ((== `(,elt . ,d) ls))
        ((== `(,a ., d) ls) (membero elt d))))))

(define on-righto
  (lambda (e1 e2 ls)
    (fresh (d a r)
      (conde
        ((== `(,e1 . ,d) ls) (== `(,e2 . ,r) d))
        ((== `(,a . ,d) ls) (on-righto e1 e2 d))))))

(define next-too
  (lambda (e1 e2 ls)
    (conde
      ((on-righto e1 e2 ls))
      ((on-righto e2 e1 ls)))))

(define zebrao
  (lambda ()
    (run 1 (h)
      (fresh (a1 a2 a3 a4 a5
              b1 b2 b3 b4 b5
              c1 c2 c3 c4 c5
              d1 d2 d3 d4 d5
              e1 e2 e3 e4 e5)
        (== h `((,a1 ,a2 ,a3 ,a4 ,a5)
                (,b1 ,b2 ,b3 ,b4 ,b5)
                (,c1 ,c2 milk ,c4 ,c5)
                (,d1 ,d2 ,d3 ,d4 ,d5)
                (,e1 ,e2 ,e3 ,e4 ,e5)))
        (== a1 'norwegian)
        (fresh (t1 t2 t3 t4 t5 t6 t7 t8)
          (next-too `(norwegian ,t1 ,t2 ,t3 ,t4)
            `(,t5 ,t6 ,t7 ,t8 blue) h))
        (fresh (t1 t2 t3 t4 t5 t6 t7 t8)
          (on-righto `(,t1 ,t2 ,t3 ,t4 ivory)
            `(,t5 ,t6 ,t7 ,t8 green) h))
        (fresh (t1 t2 t3)
          (membero `(englishman ,t1 ,t2 ,t3 red) h))
        (fresh (t1 t2 t3)
          (membero `(,t1 kools ,t2 ,t3 yellow) h))
        (fresh (t1 t2 t3)
          (membero `(spaniard ,t1 ,t2 dog ,t3) h))
        (fresh (t1 t2 t3)
          (membero `(,t1 ,t2 coffee ,t3 green) h))
        (fresh (t1 t2 t3)
          (membero `(ukrainian ,t1 tea ,t2 ,t3) h))
        (fresh (t1 t2 t3)
          (membero `(,t1 luckystrikes oj ,t2 ,t3) h))
        (fresh (t1 t2 t3)
          (membero `(japanese parliaments ,t1 ,t2 ,t3) h))
        (fresh (t1 t2 t3)
          (membero `(,t1 oldgolds ,t2 snails ,t3) h))
        (fresh (t1 t2 t3 t4 t5 t6 t7 t8)
          (next-too `(,t1 ,t2 ,t3 horse ,t4) 
            `(,t5 kools ,t6 ,t7 ,t8) h))
        (fresh (t1 t2 t3 t4 t5 t6 t7 t8)
          (next-too `(,t1 ,t2 ,t3 fox ,t4)
            `(,t5 chesterfields ,t6 ,t7 ,t8) h))))))

(define time-zebra
  (lambda ()
    (time
      (do ((i 0 (+ i 1))) ((> i 1000))
        (zebrao)))))