Einstein's puzzle in miniKanren

einstein.scm

#! /usr/bin scheme --script
;; loads two files from https://github.com/michaelballantyne/faster-miniKanren :
;; mk.scm and mk-vicare.scm
(load "lib.scm")

(define (membero x y)
  (fresh (a d)
  (== y `(,a . ,d))
  (conde
    [(== x a)]
    [(membero x d)]
    )))

;; using actual arithmetic would be overkill here
(define (right-of x y)
  (conde
    [(== x 'two) (== y 'one)]
    [(== x 'three) (== y 'two)]
    [(== x 'four) (== y 'three)]
    [(== x 'five) (== y 'four)]
  ))

(define (left-of x y)
  (right-of y x)
  )

(define (next-to x y)
  (conde
    [(left-of x y)]
    [(right-of x y)]
  ))

;; afaik minikanren has no anonymous vars,
;; so here is a hack that adds anonymous vars.
;; time is not nanosecond precise
;; a better string generation could remove this sleep
(define (_) 
  (sleep (make-time 'time-duration 1000 0))
  (vector unbound (new-scope) (time-nanosecond (current-time)))
  )

;; anon vars needed here because otherwise this would have to be
;; wrapped in a fresh with 25 variables.
;; thats not bad in itself but that way we can never reason
;; about the list definition itself (and pass it to unroll)
(define street-def
    `(
        (one ,(_) ,(_) ,(_) ,(_) ,(_))
        (two ,(_) ,(_) ,(_) ,(_) ,(_))
        (three ,(_) ,(_) ,(_) ,(_) ,(_))
        (four ,(_) ,(_) ,(_) ,(_) ,(_))
        (five ,(_) ,(_) ,(_) ,(_) ,(_))
    )
  )

;; faster-minikanren dropped disj in favor of the conde macro directly
;; i need disj+ at least in order to implement unroll
(define (disj g1 g2)
    (lambda (st) 
            (mplus* (g1 st) (g2 st)))
  )

(define (disj+ goals) 
    (let ((gcar (car goals)) (gcdr (cdr goals)))
      (cond
        ((eq? gcdr '()) gcar)
        (else (lambda (st) ((disj gcar (disj+ gcdr)) st)))
    ))
  )

;; membero-unrolled preprocesses the membero relation for (partially) known lists
;; returns a unary function that tests its input vs all elements of list ylist
;; inner map returns a list of curried equalo procedures applied to members of ylist
;; outer map applies the argument x to each of the equalo's
(define (membero-unrolled ylist)
  (lambda (x)
   (lambda (st) 
     (let ((st (state-with-scope st nonlocal-scope))) (
    (disj+ (map (lambda (f) (f x)) (map (lambda (y) (lambda (z) (== z y))) ylist)))
    st )))
   )
  )

(define unrolled (membero-unrolled street-def))

;; Speeding up Einstein's puzzle by replacing membero with unrolled
;; time without unroll: ~0.31s
;; time with unroll: ~0.22s
( printf "Einsteins puzzle: ~w\n"
  (run* (q)
    (fresh (fishowner s a b c d e f g h i j)
       (== q `(,fishowner ,s))
       (== s street-def)
       (unrolled `(,(_) brit red ,(_) ,(_) ,(_)))
       (unrolled `(,(_) swede ,(_) dog ,(_) ,(_)))
       (unrolled `(,(_) dane ,(_) ,(_) tea ,(_)))
       (unrolled `(,a ,(_) green ,(_) ,(_) ,(_)))
       (unrolled `(,b ,(_) white ,(_) ,(_) ,(_)))
       (left-of a b)
       (unrolled `(,(_) ,(_) green ,(_) coffee ,(_)))
       (unrolled `(,(_) ,(_) ,(_) birds ,(_) pall-mall))
       (unrolled `(,(_) ,(_) yellow ,(_) ,(_) dunhill))
       (unrolled `(three ,(_) ,(_) ,(_) milk ,(_)))
       (unrolled `(one norwegian ,(_) ,(_) ,(_) ,(_)))
       (unrolled `(,c ,(_) ,(_) ,(_) ,(_) blend))
       (unrolled `(,d ,(_) ,(_) cats ,(_) ,(_)))
       (next-to c d)
       (unrolled `(,e ,(_) ,(_) horse ,(_) ,(_)))
       (unrolled `(,f ,(_) ,(_) ,(_) ,(_) dunhill))
       (next-to e f)
       (unrolled `(,(_) ,(_) ,(_) ,(_) beer bluemaster))
       (unrolled `(,(_) german ,(_) ,(_) ,(_) prince))
       (unrolled `(,g norwegian ,(_) ,(_) ,(_) ,(_)))
       (unrolled `(,h ,(_) blue ,(_) ,(_) ,(_)))
       (next-to g h)
       (unrolled `(,i ,(_) ,(_) ,(_) ,(_) blend))
       (unrolled `(,j ,(_) ,(_) ,(_) water ,(_)))
       (next-to i j)
       (unrolled `(,(_) ,fishowner ,(_) fish ,(_) ,(_)))
    )))