Skip to content
Browse files

Failing zebra test

  • Loading branch information...
1 parent 1800361 commit 2cb8204aabc58f8a192f7ccc1d9b454bf02e20de @hraberg committed Oct 10, 2012
Showing with 71 additions and 4 deletions.
  1. +3 −2 src/mimir/mk.clj
  2. +68 −2 test/mimir/test/mk.clj
View
5 src/mimir/mk.clj
@@ -125,8 +125,9 @@
(postwalk cons-pairs-to-seqs (postwalk-replace vs xs))))
(defmacro run* [[& x] & g]
- `(binding [*match-var?* var?]
- (run-internal (fresh [~@x] ~@g (partial reify-goal ~(vec x))) [{}])))
+ (let [g (postwalk-replace {'_ '(mimir.mk.LVar. (gensym '_))} g)]
+ `(binding [*match-var?* var?]
+ (run-internal (fresh [~@x] ~@g (partial reify-goal ~(vec x))) [{}]))))
(defmacro run [n [& x] & g]
`(take ~n (run* [~@x] ~@g)))
View
70 test/mimir/test/mk.clj
@@ -229,8 +229,7 @@
(run* [x q]
(consᵒ 1 x q)
(restᵒ q x))
- ⇒ '(–₀ (1 . –₀))
- ))
+ ⇒ '(–₀ (1 . –₀))))
(deftest member-the-divergent
(are [a _ e] (is (= a e))
@@ -307,4 +306,71 @@
;; (1 2 3 4 5) (1 2) (2 3 4 5) (4) (3 4 5) (1 2 3 4) (5)}
))
+(deftest anonymous-vars
+ (is (= (run* [q] ( q _)) '(–₀))))
+
+;; From https://github.com/swannodette/logic-tutorial
+(deftest zebra
+ (defn rightᵒ [x y l]
+ (condᵉ
+ ((prefixᵒ [x y] l))
+ ((fresh [d]
+ (restᵒ l d)
+ (rightᵒ x y d)))))
+
+ (defn nextᵒ [x y l]
+ (condᵉ
+ ((rightᵒ x y l))
+ ((rightᵒ y x l))))
+
+ (are [a _ e] (is (= a e))
+
+ (run* [q]
+ (rightᵒ 1 2 [1 2]))
+ ⇒ '(–₀)
+
+ (run* [q]
+ (rightᵒ 1 2 [0 1 2 3]))
+ ⇒ '(–₀)
+
+ (run* [q]
+ (rightᵒ 1 2 [1]))
+ ⇒ '()
+
+ (run* [q]
+ (rightᵒ 1 2 [0 1 3 2 3]))
+ ⇒ '()
+
+ (run* [q]
+ (nextᵒ 1 2 [3 2 1]))
+ ⇒ '(–₀)
+
+ (run* [q]
+ (nextᵒ 1 2 [1 3 2]))
+ ⇒ '())
+
+ ;; Doesn't run yet, small subsets "work".
+ ;; (is (= (run 1 [hs]
+ ;; (≡ [_ _ [_ _ 'milk _ _] _ _] hs)
+ ;; (firstᵒ hs ['norwegian _ _ _ _])
+ ;; (nextᵒ ['norwegian _ _ _ _] [_ _ _ _ 'blue] hs)
+ ;; (rightᵒ [_ _ _ _ 'ivory] [_ _ _ _ 'green] hs)
+ ;; (memberᵒ ['englishman _ _ _ 'red] hs)
+ ;; (memberᵒ [_ 'kools _ _ 'yellow] hs)
+ ;; (memberᵒ ['spaniard _ _ 'dog _] hs)
+ ;; (memberᵒ [_ _ 'coffee _ 'green] hs)
+ ;; (memberᵒ ['ukrainian _ 'tea _ _] hs)
+ ;; (memberᵒ [_ 'lucky-strikes 'oj _ _] hs)
+ ;; (memberᵒ ['japanese 'parliaments _ _ _] hs)
+ ;; (memberᵒ [_ 'oldgolds _ 'snails _] hs)
+ ;; (nextᵒ [_ _ _ 'horse _] [_ 'kools _ _ _] hs)
+ ;; (nextᵒ [_ _ _ 'fox _] [_ 'chesterfields _ _ _] hs))
+
+ ;; '([[norwegian kools –₀ fox yellow]
+ ;; [ukrainian chesterfields tea horse blue]
+ ;; [englishman oldgolds milk snails red]
+ ;; [spaniard lucky-strikes oj dog ivory]
+ ;; [japanese parliaments coffee –₁ green]])))
+)
+
(alter-var-root #'*match-var?* (constantly mv))

0 comments on commit 2cb8204

Please sign in to comment.
Something went wrong with that request. Please try again.