├── doc └── intro.md ├── test └── clr │ └── core │ └── logic │ └── core_test.clj ├── .gitignore ├── deps.edn ├── CONTRIBUTING.md ├── src ├── main │ ├── dotnet │ │ └── packager │ │ │ ├── clojure.core.logic.csproj │ │ │ └── clojure.core.logic.sln │ └── clojure │ │ └── clojure │ │ └── core │ │ └── logic │ │ ├── arithmetic.clj │ │ ├── pldb.clj │ │ ├── unifier.clj │ │ ├── protocols.clj │ │ ├── dcg.clj │ │ ├── nominal.clj │ │ ├── bench.clj │ │ └── fd.clj └── test │ └── clojure │ └── clojure │ └── core │ └── logic │ ├── pldb │ └── tests.clj │ └── nominal │ └── tests.clj ├── README.md └── project.clj /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to clr.core.logic 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /test/clr/core/logic/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns clr.core.logic.core-test 2 | (:use clojure.test 3 | clr.core.logic.core)) 4 | 5 | (deftest a-test 6 | (testing "FIXME, I fail." 7 | (is (= 0 1)))) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | *.dll 9 | *.pdb 10 | *.exe 11 | .lein-deps-sum 12 | .lein-failures 13 | .lein-plugins 14 | 15 | .cpcache 16 | 17 | #Visual Studio artifacts 18 | bin/ 19 | obj/ 20 | .vs/ 21 | *.user 22 | *.suo 23 | *.nupkg -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:deps {} 2 | :paths ["src/main/clojure"] 3 | 4 | :aliases 5 | {:test 6 | {:extra-paths ["src/test/clojure"] 7 | :extra-deps {io.github.dmiller/test-runner {:git/sha "c055ea13d19c6a9b9632aa2370fcc2215c8043c3"}} 8 | ;; :main-opts {"-m" "cognitect.test-runner" "-d" "src/test/clojure"} 9 | :exec-fn cognitect.test-runner.api/test 10 | :exec-args {:dirs ["src/test/clojure"] 11 | :patterns [".*test.*"]}}} 12 | } -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This is a [Clojure contrib] project. 2 | 3 | Under the Clojure contrib [guidelines], this project cannot accept 4 | pull requests. All patches must be submitted via [JIRA]. 5 | 6 | See [Contributing] on the Clojure website for 7 | more information on how to contribute. 8 | 9 | [Clojure contrib]: https://clojure.org/community/contrib_libs 10 | [Contributing]: https://clojure.org/community/contributing 11 | [JIRA]: https://clojure.atlassian.net/browse/TNS 12 | [guidelines]: https://clojure.org/community/contrib_howto -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.core.logic.csproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | netstandard2.0;netstandard2.1 5 | 6 | 7 | 8 | clojure.core.logic 9 | clojure.core 10 | clojure.core.logic 11 | clojure.core.logic 12 | clojure.core.logic 13 | ClojureCLR contributors 14 | A port of core.logic to ClojureCLR. 15 | Copyright © Rich Hickey, David Nolen, and ClojureCLR contributors 2024 16 | EPL-1.0 17 | https://github.com/clojure/clojure.tools.namesapce 18 | ClojureCLR contributors 19 | Clojure;ClojureCLR 20 | 1.1.0 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.core.logic.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 17 4 | VisualStudioVersion = 17.4.33122.133 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "clojure.core.logic", "clojure.core.logic.csproj", "{7AF995DD-9DF9-4183-9961-1284F053E6D6}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|Any CPU = Debug|Any CPU 11 | Release|Any CPU = Release|Any CPU 12 | EndGlobalSection 13 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 14 | {7AF995DD-9DF9-4183-9961-1284F053E6D6}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 15 | {7AF995DD-9DF9-4183-9961-1284F053E6D6}.Debug|Any CPU.Build.0 = Debug|Any CPU 16 | {7AF995DD-9DF9-4183-9961-1284F053E6D6}.Release|Any CPU.ActiveCfg = Release|Any CPU 17 | {7AF995DD-9DF9-4183-9961-1284F053E6D6}.Release|Any CPU.Build.0 = Release|Any CPU 18 | EndGlobalSection 19 | GlobalSection(SolutionProperties) = preSolution 20 | HideSolutionNode = FALSE 21 | EndGlobalSection 22 | GlobalSection(ExtensibilityGlobals) = postSolution 23 | SolutionGuid = {8E82389F-E0A3-4A91-87D4-06163C960583} 24 | EndGlobalSection 25 | EndGlobal 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # clr.core.logic 2 | 3 | A port of [clojure/core.logic](https://github.com/clojure/core.logic) library to ClojureCLR. 4 | 5 | > A logic programming library for Clojure & ClojureScript. core.logic offers Prolog-like relational programming, constraint logic programming, and nominal logic programming for Clojure. At its heart is an original implementation of miniKanren as described in William Byrd's dissertation Relational Programming in miniKanren: Techniques, Applications, and Implementations as well as the extensions described in cKanren and αKanren. It is designed to be easily extended to forms of logic programming beyond the ones provided. 6 | 7 | ## Usage 8 | 9 | See the website listed above. 10 | 11 | ## Releases 12 | 13 | Latest stable release: 1.1.0 14 | 15 | [clj](https://clojure.org/guides/getting_started) dependency information: 16 | ```clojure 17 | io.github.clojure/clr.core.logic {:git/tag "v1.1.0" :git/sha "46b6ed4"} 18 | ``` 19 | 20 | 21 | Nuget reference: 22 | 23 | ``` 24 | PM> Install-Package clojure.core.logic -Version 1.1.0 25 | ``` 26 | 27 | Leiningen/Clojars reference: 28 | 29 | ``` 30 | [org.clojure.clr/core.logic "1.1.0"] 31 | ``` 32 | 33 | ## License 34 | 35 | 36 | Distributed under the Eclipse Public License, the same as Clojure. 37 | 38 | 39 | Original ClojureJVM code says: 40 | 41 | > Copyright © 2010-2020 David Nolen, Rich Hickey & contributors. 42 | > 43 | > Licensed under the EPL (see the file epl.html). 44 | 45 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject org.clojure.clr/core.logic "1.1.0" 2 | :description "A port of core.logic to ClojureCLR" 3 | :url "https://github.com/clojure/clr.core.logic" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [] 7 | :source-paths ["src/main/clojure"] 8 | :test-paths ["src/test/clojure"] 9 | :deploy-repositories [["clojars" {:url "https://clojars.org/repo/" 10 | :sign-releases false}]] 11 | :warn-on-reflection true 12 | :min-lein-version "2.0.0" 13 | :plugins [[lein-clr "0.2.2"]] 14 | :clr {:cmd-templates {:clj-exe [[?PATH "mono"] [CLJCLR14_40 %1]] 15 | :clj-dep [[?PATH "mono"] ["target/clr/clj/Debug 4.0" %1]] 16 | :clj-url "http://sourceforge.net/projects/clojureclr/files/clojure-clr-1.4.1-Debug-4.0.zip/download" 17 | :clj-zip "clojure-clr-1.4.1-Debug-4.0.zip" 18 | :curl ["curl" "--insecure" "-f" "-L" "-o" %1 %2] 19 | :nuget-ver [[?PATH "mono"] [*PATH "nuget.exe"] "install" %1 "-Version" %2] 20 | :nuget-any [[?PATH "mono"] [*PATH "nuget.exe"] "install" %1] 21 | :unzip ["unzip" "-d" %1 %2] 22 | :wget ["wget" "--no-check-certificate" "--no-clobber" "-O" %1 %2]} 23 | ;; for automatic download/unzip of ClojureCLR, 24 | ;; 1. make sure you have curl or wget installed and on PATH, 25 | ;; 2. uncomment deps in :deps-cmds, and 26 | ;; 3. use :clj-dep instead of :clj-exe in :main-cmd and :compile-cmd 27 | :deps-cmds [; [:wget :clj-zip :clj-url] ; edit to use :curl instead of :wget 28 | ; [:unzip "../clj" :clj-zip] 29 | ] 30 | :main-cmd [:clj-exe "Clojure.Main.exe"] 31 | :compile-cmd [:clj-exe "Clojure.Compile.exe"]}) 32 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/arithmetic.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.arithmetic 10 | (:refer-clojure :exclude [== = > < >= <=]) 11 | (:use [clojure.core.logic.protocols] 12 | [clojure.core.logic])) 13 | 14 | (defmacro = 15 | "Goal for testing whether x and y are equal. Non-relational." 16 | [x y] 17 | `(fn [a#] 18 | (let [wx# (walk a# ~x) 19 | wy# (walk a# ~y)] 20 | (if (clojure.core/= wx# wy# ) 21 | a# nil)))) 22 | 23 | (defmacro > 24 | "Goal for testing whether x is greater than y. Non-relational." 25 | [x y] 26 | `(fn [a#] 27 | (let [wx# (walk a# ~x) 28 | wy# (walk a# ~y)] 29 | (if (clojure.core/> wx# wy# ) 30 | a# nil)))) 31 | 32 | (defmacro >= 33 | "Goal for testing whether x is greater than or equal to y. 34 | Non-relational." 35 | [x y] 36 | `(fn [a#] 37 | (let [wx# (walk a# ~x) 38 | wy# (walk a# ~y)] 39 | (if (clojure.core/>= wx# wy# ) 40 | a# nil)))) 41 | 42 | (defmacro < 43 | "Goal for testing whether x is less than y. Non-relational." 44 | [x y] 45 | `(fn [a#] 46 | (let [wx# (walk a# ~x) 47 | wy# (walk a# ~y)] 48 | (if (clojure.core/< wx# wy# ) 49 | a# nil)))) 50 | 51 | (defmacro <= 52 | "Goal for testing whether x is less than or equal to y. 53 | Non-relational." 54 | [x y] 55 | `(fn [a#] 56 | (let [wx# (walk a# ~x) 57 | wy# (walk a# ~y)] 58 | (if (clojure.core/<= wx# wy#) 59 | a# nil)))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/pldb.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.pldb 10 | (:refer-clojure :exclude [indexed?]) 11 | (:require [clojure.core.logic :as l])) 12 | 13 | ;; ---------------------------------------- 14 | 15 | (def empty-db {}) 16 | 17 | (defmacro with-dbs [dbs & body] 18 | `(binding [l/*logic-dbs* (concat l/*logic-dbs* ~dbs)] 19 | ~@body)) 20 | 21 | (defmacro with-db [db & body] 22 | `(binding [l/*logic-dbs* (conj l/*logic-dbs* ~db)] 23 | ~@body)) 24 | 25 | (defn facts-for [dbs kname] 26 | (mapcat #(get-in % [kname ::unindexed]) dbs)) 27 | 28 | (defn facts-using-index [dbs kname index val] 29 | (mapcat #(get-in % [kname index val]) dbs)) 30 | 31 | ;; ---------------------------------------- 32 | (defn rel-key [rel] 33 | (if (keyword? rel) 34 | rel 35 | (:rel-name (meta rel)))) 36 | 37 | (defn rel-indexes [rel] 38 | (:indexes (meta rel))) 39 | 40 | (defn indexed? [v] 41 | (true? (:index (meta v)))) 42 | 43 | 44 | (defn contains-lvar? [x] 45 | (some l/lvar? (tree-seq coll? seq x))) 46 | 47 | (defn ground? [s term] 48 | (not (contains-lvar? (l/walk* s term)))) 49 | 50 | (defn index-for-query [s q indexes] 51 | (let [indexable (map #(ground? s %) q) 52 | triples (map vector (range) indexable indexes)] 53 | (first (for [[i indexable indexed] triples 54 | :when (and indexable indexed)] 55 | i)))) 56 | 57 | (defmacro db-rel [name & args] 58 | (let [arity 59 | (count args) 60 | 61 | kname 62 | (str (ns-name *ns*) "/" name "_" arity) 63 | 64 | indexes 65 | (vec (map indexed? args))] 66 | `(def ~name 67 | (with-meta 68 | (fn [& query#] 69 | (fn [subs#] 70 | (let [dbs# 71 | (-> subs# clojure.core/meta :db) 72 | 73 | facts# 74 | (if-let [index# (index-for-query subs# query# ~indexes)] 75 | (facts-using-index dbs# 76 | ~kname 77 | index# 78 | (l/walk* subs# (nth query# index#))) 79 | (facts-for dbs# ~kname))] 80 | (l/to-stream (map (fn [potential#] 81 | ((l/== query# potential#) subs#)) 82 | facts#))))) 83 | {:rel-name ~kname 84 | :indexes ~indexes})))) 85 | 86 | ;; ---------------------------------------- 87 | 88 | (defn db-fact [db rel & args] 89 | (let [key 90 | (rel-key rel) 91 | 92 | add-to-set 93 | (fn [current new] 94 | (conj (or current #{}) new)) 95 | 96 | db-with-fact 97 | (update-in db [key ::unindexed] #(add-to-set %1 args)) 98 | 99 | indexes-to-update ;; ugly - get the vector indexes of indexed attributes 100 | (map vector (rel-indexes rel) (range) args) 101 | 102 | update-index-fn 103 | (fn [db [is-indexed index-num val]] 104 | (if is-indexed 105 | (update-in db [key index-num val] #(add-to-set %1 args)) 106 | db))] 107 | (reduce update-index-fn db-with-fact indexes-to-update))) 108 | 109 | (defn db-retraction [db rel & args] 110 | (let [key 111 | (rel-key rel) 112 | 113 | retract-args 114 | #(disj %1 args) 115 | 116 | db-without-fact 117 | (update-in db [key ::unindexed] retract-args) 118 | 119 | indexes-to-update ;; also a bit ugly 120 | (map vector (rel-indexes rel) (range) args) 121 | 122 | remove-from-index-fn 123 | (fn [db [is-indexed index-num val]] 124 | (if is-indexed 125 | (update-in db [key index-num val] retract-args) 126 | db))] 127 | 128 | (reduce remove-from-index-fn db-without-fact indexes-to-update))) 129 | 130 | ;; ---------------------------------------- 131 | (defn db-facts [base-db & facts] 132 | (reduce #(apply db-fact %1 %2) base-db facts)) 133 | 134 | (defn db [& facts] 135 | (apply db-facts empty-db facts)) 136 | 137 | (defn db-retractions [base-db & retractions] 138 | (reduce #(apply db-retraction %1 %2) base-db retractions)) 139 | 140 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/unifier.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.unifier 10 | (:refer-clojure :exclude [==]) 11 | (:use [clojure.core.logic.protocols] 12 | [clojure.core.logic :exclude [unify] :as l])) 13 | 14 | ;; ============================================================================= 15 | ;; Easy Unification 16 | 17 | (defn- lvarq-sym? [s] 18 | (and (symbol? s) (= (first (str s)) \?))) 19 | 20 | (defn- proc-lvar [lvar-expr store] 21 | (let [v (if-let [u (@store lvar-expr)] 22 | u 23 | (lvar lvar-expr false))] 24 | (swap! store assoc lvar-expr v) 25 | v)) 26 | 27 | (defn- lcons-expr? [expr] 28 | (and (seq? expr) (some '#{.} (set expr)))) 29 | 30 | (declare prep*) 31 | 32 | (defn- replace-lvar [store] 33 | (fn [expr] 34 | (if (lvarq-sym? expr) 35 | (proc-lvar expr store) 36 | (if (lcons-expr? expr) 37 | (prep* expr store) 38 | expr)))) 39 | 40 | (defn- prep* 41 | ([expr store] (prep* expr store false false)) 42 | ([expr store lcons?] (prep* expr store lcons? false)) 43 | ([expr store lcons? last?] 44 | (let [expr (if (and last? (seq expr)) 45 | (first expr) 46 | expr)] 47 | (cond 48 | (lvarq-sym? expr) 49 | (proc-lvar expr store) 50 | 51 | (coll? expr) 52 | (if (or lcons? (lcons-expr? expr)) 53 | (let [[f & n] expr 54 | skip (= f '.) 55 | tail (prep* n store lcons? skip)] 56 | (if skip 57 | tail 58 | (lcons (prep* f store) tail))) 59 | (walk-term expr (replace-lvar store))) 60 | :else expr)))) 61 | 62 | (defn prep 63 | "Prep a quoted expression. All symbols preceded by ? will 64 | be replaced with logic vars." 65 | [expr] 66 | (let [lvars (atom {}) 67 | prepped (cond 68 | (lvarq-sym? expr) (proc-lvar expr lvars) 69 | 70 | (lcons-expr? expr) 71 | (prep* expr lvars true) 72 | 73 | :else (walk-term expr (replace-lvar lvars)))] 74 | (if (instance? clojure.lang.IMeta prepped) 75 | (with-meta prepped {::lvars (keys @lvars)}) 76 | prepped))) 77 | 78 | (defn queue-constraint [s c vs] 79 | (cond 80 | (vector? vs) 81 | (queue s (-unwrap (apply c (map #(lvar % false) vs)))) 82 | 83 | (set? vs) 84 | (reduce (fn [s v] (queue s (-unwrap (c (lvar v false))))) s vs) 85 | 86 | (symbol? vs) 87 | (queue s (-unwrap (apply c (map #(lvar % false) (list vs))))) 88 | 89 | :else 90 | (throw 91 | (Exception. 92 | (str "Only symbol, set of symbols, or vector of symbols allowed " 93 | "on left hand side"))))) 94 | 95 | (defn queue-constraints [s [vs cs]] 96 | (let [cs (if-not (sequential? cs) [cs] cs)] 97 | (reduce (fn [s c] (queue-constraint s c vs)) s cs))) 98 | 99 | (defn -unify* [init-s u w] 100 | (first 101 | (take* 102 | (fn [] 103 | ((fresh [q] 104 | (== u w) (== q u) 105 | (fn [a] 106 | (fix-constraints a)) 107 | (reifyg q)) 108 | init-s))))) 109 | 110 | (defn init-s [opts s] 111 | (let [s (reduce (fn [s [k v]] ((== k v) s)) s (:as opts))] 112 | (reduce queue-constraints 113 | (with-meta s {:reify-vars (fn [v rs] rs)}) 114 | (:when opts)))) 115 | 116 | (defn unify* 117 | "Unify the terms ts." 118 | ([ts] (unify* {} ts)) 119 | ([opts ts] 120 | (let [init-s (init-s opts empty-s)] 121 | (-unify* 122 | (vary-meta init-s assoc :reify-vars false) 123 | (reduce #(-unify* init-s %1 %2) (butlast ts)) 124 | (last ts))))) 125 | 126 | (defn unifier* 127 | "Return the unifier that unifies terms ts. 128 | All terms in ts should prepped terms." 129 | ([ts] (unifier* {} ts)) 130 | ([opts ts] 131 | (letfn [(-unifier* [s u w] 132 | (let [s (fix-constraints (l/unify (with-meta s {:reify-vars false}) u w))] 133 | (when s 134 | (->> (:lvars opts) 135 | (map (fn [sym] [sym (lvar sym false)])) 136 | (filter (fn [[sym var]] (not= (walk s var) var))) 137 | (map (fn [[sym var]] [sym (-reify s var)])) 138 | (into {})))))] 139 | (let [init-s (init-s opts empty-s)] 140 | (reduce #(-unifier* init-s %1 %2) ts))))) 141 | 142 | (defn unify 143 | "Unify the terms ts returning a the value that represents their 144 | unificaiton. Will prep the terms." 145 | ([ts] (unify {} ts)) 146 | ([opts ts] 147 | (let [opts (if (contains? opts :as) 148 | (assoc opts :as 149 | (->> (:as opts) 150 | (map (fn [[k v]] [(lvar k false) (prep v)])) 151 | (into {}))) 152 | opts)] 153 | (unify* opts (map prep ts))))) 154 | 155 | (defn unifier 156 | "Return the unifier for terms ts. Will prep the terms." 157 | ([ts] (unifier {} ts)) 158 | ([opts ts] 159 | (let [opts (if (contains? opts :as) 160 | (assoc opts :as 161 | (->> (:as opts) 162 | (map (fn [[k v]] [(lvar k false) (prep v)])) 163 | (into {}))) 164 | opts) 165 | ts' (map prep ts) 166 | lvars (->> (concat ts' (map val (:as opts))) 167 | (map #(-> % meta ::lvars)) 168 | (reduce into))] 169 | (unifier* (assoc opts :lvars lvars) (map prep ts))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/protocols.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.protocols) 10 | 11 | ;; Marker Interfaces 12 | 13 | (definterface IBindable) 14 | (definterface ITreeTerm) 15 | (definterface IVar) 16 | 17 | ;; ============================================================================= 18 | ;; Utility Protocols 19 | 20 | (defprotocol IUninitialized 21 | (-uninitialized [coll])) 22 | 23 | ;; ============================================================================= 24 | ;; miniKanren Protocols 25 | 26 | ;; ----------------------------------------------------------------------------- 27 | ;; Unification protocols for core Clojure types 28 | 29 | (defprotocol IUnifyTerms 30 | (unify-terms [u v s])) 31 | 32 | (defprotocol IUnifyWithRecord 33 | (unify-with-record [u v s])) 34 | 35 | (definterface INonStorable) 36 | 37 | (defn non-storable? [x] 38 | (instance? INonStorable x)) 39 | 40 | ;; ----------------------------------------------------------------------------- 41 | ;; Utility protocols 42 | 43 | (defprotocol LConsSeq 44 | (lfirst [this]) 45 | (lnext [this])) 46 | 47 | (defprotocol LConsPrint 48 | (toShortString [this])) 49 | 50 | ;; ----------------------------------------------------------------------------- 51 | ;; Substitution 52 | 53 | (defprotocol ISubstitutions 54 | (ext-no-check [this x v]) 55 | (walk [this x])) 56 | 57 | ;; ----------------------------------------------------------------------------- 58 | ;; Protocols for terms 59 | 60 | (defprotocol IReifyTerm 61 | (reify-term [v s])) 62 | 63 | (defprotocol IWalkTerm 64 | (walk-term [v f])) 65 | 66 | (defprotocol IOccursCheckTerm 67 | (occurs-check-term [v x s])) 68 | 69 | (defprotocol IBuildTerm 70 | (build-term [u s])) 71 | 72 | ;; ----------------------------------------------------------------------------- 73 | ;; Goal protocols 74 | 75 | (defprotocol IBind 76 | (bind [this g])) 77 | 78 | (defprotocol IMPlus 79 | (mplus [a f])) 80 | 81 | (defprotocol ITake 82 | (take* [a])) 83 | 84 | ;; ----------------------------------------------------------------------------- 85 | ;; soft cut & committed choice protocols 86 | 87 | (defprotocol IIfA 88 | (ifa [b gs c])) 89 | 90 | (defprotocol IIfU 91 | (ifu [b gs c])) 92 | 93 | ;; ============================================================================= 94 | ;; Rel protocols 95 | 96 | (defprotocol IRel 97 | (setfn [this arity f]) 98 | (indexes-for [this arity]) 99 | (add-indexes [this arity index])) 100 | 101 | ;; ============================================================================= 102 | ;; Tabling protocols 103 | 104 | (defprotocol ITabled 105 | (-reify-tabled [this v]) 106 | (reify-tabled [this v]) 107 | (reuse [this argv cache start end]) 108 | (subunify [this arg ans])) 109 | 110 | (defprotocol ISuspendedStream 111 | (ready? [this])) 112 | 113 | (defprotocol IAnswerCache 114 | (-add [this x]) 115 | (-cached? [this x])) 116 | 117 | ;; ============================================================================= 118 | ;; cKanren protocols 119 | 120 | (defprotocol ISubstitutionsCLP 121 | (root-val [this x]) 122 | (root-var [this x]) 123 | (ext-run-cs [this x v]) 124 | (queue [this c]) 125 | (update-var [this x v])) 126 | 127 | ;; ----------------------------------------------------------------------------- 128 | ;; Constraint Store 129 | 130 | (defprotocol IConstraintStore 131 | (addc [this a c]) 132 | (updatec [this a c]) 133 | (remc [this a c]) 134 | (runc [this c state]) 135 | (constraints-for [this a x ws]) 136 | (migrate [this x root a])) 137 | 138 | ;; ----------------------------------------------------------------------------- 139 | ;; Generic constraint protocols 140 | 141 | ;; Step, update the constraint with latest domain information 142 | 143 | (defprotocol IConstraintStep 144 | (-step [c s])) 145 | 146 | ;; the following assume implementation of -step 147 | 148 | (defprotocol IRunnable 149 | (-runnable? [c])) 150 | 151 | (defprotocol IEntailed 152 | (-entailed? [c])) 153 | 154 | (defprotocol IEntailedVar 155 | (-entailed-var? [c x])) 156 | 157 | ;; Contraint reflection protocols 158 | 159 | (defprotocol IWithConstraintId 160 | (-with-id [c id])) 161 | 162 | (defprotocol IConstraintId 163 | (-id [c])) 164 | 165 | (defn id [c] 166 | (if (instance? clojure.core.logic.protocols.IConstraintId c) 167 | (-id c) 168 | (-> c meta ::id))) 169 | 170 | (defn with-id [c id] 171 | (if (instance? clojure.core.logic.protocols.IWithConstraintId c) 172 | (-with-id c id) 173 | (vary-meta c assoc ::id id))) 174 | 175 | (defprotocol IConstraintWatchedStores 176 | (-watched-stores [c])) 177 | 178 | (defprotocol IConstraintOp 179 | (-rator [c]) 180 | (-rands [c])) 181 | 182 | (defprotocol IReifiableConstraint 183 | (-reifyc [c v r a])) 184 | 185 | (defprotocol IVerifyConstraint 186 | (-verify [c a cs])) 187 | 188 | (defn reifiable? [x] 189 | (instance? clojure.core.logic.protocols.IReifiableConstraint x)) 190 | 191 | (definterface IEnforceableConstraint) 192 | 193 | (defn enforceable? [x] 194 | (instance? clojure.core.logic.protocols.IEnforceableConstraint x)) 195 | 196 | ;; cgoal 197 | 198 | (defprotocol IUnwrapConstraint 199 | (-unwrap [c])) 200 | 201 | ;; generic domain related protocols 202 | 203 | (defprotocol IMergeDomains 204 | (-merge-doms [a b])) 205 | 206 | (defprotocol IMemberCount 207 | (-member-count [dom])) 208 | 209 | (defprotocol IForceAnswerTerm 210 | (-force-ans [v x])) 211 | 212 | ;; ----------------------------------------------------------------------------- 213 | ;; Tree Constraints 214 | 215 | (defprotocol IDisunifyTerms 216 | (-disunify-terms [u v s cs])) 217 | 218 | (definterface ITreeConstraint) 219 | 220 | (defn tree-constraint? [x] 221 | (instance? clojure.core.logic.protocols.ITreeConstraint x)) 222 | 223 | (defprotocol IPrefix 224 | (-prefix [c])) 225 | 226 | (defprotocol IWithPrefix 227 | (-with-prefix [c p])) 228 | 229 | ;; ----------------------------------------------------------------------------- 230 | ;; Partial Maps 231 | 232 | (defprotocol IUnifyWithPMap 233 | (unify-with-pmap [pmap u s])) 234 | 235 | ;; ----------------------------------------------------------------------------- 236 | ;; Deep constraints 237 | 238 | (defprotocol IConstrainTree 239 | (-constrain-tree [t fc s])) 240 | 241 | ;; ----------------------------------------------------------------------------- 242 | ;; Features 243 | 244 | (defprotocol IFeature 245 | (-feature [x])) 246 | 247 | ;; ----------------------------------------------------------------------------- 248 | ;; Jonc 249 | 250 | (defprotocol IJonc 251 | (-joncf [this])) -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/logic/pldb/tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.logic.pldb.tests 2 | (:use [clojure.test]) 3 | (:require [clojure.core.logic :as l] 4 | [clojure.core.logic.pldb :as pldb])) 5 | 6 | ;; from core.logic tests 7 | (pldb/db-rel man p) 8 | (pldb/db-rel woman p) 9 | (pldb/db-rel likes p1 p2) 10 | (pldb/db-rel fun p) 11 | 12 | (def facts0 13 | (pldb/db 14 | [man 'Bob] 15 | [man 'John] 16 | [man 'Ricky] 17 | 18 | [woman 'Mary] 19 | [woman 'Martha] 20 | [woman 'Lucy] 21 | 22 | [likes 'Bob 'Mary] 23 | [likes 'John 'Martha] 24 | [likes 'Ricky 'Lucy])) 25 | 26 | (def facts1 (-> facts0 27 | (pldb/db-fact fun 'Lucy))) 28 | 29 | (deftest test-facts0 30 | ( pldb/with-db facts0 31 | (is (= 32 | (l/run* [q] 33 | (l/fresh [x y] 34 | (likes x y) 35 | (fun y) 36 | (l/== q [x y]))) 37 | '())))) 38 | 39 | (deftest test-facts1 40 | (pldb/with-db facts1 41 | (is (= 42 | (l/run* [q] 43 | (l/fresh [x y] 44 | (likes x y) 45 | (fun y) 46 | (l/== q [x y]))) 47 | '([Ricky Lucy]))))) 48 | 49 | (def facts1-retracted 50 | (-> facts1 51 | (pldb/db-retraction likes 'Bob 'Mary))) 52 | 53 | (deftest test-rel-retract 54 | (pldb/with-db facts1-retracted 55 | (is (= (into #{} 56 | (l/run* [q] 57 | (l/fresh [x y] 58 | (likes x y) 59 | (l/== q [x y])))) 60 | (into #{} '([John Martha] [Ricky Lucy])))))) 61 | 62 | (pldb/db-rel rel1 ^:index a) 63 | (def indexed-db 64 | (pldb/db [rel1 [1 2]])) 65 | 66 | (deftest test-rel-logic-29 67 | (pldb/with-db indexed-db 68 | (is (= 69 | (l/run* [q] 70 | (l/fresh [a] 71 | (rel1 [q a]) 72 | (l/== a 2))) 73 | '(1))))) 74 | 75 | (pldb/db-rel rel2 ^:index e ^:index a ^:index v) 76 | (def facts2 77 | (pldb/db 78 | [rel2 :e1 :a1 :v1] 79 | [rel2 :e1 :a2 :v2])) 80 | 81 | (def facts2-retracted1 82 | (pldb/db-retractions facts2 83 | [rel2 :e1 :a1 :v1])) 84 | 85 | (def facts2-retracted2 86 | (pldb/db-retractions facts2 87 | [rel2 :e1 :a2 :v2])) 88 | 89 | (def facts2-retracted-all 90 | (pldb/db-retractions facts2 91 | [rel2 :e1 :a1 :v1] 92 | [rel2 :e1 :a2 :v2])) 93 | 94 | (deftest rel2-dup-retractions 95 | (is (= #{[:e1 :a1 :v1] [:e1 :a2 :v2]} 96 | (pldb/with-db facts2 97 | (into #{} 98 | (l/run* [out] 99 | (l/fresh [e a v] 100 | (rel2 e :a1 :v1) 101 | (rel2 e a v) 102 | (l/== [e a v] out))))))) 103 | (is (= #{} 104 | (pldb/with-db facts2-retracted1 105 | (into #{} 106 | (l/run* [out] 107 | (l/fresh [e a v] 108 | (rel2 e :a1 :v1) 109 | (rel2 e a v) 110 | (l/== [e a v] out))))))) 111 | (is (= #{[:e1 :a1 :v1]} 112 | (pldb/with-db facts2-retracted2 113 | (into #{} 114 | (l/run* [out] 115 | (l/fresh [e a v] 116 | (rel2 e :a1 :v1) 117 | (rel2 e a v) 118 | (l/== [e a v] out))))))) 119 | (is (= #{} 120 | (pldb/with-db facts2-retracted-all 121 | (into #{} 122 | (l/run* [out] 123 | (l/fresh [e a v] 124 | (rel2 e :a1 :v1) 125 | (rel2 e a v) 126 | (l/== [e a v] out)))))))) 127 | 128 | 129 | ;; ---------------------------------------- 130 | 131 | (pldb/db-rel protocol name port-number) 132 | (pldb/db-rel open-port ip port-number) 133 | 134 | (def known-ports 135 | (pldb/db 136 | [protocol :ftp 21] 137 | [protocol :ssh 22] 138 | [protocol :telnet 23] 139 | [protocol :smtp 25] 140 | [protocol :http 80] 141 | [protocol :pop3 110] 142 | [protocol :imap 143] 143 | [protocol :ldap 389] 144 | [protocol :https 443])) 145 | 146 | (def network1 147 | (pldb/db 148 | [open-port :10.0.1.3 22] 149 | [open-port :10.0.1.5 22] 150 | [open-port :10.0.1.8 22] 151 | [open-port :10.0.1.8 80] 152 | [open-port :10.0.1.12 22] 153 | [open-port :10.0.1.19 22] 154 | [open-port :10.0.1.19 25] 155 | [open-port :10.0.1.19 143] 156 | [open-port :10.0.1.136 22] 157 | [open-port :10.0.1.136 80] 158 | [open-port :10.0.1.136 443])) 159 | 160 | (def network2 161 | (pldb/db 162 | [open-port :192.168.128.213 22] 163 | [open-port :192.168.128.213 443] 164 | [open-port :192.168.128.217 22] 165 | [open-port :192.168.128.217 80] 166 | [open-port :192.168.128.217 443] 167 | [open-port :192.168.128.199 22] 168 | [open-port :192.168.128.140 22] 169 | [open-port :192.168.128.140 25] 170 | [open-port :192.168.128.140 110] 171 | [open-port :192.168.128.140 143] 172 | [open-port :192.168.128.140 389])) 173 | 174 | 175 | (deftest merge-same-relationship 176 | (is (= #{:10.0.1.19} 177 | (pldb/with-db network1 178 | (set (l/run* [ip] 179 | (open-port ip 143)))))) 180 | 181 | (is (= #{:192.168.128.140} 182 | (pldb/with-db network2 183 | (set (l/run* [ip] 184 | (open-port ip 143)))))) 185 | 186 | (is (= #{:192.168.128.140 :10.0.1.19} 187 | (pldb/with-db network1 188 | (pldb/with-db network2 189 | (set (l/run* [ip] 190 | (open-port ip 143))))))) 191 | 192 | (is (= #{:192.168.128.140 :10.0.1.19} 193 | (pldb/with-db network2 194 | (pldb/with-db network1 195 | (set (l/run* [ip] 196 | (open-port ip 143))))))) 197 | 198 | (is (= #{:192.168.128.140 :10.0.1.19} 199 | (pldb/with-dbs [network1 network2] 200 | (set (l/run* [ip] 201 | (open-port ip 143))))))) 202 | 203 | (deftest merge-across-relationship 204 | (is (= #{:10.0.1.136 :192.168.128.217} 205 | (pldb/with-dbs [known-ports network1 network2] 206 | (set (l/run* [ip] 207 | (l/fresh [http-port https-port] 208 | (protocol :http http-port) 209 | (protocol :https https-port) 210 | (open-port ip http-port) 211 | (open-port ip https-port)))))))) 212 | 213 | 214 | 215 | ;; ---------------------------------------- 216 | 217 | (pldb/db-rel rps move) 218 | (def moves-db (pldb/db 219 | [rps :rock] 220 | [rps :paper] 221 | [rps :scissors])) 222 | 223 | (deftest test-lazy 224 | (is (= (into #{} 225 | (pldb/with-db moves-db 226 | (l/run* [q] (rps q)))) 227 | 228 | (pldb/with-db moves-db 229 | (into #{} 230 | (l/run* [q] (rps q)))) 231 | 232 | #{:rock :paper :scissors}))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/dcg.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.dcg 10 | (:refer-clojure :exclude [==]) 11 | (:use [clojure.core.logic])) 12 | 13 | ;; TODO: think about indexing 14 | ;; TODO: note that rest args are problematic since we add two invisible args 15 | ;; TODO: make handle-clause polymorphic, we don't want to futz around with 16 | ;; with forcing macroexpand 17 | ;; TODO: fresh-expr? and !dcg? are odd, why can't we check w/ `sym 18 | 19 | (defn lsym [n] 20 | (gensym (str "l" n "_"))) 21 | 22 | (defn !dcg? [clause] 23 | (and (sequential? clause) 24 | (let [f (first clause)] 25 | (and (symbol? f) 26 | (= (name f) "!dcg"))))) 27 | 28 | (defn ->lcons 29 | ([env [m :as c] i] (->lcons env c i false)) 30 | ([env [m :as c] i quoted] 31 | (cond 32 | (empty? c) `(fresh [] 33 | (== ~(env (dec i)) ~(env i))) 34 | :else (let [m (if quoted `(quote ~m) m)] 35 | `(== ~(env (dec i)) (lcons ~m ~(env i))))))) 36 | 37 | (defn fresh-expr? [clause] 38 | (and (seq? clause) 39 | (let [f (first clause)] 40 | (and (symbol? f) 41 | (= (name f) "fresh"))))) 42 | 43 | ;; TODO: make tail recursive 44 | 45 | (defn count-clauses [clauses] 46 | (if (fresh-expr? clauses) 47 | (count-clauses (drop 2 clauses)) 48 | (reduce (fn [s c] 49 | (cond 50 | (fresh-expr? c) (+ s (count-clauses (drop 2 c))) 51 | (!dcg? c) s 52 | :else (clojure.core/inc s))) 53 | 0 clauses))) 54 | 55 | ;; TODO: might as well make this a lazy-seq 56 | 57 | (defn mark-clauses 58 | ([cs] (mark-clauses cs (atom 0))) 59 | ([[c & r :as cs] i] 60 | (cond 61 | (nil? (seq cs)) () 62 | (fresh-expr? c) (cons `(fresh ~(second c) 63 | ~@(mark-clauses (drop 2 c) i)) 64 | (mark-clauses r i)) 65 | (!dcg? c) (cons c (mark-clauses r i)) 66 | :else (cons (with-meta c 67 | {:index (swap! i clojure.core/inc)}) 68 | (mark-clauses r i))))) 69 | 70 | ;; TODO: same as above 71 | ;; combine this step with the above 72 | 73 | (defn handle-clauses [env [c & r :as cs]] 74 | (cond 75 | (nil? (seq cs)) () 76 | (fresh-expr? c) (cons `(fresh ~(second c) 77 | ~@(handle-clauses env (drop 2 c))) 78 | (handle-clauses env r)) 79 | (!dcg? c) (cons (second c) (handle-clauses env r)) 80 | (vector? c) (cons (->lcons env c (-> c meta :index)) 81 | (handle-clauses env r)) 82 | (and (seq? c) 83 | (= (first c) `quote) 84 | (vector? (second c))) (cons (->lcons env (second c) (-> c meta :index) true) 85 | (handle-clauses env r)) 86 | :else (let [i (-> c meta :index) 87 | c (if (seq? c) c (list c))] 88 | (cons (concat c [(env (dec i)) (env i)]) 89 | (handle-clauses env r))))) 90 | 91 | (defmacro --> [name & clauses] 92 | (let [r (range 1 (+ (count-clauses clauses) 2)) 93 | lsyms (into [] (map lsym r)) 94 | clauses (mark-clauses clauses) 95 | clauses (handle-clauses lsyms clauses)] 96 | `(defn ~name [~(first lsyms) ~(last lsyms)] 97 | (fresh [~@(butlast (rest lsyms))] 98 | ~@clauses)))) 99 | 100 | (defmacro def--> [name args & clauses] 101 | (let [r (range 1 (+ (count-clauses clauses) 2)) 102 | lsyms (map lsym r) 103 | clauses (mark-clauses clauses) 104 | clauses (handle-clauses lsyms clauses)] 105 | `(defn ~name [~@args ~(first lsyms) ~(last lsyms)] 106 | (fresh [~@(butlast (rest lsyms))] 107 | ~@clauses)))) 108 | 109 | (defn handle-cclause [fsym osym cclause] 110 | (let [c (count-clauses cclause) 111 | r (range 2 (clojure.core/inc c)) 112 | lsyms (conj (into [fsym] (map lsym r)) osym) 113 | clauses (mark-clauses cclause) 114 | clauses (handle-clauses lsyms clauses)] 115 | `(fresh [~@(butlast (rest lsyms))] 116 | ~@clauses))) 117 | 118 | (defmacro -->e [name & cclauses] 119 | (let [fsym (gensym "l1_") 120 | osym (gensym "o")] 121 | `(defn ~name [~fsym ~osym] 122 | (conde 123 | ~@(map list (map (partial handle-cclause fsym osym) cclauses)))))) 124 | 125 | (defmacro def-->e [name args & pcss] 126 | (let [fsym (gensym "l1_") 127 | osym (gensym "o")] 128 | `(defne ~name [~@args ~fsym ~osym] 129 | ~@(map (fn [[p & cs]] 130 | (list (-> p (conj '_) (conj '_)) 131 | (handle-cclause fsym osym cs))) 132 | pcss)))) 133 | 134 | (comment 135 | (-->e det 136 | ('[the]) 137 | ('[a])) 138 | 139 | (-->e n 140 | ('[witch]) 141 | ('[wizard])) 142 | 143 | (--> v '[curses]) 144 | 145 | (--> np det n) 146 | (--> vp v np) 147 | (--> s np vp) 148 | 149 | ;; we can stop the dcg transform 150 | (--> s np (!dcg (== 1 1)) vp) 151 | 152 | ;; success 153 | (run* [q] 154 | (np '[the witch] [])) 155 | 156 | ;; success 157 | (run* [q] 158 | (s '[a witch curses the wizard] [])) 159 | 160 | (def-->e verb [v] 161 | ([[:v 'eats]] '[eats])) 162 | 163 | (def-->e noun [n] 164 | ([[:n 'bat]] '[bat]) 165 | ([[:n 'cat]] '[cat])) 166 | 167 | (def-->e det [d] 168 | ([[:d 'the]] '[the]) 169 | ([[:d 'a]] '[a])) 170 | 171 | (def-->e noun-phrase [n] 172 | ([[:np ?d ?n]] (det ?d) (noun ?n))) 173 | 174 | (def-->e verb-phrase [n] 175 | ([[:vp ?v ?np]] (verb ?v) (noun-phrase ?np))) 176 | 177 | (def-->e sentence [s] 178 | ([[:s ?np ?vp]] (noun-phrase ?np) (verb-phrase ?vp))) 179 | 180 | (run 1 [parse-tree] 181 | (sentence parse-tree '[the bat eats a cat] [])) 182 | 183 | ;; ([:s [:np [:d the] [:n bat]] [:vp [:v eats] [:np [:d a] [:n cat]]]]) 184 | 185 | ;; ~90-100ms 186 | (dotimes [_ 10] 187 | (time 188 | (dotimes [_ 1e3] 189 | (run 1 [parse-tree] 190 | (sentence parse-tree '[the bat eats a cat] []))))) 191 | 192 | ;; parsing lisp 193 | 194 | (def digits (into #{} "1234567890")) 195 | (defn cr [c1 c2] 196 | (map char (range (int c1) (int c2)))) 197 | (def alpha (into #{} (concat (cr \a \z) (cr \A \Z)))) 198 | (def alnum (into digits (concat (cr \a \z) (cr \A \Z)))) 199 | (def nonalnum (into #{} "+/-*><=")) 200 | 201 | (-->e wso 202 | ([\space] wso) 203 | ([])) 204 | 205 | (def-->e digito [x] 206 | ([_] [x] 207 | (!dcg 208 | (project [x] 209 | (== (contains? digits x) true))))) 210 | 211 | (def-->e numo [x] 212 | ([[?d . ?ds]] (digito ?d) (numo ?ds)) 213 | ([[?d]] (digito ?d))) 214 | 215 | (declare symro) 216 | 217 | (def-->e symo [x] 218 | ([[?a . ?as]] [?a] 219 | (!dcg 220 | (project [?a] 221 | (conde 222 | ((== (contains? alpha ?a) true)) 223 | ((== (contains? nonalnum ?a) true))))) 224 | (symro ?as))) 225 | 226 | (def-->e symro [x] 227 | ([[?a . ?as]] [?a] 228 | (!dcg 229 | (project [?a] 230 | (conde 231 | ((== (contains? alnum ?a) true)) 232 | ((== (contains? nonalnum ?a) true))))) 233 | (symro ?as)) 234 | ([[]] [])) 235 | 236 | (declare exprso) 237 | 238 | (def-->e expro [e] 239 | ([[:sym ?a]] (symo ?a)) 240 | ([[:num ?n]] (numo ?n)) 241 | ([[:list ?list]] [\(] (exprso ?list) [\)]) 242 | ([[:sym :quote ?q]] [\'] (expro ?q))) 243 | 244 | ;; TODO: we need cut here, we found a valid parse 245 | (def-->e exprso [exs] 246 | ([[?e . ?es]] wso (expro ?e) wso (exprso ?es)) 247 | ([[]] [])) 248 | 249 | ;; (_.0) 250 | (run* [q] 251 | (wso (vec " ") [])) 252 | 253 | ;; () 254 | (run* [q] 255 | (wso (vec " f ") [])) 256 | 257 | ;; (\1) 258 | (run* [q] 259 | (digito q [\1] [])) 260 | 261 | ;; ((\1 \2 \3)) 262 | (run* [q] 263 | (numo q (vec "123") [])) 264 | 265 | ;; ((\a \b \c)) 266 | (run* [q] 267 | (symo q (vec "abc") [])) 268 | 269 | ;; ([:n (\1 \2 \3)]) 270 | (run* [q] 271 | (expro q (vec "123") [])) 272 | 273 | ;; ([:s (\a \b \c)]) 274 | (run* [q] 275 | (expro q (vec "abc") [])) 276 | 277 | ;; (([:list ([:sym (\+)] [:sym (\a \b \c)] [:sym (\b)] [:sym :quote [:list ([:num [\1]] [:num (\2 \3)])]])])) 278 | (run 1 [q] 279 | (exprso q (vec " (+ abc b '(1 23)) ") [])) 280 | 281 | ;; w/ def-->a ~2500ms 282 | ;; w/ def-->e ~1400ms 283 | (dotimes [_ 10] 284 | (let [s (vec " (+ abc b '(1 23)) ")] 285 | (time 286 | (dotimes [_ 50] 287 | (run 1 [q] 288 | (exprso q s [])))))) 289 | ) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/nominal.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.nominal 10 | (:refer-clojure :exclude [== hash]) 11 | (:use [clojure.core.logic.protocols] 12 | [clojure.core.logic :exclude [fresh] :as l]) 13 | (:require [clojure.pprint :as pp]) 14 | (:import [System.IO TextWriter] ;;; [java.io Writer] 15 | [clojure.core.logic LVar LCons] 16 | [clojure.core.logic.protocols IBindable ITreeTerm])) 17 | 18 | ;; ============================================================================= 19 | ;; Nominal unification with fresh, hash and tie. 20 | ;; 21 | ;; Some references / inspiration: 22 | ;; alphaKanren - http://www.cs.indiana.edu/~webyrd/alphamk/alphamk.pdf 23 | ;; Nominal Unification - http://www.cl.cam.ac.uk/~amp12/papers/nomu/nomu-jv.pdf 24 | ;; https://github.com/lkuper/relational-research/blob/master/lib/minikanren/nominal.sls 25 | 26 | ;; ============================================================================= 27 | ;; Nominal unification protocols 28 | 29 | (defprotocol INomSwap 30 | (swap-noms [t swap s])) 31 | 32 | (defn nom-swap [a swap] 33 | (cond 34 | (= a (first swap)) (second swap) 35 | (= a (second swap)) (first swap) 36 | :else a)) 37 | 38 | (declare suspc) 39 | 40 | (extend-protocol INomSwap 41 | nil 42 | (swap-noms [t swap s] [t s]) 43 | 44 | Object 45 | (swap-noms [t swap s] [t s]) 46 | 47 | LVar 48 | (swap-noms [t swap s] 49 | (let [t (walk s t)] 50 | (if (lvar? t) 51 | (let [v (with-meta (lvar) (meta t)) 52 | rt (root-val s t) 53 | s (-> (if (subst-val? rt) (ext-no-check s v rt) s) 54 | (entangle t v) 55 | ((suspc v t swap)))] 56 | [v s]) 57 | (swap-noms t swap s)))) 58 | 59 | LCons 60 | (swap-noms [t swap s] 61 | (let [[tfirst s] (swap-noms (lfirst t) swap s) 62 | [tnext s] (swap-noms (lnext t) swap s)] 63 | [(with-meta (lcons tfirst tnext) (meta t)) 64 | s])) 65 | 66 | clojure.lang.IPersistentCollection 67 | (swap-noms [t swap s] 68 | (if (seq t) 69 | (let [[tfirst s] (swap-noms (first t) swap s) 70 | [tnext s] (swap-noms (next t) swap s)] 71 | [(with-meta (cons tfirst tnext) (meta t)) s]) 72 | [t s])) 73 | 74 | clojure.lang.IPersistentVector 75 | (swap-noms [t swap s] 76 | (let [[ts s] (swap-noms (seq t) swap s)] 77 | [(vec ts) s])) 78 | 79 | clojure.lang.IPersistentMap 80 | (swap-noms [t swap s] 81 | (let [[tkvs s] (swap-noms (seq t) swap s)] 82 | [(into {} tkvs) s]))) 83 | 84 | ;; ============================================================================= 85 | ;; Nom 86 | 87 | (declare nom) 88 | 89 | (deftype Nom [lvar] 90 | IBindable 91 | 92 | Object 93 | (ToString [_] ;;; toString 94 | (str "")) 95 | (GetHashCode [_] ;;; hashCode 96 | (.GetHashCode lvar)) ;;; .hashCode 97 | (Equals [this o] ;;; equals 98 | (and (.. this GetType (IsInstanceOfType o)) ;;; getClass isInstance 99 | (= lvar (:lvar o)))) 100 | 101 | clojure.lang.IObj 102 | (withMeta [this new-meta] 103 | (nom (with-meta lvar new-meta))) 104 | (meta [this] 105 | (meta lvar)) 106 | 107 | clojure.lang.ILookup 108 | (valAt [this k] 109 | (.valAt this k nil)) 110 | (valAt [_ k not-found] 111 | (case k 112 | :lvar lvar 113 | :name (:name lvar) 114 | :oname (:oname lvar) 115 | not-found)) 116 | 117 | IReifyTerm 118 | (reify-term [v s] 119 | (ext s v (symbol (str (if (-> s meta (:reify-noms true)) "a" (:oname v)) "_" (count s))))) 120 | 121 | INomSwap 122 | (swap-noms [t swap s] 123 | [(nom-swap t swap) s])) 124 | 125 | (defn nom [lvar] 126 | (Nom. lvar)) 127 | 128 | (defn nom? [x] 129 | (instance? clojure.core.logic.nominal.Nom x)) 130 | 131 | (defn- nom-bind [sym] 132 | ((juxt identity 133 | (fn [s] `(nom (lvar '~s)))) sym)) 134 | 135 | (defn- nom-binds [syms] 136 | (mapcat nom-bind syms)) 137 | 138 | (defmacro fresh 139 | "Creates fresh noms. Goals occuring within form a logical conjunction." 140 | [[& noms] & goals] 141 | `(fn [a#] 142 | (-inc 143 | (let [~@(nom-binds noms)] 144 | (bind* a# ~@goals))))) 145 | 146 | (defmethod print-method Nom [x ^TextWriter writer] ;;; ^Writer 147 | (.Write writer (str ""))) ;;; .write 148 | 149 | ;; ============================================================================= 150 | ;; hash: ensure a nom is free in a term 151 | 152 | (declare tie? hash) 153 | 154 | (defn- -hash [a x] 155 | (reify 156 | Object 157 | (ToString [_] ;;; toString 158 | (str a "#" x)) 159 | IConstraintStep 160 | (-step [this s] 161 | (let [a (walk s a) 162 | x (walk s x)] 163 | (reify 164 | clojure.lang.IFn 165 | (invoke [_ s] 166 | ((composeg* 167 | (remcg this) 168 | (fn [s] 169 | (cond 170 | (and (lvar? a) (lvar? x) (= x a)) nil 171 | (and (nom? a) (nom? x) (= x a)) nil 172 | (and (not (lvar? a)) (not (nom? a))) nil 173 | (and (nom? a) (tie? x) (= (:binding-nom x) a)) s 174 | (and (tree-term? x) 175 | (or (not (tie? x)) (nom? a))) 176 | ((constrain-tree x 177 | (fn [t s] ((hash a t) s))) s) 178 | :else s))) s)) 179 | IRunnable 180 | (-runnable? [_] 181 | (if (lvar? a) 182 | (or (and (lvar? x) (= x a)) 183 | (and (tree-term? x) (not (tie? x)))) 184 | (or (not (nom? a)) 185 | (not (lvar? x)))))))) 186 | IConstraintOp 187 | (-rator [_] `hash) 188 | (-rands [_] [a x]) 189 | IReifiableConstraint 190 | (-reifyc [_ v r s] 191 | (let [x (walk* r (walk* s x)) 192 | a (walk* r (walk* s a))] 193 | ;; Filter constraints unrelated to reified variables. 194 | (when (and (symbol? a) (empty? (->> (list x) flatten (filter lvar?)))) 195 | (symbol (str a "#" x))))) 196 | 197 | IConstraintWatchedStores 198 | (-watched-stores [this] #{::l/subst}))) 199 | 200 | (defn hash [a t] 201 | (cgoal (-hash a t))) 202 | 203 | ;; ============================================================================= 204 | ;; Suspensions as constraints 205 | 206 | (defn- -do-suspc [t1 t2 swap a] 207 | (let [x (loop [vs #{t2} seen #{}] 208 | (let [vs (clojure.set/difference vs seen)] 209 | (cond 210 | (empty? vs) true 211 | (some #(occurs-check a % t1) vs) false 212 | :else (recur 213 | (reduce 214 | (fn [s0 s1] 215 | (clojure.set/union s0 (:eset (root-val a s1)))) 216 | #{} vs) 217 | (clojure.set/union vs seen)))))] 218 | (when x 219 | (let [[t1 a] (swap-noms t1 swap a)] 220 | ((== t1 t2) a))))) 221 | 222 | (defn -suspc [v1 v2 swap] 223 | (reify 224 | Object 225 | (ToString [_] ;;; toString 226 | (str "suspc" v1 v2 swap)) 227 | IConstraintStep 228 | (-step [this a] 229 | (let [t1 (walk a v1) 230 | t2 (walk a v2)] 231 | (reify 232 | clojure.lang.IFn 233 | (invoke [_ a] 234 | ((composeg* 235 | (remcg this) 236 | (fn [a] 237 | (cond 238 | (not (lvar? t1)) (-do-suspc t1 t2 swap a) 239 | (not (lvar? t2)) (-do-suspc t2 t1 swap a) 240 | :else ;; (= t1 t2) 241 | (loop [a* swap a a] 242 | (if (empty? a*) a 243 | (recur (rest a*) ((hash (first a*) t2) a))))))) a)) 244 | IRunnable 245 | (-runnable? [_] 246 | (or (not (lvar? t1)) (not (lvar? t2)) (= t1 t2)))))) 247 | IConstraintOp 248 | (-rator [_] `suspc) 249 | (-rands [_] [v1 v2]) 250 | IReifiableConstraint 251 | (-reifyc [c v r a] 252 | (let [t1 (walk* r (walk* a v1)) 253 | t2 (walk* r (walk* a v2)) 254 | swap (walk* r swap)] 255 | (when (and 256 | (not (lvar? t1)) 257 | (not (lvar? t2)) 258 | (symbol? (first swap)) 259 | (symbol? (second swap))) 260 | `(~'swap ~swap ~t1 ~t2)))) 261 | IConstraintWatchedStores 262 | (-watched-stores [this] #{::l/subst}))) 263 | 264 | (defn suspc [v1 v2 swap] 265 | (cgoal (-suspc v1 v2 swap))) 266 | 267 | ;; ============================================================================= 268 | ;; tie: bind a nom in a term 269 | 270 | (declare tie) 271 | 272 | (defrecord Tie [binding-nom body] 273 | ITreeTerm 274 | 275 | IUnifyTerms 276 | (unify-terms [v u s] 277 | (cond 278 | (tie? u) 279 | (if (= (:binding-nom v) (:binding-nom u)) 280 | (unify s (:body v) (:body u)) 281 | (let [[t s] (swap-noms (:body v) [(:binding-nom v) (:binding-nom u)] s)] 282 | ((composeg* 283 | (hash (:binding-nom u) (:body v)) 284 | (== t (:body u))) s))) 285 | :else nil)) 286 | 287 | IReifyTerm 288 | (reify-term [v s] 289 | (let [s (-reify* s binding-nom)] 290 | (let [s (-reify* s body)] 291 | s))) 292 | 293 | IWalkTerm 294 | (walk-term [v f] 295 | (with-meta 296 | (tie (walk-term (:binding-nom v) f) 297 | (walk-term (:body v) f)) 298 | (meta v))) 299 | 300 | IOccursCheckTerm 301 | (occurs-check-term [v x s] 302 | (occurs-check s x (:body v))) 303 | 304 | IConstrainTree 305 | (-constrain-tree [t fc s] 306 | (fc (:body t) s)) 307 | 308 | IForceAnswerTerm 309 | (-force-ans [v x] 310 | (force-ans (:body v))) 311 | 312 | INomSwap 313 | (swap-noms [t swap s] 314 | (let [[tbody s] (swap-noms (:body t) swap s)] 315 | [(with-meta (tie (nom-swap (:binding-nom t) swap) tbody) (meta t)) s]))) 316 | 317 | (defn tie [binding-nom body] 318 | (Tie. binding-nom body)) 319 | 320 | (defn tie? [x] 321 | (instance? clojure.core.logic.nominal.Tie x)) 322 | 323 | (defmethod print-method Tie [x ^TextWriter writer] ;;; ^Writer 324 | (.Write writer "[") ;;; .write 325 | (print-method (:binding-nom x) writer) 326 | (.Write writer "] ") ;;; .write 327 | (print-method (:body x) writer)) 328 | 329 | (defn- pprint-tie [x] 330 | (pp/pprint-logical-block 331 | (.Write ^TextWriter *out* "[") ;;; ^Writer .write 332 | (pp/write-out (:binding-nom x)) 333 | (.Write ^TextWriter *out* "] ") ;;; ^Writer .write 334 | (pp/write-out (:body x)))) 335 | 336 | (. ^clojure.lang.MultiFn pp/simple-dispatch addMethod Tie pprint-tie) ;;; Added type hint -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/logic/nominal/tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.logic.nominal.tests 2 | (:refer-clojure :exclude [==]) 3 | (:use [clojure.core.logic :exclude [is] :as l] 4 | [clojure.core.logic.nominal :exclude [fresh hash] :as nom] 5 | clojure.test :reload) 6 | (:require [clojure.pprint :as pp] 7 | [clojure.core.logic.fd :as fd])) 8 | 9 | ;; ============================================================================= 10 | ;; nominal unification 11 | 12 | (deftest test-nom-1 13 | (is (= (run* [q] (nom/fresh [a] (== a a))) '(_0))) 14 | (is (= (run* [q] (nom/fresh [a] (== q a))) '(a_0))) 15 | (is (= (run* [q] (nom/fresh [a] (== a q))) '(a_0))) 16 | (is (= (run* [q] (nom/fresh [a b] (== q [a b]))) '([a_0 a_1]))) 17 | (is (= (run* [q] (nom/fresh [a b] (conde [(== q a)] [(== q b)]))) '(a_0 a_0))) 18 | (is (= (run* [q] (nom/fresh [a b] (== a b))) '())) 19 | (is (= (run* [q] (nom/fresh [a] (== a 1))) '())) 20 | (is (= (run* [q] (nom/fresh [a] (== 1 a))) '())) 21 | (is (= (run* [q] (nom/fresh [a] (== nil a))) '())) 22 | (is (= (run* [q] (nom/fresh [a] (== a nil))) '())) 23 | (is (= (run* [q] (nom/fresh [a] (== q 1) (== q a))) '())) 24 | (is (= (run* [q] (nom/fresh [a] (== q a) (== q 1))) '())) 25 | (is (= (run* [q] (nom/fresh [a b] (== a q) (== b q))) '())) 26 | (is (= (run* [q] (nom/fresh [a] (predc a number? `number?))) '())) 27 | (is (= (run* [q] (nom/fresh [a] (predc q number? `number?) (== q a))) '())) 28 | (is (= (run* [q] (nom/fresh [a] (== q a) (predc q number? `number?))) '()))) 29 | 30 | (deftest test-nom-2 31 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a q) (nom/hash b q))) '(_0))) 32 | (is (= (run* [q] (fresh [x] (nom/fresh [a b] (nom/hash a x) (nom/hash b x) (== [x a b] q)))) 33 | '(([_0 a_1 a_2] :- a_2#_0 a_1#_0)))) 34 | (is (= (run* [q] (fresh [x] (nom/fresh [a] (nom/hash a q) (== q x)))) '(_0))) 35 | (is (= (run* [q] (fresh [x y] (nom/fresh [a] (nom/hash a x) (== y x) (== [y a] q)))) 36 | '(([_0 a_1] :- a_1#_0)))) 37 | (is (= (run* [q] (fresh [x] (nom/fresh [a] (nom/hash a q) (== q `(~x))))) '((_0)))) 38 | (is (= (run* [q] (fresh [x y] (nom/fresh [a] (nom/hash a y) (== y `(~x)) (== [y a] q)))) 39 | '(([(_0) a_1] :- a_1#_0)))) 40 | (is (= (run* [q] (fresh [x y z] (nom/fresh [a] (nom/hash a q) (== q `(~x ~y))))) '((_0 _1)))) 41 | ;; SET ORDER BUG 42 | #_(is (= (run* [q] (fresh [x y z] (nom/fresh [a] (nom/hash a z) (== z `(~x ~y)) (== [z a] q)))) 43 | '(([(_0 _1) a_2] :- a_2#_1 a_2#_0)))) 44 | (is (= (run* [q] (fresh [x y] (nom/fresh [a] (nom/hash a q) (conso x y q)))) `(~(lcons '_0 '_1)))) 45 | ;; SET ORDER BUG 46 | #_(is (= (run* [q] (fresh [x y z] (nom/fresh [a] (nom/hash a z) (conso x y z) (== [z a] q)))) 47 | [[[(lcons '_0 '_1) 'a_2] ':- 'a_2#_1 'a_2#_0]])) 48 | (is (= (run* [q] (fresh [x y] (nom/fresh [a] (conso x y q) (nom/hash a q)))) `(~(lcons '_0 '_1)))) 49 | ;; SET ORDER BUG 50 | #_(is (= (run* [q] (fresh [x y z] (nom/fresh [a] (nom/hash a z) (conso x y z) (== [z a] q)))) 51 | [[[(lcons '_0 '_1) 'a_2] ':- 'a_2#_1 'a_2#_0]])) 52 | (is (= (run* [q] (nom/fresh [a b] (== q nil) (nom/hash a q))) '(nil))) 53 | (is (= (run* [q] (nom/fresh [a b] (== q 1) (nom/hash a q))) '(1))) 54 | (is (= (run* [q] (nom/fresh [a b] (== q [1 1]) (nom/hash a q))) '([1 1]))) 55 | (is (= (run* [q] (nom/fresh [a b] (== q (lcons 1 ())) (nom/hash a q))) [(lcons 1 ())])) 56 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a q) (== q (lcons 1 ())))) [(lcons 1 ())])) 57 | (is (= (run* [q] (nom/fresh [a b] (== q b) (nom/hash a q))) '(a_0))) 58 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a q) (== q b))) '(a_0))) 59 | (is (= (run* [q] (nom/fresh [a b] (conde [(== q a) (nom/hash b q)] [(== q b)]))) '(a_0 a_0))) 60 | (is (= (run* [q] (nom/fresh [a] (nom/hash a a))) '())) 61 | (is (= (run* [q] (nom/fresh [a] (== q a) (nom/hash a q))) '())) 62 | (is (= (run* [q] (nom/fresh [a] (nom/hash a q) (== q a))) '())) 63 | (is (= (run* [q] (nom/fresh [a] (nom/hash a `(~a)))) '())) 64 | (is (= (run* [q] (nom/fresh [a] (== q `(~a)) (nom/hash a q))) '())) 65 | (is (= (run* [q] (nom/fresh [a] (nom/hash a q) (== q `(~a)))) '()))) 66 | 67 | (deftest test-nom-3 68 | (is (= (run* [q] (nom/fresh [a] (nom/hash a (nom/tie a a)))) '(_0))) 69 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a (nom/tie a b)))) '(_0))) 70 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a `(~b ~(nom/tie a a))))) '(_0))) 71 | (is (= (run* [q] (nom/fresh [a] (== q (nom/tie a a)) (nom/hash a q))) [(nom/tie 'a_0 'a_0)])) 72 | (is (= (run* [q] (nom/fresh [a b] (== q (nom/tie a b)) (nom/hash a q))) [(nom/tie 'a_0 'a_1)])) 73 | (is (= (run* [q] (nom/fresh [a b] (== q `(~b ~(nom/tie a a))) (nom/hash a q))) [['a_0 (nom/tie 'a_1 'a_1)]])) 74 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a (nom/tie b a)))) '())) 75 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a `(~a ~(nom/tie a a))))) '())) 76 | (is (= (run* [q] (nom/fresh [a b] (nom/hash a `(~b ~(nom/tie b a))))) '())) 77 | (is (= (run* [q] (nom/fresh [a b] (conde 78 | [(nom/hash a `(~b ~(nom/tie b a)))] 79 | [(== q (nom/tie a b)) (nom/hash a q)] 80 | [(== q `(~b ~(nom/tie a a))) (nom/hash a q)]))) 81 | [(nom/tie 'a_0 'a_1) ['a_0 (nom/tie 'a_1 'a_1)]]))) 82 | 83 | (deftest test-nom-4 84 | (is (= (run* [q] (nom/fresh [a] (== (nom/tie a a) (nom/tie a a)))) '(_0))) 85 | (is (= (run* [q] (nom/fresh [a b] (== (nom/tie a a) (nom/tie b b)))) '(_0))) 86 | (is (= (run* [q] (nom/fresh [a] (== q (nom/tie a a)))) [(nom/tie 'a_0 'a_0)])) 87 | (is (= (run* [q] (nom/fresh [a b] (== q (nom/tie a ['foo a 3 b])))) [(nom/tie 'a_0 ['foo 'a_0 3 'a_1])])) 88 | (is (= (run* [q] (nom/fresh [a b] (== (nom/tie a q) (nom/tie b b)))) '(a_0))) 89 | ;; SET ORDER BUG 90 | #_(is (= (run* [q] 91 | (nom/fresh [a b] 92 | (fresh [x y] 93 | (== (nom/tie a (nom/tie a x)) (nom/tie a (nom/tie b y))) 94 | (== [a b x y] q)))) 95 | '(([a_0 a_1 _2 _3] :- a_1#_2 (swap [a_0 a_1] _3 _2))))) 96 | (is (= (run* [q] 97 | (nom/fresh [a b] 98 | (fresh [x y] 99 | (== (nom/tie a (nom/tie a x)) (nom/tie a (nom/tie b y))) 100 | (== x y)))) 101 | '(_0))) 102 | (is (= (run* [q] 103 | (nom/fresh [a b] 104 | (fresh [x y] 105 | (== (nom/tie a (nom/tie b [y b])) (nom/tie b (nom/tie a [a x]))) 106 | (== [x y] q)))) 107 | '((a_0 a_1)))) 108 | (is (= (run* [q] 109 | (nom/fresh [a b] 110 | (fresh [x y] 111 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 112 | (== [a b x y] q)))) 113 | '(([a_0 a_1 _2 _3] :- (swap [a_0 a_1] _2 _3))))) 114 | (is (= (run* [q] 115 | (nom/fresh [a b c d] 116 | (fresh [x y v z] 117 | (== y v) 118 | (== (nom/tie a (nom/tie b [x])) (nom/tie b (nom/tie a [v]))) 119 | (== (nom/tie c (nom/tie d [z])) v) 120 | (== (nom/tie a (nom/tie b [x])) y) 121 | (== [a b c d [x] [y] [z] [v]] q)))) 122 | '())) 123 | (is (= (run* [q] 124 | (nom/fresh [a b] 125 | (fresh [x y z] 126 | (== (nom/tie a (nom/tie b [y])) (nom/tie b (nom/tie a x))) 127 | (== (nom/tie a (nom/tie b [y])) (nom/tie b (nom/tie a z))) 128 | (== x [z]) 129 | (== [x y] q)))) 130 | '())) 131 | (is (= (run* [q] 132 | (nom/fresh [a b] 133 | (fresh [x y] 134 | (conde 135 | [(== (nom/tie a (nom/tie b [x b])) 136 | (nom/tie b (nom/tie a [a x])))] 137 | [(== (nom/tie a (nom/tie b [y b])) 138 | (nom/tie b (nom/tie a [a x])))] 139 | [(== (nom/tie a (nom/tie b [b y])) 140 | (nom/tie b (nom/tie a [a x])))] 141 | [(== (nom/tie a (nom/tie b [b y])) 142 | (nom/tie a (nom/tie a [a x])))]) 143 | (== [a b x y] q)))) 144 | '([a_0 a_1 a_0 a_1] 145 | ([a_0 a_1 _2 _3] :- (swap [a_0 a_1] _2 _3)) 146 | ([a_0 a_1 _2 _3] :- (swap [a_1 a_0] _2 _3) a_0#_3)))) 147 | (is (= (run* [q] 148 | (fresh [bx by] 149 | (nom/fresh [x y] 150 | (== (nom/tie x (nom/tie y by)) (nom/tie x (nom/tie x bx))) 151 | (== by ['foo q])))) 152 | '(_0))) 153 | (is (= (run* [q] 154 | (fresh [bx by] 155 | (nom/fresh [x y] 156 | (== (nom/tie x (nom/tie y by)) (nom/tie x (nom/tie x bx))) 157 | (== ['foo q] by)))) 158 | '(_0))) 159 | (is (= (run* [q] 160 | (nom/fresh [a b c d] 161 | (fresh [x y w z] 162 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 163 | (== (nom/tie c (nom/tie d [d z])) (nom/tie d (nom/tie c [c w]))) 164 | (== y z) 165 | (== y z)))) 166 | '(_0))) 167 | (is (= (run* [q] 168 | (nom/fresh [a b] 169 | (fresh [x y] 170 | (== (nom/tie a (nom/tie b [b [y]])) (nom/tie b (nom/tie a [a [x]]))) 171 | (conso 1 y q) 172 | (== y [1])))) 173 | '((1 1)))) 174 | (is (= (run* [q] 175 | (nom/fresh [a b] 176 | (fresh [x y] 177 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 178 | (== y ()) 179 | (== [a b x y] q)))) 180 | '((a_0 a_1 () ())))) 181 | (is (= (run* [q] 182 | (nom/fresh [a b] 183 | (fresh [x y] 184 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 185 | (== y 'foo) 186 | (== [a b x y] q)))) 187 | '((a_0 a_1 foo foo)))) 188 | (is (= (run* [q] 189 | (nom/fresh [a b] 190 | (fresh [x y] 191 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 192 | (== y nil) 193 | (== [a b x y] q)))) 194 | '((a_0 a_1 nil nil))))) 195 | 196 | (deftest test-nom-5 197 | (is (= (run* [q] 198 | (fresh [t u] 199 | (nom/fresh [a b c d] 200 | (== t ['lam (nom/tie a ['lam (nom/tie b ['var a])])]) 201 | (== u ['lam (nom/tie c ['lam (nom/tie d ['var c])])]) 202 | (== t u)))) 203 | '(_0))) 204 | (is (= (run* [q] 205 | (fresh [t u] 206 | (nom/fresh [a b c d] 207 | (== t ['lam (nom/tie a ['lam (nom/tie b ['var a])])]) 208 | (== u ['lam (nom/tie c ['lam (nom/tie d ['var d])])]) 209 | (== t u)))) 210 | '())) 211 | (is (= (run* [q] 212 | (fresh [x e1 e2] 213 | (nom/fresh [a b] 214 | (== x ['lam (nom/tie a e1)]) 215 | (== e1 ['var a]) 216 | (== x ['lam (nom/tie b e2)]) 217 | (== q x)))) 218 | [['lam (nom/tie 'a_0 ['var 'a_0])]])) 219 | (is (= (run* [q] 220 | (fresh [x e1 e2] 221 | (nom/fresh [a b] 222 | (== x ['lam (nom/tie a e1)]) 223 | (== e1 ['var a]) 224 | (== ['lam (nom/tie b e2)] x) 225 | (== q x)))) 226 | [['lam (nom/tie 'a_0 ['var 'a_0])]]))) 227 | 228 | (defn- substo [e new a out] 229 | (conde 230 | [(== ['var a] e) (== new out)] 231 | [(fresh [y] 232 | (== ['var y] e) 233 | (== ['var y] out) 234 | (nom/hash a y))] 235 | [(fresh [rator ratorres rand randres] 236 | (== ['app rator rand] e) 237 | (== ['app ratorres randres] out) 238 | (substo rator new a ratorres) 239 | (substo rand new a randres))] 240 | [(fresh [body bodyres] 241 | (nom/fresh [c] 242 | (== ['lam (nom/tie c body)] e) 243 | (== ['lam (nom/tie c bodyres)] out) 244 | (nom/hash c a) 245 | (nom/hash c new) 246 | (substo body new a bodyres)))])) 247 | 248 | (deftest test-nom-6 249 | (is (= (run* [q] 250 | (nom/fresh [a b] 251 | (substo ['lam (nom/tie a ['app ['var a] ['var b]])] 252 | ['var b] 253 | a 254 | q))) 255 | [['lam (nom/tie 'a_0 '(app (var a_0) (var a_1)))]])) 256 | (is (= (run* [q] 257 | (nom/fresh [a b] 258 | (substo ['lam (nom/tie a ['var b])] 259 | ['var a] 260 | b 261 | q))) 262 | [['lam (nom/tie 'a_0 '(var a_1))]]))) 263 | 264 | (defn- lookupo [x tx g] 265 | (fresh [a d] 266 | (conso a d g) 267 | (conde 268 | [(== [x tx] a)] 269 | [(fresh [xc txc] 270 | (== [xc txc] a) 271 | (nom/hash x xc) 272 | (lookupo x tx d))]))) 273 | 274 | (defn- typo [g e te] 275 | (conde 276 | [(fresh [x] 277 | (== ['var x] e) 278 | (lookupo x te g))] 279 | [(fresh [rator trator rand trand] 280 | (== ['app rator rand] e) 281 | (== ['-> trand te] trator) 282 | (typo g rator trator) 283 | (typo g rand trand))] 284 | [(fresh [ec tec trand gc] 285 | (nom/fresh [b] 286 | (== ['lam (nom/tie b ec)] e) 287 | (== ['-> trand tec] te) 288 | (nom/hash b g) 289 | (conso [b trand] g gc) 290 | (typo gc ec tec)))])) 291 | 292 | (deftest test-nom-7 293 | (is (= (run* [q] 294 | (nom/fresh [c d] 295 | (typo [] ['lam (nom/tie c ['lam (nom/tie d ['var c])])] q))) 296 | '((-> _0 (-> _1 _0))))) 297 | (is (= (run* [q] 298 | (nom/fresh [c] 299 | (typo [] ['lam (nom/tie c ['app ['var c] ['var c]])] q))) 300 | '())) 301 | (is (= (run 2 [q] (typo [] q '(-> int int))) 302 | [['lam (nom/tie 'a_0 '(var a_0))] 303 | ['lam (nom/tie 'a_0 ['app ['lam (nom/tie 'a_1 '(var a_1))] '(var a_0)])]]))) 304 | 305 | (deftest test-nom-mix-1 306 | (is (= (run* [q] (nom/fresh [a b] (!= a b))) '(_0))) 307 | (is (= (run* [q] 308 | (nom/fresh [a b] 309 | (fresh [x y] 310 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 311 | (fd/in x (fd/interval 1 3)) 312 | (== [x y] q)))) 313 | '([1 1] [2 2] [3 3]))) 314 | (is (= (run* [q] 315 | (nom/fresh [a b] 316 | (fresh [x y] 317 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 318 | (fd/in y (fd/interval 1 3)) 319 | (== [x y] q)))) 320 | '([1 1] [2 2] [3 3]))) 321 | (is (= (run* [q] 322 | (nom/fresh [a b] 323 | (fresh [x y] 324 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 325 | (== x a) 326 | (!= x y) 327 | (== [x y] q)))) 328 | '([a_0 a_1]))) 329 | (is (= (run* [q] 330 | (nom/fresh [a b] 331 | (fresh [x y] 332 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 333 | (!= x y) 334 | (== x a) 335 | (== [x y] q)))) 336 | '([a_0 a_1]))) 337 | (is (= (run* [q] 338 | (nom/fresh [a b] 339 | (fresh [x y] 340 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 341 | (== x 'foo) 342 | (!= x y) 343 | (== [x y] q)))) 344 | '())) 345 | (is (= (run* [q] 346 | (nom/fresh [a b] 347 | (fresh [x y] 348 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 349 | (!= x y) 350 | (== x 'foo) 351 | (== [x y] q)))) 352 | '())) 353 | (is (= (run* [q] 354 | (nom/fresh [a b] 355 | (fresh [x y] 356 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 357 | (== y 'foo) 358 | (predc x number? `number?) 359 | (== [x y] q)))) 360 | '())) 361 | (is (= (run* [q] 362 | (nom/fresh [a b] 363 | (fresh [x y] 364 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 365 | (predc x number? `number?) 366 | (== y 'foo) 367 | (== [x y] q)))) 368 | '()))) 369 | 370 | ;; tickets 371 | 372 | (deftest test-91-predc-not-purged 373 | (is (= (run* [q] 374 | (nom/fresh [a] 375 | (fresh [x] 376 | (predc x number? `number?) 377 | (== x 1) 378 | (== (nom/tie a [a x]) q)))) 379 | [(nom/tie 'a_0 '(a_0 1))])) 380 | (is (= (run* [q] 381 | (nom/fresh [a] 382 | (fresh [x] 383 | (== x 1) 384 | (predc x number? `number?) 385 | (== (nom/tie a [a x]) q)))) 386 | [(nom/tie 'a_0 '(a_0 1))]))) 387 | 388 | (deftest test-92-fd-in-lost 389 | (is (= (run* [q] 390 | (fresh [x] 391 | (nom/fresh [a] 392 | (fd/in x (fd/interval 1 3)) 393 | (== q (nom/tie a x))))) 394 | [(nom/tie 'a_0 1) (nom/tie 'a_0 2) (nom/tie 'a_0 3)])) 395 | (is (= (run* [q] 396 | (nom/fresh [a b c] 397 | (fresh [x] 398 | (fd/in x (fd/interval 1 3)) 399 | (== (nom/tie b (nom/tie a x)) (nom/tie c q))))) 400 | [(nom/tie 'a_0 1) (nom/tie 'a_0 2) (nom/tie 'a_0 3)]))) 401 | 402 | (deftest test-95-nominal-disequality 403 | (is (= (run* [q] 404 | (nom/fresh [a b] 405 | (fresh [x y] 406 | (!= x y) 407 | (== (nom/tie a (nom/tie b [b y])) (nom/tie b (nom/tie a [a x]))) 408 | (== x 'foo) 409 | (== [x y] q)))) 410 | ()))) 411 | 412 | (deftest test-98-entanglement 413 | (is (= (run* [q] 414 | (nom/fresh [a b c] 415 | (fresh [x y] 416 | (== (nom/tie b (nom/tie a x)) (nom/tie c q)) 417 | (fd/in x (fd/interval 1 3))))) 418 | [(nom/tie 'a_0 1) (nom/tie 'a_0 2) (nom/tie 'a_0 3)])) 419 | (is (= (run* [q] 420 | (nom/fresh [a b c] 421 | (fresh [x y] 422 | (fd/in y (fd/interval 1 3)) 423 | (== (nom/tie b (nom/tie a x)) (nom/tie c q)) 424 | (== x y)))) 425 | [(nom/tie 'a_0 1) (nom/tie 'a_0 2) (nom/tie 'a_0 3)])) 426 | (is (= (run* [q] 427 | (nom/fresh [a b c d] 428 | (fresh [x y z] 429 | (== (nom/tie b (nom/tie a x)) (nom/tie c z)) 430 | (fd/in x (fd/interval 1 3)) 431 | (== (nom/tie d q) z)))) 432 | '(1 2 3)))) 433 | 434 | (deftest test-101-variable-nom-in-hash 435 | (is (= (run* [q] 436 | (nom/fresh [x] 437 | (fresh [y] 438 | (predc y nom? `nom?) 439 | (nom/hash y x) 440 | (== x y)))) 441 | ()))) 442 | 443 | (deftest test-102-not-nom-in-hash-and-tweaks 444 | (is (= (run* [q] 445 | (fresh [y] 446 | (nom/hash y q) 447 | (== y 'foo))) 448 | ;; fails b/c of implicit nom?-check on y 449 | ())) 450 | (is (= (run* [q] 451 | (fresh [y] 452 | (nom/hash y y))) 453 | ())) 454 | (is (= (run* [q] 455 | (fresh [x y w z] 456 | (nom/hash y [x z]) 457 | (== z [w]) 458 | (== y w) 459 | (== q [y w z]))) 460 | ())) 461 | (is (= (run* [q] 462 | (fresh [y w z] 463 | (nom/hash y z) 464 | (== z [w]) 465 | (== y w) 466 | (== q [y w z]))) 467 | ())) 468 | (is (= (run* [q] 469 | (nom/fresh [x] 470 | (fresh [y w z] 471 | (nom/hash y z) 472 | (== z [w]) 473 | (== y x) 474 | (== q [x y w z])))) 475 | '(([a_0 a_0 _1 [_1]] :- a_0#_1)))) 476 | (is (= (run* [q] 477 | (fresh [x y w z] 478 | (nom/hash y z) 479 | (== z [w]) 480 | (== y x) 481 | (== q [x y w z]))) 482 | '(([_0 _0 _1 [_1]] :- _0#_1))))) 483 | 484 | (deftest test-104-merge-complex-nom-doms 485 | (is (= (run* [q] 486 | (nom/fresh [a b c d] 487 | (fresh [x y z] 488 | (== (nom/tie a (nom/tie b y)) (nom/tie b (nom/tie a x))) 489 | (== (nom/tie c (nom/tie d x)) (nom/tie d (nom/tie c z))) 490 | (== x y) 491 | (== z x)))) 492 | '(_0)))) 493 | 494 | (deftest test-no-dup-reified-freshness-constraints 495 | ;; SET ORDER TEST 496 | #_(is (= (run* [q] 497 | (fresh [x y] 498 | (nom/fresh [a b] 499 | (== (nom/tie a x) (nom/tie b y)) 500 | (== [a b x y] q) 501 | (== x y)))) 502 | '(([a_0 a_1 _2 _2] :- a_1#_2 a_0#_2)))) 503 | (is (= (run* [q] 504 | (fresh [x] 505 | (nom/fresh [a] 506 | (nom/hash a x) 507 | (nom/hash a x) 508 | (== q [x a])))) 509 | '(([_0 a_1] :- a_1#_0))))) 510 | 511 | (deftest test-logic-119-tie-disequality-1 512 | (is (= (run* [q] 513 | (nom/fresh [a] 514 | (!= (nom/tie a a) 'foo))) 515 | '(_0))) 516 | (is (= (run* [q] 517 | (nom/fresh [a] 518 | (!= (nom/tie a a) (nom/tie a a)))) 519 | '())) 520 | (is (= (run* [q] 521 | (nom/fresh [a b] 522 | (!= (nom/tie a a) (nom/tie a b)))) 523 | '(_0))) 524 | (comment ;; this one will be tricky to get right. 525 | (is (= (run* [q] 526 | (nom/fresh [a b] 527 | (!= (nom/tie a a) (nom/tie b b)))) 528 | '())))) 529 | 530 | (deftest test-logic-127-nomswap-maps 531 | (is (= (run* [q] 532 | (fresh [body] 533 | (nom/fresh [a b] 534 | (== (nom/tie a {:k a}) (nom/tie b body)) 535 | (== {:k q} body)))) 536 | '(a_0)))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/bench.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.bench 10 | (:refer-clojure :exclude [==]) 11 | (:use [clojure.core.logic :as l]) 12 | (:require [clojure.core.logic.arithmetic :as a] 13 | [clojure.core.logic.fd :as fd] 14 | [clojure.core.logic.pldb :as pldb] 15 | [clojure.repl :as r] 16 | [clojure.pprint :as pp] 17 | [clojure.set :as set])) 18 | 19 | (comment 20 | (run* [q] 21 | (== q true)) 22 | 23 | (dotimes [_ 10] 24 | (time 25 | (dotimes [_ 1e6] 26 | (doall 27 | (run* [q] 28 | (== q true)))))) 29 | ) 30 | 31 | (comment 32 | (run 1 [q] 33 | (fresh [x y] 34 | (appendo x y q))) 35 | 36 | ;; 453ms 37 | (dotimes [_ 5] 38 | (time 39 | (dotimes [_ 1] 40 | (doall 41 | (run 700 [q] 42 | (fresh [x y] 43 | (appendo x y q))))))) 44 | ) 45 | 46 | ;; ============================================================================= 47 | ;; nrev 48 | ;; ============================================================================= 49 | 50 | (defne nrevo [l o] 51 | ([() ()]) 52 | ([[a . d] _] 53 | (fresh [r] 54 | (nrevo d r) 55 | (appendo r [a] o)))) 56 | 57 | (comment 58 | ;; we can run backwards, unlike Prolog 59 | (run 1 [q] (nrevo q (range 30))) 60 | 61 | ;; SWI-Prolog 0.06-0.08s 62 | ;; ~3.7s 63 | (let [data (into [] (range 30))] 64 | (dotimes [_ 5] 65 | (time 66 | (dotimes [_ 1e3] 67 | (doall (run-nc 1 [q] (nrevo data q))))))) 68 | 69 | ;; the LIPS are ridiculously high for SWI-Prolog 70 | ;; clearly nrev is a case that SWI-Prolog can optimize away 71 | ) 72 | 73 | ;; ============================================================================= 74 | ;; zebra 75 | ;; ============================================================================= 76 | 77 | (defne righto [x y l] 78 | ([_ _ [x y . r]]) 79 | ([_ _ [_ . r]] (righto x y r))) 80 | 81 | (defn nexto [x y l] 82 | (conde 83 | [(righto x y l)] 84 | [(righto y x l)])) 85 | 86 | (defn zebrao [hs] 87 | (all 88 | (== [(lvar) (lvar) [(lvar) (lvar) 'milk (lvar) (lvar)] (lvar) (lvar)] hs) 89 | (firsto hs ['norwegian (lvar) (lvar) (lvar) (lvar)]) 90 | (nexto ['norwegian (lvar) (lvar) (lvar) (lvar)] [(lvar) (lvar) (lvar) (lvar) 'blue] hs) 91 | (righto [(lvar) (lvar) (lvar) (lvar) 'ivory] [(lvar) (lvar) (lvar) (lvar) 'green] hs) 92 | (membero ['englishman (lvar) (lvar) (lvar) 'red] hs) 93 | (membero [(lvar) 'kools (lvar) (lvar) 'yellow] hs) 94 | (membero ['spaniard (lvar) (lvar) 'dog (lvar)] hs) 95 | (membero [(lvar) (lvar) 'coffee (lvar) 'green] hs) 96 | (membero ['ukrainian (lvar) 'tea (lvar) (lvar)] hs) 97 | (membero [(lvar) 'lucky-strikes 'oj (lvar) (lvar)] hs) 98 | (membero ['japanese 'parliaments (lvar) (lvar) (lvar)] hs) 99 | (membero [(lvar) 'oldgolds (lvar) 'snails (lvar)] hs) 100 | (nexto [(lvar) (lvar) (lvar) 'horse (lvar)] [(lvar) 'kools (lvar) (lvar) (lvar)] hs) 101 | (nexto [(lvar) (lvar) (lvar) 'fox (lvar)] [(lvar) 'chesterfields (lvar) (lvar) (lvar)] hs))) 102 | 103 | (comment 104 | (run 1 [q] (zebrao q)) 105 | 106 | ;; SWI-Prolog 6-8.5s 107 | ;; now 2.5-2.6s, old days <2.4s 108 | (dotimes [_ 5] 109 | (time 110 | (dotimes [_ 1e3] 111 | (doall (run-nc 1 [q] (zebrao q)))))) 112 | 113 | ;; now ~4s, in old days closer to ~3.7s 114 | (dotimes [_ 5] 115 | (time 116 | (dotimes [_ 1e3] 117 | (doall (run 1 [q] (zebrao q)))))) 118 | ) 119 | 120 | ;; ============================================================================= 121 | ;; cliques 122 | 123 | (pldb/db-rel connected ^:index x ^:index y) 124 | 125 | (def connected-db 126 | (pldb/db 127 | [connected 1 2] 128 | [connected 1 5] 129 | [connected 2 1] 130 | [connected 2 3] 131 | [connected 2 5] 132 | [connected 3 2] 133 | [connected 3 4] 134 | [connected 4 3] 135 | [connected 4 5] 136 | [connected 4 6] 137 | [connected 5 1] 138 | [connected 5 2] 139 | [connected 5 4] 140 | [connected 6 4])) 141 | 142 | (defne connected-to-allo 143 | "Ensure that vertex v is connected to all vertices 144 | vs." 145 | [v vs] 146 | ([_ ()]) 147 | ([_ [vh . vr]] 148 | (connected v vh) 149 | (connected-to-allo v vr))) 150 | 151 | (defne all-connected-to-allo 152 | "Collect all cliques in l. l must be bounded to ensure 153 | termination." 154 | [l] 155 | ([()]) 156 | ([[h . t]] 157 | (connected-to-allo h t) 158 | (all-connected-to-allo t))) 159 | 160 | (comment 161 | (pldb/with-db connected-db 162 | (run-nc* [q] 163 | (fresh [a b d] 164 | (== q (llist a b d)) 165 | (fd/bounded-listo q 6) 166 | (all-connected-to-allo q)))) 167 | 168 | ;; 350-400ms 169 | (dotimes [_ 5] 170 | (time 171 | (dotimes [_ 100] 172 | (doall 173 | (pldb/with-db connected-db 174 | (run-nc 20 [q] 175 | (fresh [a b d] 176 | (== q (llist a b d)) 177 | (fd/bounded-listo q 6) 178 | (all-connected-to-allo q)))))))) 179 | ) 180 | 181 | ;; ============================================================================= 182 | ;; nqueens 183 | 184 | ;; Bratko 3d pg 103 185 | 186 | (comment 187 | (declare noattacko) 188 | 189 | (defne nqueenso [l] 190 | ([()]) 191 | ([[[x y] . others]] 192 | (nqueenso others) 193 | (membero y [1 2 3 4 5 6 7 8]) 194 | (noattacko [x y] others))) 195 | 196 | (defne noattacko [q others] 197 | ([_ ()]) 198 | ([[x y] [[x1 y1] . r]] 199 | (!= y y1) 200 | (project [y y1 x x1] 201 | (!= (- y1 y) (- x1 x)) 202 | (!= (- y1 y) (- x x1))) 203 | (noattacko [x y] r))) 204 | 205 | (defn solve-nqueens [] 206 | (run-nc* [q] 207 | (fresh [y1 y2 y3 y4 y5 y6 y7 y8] 208 | (== q [[1 y1] [2 y2] [3 y3] [4 y4] [5 y5] [6 y6] [7 y7] [8 y8]]) 209 | (nqueenso q)))) 210 | ) 211 | 212 | (comment 213 | (take 1 (solve-nqueens)) 214 | 215 | ;; 92 solutions 216 | (count (solve-nqueens)) 217 | 218 | ;; < 3s for 100x 219 | ;; about 18X slower that SWI 220 | (dotimes [_ 5] 221 | (time 222 | (dotimes [_ 1] 223 | (doall (take 1 (solve-nqueens)))))) 224 | 225 | ;; ~550ms 226 | (dotimes [_ 10] 227 | (time 228 | (dotimes [_ 1] 229 | (doall (solve-nqueens))))) 230 | 231 | ;; ~610ms 232 | (dotimes [_ 10] 233 | (time 234 | (dotimes [_ 1] 235 | (doall (solve-nqueens))))) 236 | 237 | ;; nqueens benefits from constraints 238 | ) 239 | 240 | ;; ============================================================================= 241 | ;; nqueensfd 242 | 243 | ;; based on Bratko 3d pg 344, constraint version 244 | 245 | (comment 246 | ;; direct translation does not work 247 | ;; because of the subtraction constraints 248 | ;; also, some domain inference would be nice 249 | 250 | (defne noattackfd [y ys d] 251 | ([_ () _]) 252 | ([y1 [y2 . yr] d] 253 | (fresh [x nd] 254 | (fd/in x nd (fd/interval 1 8)) 255 | (fd/!= d x) 256 | (conde 257 | [(fd/< y1 y2) (fd/+ y1 x y2)] 258 | [(fd/< y2 y1) (fd/+ y2 x y1)]) 259 | (fd/+ d 1 nd) 260 | (noattackfd y1 yr nd))) 261 | 262 | (defne safefd [l] 263 | ([()]) 264 | ([[y . ys]] 265 | (noattackfd y ys 1) 266 | (safefd ys)))) 267 | 268 | (defn nqueensfd [] 269 | (run* [q] 270 | (fresh [a b c d e f g h] 271 | (fd/in a b c d e f g h (fd/interval 1 8)) 272 | (== q [a b c d e f g h]) 273 | (fd/distinct q) 274 | (safefd q)))) 275 | 276 | (nqueensfd) 277 | 278 | (run* [q] 279 | (fresh [a b] 280 | (fd/in a b (fd/interval 1 8)) 281 | (== q [a b]) 282 | (safefd q))) 283 | ) 284 | 285 | ;; ============================================================================= 286 | ;; send more money 287 | 288 | (defne takeouto [x l y] 289 | ([_ [x . y] _]) 290 | ([_ [h . t] [h . r]] (takeouto x t r))) 291 | 292 | (defn digito [x l y] 293 | (takeouto x l y)) 294 | 295 | (defn first-digito [x l y] 296 | (all 297 | (digito x l y) 298 | (a/> x 0))) 299 | 300 | (defne do-send-moolao [q l ll] 301 | ([[send more money] _ _] 302 | (fresh [s e n d m o r y 303 | l1 l2 l3 l4 l5 l6 l7 l8 l9] 304 | (first-digito s l l1) 305 | (first-digito m l1 l2) 306 | (digito e l2 l3) 307 | (digito n l3 l4) 308 | (digito d l4 l5) 309 | (digito o l5 l6) 310 | (digito r l6 l7) 311 | (digito y l7 l8) 312 | (project [s e n d m o r y] 313 | (== send (+ (* s 1000) (* e 100) (* n 10) d)) 314 | (== more (+ (* m 1000) (* o 100) (* r 10) e)) 315 | (== money (+ (* m 10000) (* o 1000) (* n 100) (* e 10) y)) 316 | (project [send more] 317 | (== money (+ send more))))))) 318 | 319 | (defn send-money-quicklyo [send more money] 320 | (fresh [l] 321 | (do-send-moolao [send more money] (range 10) l))) 322 | 323 | (comment 324 | ;; ~16-17s, w/o occurs-check 325 | ;; SWI-Prolog takes 4s, so 3.8X faster 326 | ;; again I suspect the overhead here is from 327 | ;; interleaving, need to figure 328 | (time 329 | (run-nc 1 [q] 330 | (fresh [send more money] 331 | (send-money-quicklyo send more money) 332 | (== [send more money] q)))) 333 | ) 334 | 335 | ;; ============================================================================= 336 | ;; Cryptarithmetic Puzzle 337 | 338 | (defn cryptarithfd-1 [] 339 | (run-nc* [s e n d m o r y :as q] 340 | (fd/in s e n d m o r y (fd/interval 0 9)) 341 | (fd/distinct q) 342 | (distribute q ::l/ff) 343 | (fd/!= m 0) (fd/!= s 0) 344 | (fd/eq 345 | (= (+ (* 1000 s) (* 100 e) (* 10 n) d 346 | (* 1000 m) (* 100 o) (* 10 r) e) 347 | (+ (* 10000 m) (* 1000 o) (* 100 n) (* 10 e) y))))) 348 | 349 | ;; Bratko 3rd ed pg 343 350 | 351 | (defn cryptarithfd-2 [] 352 | (run-nc* [d o n a l g e r b t :as q] 353 | (distribute q ::l/ff) 354 | (fd/in d o n a l g e r b t (fd/interval 0 9)) 355 | (fd/distinct q) 356 | (fd/eq 357 | (= (+ (* 100000 d) (* 10000 o) (* 1000 n) (* 100 a) (* 10 l) d 358 | (* 100000 g) (* 10000 e) (* 1000 r) (* 100 a) (* 10 l) d) 359 | (+ (* 100000 r) (* 10000 o) (* 1000 b) (* 100 e) (* 10 r) t))))) 360 | 361 | (comment 362 | ;; FIXME: we don't see as much propagation as Oz, why not? 363 | 364 | (cryptarithfd-1) 365 | 366 | (time (cryptarithfd-1)) 367 | 368 | ;; ~1050ms, a little bit slower w/ distribute step 369 | (dotimes [_ 5] 370 | (time 371 | (dotimes [_ 100] 372 | (doall (cryptarithfd-1))))) 373 | 374 | ;; 3X slower still 375 | (dotimes [_ 5] 376 | (time 377 | (dotimes [_ 10] 378 | (doall (cryptarithfd-1))))) 379 | 380 | ;; WORKS: takes a long time ([5 2 6 4 8 1 9 7 3 0]) 381 | ;; ~1.3s now 382 | (dotimes [_ 5] 383 | (time (doall (cryptarithfd-2)))) 384 | ) 385 | 386 | ;; ============================================================================= 387 | ;; Hanoi 388 | 389 | (defne moveo [n x y z] 390 | ([1 _ _ _] 391 | (trace-lvars "Move top disk from " x) 392 | (trace-lvars " to " y)) 393 | ([_ _ _ _] 394 | (pred n #(> % 1)) 395 | (fresh [m _] (is m n dec) 396 | (moveo m x z y) (moveo 1 x y _) (moveo m z y x)))) 397 | 398 | (comment 399 | (run* [q] 400 | (moveo 3 :left :right :center)) 401 | ) 402 | 403 | ;; ============================================================================= 404 | ;; Quick Sort 405 | 406 | (declare partitiono) 407 | 408 | (defne qsorto [l r r0] 409 | ([[] _ r]) 410 | ([[x . lr] _ _] 411 | (fresh [l1 l2 r1] 412 | (partitiono lr x l1 l2) 413 | (qsorto l2 r1 r0) 414 | (qsorto l1 r (lcons x r1))))) 415 | 416 | (defne partitiono [a b c d] 417 | ([[x . l] _ [x . l1] _] 418 | (conda 419 | ((project [x b] 420 | (== (<= x b) true)) 421 | (partitiono l b l1 d)) 422 | (partitiono l b c d)))) 423 | 424 | ;; ============================================================================= 425 | ;; Dinesman Dwelling Problem with CLP(FD) 426 | 427 | (defn not-adjacento [x y] 428 | (fresh [f] 429 | (fd/in f (fd/interval 1 5)) 430 | (conde 431 | [(fd/+ x f y) (fd/< 1 f)] 432 | [(fd/+ y f x) (fd/< 1 f)]))) 433 | 434 | (defn dinesmanfd [] 435 | (run* [baker cooper fletcher miller smith :as vs] 436 | (fd/distinct vs) 437 | (everyg #(fd/in % (fd/interval 1 5)) vs) 438 | (fd/!= baker 5) (fd/!= cooper 1) 439 | (fd/!= fletcher 5) (fd/!= fletcher 1) 440 | (fd/< cooper miller) 441 | (not-adjacento smith fletcher) 442 | (not-adjacento fletcher cooper))) 443 | 444 | (defn sort-dwellers [[fa _] [fb _]] 445 | (cond (< fa fb) -1 (= fa fb) 0 :else 1)) 446 | 447 | (defn ->answer [ns] 448 | (->> (map vector ns [:baker :cooper :fletcher :miller :smith]) 449 | (sort sort-dwellers) 450 | (map second))) 451 | 452 | (comment 453 | (time (doall (dinesmanfd))) 454 | ;; close to 2X faster than Petite Chez 455 | ;; ~1942ms 456 | (dotimes [_ 5] 457 | (time 458 | (dotimes [_ 1000] 459 | (doall (dinesmanfd))))) 460 | 461 | (-> (dinesmanfd) first ->answer) ; (:smith :cooper :baker :fletcher :miller) 462 | ) 463 | 464 | ;; ============================================================================= 465 | ;; Simple 466 | 467 | (defn simplefd [] 468 | (run* [x y] 469 | (fd/in x y (fd/interval 0 9)) 470 | (fd/+ x y 9) 471 | (fresh [p0 p1] 472 | (fd/* 2 x p0) 473 | (fd/* 4 y p1) 474 | (fd/+ p0 p1 24)))) 475 | 476 | ;; with fd/eq sugar 477 | 478 | (defn simple-fd-eq [] 479 | (run* [x y] 480 | (fd/in x y (fd/interval 0 9)) 481 | (fd/eq 482 | (= (+ x y) 9) 483 | (= (+ (* x 2) (* y 4)) 24)))) 484 | 485 | (comment 486 | ;; "Finite Domain Constraint Programming in Oz. A Tutorial." (Schulte & Smolka) 487 | ;; currently none of the constraints above trigger any refinements! 488 | (simplefd) 489 | 490 | (simple-fd-eq) 491 | 492 | ;; 620ms 493 | (dotimes [_ 10] 494 | (time 495 | (dotimes [_ 1e3] 496 | (doall (simple-fd-eq))))) 497 | 498 | (run* [q] 499 | (fresh [a b] 500 | (fd/* a 3 34) 501 | (debug-doms))) 502 | ) 503 | 504 | ;; ============================================================================= 505 | ;; Stone Problem 506 | 507 | ;; w - is a stone (weight) 508 | ;; sl - stone (weight) list 509 | ;; r - the input range we can construct 510 | ;; o - the output range we can construct 511 | ;; n - the bound 512 | 513 | (defne subchecko [w sl r o n] 514 | ;; we have no more stones to test in sl to test w with 515 | ([_ () _ _ _] 516 | (fresh [hr] 517 | (fd/in hr (fd/interval 1 n)) 518 | (matche [r o] 519 | ;; r is not empty, we add w to the output only if 520 | ;; w is head of r + 1 521 | ([[hr . _] [w . r]] (fd/+ hr 1 w)) 522 | ;; r is empty, just add the weight 523 | ;; only works for w == 1 524 | ([() [w . r]])))) 525 | ;; we have stones to in sl to test w with 526 | ([_ [hsl . rsl] _ _ _] 527 | (fresh [w-hsl w+hsl o0 o1 nw] 528 | (fd/in hsl w-hsl w+hsl (fd/interval 1 n)) 529 | (fd/+ hsl w-hsl w) (fd/+ hsl w w+hsl) 530 | ;; attempt to construct values prior w 531 | (subchecko w-hsl rsl r o0 n) 532 | ;; attempt to construct values around w 533 | (subchecko w rsl o0 o1 n) 534 | ;; attempt to construct values after w 535 | (subchecko w+hsl rsl o1 o n)))) 536 | 537 | ;; checks that list of weight can produce the list 538 | ;; of integers from 1 to 40, in reverse order (40 ... 1) 539 | (defne checko [ws sl r n] 540 | ;; if ws is empty, the first element of r must be n 541 | ([() _ [a . _] a]) 542 | ;; otherwise we check the first weight 543 | ([[w . wr] _ _ _] 544 | (fresh [nsl nr] 545 | ;; check the first weight with subchecko 546 | (subchecko w sl r nr n) 547 | ;; if it succeeds we add w to the new stone list 548 | (conso w sl nsl) 549 | ;; check remaining weights 550 | (checko wr nsl nr n)))) 551 | 552 | (defn matches [n] 553 | (run 1 [a b c d] 554 | (fd/in a b c d (fd/interval 1 n)) 555 | (fd/distinct [a b c d]) 556 | (== a 1) 557 | (fd/<= a b) (fd/<= b c) (fd/<= c d) 558 | (fd/eq (= (+ a b c d) n)) 559 | (checko [a b c d] () () n))) 560 | 561 | (comment 562 | (time (doall (matches 40))) 563 | 564 | ;; ~6.3s 565 | (dotimes [_ 5] 566 | (time 567 | (dotimes [_ 1000] 568 | (doall (matches 40))))) 569 | ) 570 | 571 | ;; ============================================================================= 572 | ;; Sudoku 573 | 574 | ;; ----------------------------------------------------------------------------- 575 | ;; small 576 | 577 | (defn small-sudokufd [] 578 | (run-nc 1 [q] 579 | (fresh [a1 a2 a3 a4 580 | b1 b2 b3 b4 581 | c1 c2 c3 c4 582 | d1 d2 d3 d4] 583 | (== q [[a1 a2 a3 a4] 584 | [b1 b2 b3 b4] 585 | [c1 c2 c3 c4] 586 | [d1 d2 d3 d4]]) 587 | (fd/in a1 a2 a3 a4 588 | b1 b2 b3 b4 589 | c1 c2 c3 c4 590 | d1 d2 d3 d4 591 | (fd/domain 1 2 3 4)) 592 | (let [row1 [a1 a2 a3 a4] 593 | row2 [b1 b2 b3 b4] 594 | row3 [c1 c2 c3 c4] 595 | row4 [d1 d2 d3 d4] 596 | col1 [a1 b1 c1 d1] 597 | col2 [a2 b2 c2 d2] 598 | col3 [a3 b3 c3 d3] 599 | col4 [a4 b4 c4 d4] 600 | sq1 [a1 a2 b1 b2] 601 | sq2 [a3 a4 b3 b4] 602 | sq3 [c1 c2 d1 d2] 603 | sq4 [c3 c4 d3 d4]] 604 | (everyg fd/distinct 605 | [row1 row2 row3 row4 606 | col1 col2 col3 col4 607 | sq1 sq2 sq3 sq4]))))) 608 | 609 | (comment 610 | ;; 1.9s 611 | (dotimes [_ 10] 612 | (time 613 | (dotimes [_ 1e3] 614 | (doall (small-sudokufd))))) 615 | 616 | (small-sudokufd) 617 | ) 618 | 619 | ;; ----------------------------------------------------------------------------- 620 | ;; 9x9 621 | 622 | (defn get-square [rows x y] 623 | (for [x (range x (+ x 3)) 624 | y (range y (+ y 3))] 625 | (get-in rows [x y]))) 626 | 627 | (defn init [vars hints] 628 | (if (seq vars) 629 | (let [hint (first hints)] 630 | (all 631 | (if-not (zero? hint) 632 | (== (first vars) hint) 633 | succeed) 634 | (init (next vars) (next hints)))) 635 | succeed)) 636 | 637 | (defn ->rows [xs] 638 | (->> xs (partition 9) (map vec) (into []))) 639 | 640 | (defn ->cols [rows] 641 | (apply map vector rows)) 642 | 643 | (defn ->squares [rows] 644 | (for [x (range 0 9 3) 645 | y (range 0 9 3)] 646 | (get-square rows x y))) 647 | 648 | (defn sudokufd [hints] 649 | (let [vars (repeatedly 81 lvar) 650 | rows (->rows vars) 651 | cols (->cols rows) 652 | sqs (->squares rows)] 653 | (run-nc 1 [q] 654 | (== q vars) 655 | ;;(distribute q ::l/ff) 656 | (everyg #(fd/in % (fd/domain 1 2 3 4 5 6 7 8 9)) vars) 657 | (init vars hints) 658 | (everyg fd/distinct rows) 659 | (everyg fd/distinct cols) 660 | (everyg fd/distinct sqs)))) 661 | 662 | ;; Helpers 663 | 664 | (defn verify [vars] 665 | (let [rows (->rows vars) 666 | cols (->cols rows) 667 | sqs (->squares rows) 668 | verify-group (fn [group] 669 | (every? #(= (->> % (into #{}) count) 9) 670 | group))] 671 | (and (verify-group rows) 672 | (verify-group cols) 673 | (verify-group sqs)))) 674 | 675 | (defn print-solution [vars] 676 | (doseq [row-group (->> vars 677 | (partition 9) 678 | (partition 3) 679 | (interpose "\n\n"))] 680 | (if-not (string? row-group) 681 | (doseq [row (interpose "\n" row-group)] 682 | (if-not (string? row) 683 | (doseq [x (->> row 684 | (partition 3) 685 | (map #(interpose " " %)) 686 | (interpose " "))] 687 | (print (apply str x))) 688 | (print row))) 689 | (print row-group))) 690 | (println) (println)) 691 | 692 | (comment 693 | (def easy0 694 | [0 0 3 0 2 0 6 0 0 695 | 9 0 0 3 0 5 0 0 1 696 | 0 0 1 8 0 6 4 0 0 697 | 698 | 0 0 8 1 0 2 9 0 0 699 | 7 0 0 0 0 0 0 0 8 700 | 0 0 6 7 0 8 2 0 0 701 | 702 | 0 0 2 6 0 9 5 0 0 703 | 8 0 0 2 0 3 0 0 9 704 | 0 0 5 0 1 0 3 0 0]) 705 | 706 | (def easy1 707 | [2 0 0 0 8 0 3 0 0 708 | 0 6 0 0 7 0 0 8 4 709 | 0 3 0 5 0 0 2 0 9 710 | 711 | 0 0 0 1 0 5 4 0 8 712 | 0 0 0 0 0 0 0 0 0 713 | 4 0 2 7 0 6 0 0 0 714 | 715 | 3 0 1 0 0 7 0 4 0 716 | 7 2 0 0 4 0 0 6 0 717 | 0 0 4 0 1 0 0 0 3]) 718 | 719 | (sudokufd easy0) 720 | (time (doall (sudokufd easy0))) 721 | 722 | (sudokufd easy1) 723 | (time (sudokufd easy1)) 724 | 725 | (-> (sudokufd easy0) first print-solution) 726 | 727 | (-> (sudokufd easy0) first verify) 728 | 729 | ;; ~900ms w/o distribute 730 | (dotimes [_ 5] 731 | (time 732 | (dotimes [_ 100] 733 | (doall (sudokufd easy0))))) 734 | 735 | ;; ~1000ms w/o distribute 736 | (dotimes [_ 5] 737 | (time 738 | (dotimes [_ 100] 739 | (doall (sudokufd easy1))))) 740 | 741 | ;; Hardest Norvig Random 742 | (def hard0 743 | [0 0 0 0 0 6 0 0 0 744 | 0 5 9 0 0 0 0 0 8 745 | 2 0 0 0 0 8 0 0 0 746 | 747 | 0 4 5 0 0 0 0 0 0 748 | 0 0 3 0 0 0 0 0 0 749 | 0 0 6 0 0 3 0 5 4 750 | 751 | 0 0 0 3 2 5 0 0 6 752 | 0 0 0 0 0 0 0 0 0 753 | 0 0 0 0 0 0 0 0 0]) 754 | 755 | ;; ~5.2s w/o distribute 756 | (time (doall (sudokufd hard0))) 757 | 758 | (-> (sudokufd hard0) first verify) 759 | 760 | (dotimes [_ 5] 761 | (time 762 | (dotimes [_ 100] 763 | (doall (sudokufd hard0))))) 764 | 765 | ;; from GeCode test suite 766 | (def hard1 767 | [0 0 0 0 0 3 0 6 0 768 | 0 0 0 0 0 0 0 1 0 769 | 0 9 7 5 0 0 0 8 0 770 | 771 | 0 0 0 0 9 0 2 0 0 772 | 0 0 8 0 7 0 4 0 0 773 | 0 0 3 0 6 0 0 0 0 774 | 775 | 0 1 0 0 0 2 8 9 0 776 | 0 4 0 0 0 0 0 0 0 777 | 0 5 0 1 0 0 0 0 0]) 778 | 779 | ;; ~50ms 780 | (time (doall (sudokufd hard1))) 781 | 782 | (-> (sudokufd hard1) first verify) 783 | 784 | ;; ~2.5 seconds w/o distribute 785 | ;; < 260ms w/ distribute, nearly 10X faster 786 | (dotimes [_ 5] 787 | (time 788 | (dotimes [_ 10] 789 | (doall (sudokufd hard1))))) 790 | 791 | ;; from Wikipedia 792 | (def hard2 793 | [1 2 0 4 0 0 3 0 0 794 | 3 0 0 0 1 0 0 5 0 795 | 0 0 6 0 0 0 1 0 0 796 | 797 | 7 0 0 0 9 0 0 0 0 798 | 0 4 0 6 0 3 0 0 0 799 | 0 0 3 0 0 2 0 0 0 800 | 801 | 5 0 0 0 8 0 7 0 0 802 | 0 0 7 0 0 0 0 0 5 803 | 0 0 0 0 0 0 0 9 8]) 804 | 805 | ;; ~.9s w/ distribute 806 | (time (doall (sudokufd hard2))) 807 | 808 | (-> (sudokufd hard2) first print-solution) 809 | 810 | (dotimes [_ 5] 811 | (time 812 | (doall (sudokufd hard2)))) 813 | 814 | (def ciao 815 | [0 4 3 0 8 0 2 5 0 816 | 6 0 0 0 0 0 0 0 0 817 | 0 0 0 0 0 1 0 9 4 818 | 819 | 9 0 0 0 0 4 0 7 0 820 | 0 0 0 6 0 8 0 0 0 821 | 0 1 0 2 0 0 0 0 3 822 | 823 | 8 2 0 5 0 0 0 0 0 824 | 0 0 0 0 0 0 0 0 5 825 | 0 3 4 0 9 0 7 1 0]) 826 | 827 | ;; ~13ms w/o distribute 828 | ;; ~18ms w/ distribute 829 | (dotimes [_ 5] 830 | (time 831 | (dotimes [_ 100] 832 | (doall (sudokufd ciao))))) 833 | 834 | (def jacop 835 | [0 1 0 4 2 0 0 0 5 836 | 0 0 2 0 7 1 0 3 9 837 | 0 0 0 0 0 0 0 4 0 838 | 839 | 2 0 7 1 0 0 0 0 6 840 | 0 0 0 0 4 0 0 0 0 841 | 6 0 0 0 0 7 4 0 3 842 | 843 | 0 7 0 0 0 0 0 0 0 844 | 1 2 0 7 3 0 5 0 0 845 | 3 0 0 0 8 2 0 7 0]) 846 | 847 | ;; 400ms 848 | (dotimes [_ 5] 849 | (time 850 | (dotimes [_ 10] 851 | (doall (sudokufd jacop))))) 852 | 853 | ) 854 | 855 | ;; From "Finite Domain Constraint Programming in Oz. A Tutorial" pg 22 856 | 857 | (defn safefd [] 858 | (run* [c1 c2 c3 c4 c5 c6 c7 c8 c9 :as vs] 859 | (everyg #(fd/in % (fd/interval 1 9)) vs) 860 | (fd/distinct vs) 861 | (fd/eq 862 | (= (- c4 c6) c7) 863 | (= (* c1 c2 c3) (+ c8 c9)) 864 | (< (+ c2 c3 c6) c8) 865 | (< c9 c8)) 866 | (project [vs] 867 | (everyg (fn [[v n]] (fd/!= v n)) 868 | (map vector vs (range 1 10)))))) 869 | 870 | (comment 871 | (time (safefd)) 872 | 873 | (every? 874 | (fn [[c1 c2 c3 c4 c5 c6 c7 c8 c9]] 875 | (and 876 | (not= c1 1) (not= c2 2) (not= c3 3) 877 | (not= c4 4) (not= c5 5) (not= c6 6) 878 | (not= c7 7) (not= c8 8) (not= c9 9) 879 | (= (- c4 c6) c7) 880 | (= (* c1 c2 c3) (+ c8 c9)) 881 | (< (+ c2 c3 c6) c8) 882 | (< c9 c8))) 883 | (safefd)) 884 | 885 | ;; ~2300ms 886 | (dotimes [_ 5] 887 | (time 888 | (dotimes [_ 100] 889 | (doall (safefd))))) 890 | ) 891 | 892 | ;; Magic Squares 893 | 894 | (defn magic-grid [n] 895 | (repeatedly (* n n) lvar)) 896 | 897 | (defn magic-cols [n grid] 898 | (apply map list (partition n grid))) 899 | 900 | (defn magic-diag [n rows] 901 | (first 902 | (reduce 903 | (fn [[r n] xs] 904 | [(conj r (nth xs n)) (inc n)]) 905 | [[] 0] 906 | rows))) 907 | 908 | (defn magic-sum [ls res] 909 | (conde 910 | [(== ls []) (== res 0)] 911 | [(== ls [res])] 912 | [(fresh [h t inter] 913 | (conso h t ls) 914 | (fd/+ h inter res) 915 | (magic-sum t inter))])) 916 | 917 | (defn magic [n] 918 | (let [g (magic-grid n) 919 | nums (range 1 (inc (* n n))) 920 | ndom (fd/interval 1 (* n n)) 921 | lsum (/ (apply + nums) n) 922 | rows (partition n g) 923 | lines (concat 924 | [(magic-diag n rows) 925 | (magic-diag n (map reverse rows))] 926 | rows 927 | (magic-cols n g))] 928 | (run* [q] 929 | (== q g) 930 | (everyg #(fd/in % ndom) q) 931 | (distribute q ::l/ff) 932 | (fd/distinct q) 933 | (everyg #(magic-sum % lsum) lines)))) 934 | 935 | (comment 936 | ;; ~420ms 937 | (dotimes [_ 5] 938 | (time 939 | (dotimes [_ 10] 940 | (doall (take 1 (magic 3)))))) 941 | 942 | ;; ~670ms 943 | (dotimes [_ 5] 944 | (time 945 | (dotimes [_ 1] 946 | (doall (take 1 (magic 4)))))) 947 | ) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/logic/fd.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) David Nolen, Rich Hickey, contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.logic.fd 10 | (:refer-clojure :exclude [== < > <= >= + - * quot distinct]) 11 | (:use [clojure.core.logic.protocols] 12 | [clojure.core.logic :exclude [get-dom == != !=c] :as l]) 13 | (:require [clojure.set :as set] 14 | [clojure.string :as string]) 15 | (:import [System.IO TextWriter] ;;; [java.io Writer] 16 | ;;; [java.util UUID] 17 | [clojure.core.logic.protocols IEnforceableConstraint])) 18 | 19 | (alias 'core 'clojure.core) 20 | 21 | ;; ----------------------------------------------------------------------------- 22 | ;; Finite domain protocol types 23 | 24 | (defprotocol IInterval 25 | (-lb [this]) 26 | (-ub [this])) 27 | 28 | (defprotocol IIntervals 29 | (-intervals [this])) 30 | 31 | (defprotocol ISortedDomain 32 | (-drop-one [this]) 33 | (-drop-before [this n]) 34 | (-keep-before [this n])) 35 | 36 | (defprotocol ISet 37 | (-member? [this n]) 38 | (-disjoint? [this that]) 39 | (-intersection [this that]) 40 | (-difference [this that])) 41 | 42 | (declare domain sorted-set->domain 43 | difference* intersection* disjoint?* 44 | unify-with-domain* finite-domain? 45 | interval multi-interval) 46 | 47 | (defn bounds [i] 48 | (pair (-lb i) (-ub i))) 49 | 50 | (defn interval-< [i j] 51 | (core/< (-ub i) (-lb j))) 52 | 53 | (defn interval-<= [i j] 54 | (core/<= (-ub i) (-lb j))) 55 | 56 | (defn interval-> [i j] 57 | (core/> (-lb i) (-ub j))) 58 | 59 | (defn interval->= [i j] 60 | (core/>= (-lb i) (-ub j))) 61 | 62 | ;; FiniteDomain 63 | ;; ----- 64 | ;; wrapper around Clojure sorted sets. Used to represent small 65 | ;; domains. Optimization when interval arithmetic provides little 66 | ;; benefit. 67 | ;; 68 | ;; s - a sorted set 69 | ;; min - the minimum value, an optimization 70 | ;; max - the maximum value, an optimization 71 | 72 | (deftype FiniteDomain [s min max] 73 | Object 74 | (Equals [this that] ;;; equals 75 | (if (finite-domain? that) 76 | (if (= (-member-count this) (-member-count that)) 77 | (= s (:s that)) 78 | false) 79 | false)) 80 | 81 | clojure.lang.ILookup 82 | (valAt [this k] 83 | (.valAt this k nil)) 84 | (valAt [this k not-found] 85 | (case k 86 | :s s 87 | :min min 88 | :max max 89 | not-found)) 90 | 91 | IMemberCount 92 | (-member-count [this] (count s)) 93 | 94 | IInterval 95 | (-lb [_] min) 96 | (-ub [_] max) 97 | 98 | ISortedDomain 99 | (-drop-one [_] 100 | (let [s (disj s min) 101 | c (count s)] 102 | (cond 103 | (= c 1) (first s) 104 | (core/> c 1) (FiniteDomain. s (first s) max) 105 | :else nil))) 106 | 107 | (-drop-before [_ n] 108 | (apply domain (drop-while #(core/< % n) s))) 109 | 110 | (-keep-before [this n] 111 | (apply domain (take-while #(core/< % n) s))) 112 | 113 | ISet 114 | (-member? [this n] 115 | (if (s n) true false)) 116 | 117 | (-disjoint? [this that] 118 | (cond 119 | (integer? that) 120 | (if (s that) false true) 121 | (instance? FiniteDomain that) 122 | (cond 123 | (core/< max (:min that)) true 124 | (core/> min (:max that)) true 125 | :else (empty? (set/intersection s (:s that)))) 126 | :else (disjoint?* this that))) 127 | 128 | (-intersection [this that] 129 | (cond 130 | (integer? that) 131 | (when (-member? this that) that) 132 | (instance? FiniteDomain that) 133 | (sorted-set->domain (set/intersection s (:s that))) 134 | :else 135 | (intersection* this that))) 136 | 137 | (-difference [this that] 138 | (cond 139 | (integer? that) 140 | (sorted-set->domain (disj s that)) 141 | (instance? FiniteDomain that) 142 | (sorted-set->domain (set/difference s (:s that))) 143 | :else 144 | (difference* this that))) 145 | 146 | IIntervals 147 | (-intervals [_] (seq s)) 148 | 149 | IMergeDomains 150 | (-merge-doms [this that] 151 | (-intersection this that))) 152 | 153 | (defn finite-domain? [x] 154 | (instance? FiniteDomain x)) 155 | 156 | (defn sorted-set->domain [s] 157 | (let [c (count s)] 158 | (cond 159 | (zero? c) nil 160 | (= c 1) (first s) 161 | :else (FiniteDomain. s (first s) (first (rseq s)))))) 162 | 163 | (defn domain 164 | "Construct a domain for assignment to a var. Arguments should 165 | be integers given in sorted order. domains may be more efficient 166 | than intervals when only a few values are possible." 167 | [& args] 168 | (let [args (remove neg? args)] 169 | (when (seq args) 170 | (sorted-set->domain (into (sorted-set) args))))) 171 | 172 | (defmethod print-method FiniteDomain [x ^TextWriter writer] ;;; Writer 173 | (.Write writer (str ""))) ;;; write 174 | 175 | (declare interval?) 176 | 177 | (defmacro extend-to-fd [t] 178 | `(extend-type ~t 179 | IMemberCount 180 | (~'-member-count [this#] 1) 181 | 182 | IInterval 183 | (~'-lb [this#] this#) 184 | (~'-ub [this#] this#) 185 | 186 | ISortedDomain 187 | (~'-drop-one [this#] 188 | nil) 189 | (~'-drop-before [this# n#] 190 | (when (clojure.core/>= this# n#) 191 | this#)) 192 | (~'-keep-before [this# n#] 193 | (when (clojure.core/< this# n#) 194 | this#)) 195 | 196 | ISet 197 | (~'-member? [this# that#] 198 | (if (integer? that#) 199 | (= this# that#) 200 | (-member? that# this#))) 201 | (~'-disjoint? [this# that#] 202 | (if (integer? that#) 203 | (not= this# that#) 204 | (-disjoint? that# this#))) 205 | (~'-intersection [this# that#] 206 | (cond 207 | (integer? that#) (when (= this# that#) 208 | this#) 209 | (interval? that#) (-intersection that# this#) 210 | :else (intersection* this# that#))) 211 | (~'-difference [this# that#] 212 | (cond 213 | (integer? that#) (if (= this# that#) 214 | nil 215 | this#) 216 | (interval? that#) (-difference that# this#) 217 | :else (difference* this# that#))) 218 | 219 | IIntervals 220 | (~'-intervals [this#] 221 | (list this#)))) 222 | 223 | ;;;(extend-to-fd System.Byte) (extend-to-fd System.SByte) ;;; (extend-to-fd java.lang.Byte) 224 | ;;;(extend-to-fd System.Int16) (extend-to-fd System.UInt16) ;;; (extend-to-fd java.lang.Short) 225 | ;;;(extend-to-fd System.Int32) (extend-to-fd System.UInt32) ;;; (extend-to-fd java.lang.Integer) 226 | (extend-to-fd System.Int64) ;;;(extend-to-fd System.UInt64) ;;; (extend-to-fd java.lang.Long) 227 | (extend-to-fd clojure.lang.BigInteger) ;;; (extend-to-fd java.math.BigInteger) 228 | (extend-to-fd clojure.lang.BigInt) 229 | 230 | (declare interval) 231 | 232 | ;; IntervalFD 233 | ;; ----- 234 | ;; Type optimized for interval arithmetic. Only stores bounds. 235 | ;; 236 | ;; lb - lower bound 237 | ;; ub - upper bound 238 | 239 | (deftype IntervalFD [lb ub] 240 | Object 241 | (Equals [_ o] ;;; equals 242 | (if (instance? IntervalFD o) 243 | (and (= lb (-lb o)) 244 | (= ub (-ub o))) 245 | false)) 246 | 247 | (ToString [this] ;;; toString 248 | (pr-str this)) 249 | 250 | IMemberCount 251 | (-member-count [this] (inc (core/- ub lb))) 252 | 253 | IInterval 254 | (-lb [_] lb) 255 | (-ub [_] ub) 256 | 257 | ISortedDomain 258 | (-drop-one [_] 259 | (let [nlb (inc lb)] 260 | (when (core/<= nlb ub) 261 | (interval nlb ub)))) 262 | 263 | (-drop-before [this n] 264 | (cond 265 | (= n ub) n 266 | (core/< n lb) this 267 | (core/> n ub) nil 268 | :else (interval n ub))) 269 | 270 | (-keep-before [this n] 271 | (cond 272 | (core/<= n lb) nil 273 | (core/> n ub) this 274 | :else (interval lb (dec n)))) 275 | 276 | ISet 277 | (-member? [this n] 278 | (and (core/>= n lb) (core/<= n ub))) 279 | 280 | (-disjoint? [this that] 281 | (cond 282 | (integer? that) 283 | (not (-member? this that)) 284 | 285 | (interval? that) 286 | (let [i this 287 | j that 288 | [imin imax] (bounds i) 289 | [jmin jmax] (bounds j)] 290 | (or (core/> imin jmax) 291 | (core/< imax jmin))) 292 | 293 | :else (disjoint?* this that))) 294 | 295 | (-intersection [this that] 296 | (cond 297 | (integer? that) 298 | (if (-member? this that) 299 | that 300 | nil) 301 | 302 | (interval? that) 303 | (let [i this j that 304 | imin (-lb i) imax (-ub i) 305 | jmin (-lb j) jmax (-ub j)] 306 | (cond 307 | (core/< imax jmin) nil 308 | (core/< jmax imin) nil 309 | (and (core/<= imin jmin) 310 | (core/>= imax jmax)) j 311 | (and (core/<= jmin imin) 312 | (core/>= jmax imax)) i 313 | (and (core/<= imin jmin) 314 | (core/<= imax jmax)) (interval jmin imax) 315 | (and (core/<= jmin imin) 316 | (core/<= jmax imax)) (interval imin jmax) 317 | :else (throw (Exception. (str "Interval intersection not defined " i " " j))))) ;;; Error. 318 | 319 | :else (intersection* this that))) 320 | 321 | (-difference [this that] 322 | (cond 323 | (integer? that) 324 | (cond 325 | (= lb that) (interval (inc lb) ub) 326 | (= ub that) (interval lb (dec ub)) 327 | :else (if (-member? this that) 328 | (multi-interval (interval lb (dec that)) 329 | (interval (inc that) ub)) 330 | this)) 331 | 332 | (interval? that) 333 | (let [i this j that 334 | imin (-lb i) imax (-ub i) 335 | jmin (-lb j) jmax (-ub j)] 336 | (cond 337 | (core/> jmin imax) i 338 | (and (core/<= jmin imin) 339 | (core/>= jmax imax)) nil 340 | (and (core/< imin jmin) 341 | (core/> imax jmax)) (multi-interval (interval imin (dec jmin)) 342 | (interval (inc jmax) imax)) 343 | (and (core/< imin jmin) 344 | (core/<= jmin imax)) (interval imin (dec jmin)) 345 | (and (core/> imax jmax) 346 | (core/<= jmin imin)) (interval (inc jmax) imax) 347 | :else (throw (Exception. (str "Interval difference not defined " i " " j))))) ;;; Error. 348 | 349 | :else (difference* this that))) 350 | 351 | IIntervals 352 | (-intervals [this] 353 | (list this)) 354 | 355 | IMergeDomains 356 | (-merge-doms [this that] 357 | (-intersection this that))) 358 | 359 | (defn interval? [x] 360 | (instance? IntervalFD x)) 361 | 362 | (defmethod print-method IntervalFD [x ^TextWriter writer] ;;; Writer 363 | (.Write writer (str ""))) ;;; .write 364 | 365 | (defn interval 366 | "Construct an interval for an assignment to a var. intervals may 367 | be more efficient that the domain type when the range of possiblities 368 | is large." 369 | ([ub] (interval 0 ub)) 370 | ([lb ub] 371 | (let [lb (if (neg? lb) 0 lb) 372 | ub (if (neg? ub) 0 ub)] 373 | (cond 374 | (zero? (core/- ub lb)) ub 375 | :else (IntervalFD. lb ub))))) 376 | 377 | (defn intersection* [is js] 378 | (loop [is (seq (-intervals is)) js (seq (-intervals js)) r []] 379 | (if (and is js) 380 | (let [i (first is) 381 | j (first js)] 382 | (cond 383 | (interval-< i j) (recur (next is) js r) 384 | (interval-> i j) (recur is (next js) r) 385 | :else 386 | (let [[imin imax] (bounds i) 387 | [jmin jmax] (bounds j)] 388 | (cond 389 | (core/<= imin jmin) 390 | (cond 391 | (core/< imax jmax) 392 | (recur (next is) 393 | (cons (interval (inc imax) jmax) (next js)) 394 | (conj r (interval jmin imax))) 395 | (core/> imax jmax) 396 | (recur (cons (interval (inc jmax) imax) (next is)) 397 | (next js) 398 | (conj r j)) 399 | :else 400 | (recur (next is) (next js) 401 | (conj r (interval jmin jmax)))) 402 | (core/> imin jmin) 403 | (cond 404 | (core/> imax jmax) 405 | (recur (cons (interval (inc jmax) imax) (next is)) 406 | (next js) 407 | (conj r (interval imin jmax))) 408 | (core/< imax jmax) 409 | (recur is (cons (interval (inc imax) jmax) (next js)) 410 | (conj r i)) 411 | :else 412 | (recur (next is) (next js) 413 | (conj r (interval imin imax)))))))) 414 | (apply multi-interval r)))) 415 | 416 | (defn difference* [is js] 417 | (loop [is (seq (-intervals is)) js (seq (-intervals js)) r []] 418 | (if is 419 | (if js 420 | (let [i (first is) 421 | j (first js)] 422 | (cond 423 | (interval-< i j) (recur (next is) js (conj r i)) 424 | (interval-> i j) (recur is (next js) r) 425 | :else 426 | (let [[imin imax] (bounds i) 427 | [jmin jmax] (bounds j)] 428 | (cond 429 | (core/< imin jmin) 430 | (cond 431 | (core/< jmax imax) 432 | (recur (cons (interval (inc jmax) imax) (next is)) 433 | (next js) 434 | (conj r (interval imin (dec jmin)))) 435 | (core/> jmax imax) 436 | (recur (next is) 437 | (cons (interval (inc imax) jmax) (next js)) 438 | (conj r (interval imin (dec jmin)))) 439 | :else 440 | (recur (next is) (next js) 441 | (conj r (interval imin (dec jmin))))) 442 | (core/>= imin jmin) 443 | (cond 444 | (core/< imax jmax) 445 | (recur (next is) 446 | (cons (interval (inc imax) jmax) (next js)) 447 | r) 448 | (core/> imax jmax) 449 | (recur (cons (interval (inc jmax) imax) (next is)) 450 | (next js) 451 | r) 452 | :else (recur (next is) (next js) 453 | r)))))) 454 | (apply multi-interval (into r is))) 455 | (apply multi-interval r)))) 456 | 457 | (defn disjoint?* [is js] 458 | (if (-disjoint? (interval (-lb is) (-ub is)) 459 | (interval (-lb js) (-ub js))) 460 | true 461 | (let [d0 (-intervals is) 462 | d1 (-intervals js)] 463 | (loop [d0 d0 d1 d1] 464 | (if (or (nil? d0) (nil? d1)) 465 | true 466 | (let [i (first d0) 467 | j (first d1)] 468 | (cond 469 | (interval-< i j) (recur (next d0) d1) 470 | (interval-> i j) (recur d0 (next d1)) 471 | (-disjoint? i j) (recur (next d0) d1) 472 | :else false))))))) 473 | 474 | (declare normalize-intervals singleton-dom? multi-interval) 475 | 476 | ;; MultiIntervalFD 477 | ;; ----- 478 | ;; Running difference operations on IntervalFD will result in 479 | ;; a series of intervals. 480 | ;; 481 | ;; min - minimum value of all contained intervals 482 | ;; max - maximum value of all contained intervals 483 | ;; is - the intervals 484 | 485 | (deftype MultiIntervalFD [min max is] 486 | clojure.lang.ILookup 487 | (valAt [this k] 488 | (.valAt this k nil)) 489 | (valAt [this k not-found] 490 | (case k 491 | :is is 492 | :min min 493 | :max max 494 | not-found)) 495 | 496 | Object 497 | (Equals [this j] ;;; equals 498 | (if (instance? MultiIntervalFD j) 499 | (let [i this 500 | [jmin jmax] (bounds j)] 501 | (if (and (= min jmin) (= max jmax)) 502 | (let [is (normalize-intervals is) 503 | js (normalize-intervals (-intervals j))] 504 | (= is js)) 505 | false)) 506 | false)) 507 | 508 | IMemberCount 509 | (-member-count [this] 510 | ;; NOTE: ugly hack around https://clojure.atlassian.net/browse/CLJ-1202 - David 511 | (reduce core/+ 0 (map #(-member-count %) is))) 512 | 513 | IInterval 514 | (-lb [_] min) 515 | (-ub [_] max) 516 | 517 | ISortedDomain 518 | (-drop-one [_] 519 | (let [i (first is)] 520 | (if (singleton-dom? i) 521 | (let [nis (rest is)] 522 | (MultiIntervalFD. (-lb (first nis)) max nis)) 523 | (let [ni (-drop-one i)] 524 | (MultiIntervalFD. (-lb ni) max (cons ni (rest is))))))) 525 | 526 | (-drop-before [_ n] 527 | (let [is (seq is)] 528 | (loop [is is r []] 529 | (if is 530 | (let [i (-drop-before (first is) n)] 531 | (if i 532 | (recur (next is) (conj r i)) 533 | (recur (next is) r))) 534 | (when (pos? (count r)) 535 | (apply multi-interval r)))))) 536 | 537 | (-keep-before [_ n] 538 | (let [is (seq is)] 539 | (loop [is is r []] 540 | (if is 541 | (let [i (-keep-before (first is) n)] 542 | (if i 543 | (recur (next is) (conj r i)) 544 | (recur (next is) r))) 545 | (when (pos? (count r)) 546 | (apply multi-interval r)))))) 547 | 548 | ISet 549 | (-member? [this n] 550 | (if (some #(-member? % n) is) 551 | true 552 | false)) 553 | (-disjoint? [this that] 554 | (disjoint?* this that)) 555 | (-intersection [this that] 556 | (intersection* this that)) 557 | (-difference [this that] 558 | (difference* this that)) 559 | 560 | IIntervals 561 | (-intervals [this] 562 | (seq is)) 563 | 564 | IMergeDomains 565 | (-merge-doms [this that] 566 | (-intersection this that))) 567 | 568 | ;; union where possible 569 | (defn normalize-intervals [is] 570 | (reduce (fn [r i] 571 | (if (zero? (count r)) 572 | (conj r i) 573 | (let [j (peek r) 574 | jmax (-ub j) 575 | imin (-lb i)] 576 | (if (core/<= (dec imin) jmax) 577 | (conj (pop r) (interval (-lb j) (-ub i))) 578 | (conj r i))))) 579 | [] is)) 580 | 581 | (defn multi-interval 582 | ([] nil) 583 | ([i0] i0) 584 | ([i0 i1] 585 | (let [is [i0 i1]] 586 | (MultiIntervalFD. (max 0 (reduce min (map -lb is))) (max 0 (reduce max (map -ub is))) is))) 587 | ([i0 i1 & ir] 588 | (let [is (into [] (concat (list i0 i1) ir))] 589 | (MultiIntervalFD. (max 0 (reduce min (map -lb is))) (max 0 (reduce max (map -ub is))) is)))) 590 | 591 | (defmethod print-method MultiIntervalFD [x ^TextWriter writer] ;;; Writer 592 | (.Write writer (str ""))) ;;; write 593 | 594 | ;; ============================================================================= 595 | ;; CLP(FD) 596 | 597 | ;; NOTE: aliasing FD? for solving problems like zebra - David 598 | 599 | (defn get-dom 600 | [a x] 601 | (if (lvar? x) 602 | (l/get-dom a x ::l/fd) 603 | x)) 604 | 605 | (defn ext-dom-fd 606 | [a x dom domp] 607 | (let [a (add-dom a x ::l/fd dom)] 608 | (if (not= domp dom) 609 | ((run-constraints* [x] (:cs a) ::l/fd) a) 610 | a))) 611 | 612 | (defn singleton-dom? [x] 613 | (integer? x)) 614 | 615 | (defn resolve-storable-dom 616 | [a x dom domp] 617 | (if (singleton-dom? dom) 618 | (let [xv (walk a x)] 619 | (if (lvar? xv) 620 | (ext-run-cs (rem-dom a x ::l/fd) x dom) 621 | a)) 622 | (ext-dom-fd a x dom domp))) 623 | 624 | (defn process-dom 625 | "If x is a var we update its domain. If it's an integer 626 | we check that it's a member of the given domain. dom is 627 | then new domain, it should have already been calculated from 628 | domp which was the previous domain." 629 | [x dom domp] 630 | (fn [a] 631 | (when dom 632 | (cond 633 | (lvar? x) (resolve-storable-dom a x dom domp) 634 | (-member? dom x) a 635 | :else nil)))) 636 | 637 | (declare domc) 638 | 639 | (defn dom 640 | "Assign a var x a domain." 641 | [x dom] 642 | (fn [a] 643 | (let [domp (get-dom a x) 644 | dom (if domp 645 | (-intersection dom domp) 646 | dom)] 647 | ((composeg 648 | (process-dom x dom domp) 649 | (if (and (nil? domp) 650 | (not (singleton-dom? dom))) 651 | (domc x) 652 | identity)) a)))) 653 | 654 | (defmacro in 655 | "Assign vars to domain. The domain must come last." 656 | [& xs-and-dom] 657 | (let [xs (butlast xs-and-dom) 658 | dom (last xs-and-dom) 659 | domsym (gensym "dom_")] 660 | `(let [~domsym ~dom] 661 | (fresh [] 662 | ~@(map (fn [x] 663 | `(dom ~x ~domsym)) 664 | xs))))) 665 | 666 | (defn map-sum [f] 667 | (fn loop [ls] 668 | (if (empty? ls) 669 | (fn [a] nil) 670 | (fn [a] 671 | (mplus 672 | ((f (first ls)) a) 673 | (fn [] 674 | ((loop (rest ls)) a))))))) 675 | 676 | (defn to-vals [dom] 677 | (letfn [(to-vals* [is] 678 | (when is 679 | (let [i (first is)] 680 | (lazy-seq 681 | (cons (-lb i) 682 | (if-let [ni (-drop-one i)] 683 | (to-vals* (cons ni (next is))) 684 | (to-vals* (next is))))))))] 685 | (to-vals* (seq (-intervals dom))))) 686 | 687 | (extend-protocol IForceAnswerTerm 688 | FiniteDomain 689 | (-force-ans [v x] 690 | ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v))) 691 | 692 | IntervalFD 693 | (-force-ans [v x] 694 | ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v))) 695 | 696 | MultiIntervalFD 697 | (-force-ans [v x] 698 | ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v)))) 699 | 700 | (defn -domc [x] 701 | (reify 702 | IEnforceableConstraint 703 | IConstraintStep 704 | (-step [this s] 705 | (let [xv (walk s x) 706 | xd (-> (root-val s x) :doms ::l/fd)] 707 | (reify 708 | clojure.lang.IFn 709 | (invoke [_ s] 710 | (if xd 711 | (when (-member? xd xv) 712 | (rem-dom s x ::l/fd)) 713 | s)) 714 | IEntailed 715 | (-entailed? [_] 716 | (nil? xd)) 717 | IRunnable 718 | (-runnable? [_] 719 | (not (lvar? xv)))))) 720 | IConstraintOp 721 | (-rator [_] `domc) 722 | (-rands [_] [x]) 723 | IConstraintWatchedStores 724 | (-watched-stores [this] #{::l/subst}))) 725 | 726 | (defn domc [x] 727 | (cgoal (-domc x))) 728 | 729 | (defn ==c [u v] 730 | (reify 731 | IEnforceableConstraint 732 | IConstraintStep 733 | (-step [this s] 734 | (let-dom s [u du v dv] 735 | (reify 736 | clojure.lang.IFn 737 | (invoke [_ s] 738 | (let [i (-intersection du dv)] 739 | ((composeg 740 | (process-dom u i du) 741 | (process-dom v i dv)) s))) 742 | IEntailed 743 | (-entailed? [_] 744 | (and (singleton-dom? du) 745 | (singleton-dom? dv) 746 | (= du dv))) 747 | IRunnable 748 | (-runnable? [_] 749 | (and du dv))))) 750 | IConstraintOp 751 | (-rator [_] `==) 752 | (-rands [_] [u v]) 753 | IConstraintWatchedStores 754 | (-watched-stores [this] 755 | #{::l/subst ::l/fd}))) 756 | 757 | (defn == 758 | "A finite domain constraint. u and v must be equal. u and v must 759 | eventually be given domains if vars." 760 | [u v] 761 | (cgoal (==c u v))) 762 | 763 | (defn !=c [u v] 764 | (reify 765 | IEnforceableConstraint 766 | IConstraintStep 767 | (-step [this s] 768 | (let-dom s [u du v dv] 769 | (let [su? (singleton-dom? du) 770 | sv? (singleton-dom? dv)] 771 | (reify 772 | clojure.lang.IFn 773 | (invoke [_ s] 774 | (cond 775 | (and su? sv? (= du dv)) nil 776 | (-disjoint? du dv) s 777 | su? (when-let [vdiff (-difference dv du)] 778 | ((process-dom v vdiff dv) s)) 779 | :else (when-let [udiff (-difference du dv)] 780 | ((process-dom u udiff du) s)))) 781 | IEntailed 782 | (-entailed? [_] 783 | (and du dv (-disjoint? du dv))) 784 | IRunnable 785 | (-runnable? [_] 786 | (and du dv (or su? sv?))))))) 787 | IConstraintOp 788 | (-rator [_] `!=) 789 | (-rands [_] [u v]) 790 | IConstraintWatchedStores 791 | (-watched-stores [this] 792 | #{::l/subst ::l/fd}))) 793 | 794 | (defn != 795 | "A finite domain constraint. u and v must not be equal. u and v 796 | must eventually be given domains if vars." 797 | [u v] 798 | (cgoal (!=c u v))) 799 | 800 | (defn <=c [u v] 801 | (reify 802 | IEnforceableConstraint 803 | IConstraintStep 804 | (-step [this s] 805 | (let-dom s [u du v dv] 806 | (reify 807 | clojure.lang.IFn 808 | (invoke [_ s] 809 | (let [umin (-lb du) 810 | vmax (-ub dv)] 811 | ((composeg* 812 | (process-dom u (-keep-before du (inc vmax)) du) 813 | (process-dom v (-drop-before dv umin) dv)) s))) 814 | IEntailed 815 | (-entailed? [_] 816 | (and du dv (interval-<= du dv))) 817 | IRunnable 818 | (-runnable? [_] 819 | (and du dv))))) 820 | IConstraintOp 821 | (-rator [_] `<=) 822 | (-rands [_] [u v]) 823 | IConstraintWatchedStores 824 | (-watched-stores [this] 825 | #{::l/subst ::l/fd}))) 826 | 827 | (defn <= 828 | "A finite domain constraint. u must be less than or equal to v. 829 | u and v must eventually be given domains if vars." 830 | [u v] 831 | (cgoal (<=c u v))) 832 | 833 | (defn < 834 | "A finite domain constraint. u must be less than v. u and v 835 | must eventually be given domains if vars." 836 | [u v] 837 | (all 838 | (<= u v) 839 | (!= u v))) 840 | 841 | (defn > 842 | "A finite domain constraint. u must be greater than v. u and v 843 | must eventually be given domains if vars." 844 | [u v] 845 | (< v u)) 846 | 847 | (defn >= 848 | "A finite domain constraint. u must be greater than or equal to v. 849 | u and v must eventually be given domains if vars." 850 | [u v] 851 | (<= v u)) 852 | 853 | ;; NOTE: we could put logic right back in but then we're managing 854 | ;; the constraint in the body again which were trying to get 855 | ;; away from 856 | 857 | (defn +c [u v w] 858 | (reify 859 | IEnforceableConstraint 860 | IConstraintStep 861 | (-step [this s] 862 | (let-dom s [u du v dv w dw] 863 | (reify 864 | clojure.lang.IFn 865 | (invoke [_ s] 866 | (let [[wmin wmax] (if dw 867 | (bounds dw) 868 | [(core/+ (-lb du) (-lb dv)) (core/+ (-ub du) (-ub dv))]) 869 | [umin umax] (if du 870 | (bounds du) 871 | [(core/- (-lb dw) (-ub dv)) (core/- (-ub dw) (-lb dv))]) 872 | [vmin vmax] (if dv 873 | (bounds dv) 874 | [(core/- (-lb dw) (-ub du)) (core/- (-ub dw) (-lb du))]) 875 | wi (interval (core/+ umin vmin) (core/+ umax vmax)) 876 | ui (interval (core/- wmin vmax) (core/- wmax vmin)) 877 | vi (interval (core/- wmin umax) (core/- wmax umin))] 878 | (when-let [wi (if (and wi dw) (-intersection wi dw) wi)] 879 | (when-let [ui (if (and ui du) (-intersection ui du) ui)] 880 | (when-let [vi (if (and vi dv) (-intersection vi dv) vi)] 881 | (when (or (not (every? singleton-dom? [wi ui vi])) 882 | (core/= (core/+ ui vi) wi)) 883 | ((composeg* 884 | (process-dom w wi dw) 885 | (process-dom u ui du) 886 | (process-dom v vi dv)) 887 | s))))))) 888 | IEntailed 889 | (-entailed? [_] 890 | (and (singleton-dom? du) 891 | (singleton-dom? dv) 892 | (singleton-dom? dw) 893 | (= (core/+ du dv) dw))) 894 | IRunnable 895 | (-runnable? [_] 896 | (cond 897 | du (or dv dw) 898 | dv (or du dw) 899 | dw (or du dv) 900 | :else false))))) 901 | IConstraintOp 902 | (-rator [_] `+) 903 | (-rands [_] [u v w]) 904 | IConstraintWatchedStores 905 | (-watched-stores [this] 906 | #{::l/subst ::l/fd}))) 907 | 908 | (defn + 909 | "A finite domain constraint for addition and subtraction. 910 | x, y & sum must eventually be given domains if vars." 911 | [x y sum] 912 | (cgoal (+c x y sum))) 913 | 914 | (defn - 915 | [u v w] 916 | (+ v w u)) 917 | 918 | ;; TODO NOW: we run into trouble with division this is why 919 | ;; simplefd in bench.clj needs map-sum when it should not 920 | 921 | (defn *c [u v w] 922 | (letfn [(safe-div [n c a t] 923 | (if (zero? n) 924 | c 925 | (let [q (core/quot a n)] 926 | (case t 927 | :lower (if (pos? (rem a n)) 928 | (inc q) 929 | q) 930 | :upper q))))] 931 | (reify 932 | IEnforceableConstraint 933 | IConstraintStep 934 | (-step [this s] 935 | (let-dom s [u du v dv w dw] 936 | (reify 937 | clojure.lang.IFn 938 | (invoke [_ s] 939 | (let [[wmin wmax] (if dw 940 | (bounds dw) 941 | [(core/* (-lb du) (-lb dv)) (core/* (-ub du) (-ub dv))]) 942 | [umin umax] (if du 943 | (bounds du) 944 | [(safe-div (-ub dv) (-lb dw) (-lb dw) :lower) 945 | (safe-div (-lb dv) (-lb dw) (-ub dw) :upper)]) 946 | [vmin vmax] (if dv 947 | (bounds dv) 948 | [(safe-div (-ub du) (-lb dw) (-lb dw) :lower) 949 | (safe-div (-lb du) (-lb dw) (-ub dw) :upper)]) 950 | wi (interval (core/* umin vmin) (core/* umax vmax)) 951 | ui (interval (safe-div vmax umin wmin :lower) 952 | (safe-div vmin umax wmax :upper)) 953 | vi (interval (safe-div umax vmin wmin :lower) 954 | (safe-div umin vmax wmax :upper))] 955 | (when-let [wi (if (and wi dw) (-intersection wi dw) wi)] 956 | (when-let [ui (if (and ui du) (-intersection ui du) ui)] 957 | (when-let [vi (if (and vi dv) (-intersection vi dv) vi)] 958 | (when (or (not (every? singleton-dom? [wi ui vi])) 959 | (core/= (core/* ui vi) wi)) 960 | ((composeg* 961 | (process-dom w wi dw) 962 | (process-dom u ui du) 963 | (process-dom v vi dv)) s))))))) 964 | IEntailed 965 | (-entailed? [_] 966 | (and (singleton-dom? du) 967 | (singleton-dom? dv) 968 | (singleton-dom? dw) 969 | (= (core/* du dv) dw))) 970 | IRunnable 971 | (-runnable? [_] 972 | (cond 973 | du (or dv dw) 974 | dv (or du dw) 975 | dw (or du dv) 976 | :else false))))) 977 | IConstraintOp 978 | (-rator [_] `*) 979 | (-rands [_] [u v w]) 980 | IConstraintWatchedStores 981 | (-watched-stores [this] 982 | #{::l/subst ::l/fd})))) 983 | 984 | (defn * 985 | "A finite domain constraint for multiplication and 986 | thus division. x, y & product must be eventually be given 987 | domains if vars." 988 | [x y product] 989 | (cgoal (*c x y product))) 990 | 991 | (defn quot [u v w] 992 | (* v w u)) 993 | 994 | (defn -distinctc 995 | "The real *individual* distinct constraint. x is a var that now is bound to 996 | a single value. y* were the non-singleton bound vars that existed at the 997 | construction of the constraint. n* is the set of singleton domain values 998 | that existed at the construction of the constraint. We use categorize to 999 | determine the current non-singleton bound vars and singleton vlaues. if x 1000 | is in n* or the new singletons we have failed. If not we simply remove 1001 | the value of x from the remaining non-singleton domains bound to vars." 1002 | [x y* n*] 1003 | (reify 1004 | IEnforceableConstraint 1005 | IConstraintStep 1006 | (-step [this s] 1007 | (let [x (walk s x)] 1008 | (reify 1009 | clojure.lang.IFn 1010 | (invoke [_ s] 1011 | (when-not (n* x) 1012 | (loop [y* (seq y*) s s] 1013 | (if y* 1014 | (let [y (first y*) 1015 | ;; NOTE: we can't just get-dom because get-dom 1016 | ;; return nil, walk returns the var - David 1017 | v (or (get-dom s y) (walk s y)) 1018 | s (if-not (lvar? v) 1019 | (cond 1020 | (= x v) nil 1021 | (-member? v x) ((process-dom y (-difference v x) v) s) 1022 | :else s) 1023 | s)] 1024 | (when s 1025 | (recur (next y*) s))) 1026 | ((remcg this) s))))) 1027 | IRunnable 1028 | (-runnable? [_] 1029 | (singleton-dom? x))))) 1030 | IConstraintOp 1031 | (-rator [_] `-distinct) 1032 | (-rands [_] [x]) 1033 | IConstraintWatchedStores 1034 | (-watched-stores [this] #{::l/subst}))) 1035 | 1036 | (defn -distinct [x y* n*] 1037 | (cgoal (-distinctc x y* n*))) 1038 | 1039 | (defn list-sorted? [pred ls] 1040 | (if (empty? ls) 1041 | true 1042 | (loop [f (first ls) ls (next ls)] 1043 | (if ls 1044 | (let [s (first ls)] 1045 | (if (pred f s) 1046 | (recur s (next ls)) 1047 | false)) 1048 | true)))) 1049 | 1050 | (defn distinctc 1051 | "The real distinct constraint. v* can be seq of logic vars and 1052 | values or it can be a logic var itself. This constraint does not 1053 | run until v* has become ground. When it has become ground we group 1054 | v* into a set of logic vars and a sorted set of known singleton 1055 | values. We then construct the individual constraint for each var." 1056 | [v*] 1057 | (reify 1058 | IEnforceableConstraint 1059 | IConstraintStep 1060 | (-step [this s] 1061 | (let [v* (walk s v*)] 1062 | (reify 1063 | clojure.lang.IFn 1064 | (invoke [_ s] 1065 | (let [{x* true n* false} (group-by lvar? v*) 1066 | n* (sort core/< n*)] 1067 | (when (list-sorted? core/< n*) 1068 | (let [x* (into #{} x*) 1069 | n* (into (sorted-set) n*)] 1070 | (loop [xs (seq x*) s s] 1071 | (if xs 1072 | (let [x (first xs)] 1073 | (when-let [s ((-distinct x (disj x* x) n*) s)] 1074 | (recur (next xs) s))) 1075 | ((remcg this) s))))))) 1076 | IRunnable 1077 | (-runnable? [_] 1078 | (not (lvar? v*)))))) 1079 | IConstraintOp 1080 | (-rator [_] `distinct) 1081 | (-rands [_] [v*]) 1082 | IConstraintWatchedStores 1083 | (-watched-stores [this] #{::l/subst}))) 1084 | 1085 | (defn distinct 1086 | "A finite domain constraint that will guarantee that 1087 | all vars that occur in v* will be unified with unique 1088 | values. v* need not be ground. Any vars in v* should 1089 | eventually be given a domain." 1090 | [v*] 1091 | (cgoal (distinctc v*))) 1092 | 1093 | (defne bounded-listo 1094 | "Ensure that the list l never grows beyond bound n. 1095 | n must have been assigned a domain." 1096 | [l n] 1097 | ([() _] (<= 0 n)) 1098 | ([[h . t] n] 1099 | (fresh [m] 1100 | (in m (interval 0 Int32/MaxValue)) ;;; Integer/MAX_VALUE 1101 | (+ m 1 n) 1102 | (bounded-listo t m)))) 1103 | 1104 | ;; ----------------------------------------------------------------------------- 1105 | ;; FD Equation Sugar 1106 | 1107 | (def binops->fd 1108 | '{+ clojure.core.logic.fd/+ 1109 | - clojure.core.logic.fd/- 1110 | * clojure.core.logic.fd/* 1111 | / clojure.core.logic.fd/quot 1112 | = clojure.core.logic.fd/== 1113 | != clojure.core.logic.fd/!= 1114 | <= clojure.core.logic.fd/<= 1115 | < clojure.core.logic.fd/< 1116 | >= clojure.core.logic.fd/>= 1117 | > clojure.core.logic.fd/>}) 1118 | 1119 | (def binops (set (keys binops->fd))) 1120 | 1121 | (defn expand [form] 1122 | (if (seq? form) 1123 | (let [[op & args] form] 1124 | (if (and (binops op) (core/> (count args) 2)) 1125 | (list op (expand (first args)) 1126 | (expand (cons op (rest args)))) 1127 | (cons op (map expand args)))) 1128 | form)) 1129 | 1130 | (defn eq* 1131 | ([form vars] (eq* form vars nil)) 1132 | ([form vars out] 1133 | (if (seq? form) 1134 | (let [[op r1 r2] form 1135 | [outl outlv?] (if (seq? r1) 1136 | (let [s (gensym)] 1137 | (swap! vars conj s) 1138 | [s true]) 1139 | [r1 false]) 1140 | [outr outrv?] (if (seq? r2) 1141 | (let [s (gensym)] 1142 | (swap! vars conj s) 1143 | [s true]) 1144 | [r2 false]) 1145 | op (binops->fd op)] 1146 | (cons (if out 1147 | (list op outl outr out) 1148 | (list op outl outr)) 1149 | (concat (when (seq? r1) 1150 | (eq* r1 vars (when outlv? outl))) 1151 | (when (seq? r2) 1152 | (eq* r2 vars (when outrv? outr)))))) 1153 | form))) 1154 | 1155 | (defn ->fd [vars exprs] 1156 | `(fresh [~@vars] 1157 | ~@(reverse exprs))) 1158 | 1159 | (defn eq-form [form] 1160 | (let [vars (atom []) 1161 | exprs (eq* (expand form) vars)] 1162 | (->fd @vars exprs))) 1163 | 1164 | (defmacro eq [& forms] 1165 | `(all 1166 | ~@(map eq-form forms))) --------------------------------------------------------------------------------