├── LICENSE ├── README.md ├── microKanren-load.shen ├── microKanren.shen └── miniKanren-macros.shen /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Jason Hemann 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # microKanren-shen 2 | An implementation of microKanren in Shen 3 | 4 | -------------------------------------------------------------------------------- /microKanren-load.shen: -------------------------------------------------------------------------------- 1 | (load "miniKanren-macros.shen") 2 | (load "microKanren.shen") -------------------------------------------------------------------------------- /microKanren.shen: -------------------------------------------------------------------------------- 1 | \\ microKanren.shen 2 | \\ Jason Hemann and Dan Friedman 3 | 4 | \* 5 | * Shen doesn't have Scheme's truthiness, so instead in walk and ==, we 6 | ask (cons? ) or (not (= false )) in the question of an if. 7 | * We couldn't see how to write thunks, so we use freeze and thaw. 8 | * We couldn't find frozen?, closure? or procedure?, so we re-ordered 9 | cases lines in sappend and sappend-map. 10 | * We had to call 'unify' 'unifyy' to avoid colliding with the primitive. 11 | * We also didn't port the relational numbers suite; that wants doing. 12 | *\ 13 | 14 | (defun var (N) N) 15 | (defun var? (X) (number? X)) 16 | 17 | (var 4) 18 | (var? (var 4)) 19 | 20 | (defun ext-s (X V S) [[X | V] | S]) 21 | (ext-s 3 4 (ext-s 2 3 [])) 22 | 23 | (defun assv (X S) 24 | (if (= [] S) 25 | false 26 | (let A (head S) 27 | (if (= (head A) X) A (assv X (tail S)))))) 28 | 29 | (assv cat [[horse | turtle] [cat | dog]]) 30 | 31 | (defun walk (U S) 32 | (let PR (if (var? U) (assv U S) false) 33 | (if (cons? PR) (walk (tail PR) S) U))) 34 | 35 | (walk 2 (ext-s 3 4 (ext-s 2 3 []))) 36 | 37 | (defun unifyy (U V S) 38 | (let U (walk U S) 39 | (let V (walk V S) 40 | (cases 41 | (= U V) S 42 | (var? U) (ext-s U V S) 43 | (var? V) (ext-s V U S) 44 | (and (cons? U) (cons? V)) (let S1 (unifyy (head U) (head V) S) 45 | (if (not (= S1 false)) (unifyy (tail U) (tail V) S1) false)) 46 | true false)))) 47 | 48 | (unifyy [cat | 0] [1 | horse] []) 49 | 50 | (defun == (U V) 51 | (lambda S/C 52 | (let S (unifyy U V (head S/C)) 53 | (if (not (= S false)) [[S | (tail S/C)]] [])))) 54 | 55 | (defun call/empty-state (G) (G [[] | 0])) 56 | 57 | (call/empty-state (== [cat | horse] [cat | horse])) 58 | 59 | (defun call/fresh (F) 60 | (lambda S/C 61 | (let C (tail S/C) 62 | ((F (var C)) [(head S/C) | (+ 1 C)])))) 63 | 64 | (call/empty-state 65 | (call/fresh 66 | (lambda X 67 | (call/fresh 68 | (lambda Y 69 | (lambda S/C 70 | ((== X cat) S/C))))))) 71 | 72 | (call/empty-state 73 | (call/fresh 74 | (lambda X 75 | (call/fresh 76 | (lambda Y 77 | (lambda S/C 78 | ((== [cat | X] [Y | dog]) S/C))))))) 79 | 80 | (defun disj (G1 G2) (lambda S/C (sappend (G1 S/C) (G2 S/C)))) 81 | 82 | (defun sappend (S1 S2) 83 | (cases 84 | (= S1 []) S2 85 | (cons? S1) [(head S1) | (sappend (tail S1) S2)] 86 | true (freeze (sappend S2 (thaw S1))))) 87 | 88 | (freeze (sappend (thaw S1) S2)) 89 | 90 | (call/empty-state 91 | (call/fresh 92 | (lambda X 93 | (call/fresh 94 | (lambda Y 95 | (disj (== [X | cat] [dog | Y]) (== [X | horse] [turtle | Y]))))))) 96 | 97 | (defun conj (G1 G2) (lambda S/C (sappend-map G2 (G1 S/C)))) 98 | 99 | (defun sappend-map (G S) 100 | (cases 101 | (= S []) [] 102 | (cons? S) (sappend (G (head S)) (sappend-map G (tail S))) 103 | true (freeze (sappend-map G (thaw S))))) 104 | 105 | (call/empty-state 106 | (call/fresh 107 | (lambda X 108 | (call/fresh 109 | (lambda Y 110 | (conj (== X cat) (== Y dog))))))) 111 | 112 | (defun hot-dogs (MEAL) 113 | (disj 114 | (== dog MEAL) 115 | (call/fresh 116 | (lambda RES 117 | (conj 118 | (== [hot | RES] MEAL) 119 | (lambda S/C 120 | (freeze ((hot-dogs RES) S/C)))))))) 121 | 122 | (call/empty-state 123 | (call/fresh hot-dogs)) 124 | 125 | (thaw 126 | (tail 127 | (call/empty-state 128 | (call/fresh hot-dogs)))) 129 | 130 | (thaw 131 | (tail 132 | (thaw 133 | (tail 134 | (call/empty-state 135 | (call/fresh hot-dogs)))))) 136 | 137 | (defun appendo (L S O) 138 | (disj 139 | (conj (== L []) (== S O)) 140 | (call/fresh 141 | (lambda A 142 | (call/fresh 143 | (lambda D 144 | (conj 145 | (== [A | D] L) 146 | (call/fresh 147 | (lambda RES 148 | (conj 149 | (== [A | RES] O) 150 | (lambda S/C 151 | (freeze ((appendo D S RES) S/C))))))))))))) 152 | 153 | (thaw 154 | (call/empty-state 155 | (call/fresh 156 | (lambda Q 157 | (appendo [a] [] Q))))) 158 | 159 | (defun pull (S) 160 | (if (or (= S []) (cons? S)) S (pull (thaw S)))) 161 | 162 | (pull 163 | (call/empty-state 164 | (call/fresh 165 | (lambda Q 166 | (appendo Q [d e f] [c a t]))))) 167 | 168 | (pull 169 | (call/empty-state 170 | (call/fresh 171 | (lambda Q 172 | (appendo [d e f] Q [c a t]))))) 173 | 174 | (defun take (N S) 175 | (if (= 0 N) 176 | [] 177 | (let S (pull S) 178 | (if (= S []) 179 | [] 180 | [(head S) | (take (- N 1) (tail S))])))) 181 | 182 | (take 3 (call/empty-state 183 | (call/fresh 184 | (lambda Q 185 | (call/fresh 186 | (lambda O 187 | (appendo Q [D E F] O))))))) 188 | 189 | (defun walk* (U S) 190 | (let U (walk U S) 191 | (cases 192 | (var? U) U 193 | (cons? U) [(walk* (head U) S) | (walk* (tail U) S)] 194 | true U))) 195 | 196 | (defun rename-S (V S) 197 | (let V (walk V S) 198 | (cases 199 | (var? V) (let V1 (rename-V S) 200 | [[V | V1] | S]) 201 | (cons? V) (rename-S (tail V) (rename-S (head V) S)) 202 | true S))) 203 | 204 | (defun rename-V (S) 205 | (concat _. (length S))) 206 | 207 | (defun reify-var0 (S/C) 208 | (let V (walk* (var 0) (head S/C)) 209 | (walk* V (rename-S V [])))) 210 | 211 | (defun mK-reify (L) 212 | (map reify-var0 L)) 213 | 214 | (mK-reify 215 | (take 3 (call/empty-state 216 | (call/fresh 217 | (lambda Q 218 | (call/fresh 219 | (lambda O 220 | (appendo Q [D E F] O)))))))) 221 | 222 | \* Macros adopted from the recent extempore port, and from @deech's 223 | vending machine thingy, and from vasil-sd on github's macros.shen *\ 224 | 225 | 226 | (defun bug (MSG X) 227 | ((lambda Y X) 228 | (print (cn MSG (make-string " ~A" X))))) 229 | 230 | (defun appendo (L S O) 231 | (conde 232 | ((== L []) (== S O)) 233 | ((fresh (A D) 234 | (== [A | D] L) 235 | (fresh (RES) 236 | (== [A | RES] O) 237 | (appendo D S RES)))))) 238 | 239 | (run 3 (Q) (fresh (L OUT) (== Q [L OUT]) (appendo L [d e f] OUT))) 240 | 241 | (defun call/project (X F) 242 | (lambda S/C 243 | ((F (walk* X (head S/C))) S/C))) 244 | 245 | (defun ifte (G0 G1 G2) 246 | (lambda S/C 247 | (ifte-help S/C (G0 S/C) G1 G2))) 248 | 249 | (defun ifte-help (S/C S G1 G2) 250 | (cases 251 | (= S []) (G2 S/C) 252 | (cons? S) (sappend-map G1 S/C) 253 | true (freeze (ifte-help S/C (thaw S) G1 G2)))) 254 | 255 | (defun once (G0) 256 | (lambda S/C 257 | (once-help (G0 S/C)))) 258 | 259 | (defun once-help (S) 260 | (cases 261 | (= S []) [] 262 | (cons? S) [(head S)] 263 | true (freeze (once-help (thaw S))))) 264 | 265 | (run 3 (Q) (fresh (L O) (== Q [L O]) (once (appendo L [d e f] O)))) 266 | 267 | \\ Still need to do impure macros 268 | -------------------------------------------------------------------------------- /miniKanren-macros.shen: -------------------------------------------------------------------------------- 1 | (defmacro inverse-eta-delay-macro 2 | [inverse-eta-delay G] -> (let TEMP (intern (str (gensym s/c))) 3 | [lambda TEMP [freeze [G TEMP]]])) 4 | 5 | (defmacro disj-macro 6 | [disj G] -> G 7 | [disj G0 G1 G2 | G*] -> [disj G0 [disj G1 G2 | G*]]) 8 | 9 | (defmacro conj-macro 10 | [conj G] -> G 11 | [conj G0 G1 G2 | G*] -> [conj G0 [conj G1 G2 | G*]]) 12 | 13 | (defmacro conde-macro 14 | [conde | CL*] -> [inverse-eta-delay [disj | (map (lambda CL (cons conj CL)) CL*)]]) 15 | 16 | (defmacro fresh-macro 17 | [fresh [] | G*] -> [conj | G*] 18 | [fresh [X | X*] | G* ] -> [call/fresh [lambda X [fresh X* | G*]]]) 19 | 20 | (defmacro run-macro 21 | [run N [Q] | G*] -> [mK-reify [take N [call/empty-state [fresh [Q] | G*]]]]) 22 | 23 | --------------------------------------------------------------------------------