├── .gitignore ├── project.clj ├── README ├── src └── mini_kanren │ └── core.clj └── test └── mini_kanren └── test └── core.clj /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | *jar 3 | lib 4 | classes 5 | clojars 6 | .*.swp 7 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject net.intensivesystems/mini-kanren "1.0.0-SNAPSHOT" 2 | :description "FIXME: write" 3 | :dependencies [[org.clojure/clojure "1.2.0"] 4 | [org.clojure/clojure-contrib "1.2.0"]]) 5 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | # mini-kanren 2 | 3 | FIXME: write description 4 | 5 | ## Usage 6 | 7 | FIXME: write 8 | 9 | ## Installation 10 | 11 | FIXME: write 12 | 13 | ## License 14 | 15 | Copyright (C) 2010 FIXME 16 | 17 | Distributed under the Eclipse Public License, the same as Clojure. 18 | -------------------------------------------------------------------------------- /src/mini_kanren/core.clj: -------------------------------------------------------------------------------- 1 | ;; Mini-Kanren implemented in Clojure 2 | 3 | ;; by Jim Duey 4 | ;; last updated March 23, 2010 5 | 6 | ;; Copyright (c) Jim Duey, 2009, 2010. All rights reserved. The use 7 | ;; and distribution terms for this software are covered by the Eclipse 8 | ;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 9 | ;; which can be found in the file epl-v10.html at the root of this 10 | ;; distribution. By using this software in any fashion, you are 11 | ;; agreeing to be bound by the terms of this license. You must not 12 | ;; remove this notice, or any other, from this software. 13 | 14 | (ns mini-kanren.core 15 | (:use [clojure.contrib monads] 16 | [clojure.pprint :only [pprint]])) 17 | 18 | (comment 19 | This file is the result of implementing the logic programming system described 20 | in "The Reasoned Schemer", called mini-kanren, in Clojure. I was struggling 21 | to understand the material in the book without a concrete system to work with, 22 | so I decided to implement the system in the book to aid my understanding. 23 | 24 | "The Reasoned Schemere" is the third book in the "Little Schemer" series of books 25 | that explain the Scheme programming language and various aspects of programming 26 | in Scheme. "The Reasoned Schemer" extends Scheme to include logic programming like 27 | Prolog and the pattern maching in Erlang. The first six chapters introduce the 28 | syntax and semantics of this extension, which is what this file covers. 29 | 30 | I chose to pretty much lift the logic function names directly from the book to make 31 | learning the material easier. Though there are some differences which should be 32 | easily discerned by comparing the code to the book. 33 | 34 | There are two areas that required some work to implement this system in Clojure. 35 | 36 | First, in the book's implementation, logic variables are represented as vectors. 37 | I chose to represent logic variables as keywords, for reasons explained later. So, 38 | the following definition creates a logic variable. Each time an lvar is created, 39 | it is assigned a unique name using the gensym facility provided by Clojure.) 40 | 41 | ; a couple of special symbols 42 | 43 | (def _ '_) 44 | (def | '|) 45 | 46 | ; working with logic variables 47 | 48 | (defn lvar 49 | "Creating a unique logic variable that has no value assigned" 50 | [] 51 | (str (gensym (str "lvar__")))) 52 | 53 | (defn lvar? 54 | "Determine if a value is an logic variable or not." 55 | [x] 56 | (and (string? x) 57 | (.startsWith x "lvar"))) 58 | 59 | (comment 60 | The second area of work stems from the fact that Clojure does not use cons cells 61 | to hold elements of lists. The book made heavy use of this feature of Scheme and 62 | so a special version of cons had to be defined. Passing an item and a list caused 63 | the item to be added at the head of the list. Both of those cases were easy to 64 | account for. The third case is when the second parameter to cons is not a list, 65 | causing cons to create a dotted pair where the cdr of the cons cell is a value, not 66 | a pointer to the rest of the list. This aspect of cons is used heavily in the book 67 | to represent lists where the cdr may be undefined. Since this was a required feature, 68 | I chose to implement an incomplete list by adding a :tail item to the meta data of a 69 | literal list, if the second parameter to cons is an lvar. This worked very well. 70 | 71 | This also meant that a special version of 'next' had to be defined to handle incomplete lists.) 72 | 73 | (defn- is-seq? [l] 74 | (or (seq? l) 75 | (set? l) 76 | (vector? l))) 77 | 78 | (defn lcons [a b] 79 | "cons a value onto a logic seq" 80 | (cond 81 | (nil? b) (list a) 82 | (is-seq? b) (with-meta (cons a b) (meta b)) 83 | (lvar? b) (with-meta (list a) {:tail b}) 84 | :else (cons a b))) 85 | 86 | (defn- lseq? [l] 87 | "test if a value is logic sequence or not 88 | an empty sequence is not a valid logic sequence" 89 | (and (is-seq? l) 90 | (not (empty? l)))) 91 | 92 | (defn incomplete [l t] 93 | "make a logic sequence that is incomplete, the rest of the 94 | sequence is in the tail" 95 | (with-meta l {:tail t})) 96 | 97 | (defn- lnext [l] 98 | "get everything but the first element of a logic sequence" 99 | (let [nl (rest l)] 100 | (cond 101 | (= (first nl) |) (second nl) 102 | (and (empty? nl) (:tail (meta l))) (:tail (meta l)) 103 | (empty? nl) [] 104 | :else (with-meta nl (meta l))))) 105 | 106 | (comment 107 | Values are assigned to logic variables through a mechanism called substitution. In 108 | the book's implementation, this was accomplished through the use of an associative 109 | list, which is basically a list of cons cells where the car of the cell is the key 110 | and the cdr of the cell is the value. Clojure has the hash-map data type which is 111 | a natural replacement for an associative list. Using a hash-map to hold a substitution, 112 | the use of keywords for logic variables means that retrieval of a variable's value is 113 | simply a get operation on the map with that variable.) 114 | 115 | ; operations on substitutions 116 | 117 | ; this is what a substitution looks like, 'e is a value, :x and :y are 118 | ; logic variables: 119 | ; 120 | ; the keys in a substitution may only be keywords 121 | ; {:y 'e :x :y} 122 | ; 123 | ; the values in a substitution may be: 124 | ; a symbol 125 | ; a keyword (may or may not be a key in the substitution) 126 | ; a literal list 127 | 128 | (defn lget [s v] 129 | "Retrieve the value of a logic variable from a substitution" 130 | (cond 131 | (= _ v) (lvar) 132 | (contains? s v) (recur s (get s v)) 133 | (lvar? v) v 134 | (and (is-seq? v) (:tail (meta v))) (let [tail (lget s (:tail (meta v)))] 135 | (if (is-seq? tail) 136 | (with-meta (seq (concat v tail)) (meta tail)) 137 | (with-meta v {:tail tail}))) 138 | :else v)) 139 | 140 | (defn deep-lget [s v] 141 | "Walk a logic variable through a substitution. If the value 142 | of the variable is a list, get each item in the list. 143 | Repeat recursively until all atoms are either variables 144 | with no values or values." 145 | (let [v (lget s v)] 146 | (cond 147 | (lvar? v) v 148 | (lseq? v) (let [sq (if (:tail (meta v)) 149 | (concat (map (partial deep-lget s) v) 150 | [| (deep-lget s (:tail (meta v)))]) 151 | (map (partial deep-lget s) v))] 152 | (if (vector? v) 153 | (vec sq) 154 | sq)) 155 | :else v))) 156 | 157 | (defn deep-reify [s v] 158 | "Associate an indeterminate value with 'v' in 's' if 159 | it does not already have a value assigned to it. 160 | If the value of 'v' is a list, recursively associate 161 | values with each logic variable in the list." 162 | (let [v (lget s v)] 163 | (cond 164 | (lvar? v) (assoc s v (symbol (str "_." (count s)))) 165 | (lseq? v) (with-meta (reduce deep-reify s v) 166 | {:tail (:tail (meta v))}) 167 | :else s))) 168 | 169 | (defn mk-reify [v] 170 | "Assign an indeterminate value to 'v'" 171 | (deep-lget (deep-reify {} v) v)) 172 | 173 | (defn- circular? [s x v] 174 | "Tests if associating x with v in s will generate a 175 | circular association" 176 | (let [v (lget s v)] 177 | (cond 178 | (lvar? v) (identical? v x) 179 | (lseq? v) (some (partial circular? s x) v) 180 | :else nil))) 181 | 182 | (defn- _-to-lvar 183 | "Replace all the _'s in a value with lvars." 184 | [v] 185 | (cond 186 | (= _ v) (lvar) 187 | (is-seq? v) (if (contains? (meta v) :tail) 188 | (let [new-v (with-meta (map _-to-lvar v) (meta v))] 189 | (if (vector? v) 190 | (vec new-v) 191 | new-v)) 192 | (let [[sq tail] (split-with (partial not= |) v) 193 | new-v (map _-to-lvar sq) 194 | new-meta {:tail (_-to-lvar (second tail))}] 195 | (if (vector? v) 196 | (with-meta (vec new-v) new-meta) 197 | (with-meta new-v new-meta)))) 198 | :else v)) 199 | 200 | (defn- safe-assoc [x v s] 201 | "Associate x with v in s if it will not create 202 | a circular association" 203 | (cond 204 | (circular? s x v) nil 205 | :else (assoc s x (_-to-lvar v)))) 206 | 207 | (defn unify [v w s] 208 | "Add an association to a substitution if it is not already there, 209 | if it does not violate any associations already in the substitution 210 | and if it won't create a circular association" 211 | (let [v (lget s v) 212 | w (lget s w)] 213 | (cond 214 | (identical? v w) s 215 | (lvar? v) (safe-assoc v w s) 216 | (lvar? w) (safe-assoc w v s) 217 | (and (lseq? v) (lseq? w)) (when-let [new-s (unify (first v) (first w) s)] 218 | (recur (lnext v) (lnext w) new-s)) 219 | (= v w) s 220 | :else nil))) 221 | 222 | ; To unify means to add associations to a substitution according to the following rules: 223 | (comment 224 | (let [x (lvar) 225 | y (lvar) 226 | w (lvar) 227 | q (lvar)] 228 | (assert (= {x 'a} (unify x 'a {}))) 229 | (assert (= {x y} (unify x y {}))) 230 | (assert (= {x 'b y 'b} (unify x y {y 'b}))) 231 | (assert (= {x 'c y 'c} (unify x y {x 'c}))) 232 | (assert (= {x 'a y 'a} (unify x y {x 'a y 'a}))) 233 | (assert (= {x 'a y x} (unify x y {x 'a y x}))) 234 | (assert (= {q 1 w 9} (unify x x {q 1 w 9}))) 235 | (assert (= {q 1 w 9} (unify '(1 2 3) '(1 2 3) {q 1 w 9}))) 236 | (assert (= {x '(a b)} (unify x '(a b) {}))) 237 | (assert (= {x (list 'a y)} (unify x (list 'a y) {}))) 238 | (assert (= {x 'a y 'b} (unify (list x 'b) (list 'a y) {}))) 239 | (assert (= {x 'a y '(b c)} (unify (lcons x y) (list 'a 'b 'c) {}))) 240 | (assert (= {x 'b} (unify (list 'a x 'c) (list 'a 'b 'c) {}))) 241 | (assert (= nil (unify (lcons x y) () {q 1 w 9}))) 242 | )) 243 | 244 | ; The monad foundation for the implementation. It's basically a lazier 245 | ; variant of the sequence-m monad. 246 | 247 | (defmonad logic-m 248 | [m-result (fn [v] 249 | (list v)) 250 | m-bind (fn m-bind-sequence [mv f] 251 | (lazy-seq 252 | (when-let [vs (seq mv)] 253 | (lazy-cat (f (first vs)) 254 | (m-bind-sequence (rest vs) f))))) 255 | m-zero (list) 256 | m-plus (fn [mvs] 257 | (lazy-seq 258 | (apply concat mvs))) 259 | ]) 260 | 261 | ; A similar monad except that it's m-plus function interleaves the values 262 | ; from each of the monadic values. 263 | 264 | (defmonad logic-interleave-m 265 | [m-result (fn [v] 266 | (list v)) 267 | m-bind (fn m-bind-sequence [mv f] 268 | (lazy-seq 269 | (when-let [vs (seq mv)] 270 | (concat (f (first vs)) 271 | (m-bind-sequence (rest vs) f))))) 272 | m-zero (list) 273 | m-plus (fn m-plus-logic [mvs] 274 | (let [mvs (drop-while empty? mvs)] 275 | (when-not (empty? mvs) 276 | (lazy-seq 277 | (cons 278 | (ffirst mvs) 279 | (m-plus-logic (concat (rest mvs) 280 | (list (rest (first mvs)))))))))) 281 | ]) 282 | 283 | ; Clojure implementation of 'Reasoned Schemer' goals 284 | ; a goal is a function that accepts a substitution and 285 | ; returns a list of substitutions. They are monadic functions 286 | ; under the logic-m monad. 287 | 288 | ; The two foundational goals. A goal takes a stream of 289 | ; substitutions and returns a stream of substitutions. 290 | (defn fail [s] 291 | (list)) 292 | 293 | (defn succeed [s] 294 | (list s)) 295 | 296 | ; generates a goal that associates a logic variable 297 | ; with a value 298 | (defn & [v w] 299 | (fn [s] 300 | (if-let [result (unify v w s)] 301 | (list result) 302 | (list)))) 303 | 304 | ; &-expr generates a goal that associates a logic variable 305 | ; with the value produced by an expression. value-of is 306 | ; a function that can be used in expressions to get the 307 | ; current value of a logic variable. 308 | (def curr-subst) 309 | (defn value-of [x] 310 | (deep-lget curr-subst x)) 311 | 312 | (defmacro &-expr [v expr] 313 | "Associates a free variable with the result of evaluating 'expr'." 314 | `(fn [s#] 315 | (binding [curr-subst s#] 316 | (when-let [result# (unify ~v ~expr curr-subst)] 317 | (list result#))))) 318 | 319 | ; some utility functions to build the mini-kanren operators 320 | 321 | (defn- remove-else [clause-list] 322 | (map #(if (= 'else (first %)) 323 | (next %) 324 | %) 325 | clause-list)) 326 | 327 | (with-monad logic-m 328 | (defn do-question [& clause] 329 | (m-chain clause)) 330 | 331 | (defn test-question [& clause] 332 | (let [answer (m-chain (rest clause))] 333 | (fn [s] 334 | (let [tested ((first clause) s)] 335 | (when-not (= m-zero tested) 336 | (m-bind tested answer))))))) 337 | 338 | (defn- build-clauses [c-list] 339 | (map #(cons 'do-question %) 340 | (remove-else c-list))) 341 | 342 | (defn- build-questions [c-list] 343 | (map #(cons 'mini-kanren.core/test-question %) 344 | (remove-else c-list))) 345 | 346 | ; the mini-kanren operators 347 | 348 | (defmacro cond-e [& c-list] 349 | (let [clauses (build-clauses c-list)] 350 | `(with-monad logic-m 351 | (fn [s#] 352 | (~'m-plus (map (fn [c#] (c# s#)) 353 | (lazy-seq (list ~@clauses)))))))) 354 | 355 | (defmacro cond-i [& c-list] 356 | (let [clauses (build-clauses c-list)] 357 | `(with-monad logic-interleave-m 358 | (fn [s#] 359 | (~'m-plus (map (fn [c#] (c# s#)) 360 | (lazy-seq (list ~@clauses)))))))) 361 | 362 | (defmacro cond-a [& c-list] 363 | (let [questions (build-questions c-list)] 364 | `(with-monad logic-m 365 | (fn [s#] 366 | (first 367 | (drop-while nil? (map (fn [c#] (c# s#)) 368 | (lazy-seq (list ~@questions))))))))) 369 | 370 | (defmacro cond-u [& c-list] 371 | (let [questions (build-questions c-list)] 372 | `(with-monad logic-m 373 | (fn [s#] 374 | (take 1 375 | (~'m-plus (map (fn [c#] (c# s#)) 376 | (lazy-seq (list ~@questions))))))))) 377 | 378 | ; exist is used to create new logic variables that can then be bound to values 379 | (defmacro exist [v-list & goals] 380 | `(with-monad logic-m 381 | (let [~@(mapcat (fn [v] 382 | `(~v (lvar))) 383 | (seq v-list))] 384 | (m-chain (list ~@goals))))) 385 | 386 | (defn all [& args] 387 | (with-monad logic-m 388 | (m-chain args))) 389 | 390 | ; run computes the results of a mini-kanren expression 391 | (defmacro run [x & goals] 392 | `(with-monad logic-m 393 | (let [~x (lvar)] 394 | (map (fn [s#] 395 | (mk-reify (deep-lget s# ~x))) 396 | (filter (complement nil?) 397 | ((m-chain (list ~@goals)) {})))))) 398 | 399 | ; various logic programming functions from "Reasoned Schemer" 400 | 401 | (defn cons-o 402 | "Generates a goal that associates '(cons f r) with 'l'." 403 | [f r l] 404 | (cond 405 | (or (nil? r) (= r ())) (& (list f) l) 406 | (lvar? r) (& (lcons f r) l) 407 | (is-seq? r) (exist (new-r) 408 | (& new-r r) 409 | (& (lcons f new-r) l)) 410 | :else (& (lcons f (list r)) l))) 411 | 412 | (defn first-o 413 | "Generates a goal that associates 'f' with 414 | the first element of 'l'." 415 | [l f] 416 | (exist [r] 417 | (cons-o f r l))) 418 | 419 | (defn rest-o 420 | "Generates a goal that associates 'r' with 421 | the rest of 'l'." 422 | [l r] 423 | (fn [s-list] 424 | ((exist (f) 425 | (cons-o f r l)) 426 | s-list))) 427 | 428 | (defn null-o [x] 429 | (fn [s-list] 430 | ((& [] x) s-list))) 431 | 432 | (defn eq-o [x y] 433 | (& x y)) 434 | 435 | (defn pair-o [l] 436 | (if (= l []) 437 | fail 438 | (fn [s-list] 439 | ((exist (f r) 440 | (cons-o f r l)) s-list)))) 441 | 442 | (defn list-o [l] 443 | (cond-e 444 | ((null-o l) succeed) 445 | ((pair-o l) (exist (f r) 446 | (rest-o l r) 447 | (list-o r))) 448 | (else fail))) 449 | 450 | (defn map-o [m] 451 | (fn [s] 452 | (when (map? (deep-lget s m)) 453 | (list s)))) 454 | 455 | (defn vector-o [m] 456 | (fn [s] 457 | (when (vector? (deep-lget s m)) 458 | (list s)))) 459 | 460 | (defn lol-o [l] 461 | (cond-e 462 | ((null-o l) succeed) 463 | ((exist (a) 464 | (first-o l a) 465 | (list-o a)) 466 | (exist (d) 467 | (rest-o l d) 468 | (lol-o d))) 469 | (else fail))) 470 | 471 | (defn twins-o [s] 472 | (exist (x) 473 | (& (list x x) s))) 474 | 475 | (defn lot-o [l] 476 | (cond-e 477 | ((null-o l) succeed) 478 | ((exist (f) 479 | (first-o l f) 480 | (twins-o f)) 481 | (exist (r) 482 | (rest-o l r) 483 | (lot-o r))) 484 | (else fail))) 485 | 486 | (defn listof-o [pred-o l] 487 | (cond-e 488 | ((null-o l) succeed) 489 | ((exist (f) 490 | (first-o l f) 491 | (pred-o f)) 492 | (exist (r) 493 | (rest-o l r) 494 | (listof-o pred-o r))) 495 | (else fail))) 496 | 497 | (defn lot-o [l] 498 | (listof-o twins-o l)) 499 | 500 | (defn lol-o [l] 501 | (listof-o list-o l)) 502 | 503 | (defn member-o [x l] 504 | (exist [r] 505 | (cond-e 506 | ((& [x | _] l)) 507 | ((& [_ | r] l) (member-o x r))))) 508 | 509 | (defn pmember-o [x l] 510 | (cond-e 511 | ((first-o l x) (rest-o l ())) 512 | ((first-o l x) (exist (f r) 513 | (rest-o l (lcons f r)))) 514 | (else (exist (r) 515 | (rest-o l r) 516 | (pmember-o x r))))) 517 | 518 | (defn mem-o [x l out] 519 | (cond-e 520 | ((first-o l x) (& l out)) 521 | (else (exist (r) 522 | (rest-o l r) 523 | (mem-o x r out))))) 524 | 525 | (defn rember-o [x l out] 526 | (cond-e 527 | ((null-o l) (& () out)) 528 | ((first-o l x) (rest-o l out)) 529 | (else (exist (f r res) 530 | (cons-o f r l) 531 | (rember-o x r res) 532 | (cons-o f res out))))) 533 | 534 | (defn surprise-o [s] 535 | (rember-o s '(a b c) '(a b c))) 536 | 537 | (defn append-o [l s out] 538 | (cond-e 539 | ((null-o l) (& s out)) 540 | (else 541 | (exist (f r res) 542 | (cons-o f r l) 543 | (cons-o f res out) 544 | (append-o r s res))))) 545 | 546 | (defn unwrap-o [x out] 547 | (cond-e 548 | (succeed (& x out)) 549 | (else (pair-o x) (exist (f) 550 | (first-o x f) 551 | (unwrap-o f out))))) 552 | 553 | (defn flattenrev-o [s out] 554 | (cond-e 555 | (succeed (cons-o s () out)) 556 | ((null-o s) (& () out)) 557 | (else (exist (f r res-f res-r) 558 | (cons-o f r s) 559 | (flattenrev-o f res-f) 560 | (flattenrev-o r res-r) 561 | (append-o res-f res-r out))))) 562 | 563 | (defn any-o [g] 564 | (cond-e 565 | (g succeed) 566 | (else (any-o g)))) 567 | 568 | (def never-o 569 | (any-o fail)) 570 | 571 | (def always-o 572 | (any-o succeed)) 573 | 574 | (defn once-o [g] 575 | (cond-u 576 | (g succeed) 577 | (else fail))) 578 | 579 | (defn sal-o [g] 580 | (cond-e 581 | (succeed succeed) 582 | (else g))) 583 | 584 | (defn not-pasta-o [x] 585 | (cond-a 586 | ((& 'pasta x) fail) 587 | (else succeed))) 588 | -------------------------------------------------------------------------------- /test/mini_kanren/test/core.clj: -------------------------------------------------------------------------------- 1 | ;; Mini-Kanren implemented in Clojure 2 | 3 | ;; by Jim Duey 4 | ;; last updated March 23, 2010 5 | 6 | ;; Copyright (c) Jim Duey, 2009, 2010. All rights reserved. The use 7 | ;; and distribution terms for this software are covered by the Eclipse 8 | ;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 9 | ;; which can be found in the file epl-v10.html at the root of this 10 | ;; distribution. By using this software in any fashion, you are 11 | ;; agreeing to be bound by the terms of this license. You must not 12 | ;; remove this notice, or any other, from this software. 13 | 14 | (ns mini-kanren.test.core 15 | (:use mini-kanren.core :reload-all) 16 | (:use clojure.test)) 17 | 18 | ; questions from the book as unit tests 19 | 20 | (defmacro frame [frame-num value expr] 21 | `(deftest ~(symbol (format "frame-%s" frame-num)) 22 | (let [result# ~expr] 23 | (is (= ~value result#))))) 24 | 25 | (frame "1.10" [] 26 | (run q 27 | fail)) 28 | 29 | (frame 1.11 '(true) 30 | (run q 31 | (& true q))) 32 | 33 | (frame 1.12 [] 34 | (run q 35 | fail 36 | (& true q))) 37 | 38 | (frame 1.13 '(true) 39 | (run q 40 | succeed 41 | (& true q))) 42 | 43 | (frame 1.15 '(corn) 44 | (run q 45 | succeed 46 | (& 'corn q))) 47 | 48 | 49 | (frame 1.23 '(true) 50 | (run q 51 | (exist [x] 52 | (& true x) 53 | (& true q)))) 54 | 55 | (frame 1.26 '(true) 56 | (run q 57 | (exist (x) 58 | (& x true) 59 | (& true q)))) 60 | 61 | (frame 1.27 '(true) 62 | (run q 63 | (exist (x) 64 | (& x true) 65 | (& q true)))) 66 | 67 | (frame 1.29 '(_.0) 68 | (run q 69 | (let [x false] 70 | (exist (x) 71 | (& x true))))) 72 | 73 | (frame "1.30" '((_.0 _.1)) 74 | (run r 75 | (exist (x y) 76 | (& (lcons x (lcons y ())) r)))) 77 | 78 | (frame "1.30a" '((_.0 _.1)) 79 | (run r 80 | (exist (x y) 81 | (& [x y] r)))) 82 | 83 | (frame 1.32 '((_.0 _.1 _.0)) 84 | (run r 85 | (exist (x) 86 | (let [y x] 87 | (exist (x) 88 | (& (lcons y (lcons x (lcons y ()))) r)))))) 89 | 90 | (frame "1.32a" '((_.0 _.1 _.0)) 91 | (run r 92 | (exist (x) 93 | (let [y x] 94 | (exist (x) 95 | (& [y x y] r)))))) 96 | 97 | (frame 1.34 [] 98 | (run q 99 | (& true q) 100 | (& false q))) 101 | 102 | (frame 1.35 '(false) 103 | (run q 104 | (& false q) 105 | (& false q))) 106 | 107 | (frame 1.36 '(true) 108 | (run q 109 | (let [x q] 110 | (& true x)))) 111 | 112 | (frame 1.37 '(_.0) 113 | (run r 114 | (exist (x) 115 | (& r x)))) 116 | 117 | (frame 1.38 '(true) 118 | (run q 119 | (exist (x) 120 | (& true x) 121 | (& x q)))) 122 | 123 | (frame 1.39 '(true) 124 | (run q 125 | (exist (x) 126 | (& x q) 127 | (& true x)))) 128 | 129 | (frame 1.47 [:olive :oil] 130 | (run x 131 | (cond-e 132 | ((& x :olive) succeed) 133 | ((& x :oil) succeed) 134 | (else fail)))) 135 | 136 | (frame "1.50" '(olive _.0 oil) 137 | (run x 138 | (cond-e 139 | ((& x 'virgin) fail) 140 | ((& x 'olive) succeed) 141 | (succeed succeed) 142 | ((& x 'oil) succeed) 143 | (else fail)))) 144 | 145 | (frame 1.55 '((split pea soup) (navy bean soup)) 146 | (run r 147 | (exist (x y) 148 | (cond-e 149 | ((& x 'split) (& y 'pea)) 150 | ((& x 'navy) (& y 'bean)) 151 | (else fail)) 152 | (& (lcons x (lcons y (lcons 'soup ()))) r)))) 153 | 154 | (frame "1.55a" '((split pea soup) (navy bean soup)) 155 | (run r 156 | (exist (x y) 157 | (cond-e 158 | ((& x 'split) (& y 'pea)) 159 | ((& x 'navy) (& y 'bean)) 160 | (else fail)) 161 | (& [x y 'soup] r)))) 162 | 163 | ; frame 1.56 164 | (defn teacup-o [x] 165 | (cond-e 166 | ((& 'tea x) succeed) 167 | ((& 'cup x) succeed) 168 | (else fail))) 169 | 170 | (frame 1.56 '(tea cup) 171 | (run x 172 | (teacup-o x))) 173 | 174 | (frame 1.57 '((tea true) (cup true) (false true)) 175 | (run r 176 | (exist (x y) 177 | (cond-e 178 | ((teacup-o x) (& true y) succeed) 179 | ((& false x) (& true y)) 180 | (else fail)) 181 | (& (lcons x (lcons y ())) r)))) 182 | 183 | (frame "1.57a" '((tea true) (cup true) (false true)) 184 | (run r 185 | (exist (x y) 186 | (cond-e 187 | ((teacup-o x) (& true y) succeed) 188 | ((& false x) (& true y)) 189 | (else fail)) 190 | (& [x y] r)))) 191 | 192 | (frame 1.58 '((_.0 _.1) (_.0 _.1)) 193 | (run r 194 | (exist (x y z) 195 | (cond-e 196 | ((& y x) (exist (x) (& z x))) 197 | ((exist (x) (& y x)) (& z x)) 198 | (else fail)) 199 | (& (lcons y (lcons z ())) r)))) 200 | 201 | (frame "1.58a" '((_.0 _.1) (_.0 _.1)) 202 | (run r 203 | (exist (x y z) 204 | (cond-e 205 | ((& y x) (exist (x) (& z x))) 206 | ((exist (x) (& y x)) (& z x)) 207 | (else fail)) 208 | (& [y z] r)))) 209 | 210 | (frame 1.59 '((false _.0) (_.0 false)) 211 | (run r 212 | (exist (x y z) 213 | (cond-e 214 | ((& y x) (exist (x) (& z x))) 215 | ((exist (x) (& y x)) (& z x)) 216 | (else fail)) 217 | (& false x) 218 | (& (lcons y (lcons z ())) r)))) 219 | 220 | (frame 2.6 '(a) 221 | (run r 222 | (first-o '(a c o r n) r))) 223 | 224 | (frame "2.6a" [:a] 225 | (run r 226 | (first-o [:a :c :o :r :n] r))) 227 | 228 | (frame 2.8 '(pear) 229 | (run r 230 | (exist (x y) 231 | (first-o (list r y) x) 232 | (& 'pear x)))) 233 | 234 | (frame "2.8a" ['pear] 235 | (run r 236 | (exist (x y) 237 | (first-o [r y] x) 238 | (& 'pear x)))) 239 | 240 | (frame 2.15 '(c) 241 | (run r 242 | (exist (v) 243 | (rest-o '(a c o r n) v) 244 | (first-o v r)))) 245 | 246 | (frame "2.15a" ['c] 247 | (run r 248 | (exist (v) 249 | (rest-o ['a 'c 'o 'r 'n] v) 250 | (first-o v r)))) 251 | 252 | (frame "2.20" '(o) 253 | (run x 254 | (rest-o '(c o r n) (list x 'r 'n)))) 255 | 256 | (frame 2.21 '((a c o r n)) 257 | (run l 258 | (exist (x) 259 | (rest-o l '(c o r n)) 260 | (first-o l x) 261 | (& 'a x)))) 262 | 263 | (frame 2.22 '(((a b c) d e)) 264 | (run l 265 | (cons-o '(a b c) '(d e) l))) 266 | 267 | (frame 2.23 '(d) 268 | (run x 269 | (cons-o x '(a b c) '(d a b c)))) 270 | 271 | (frame 2.24 '((e a d c)) 272 | (run r 273 | (exist (x y z) 274 | (& (list 'e 'a 'd x) r) 275 | (cons-o y (list 'a z 'c) r)))) 276 | 277 | (frame 2.25 '(d) 278 | (run x 279 | (cons-o x (list 'a x 'c) (list 'd 'a x 'c)))) 280 | 281 | (frame 2.26 '((d a d c)) 282 | (run l 283 | (exist (x) 284 | (& (list 'd 'a x 'c) l) 285 | (cons-o x (list 'a x 'c) l)))) 286 | 287 | (frame 2.27 '((d a d c)) 288 | (run l 289 | (exist (x) 290 | (cons-o x (list 'a x 'c) l) 291 | (& (list 'd 'a x 'c) l)))) 292 | 293 | (frame 2.29 '((b e a n s)) 294 | (run l 295 | (exist (d x y w s) 296 | (cons-o w '(a n s) s) 297 | (rest-o l s) 298 | (first-o l x) 299 | (& 'b x) 300 | (rest-o l d) 301 | (first-o d y) 302 | (& 'e y)))) 303 | 304 | (frame 2.32 [] 305 | (run q 306 | (null-o '(grape raisin pear)) 307 | (& true q))) 308 | 309 | (frame 2.33 '(true) 310 | (run q 311 | (null-o ()) 312 | (& true q))) 313 | 314 | (frame 2.34 '(()) 315 | (run x 316 | (null-o x))) 317 | 318 | (frame 2.38 [] 319 | (run q 320 | (eq-o 'pear 'plum) 321 | (& true q))) 322 | 323 | (frame 2.39 '(true) 324 | (run q 325 | (eq-o 'plum 'plum) 326 | (& true q))) 327 | 328 | (frame 2.54 '(true) 329 | (run q 330 | (pair-o (list q q)) 331 | (& true q))) 332 | 333 | (frame 2.55 [] 334 | (run q 335 | (pair-o ()) 336 | (& true q))) 337 | 338 | (frame 2.56 [] 339 | (run q 340 | (pair-o 'pair) 341 | (& true q))) 342 | 343 | (frame 2.57 '[_.0 | _.1] 344 | (first (run x 345 | (pair-o x)))) 346 | 347 | (frame 2.58 '(_.0) 348 | (run r 349 | (pair-o (list r 'pear)))) 350 | 351 | (frame "3.10" '(()) 352 | (take 1 353 | (run x 354 | (list-o ['a 'b 'c | x])))) 355 | 356 | (frame 3.14 '(() (_.0) (_.0 _.1) (_.0 _.1 _.2) (_.0 _.1 _.2 _.3)) 357 | (take 5 358 | (run x 359 | (list-o ['a 'b 'c | x])))) 360 | 361 | (frame 3.21 '(true) 362 | (run q 363 | (exist (x y) 364 | (lol-o (list '(a b) (list x 'c) (list 'd y))) 365 | (& true q)))) 366 | 367 | (frame 3.23 '(()) 368 | (take 1 369 | (run x 370 | (lol-o [['a 'b] ['c 'd] | x])))) 371 | 372 | (frame 3.24 '(() (()) (()()) (()()()) (()()()())) 373 | (take 5 374 | (run x 375 | (lol-o [['a 'b] ['c 'd] | x])))) 376 | 377 | (frame 3.32 '(true) 378 | (run q 379 | (twins-o '(tofu tofu)) 380 | (& true q))) 381 | 382 | (frame 3.33 '(tofu) 383 | (run z 384 | (twins-o (list z 'tofu)))) 385 | 386 | (frame "" '(thing-1) 387 | (run t 388 | (lot-o (list (list 'thing-1 t) '(thing-2 thing-2))))) 389 | 390 | (frame "" '(thing-1) 391 | (run t 392 | (exist (u) 393 | (lot-o (list (list 'thing-1 t) (list u 'thing-2)))))) 394 | 395 | (frame 3.42 '(() 396 | ((_.0 _.0)) 397 | ((_.0 _.0) (_.1 _.1)) 398 | ((_.0 _.0) (_.1 _.1) (_.2 _.2)) 399 | ((_.0 _.0) (_.1 _.1) (_.2 _.2) (_.3 _.3))) 400 | (take 5 401 | (run z 402 | (lot-o [['g 'g] | z])))) 403 | 404 | (frame 3.45 '((e (_.0 _.0) ()) 405 | (e (_.0 _.0) ((_.1 _.1))) 406 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2))) 407 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2) (_.3 _.3))) 408 | (e (_.0 _.0) ((_.1 _.1) (_.2 _.2) (_.3 _.3) (_.4 _.4)))) 409 | (take 5 410 | (run r 411 | (exist (w x y z) 412 | (lot-o (incomplete (list '(g g) (list 'e w) (list x y)) z)) 413 | (& (list w (list x y) z) r))))) 414 | 415 | (frame 3.47 '(((g g) (e e) (_.0 _.0)) 416 | ((g g) (e e) (_.0 _.0) (_.1 _.1)) 417 | ((g g) (e e) (_.0 _.0) (_.1 _.1) (_.2 _.2))) 418 | (take 3 419 | (run out 420 | (exist (w x y z) 421 | (& (incomplete (list '(g g) (list 'e w) (list x y)) z) out) 422 | (lot-o out))))) 423 | 424 | (frame 3.57 '(true) 425 | (run q 426 | (member-o 'olive '(virgin olive oil)) 427 | (& true q))) 428 | 429 | (frame 3.58 '(hummus) 430 | (take 1 431 | (run y 432 | (member-o y '(hummus with pita))))) 433 | 434 | (frame 3.62 '(hummus with pita) 435 | (run y 436 | (member-o y '(hummus with pita)))) 437 | 438 | (frame 3.66 '(e) 439 | (run x 440 | (member-o 'e (list 'pasta x 'fagioli)))) 441 | 442 | (frame 3.71 '((e _.0) (_.0 e)) 443 | (run r 444 | (exist (x y) 445 | (member-o 'e (list 'pasta x 'fagioli y)) 446 | (& (list x y) r)))) 447 | 448 | (frame 3.73 '[tofu | _.0] 449 | (first (run l 450 | (member-o 'tofu l)))) 451 | 452 | 453 | (frame 3.76 '((tofu | _.0) 454 | (_.0 tofu | _.1) 455 | (_.0 _.1 tofu | _.2) 456 | (_.0 _.1 _.2 tofu | _.3) 457 | (_.0 _.1 _.2 _.3 tofu | _.4)) 458 | (take 5 459 | (run l 460 | (member-o 'tofu l)))) 461 | 462 | (frame 3.88 '(true true) 463 | (run q 464 | (pmember-o 'tofu '(a b tofu d tofu)) 465 | (& true q))) 466 | 467 | (frame "4.10" '((tofu d tofu e)) 468 | (take 1 469 | (run out 470 | (mem-o 'tofu '(a b tofu d tofu e) out)))) 471 | 472 | (frame 4.11 '((tofu d tofu e)) 473 | (take 1 474 | (run out 475 | (exist (x) 476 | (mem-o 'tofu (list 'a 'b x 'd 'tofu 'e) out))))) 477 | 478 | (frame 4.12 '(tofu) 479 | (run r 480 | (mem-o r 481 | '(a b tofu d tofu e) 482 | '(tofu d tofu e)))) 483 | 484 | (frame 4.15 '(tofu) 485 | (run x 486 | (mem-o 'tofu 487 | '(tofu e) 488 | (list x 'e)))) 489 | 490 | (frame 4.16 [] 491 | (run x 492 | (mem-o 'tofu 493 | '(tofu e) 494 | (list 'peas x)))) 495 | 496 | (frame 4.17 '((tofu d tofu e) (tofu e)) 497 | (run out 498 | (exist (x) 499 | (mem-o 'tofu (list 'a 'b x 'd 'tofu 'e) out)))) 500 | 501 | (frame 4.18 '(_.0 502 | _.0 503 | (tofu | _.0) 504 | (_.0 tofu | _.1) 505 | (_.0 _.1 tofu | _.2) 506 | (_.0 _.1 _.2 tofu | _.3) 507 | (_.0 _.1 _.2 _.3 tofu | _.4)) 508 | (take 7 509 | (run z 510 | (exist (u) 511 | (mem-o 'tofu (incomplete '(a b tofu d tofu e) z) u))))) 512 | 513 | (frame "4.30" '((a b d peas e)) 514 | (take 1 515 | (run out 516 | (exist (y) 517 | (rember-o 'peas (list 'a 'b y 'd 'peas 'e) out))))) 518 | 519 | (frame 4.31 '((b a d _.0 e) 520 | (a b d _.0 e) 521 | (a b d _.0 e) 522 | (a b d _.0 e) 523 | (a b _.0 d e) 524 | (a b e d _.0) 525 | (a b _.0 d _.1 e)) 526 | (run out 527 | (exist (y z) 528 | (rember-o y (list 'a 'b y 'd z 'e) out)))) 529 | 530 | (frame 4.49 '((d d) (d d) (_.0 _.0) (e e)) 531 | (run r 532 | (exist (y z) 533 | (rember-o y (list y 'd z 'e) (list y 'd 'e)) 534 | (& (list y z) r)))) 535 | 536 | (frame 4.57 '(_.0 537 | _.0 538 | _.0 539 | _.0 540 | _.0 541 | () 542 | (_.0 | _.1) 543 | (_.0) 544 | (_.0 _.1 | _.2) 545 | (_.0 _.1) 546 | (_.0 _.1 _.2 | _.3) 547 | (_.0 _.1 _.2) 548 | (_.0 _.1 _.2 _.3 | _.4)) 549 | (take 13 550 | (run w 551 | (exist (y z out) 552 | (rember-o y (incomplete (list 'a 'b y 'd z) w) out))))) 553 | 554 | (frame 4.69 '(d) 555 | (run r 556 | (& 'd r) 557 | (surprise-o r))) 558 | 559 | (frame "4.70" '(_.0) 560 | (run r 561 | (surprise-o r))) 562 | 563 | (frame 4.71 '(b) 564 | (run r 565 | (& r 'b) 566 | (surprise-o r))) 567 | 568 | (frame "5.10" '((cake tastes yummy)) 569 | (run x 570 | (append-o '(cake) '(tastes yummy) x))) 571 | 572 | (frame 5.11 '((cake with ice _.0 tastes yummy)) 573 | (run x 574 | (exist (y) 575 | (append-o (list 'cake 'with 'ice y) 576 | '(tastes yummy) 577 | x)))) 578 | 579 | (frame 5.12 '(cake with ice cream | _.0) 580 | (first (run x 581 | (exist (y) 582 | (append-o '(cake with ice cream) y x))))) 583 | 584 | (frame 5.13 '((cake with ice d t)) 585 | (take 1 586 | (run x 587 | (exist (y) 588 | (append-o (incomplete '(cake with ice) y) '(d t) x))))) 589 | 590 | (frame 5.26 '((() (cake with ice d t)) 591 | ((cake) (with ice d t)) 592 | ((cake with) (ice d t)) 593 | ((cake with ice) (d t)) 594 | ((cake with ice d) (t)) 595 | ((cake with ice d t) ())) 596 | (take 6 597 | (run r 598 | (exist (x y) 599 | (append-o x y '(cake with ice d t)) 600 | (& (list x y) r))))) 601 | 602 | (frame 5.33 '(() 603 | (_.0) 604 | (_.0 _.1) 605 | (_.0 _.1 _.2) 606 | (_.0 _.1 _.2 _.3) 607 | (_.0 _.1 _.2 _.3 _.4) 608 | (_.0 _.1 _.2 _.3 _.4 _.5)) 609 | (take 7 610 | (run x 611 | (exist (y z) 612 | (append-o x y z))))) 613 | 614 | (frame 5.34 '(_.0 _.0 _.0 _.0 _.0 _.0 _.0) 615 | (take 7 616 | (run y 617 | (exist (x z) 618 | (append-o x y z))))) 619 | 620 | (frame 5.46 '((((pizza))) 621 | ((pizza)) 622 | (pizza) 623 | pizza) 624 | (run x 625 | (unwrap-o '(((pizza))) x))) 626 | 627 | (frame 5.75 '((((a b) c)) 628 | ((a b) (c)) 629 | ((a b) c ()) 630 | ((a b) c) 631 | (a (b) (c)) 632 | (a (b) c ()) 633 | (a (b) c) 634 | (a b () (c)) 635 | (a b () c ()) 636 | (a b () c) 637 | (a b (c)) 638 | (a b c ()) 639 | (a b c)) 640 | (run x 641 | (flattenrev-o '((a b) c) x))) 642 | 643 | (frame 5.80 574 644 | (count 645 | (run x 646 | (flattenrev-o '((((a (((b))) c))) d) x)))) 647 | 648 | (frame "6.10" '(true true true true true) 649 | (take 5 650 | (run q 651 | always-o 652 | (& true q)))) 653 | 654 | (frame 6.19 '(true) 655 | (take 1 656 | (run q 657 | (cond-i 658 | ((& false q) ) 659 | (else (& true q))) 660 | (& true q)))) 661 | 662 | (frame "6.20" '(true true true true true) 663 | (take 5 664 | (run q 665 | (cond-i 666 | ((& false q) ) 667 | (else (any-o (& true q)))) 668 | (& true q)))) 669 | 670 | (frame 6.24 '(tea false cup) 671 | (take 5 672 | (run r 673 | (cond-i 674 | ((teacup-o r) succeed) 675 | ((& false r) succeed) 676 | (else fail))))) 677 | 678 | (frame 10.5 '(olive) 679 | (run x 680 | (cond-a 681 | ((& 'olive x) succeed) 682 | ((& 'oil x) succeed) 683 | (else fail)))) 684 | 685 | (frame 10.7 [] 686 | (run x 687 | (cond-a 688 | ((& 'virgin x) fail) 689 | ((& 'olive x) succeed) 690 | ((& 'oil x) succeed) 691 | (else fail)))) 692 | 693 | (frame 10.8 [] 694 | (run q 695 | (exist [x y] 696 | (& 'split x) 697 | (& 'pea y) 698 | (cond-a 699 | ((& 'split x) (& x y)) 700 | (else succeed))) 701 | (& true q))) 702 | 703 | (frame 10.9 '(true) 704 | (run q 705 | (exist [x y] 706 | (& 'split x) 707 | (& 'pea y) 708 | (cond-a 709 | ((& x y) (& 'split x)) 710 | (else succeed))) 711 | (& true q))) 712 | 713 | (frame 10.11 '(spaghetti) 714 | (run x 715 | (cond-a 716 | ((not-pasta-o x) fail) 717 | (else (& 'spaghetti x))))) 718 | 719 | (frame 10.12 [] 720 | (run x 721 | (& 'spaghetti x) 722 | (cond-a 723 | ((not-pasta-o x) fail) 724 | (else (& 'spaghetti x))))) 725 | 726 | (frame 10.14 '(true) 727 | (run q 728 | (cond-u 729 | (always-o succeed) 730 | (else fail)) 731 | (& true q))) 732 | 733 | (frame 10.18 [] 734 | (take 1 735 | (run q 736 | (cond-u 737 | (always-o succeed) 738 | (else fail)) 739 | fail 740 | (& true q)))) 741 | 742 | (frame 10.19 '(tea) 743 | (run x 744 | (once-o (teacup-o x)))) 745 | 746 | (frame "10.20" [] 747 | (run q 748 | (once-o (sal-o never-o)) 749 | fail)) 750 | 751 | (frame 10.24 '(false) 752 | (run r 753 | (& false r) 754 | (cond-u 755 | ((teacup-o r) succeed) 756 | ((& false r) succeed) 757 | (else fail)))) 758 | 759 | ; solve the 'zebra' problem 760 | (defn- on-right [x y l] 761 | (exist [fst rst scnd] 762 | (& [fst scnd | _] l) 763 | (cond-e 764 | ((& fst x) (& scnd y)) 765 | ((rest-o l rst) (on-right x y rst))))) 766 | 767 | (defn- next-to [x y l] 768 | (cond-e 769 | ((on-right x y l)) 770 | ((on-right y x l)))) 771 | 772 | (defn- zebra [h] 773 | (all 774 | (& [_ _ [_ _ :milk _ _] _ _] h) 775 | (first-o h [:norwegian _ _ _ _]) 776 | (next-to [:norwegian _ _ _ _] [_ _ _ _ :blue] h) 777 | (on-right [_ _ _ _ :ivory] [_ _ _ _ :green] h) 778 | (member-o [:englishman _ _ _ :red] h) 779 | (member-o [_ :kools _ _ :yellow] h) 780 | (member-o [:spaniard _ _ :dog _] h) 781 | (member-o [_ _ :coffee _ :green] h) 782 | (member-o [:ukrainian _ :tea _ _] h) 783 | (member-o [_ :luckystrikes :oj _ _] h) 784 | (member-o [:japanese :parliaments _ _ _] h) 785 | (member-o [_ :oldgolds _ :snails _] h) 786 | (next-to [_ _ _ :horse _] [_ :kools _ _ _] h) 787 | (next-to [_ _ _ :fox _] [_ :chesterfields _ _ _] h))) 788 | 789 | (deftest test-zebra 790 | (is (= '[[[:norwegian :kools _.0 :fox :yellow] 791 | [:ukrainian :chesterfields :tea :horse :blue] 792 | [:englishman :oldgolds :milk :snails :red] 793 | [:spaniard :luckystrikes :oj :dog :ivory] 794 | [:japanese :parliaments :coffee _.1 :green]]] 795 | (run q 796 | (zebra q))))) 797 | 798 | --------------------------------------------------------------------------------