Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 167 lines (137 sloc) 4.736 kb
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
1 (ns mimir.mk
2 (:use [clojure.tools.logging :only (debug info warn error spy)]
2298200 Håkan Råberg More lvar/seq hacks
authored
3 [mimir.match :only (filter-walk prepare-matcher *match-var?* match-any bind-vars MatchAny MatchSeq)]
4 [clojure.walk :only (postwalk-replace postwalk)])
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
5 (:import [java.io Writer]
8c6b715 Håkan Råberg Diequality, lvar seq hack
authored
6 [clojure.lang Symbol Seqable])
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
7 (:refer-clojure :exclude [reify var? ==]))
8
c5d9c88 Håkan Råberg mímirKanren
authored
9 ;; mímirKanren: loosely based on "Implementation I: Core miniKanren", Chapter 3 in Byrd.
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
10
11 (defprotocol MatchVar (match-var [this x acc]))
12
13 (extend-protocol MatchVar
14 Object
15 (match-var [x this acc] (when-let [x (-> x meta :tag)]
16 (match-any x this acc)))
17 nil
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
18 (match-var [x this acc])
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
19 Symbol
503d66f Håkan Råberg Conso tests
authored
20 (match-var [x this acc]))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
21
22 (extend-protocol MatchAny
23 Object
24 (match-any [this x acc] (if (= this x) acc
25 (match-var x this acc)))
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
26 Symbol
27 (match-any [this x acc] (if (= this x) acc
28 (match-var x this acc)))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
29 nil
30 (match-any [this x acc] (if (nil? x) acc
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
31 (match-var x this acc))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
32
33 (deftype LVar [name]
34 MatchAny
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
35 (match-any [this x acc] (if (= this x) acc
36 (bind-vars x this acc)))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
37 MatchVar
38 (match-var [x this acc] (match-any x this acc))
2298200 Håkan Råberg More lvar/seq hacks
authored
39 MatchSeq
05b87f5 Håkan Råberg bind rest to () instead of nil if empty
authored
40 (match-seq [x this acc] (when ((every-pred sequential? seq) (acc x))
41 (match-any this (acc x) acc)))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
42 Object
7b6fb59 Håkan Råberg seq matching mess
authored
43 (hashCode [this] (if name (.hashCode name) 0))
4085d15 Håkan Råberg Lazy run
authored
44 (equals [this o] (and (instance? LVar o) (= (.name this) (.name ^LVar o)))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
45
46 (defmethod print-method LVar [o ^Writer w]
7b6fb59 Håkan Råberg seq matching mess
authored
47 (.write w (str (.name o))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
48
49 (defmacro alias-macro [m a]
50 `(doto (intern *ns* '~a (var ~m)) .setMacro))
51
52 (defn var? [x] (instance? LVar x))
53
2298200 Håkan Råberg More lvar/seq hacks
authored
54 (defn cons-pairs-to-seqs [x]
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
55 (if (and (sequential? x) (= 3 (count x)) (= '. (second x))
56 ((some-fn sequential? nil?) (last x)))
57 (cons (first x) (last x))
2298200 Håkan Råberg More lvar/seq hacks
authored
58 x))
59
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
60 (defmacro unify [u v s]
b6500d2 Håkan Råberg Simplify
authored
61 (let [[u v] (map #(prepare-matcher % &env) [u v])]
62 `(binding [*match-var?* var?]
63 (merge (match-any ~u ~v ~s) (match-any ~v ~u ~s)))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
64
65 (def ^:private subscripts '[₀ ₁ ₂ ₃ ₄ ₅ ₆ ₇ ₈ ₉])
66
67 (defn reify-name [n]
68 (symbol (apply str "" (map (comp subscripts int bigdec str) (str n)))))
69
70 (defn reify [v s]
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
71 (loop [v v s s check #{v}]
72 (let [v' (postwalk-replace s v)]
73 (debug v')
74 (if (contains? check v')
75 v'
76 (recur v' s (conj check v'))))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
77
78 (defmacro [u v]
4085d15 Håkan Råberg Lazy run
authored
79 `(fn ≡ [a#]
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
80 [(unify ~u ~v a#)]))
81 (alias-macro ≡ ==)
82
8c6b715 Håkan Råberg Diequality, lvar seq hack
authored
83 (defmacro [u v]
4085d15 Håkan Råberg Lazy run
authored
84 `(fn ≠ [a#]
3503b24 Håkan Råberg Slightly different, but not really correct disequality
authored
85 [(when-not (seq (select-keys (unify ~u ~v a#) (keys a#))) a#)]))
8c6b715 Håkan Råberg Diequality, lvar seq hack
authored
86 (alias-macro ≠ !=)
87
7b6fb59 Håkan Råberg seq matching mess
authored
88 (defn interleave-all [& colls]
4085d15 Håkan Råberg Lazy run
authored
89 (when-let [ss (seq (remove nil? (map seq colls)))]
90 (concat (map first ss) (lazy-seq (apply interleave-all (map rest ss))))))
7b6fb59 Håkan Råberg seq matching mess
authored
91
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
92 (defmacro condᵉ [& gs]
93 (let [a (gensym "a")]
8865666 Håkan Råberg Formatting
authored
94 `(fn condᵉ [~a]
95 (interleave-all ~@(map #(do `(run-internal ~(vec %) [~a])) gs)))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
96 (alias-macro condᵉ conde)
97
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
98 (defmacro fresh [[& x] & gs]
2298200 Håkan Råberg More lvar/seq hacks
authored
99 `(let [~@(mapcat (fn [x] `[~x (LVar. (gensym '~x))]) x)]
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
100 [~@gs]))
101
01dea51 Håkan Råberg Project
authored
102 (defmacro project [[& x] & gs]
103 (let [a (gensym "a")]
104 `(fn project [~a]
105 (let [~@(mapcat (fn [x] `[~x (~a ~x)]) x)]
106 (run-internal ~(vec gs) [~a])))))
107
4085d15 Håkan Råberg Lazy run
authored
108 (defn run-internal [gs s]
109 (lazy-seq
110 (let [[g & gs] (flatten gs)
96bc1b1 Håkan Råberg Simplify
authored
111 s (remove nil? s)]
112 (if-not g
113 s
52ee471 Håkan Råberg Minor refactoring
authored
114 (mapcat #(when-let [s (g %)]
115 (concat (run-internal gs [(first s)])
116 (run-internal gs (rest s)))) s)))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
117
cb73a9e Håkan Råberg mk tests, matchvar mess
authored
118 (defn reify-goal [xs s]
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
119 (let [xs (map #(reify % s) xs)
51fab65 Håkan Råberg The different definitions of what a var is in the matcher is a mess, but...
authored
120 vs (loop [[v & vs] (distinct (filter-walk var? xs))
121 acc {}]
122 (if-not v
123 acc
124 (recur vs (assoc acc v (or (acc (s v)) (reify-name (count acc)))))))]
2298200 Håkan Råberg More lvar/seq hacks
authored
125 (postwalk cons-pairs-to-seqs (postwalk-replace vs xs))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
126
127 (defmacro run* [[& x] & g]
2cb8204 Håkan Råberg Failing zebra test
authored
128 (let [g (postwalk-replace {'_ '(mimir.mk.LVar. (gensym '_))} g)]
129 `(binding [*match-var?* var?]
130 (run-internal (fresh [~@x] ~@g (partial reify-goal ~(vec x))) [{}]))))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
131
132 (defmacro run [n [& x] & g]
133 `(take ~n (run* [~@x] ~@g)))
134
135 (def succeed (≡ false false))
136 (def fail (≡ false true))
137
138 (defn consᵒ [a d l]
2298200 Håkan Råberg More lvar/seq hacks
authored
139 (if (var? l)
140 (let [d (if (var? d) ['. d] d)]
b0039d5 Håkan Råberg More tests, appendo, membero. Most commented out. Now - getting these to...
authored
141 (≡ (cons a d) l))
2298200 Håkan Råberg More lvar/seq hacks
authored
142 [(≡ a (first l))
143 (≡ d (rest l))]))
a5d98a3 Håkan Råberg A small miniKanren inspired thing that might be of use
authored
144
145 (defn firstᵒ [l a]
146 (fresh [d]
147 (consᵒ a d l)))
148
149 (defn restᵒ [l d]
150 (fresh [a]
151 (consᵒ a d l)))
152
2298200 Håkan Råberg More lvar/seq hacks
authored
153 (defn memberᵒ [x ls]
154 (fresh [a d]
155 (consᵒ a d ls)
4085d15 Håkan Råberg Lazy run
authored
156 (condᵉ
2298200 Håkan Råberg More lvar/seq hacks
authored
157 ((≡ a x))
158 ((memberᵒ x d)))))
8c6b715 Håkan Råberg Diequality, lvar seq hack
authored
159
160 (defn appendᵒ [l1 l2 o]
161 (condᵉ
162 ((≡ l1 ()) (≡ l2 o))
163 ((fresh [a d r]
2298200 Håkan Råberg More lvar/seq hacks
authored
164 (consᵒ a d l1)
165 (consᵒ a r o)
166 (appendᵒ d l2 r)))))
Something went wrong with that request. Please try again.