Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: jamii/mist
base: 0b963dfddf
...
head fork: jamii/mist
compare: cb8788bd42
Checking mergeability… Don't worry, you can still create the pull request.
  • 2 commits
  • 2 files changed
  • 0 commit comments
  • 1 contributor
Showing with 83 additions and 86 deletions.
  1. +1 −1  src/mist/strict.clj
  2. +82 −85 src/shackles/search.clj
View
2  src/mist/strict.clj
@@ -7,7 +7,7 @@
pattern#
~@args
:else (let [msg# (str "Could not match " pattern#)]
- (throw (new Exception msg#))))))
+ (throw (Error. msg#))))))
(defn unleave [seq]=
[(take-nth 2 seq) (take-nth 2 (rest seq))])
View
167 src/shackles/search.clj
@@ -1,104 +1,101 @@
(ns shackles.search
- (:require [shackles.core :as core]
- [mist.strict :as strict]))
+ (:require [shackles.core :as core])
+ (:import [shackles.core Equal NotEqual]
+ [clojure.lang PersistentQueue]))
-(defrecord Tree [root children])
+(defprotocol Search
+ (search-step [comb root] "Applies the search combinator to the root space, returning a finite list of (comb, space) pairs."))
-(defn leaf? [tree]
- (and
- (empty? (:children tree))
- (not (core/failed? (:root tree)))))
+(defrecord Terminate []
+ Search
+ (search-step [_ root] nil))
-(defprotocol Search
- (search [comb root] "Applies the search combinator to the root space, returning a lazy tree of spaces"))
+(def terminate (Terminate.))
(defprotocol Chooser
- (choose [chooser vars-doms] "Chooses a var-dom pair from a var-dom map"))
+ (choose [chooser vars&doms] "Chooses a [var dom] pair from vars&doms, or return nil if non are suitable."))
-(defrecord ChooseFirstUnassigned []
+(defrecord ChooseUnassigned []
Chooser
- (choose [_ vars-doms]
- (first (filter (fn [[_ dom]] (not (core/assigned? dom))) vars-doms))))
+ (choose [_ vars&doms]
+ (first (filter (fn [[_ dom]] (not (core/assigned? dom))) vars&doms))))
(defprotocol Splitter
(split [splitter dom] "Returns a seq of actions which create subdoms whose union is the original dom"))
-(defrecord Null []
- Search
- (search [null root]
- (Tree. root nil)))
+(defrecord SplitAssign [] ; finite dom only
+ Splitter
+ (split [_ dom]
+ (when-not (core/assigned? dom)
+ (let [value (first (core/elems dom))]
+ (list (Equal. value) (NotEqual. value))))))
-(defrecord Guess [vars chooser splitter]
+(defrecord Exhaust [vars chooser splitter]
Search
- (search [{:keys [vars choooser splitter] :as guess} root]
- (Tree.
- root
- (lazy-seq
- (if-not (core/failed? root)
- (let [vars-doms (core/select-vars root vars)
- [var dom] (choose chooser vars-doms)
- actions (split splitter dom)
- children (map core/stabilise (map #(core/handle-action root var %) actions))]
- (map #(search guess %) children)))))))
-
-(defrecord Prune [condition start-comb]
- Search
- (search [{:keys [condition start-comb]} root]
- (letfn [(prune-tree [tree]
- (Tree.
- (:root tree)
- (lazy-seq
- (if (condition tree)
- nil
- (map prune-tree (:children tree))))))]
- (prune-tree (search start-comb root)))))
-
-(defrecord Extend [condition extend-comb start-comb]
- Search
- (search [{:keys [condition extend-comb start-comb]} root]
- (letfn [(extend-tree [tree]
- (Tree.
- (:root tree)
- (lazy-cat
- (:children tree)
- (if (condition tree)
- (:children (search extend-comb (:root tree)))
- nil))))]
- (extend-tree (search start-comb root)))))
-
-(defrecord Seq [combs]
+ (search-step [this root]
+ (when-let [[var dom] (choose chooser (core/select-vars root vars))]
+ (let [actions (split splitter dom)
+ children (map #(core/handle-action root var %) actions)]
+ (for [child children] [this child])))))
+
+(defrecord Until [condition start-comb end-comb]
Search
- (search [{:keys [combs]} root]
- (letfn [(extension [combs]
- (if-let [[comb & combs] combs]
- (Extend. leaf? comb (extension combs))
- (Null.)))]
- (search (extension (reverse combs)) root))))
-
-(defrecord Par [combs]
+ (search-step [this root]
+ (if (condition root)
+ (search-step end-comb root)
+ (for [[new-start-comb new-root] (search-step start-comb root)]
+ (let [new-this (if (identical? start-comb new-start-comb)
+ this
+ (And. condition new-start-comb end-comb))]
+ [new-this new-root])))))
+
+(defrecord Modify [fun comb]
Search
- (search [{:keys [combs]} root]
- (Tree.
- root
- (mapcat (fn [comb] (:children (search comb root))) combs))))
+ (search-step [_ root]
+ (list [terminate (core/stabilise (fun root))])))
-(defrecord Find [condition queue comb]
+(defrecord Or [combs]
Search
- (search [{:keys [condition queue comb]} root]
- (letfn [(find-with [queue]
- (if (empty? queue)
- nil
- (lazy-seq
- (let [tree (peek queue)
- root (:root tree)
- children (:children tree)
- queue (into (pop queue) children)
- rest (find-with queue)]
- (if (condition root)
- (cons root rest)
- rest)))))]
- (find-with (conj queue (search comb root))))))
-
-(defrecord Constrain [prop comb]
+ (search-step [_ root]
+ (mapcat (fn [comb] (search-step comb root)) combs)))
+
+(def fifo PersistentQueue/EMPTY)
+(def filo ())
+
+(defrecord And [combs]
Search
- (search [constrain root])) ; ???
+ (search-step [_ root]
+ (when-first [comb combs]
+ (for [[new-comb new-root] (search-step comb root)]
+ [(And. (conj new-comb combs)) new-root]))))
+
+(defn ->AndPar [combs] (And. (into fifo combs)))
+(defn ->AndSeq [combs] (And. (into filo combs)))
+
+(defrecord Tree [root children])
+
+(defn expand [[comb root]]
+ (Tree.
+ root
+ (when-not (or (identical? terminate comb) (core/failed? root))
+ (map expand (search-step comb root)))))
+
+(defn- search-with-queue [condition queue]
+ (if (empty? queue)
+ nil
+ (let [[comb tree] (peek queue)
+ root (core/stabilise (.root tree))
+ children (.children tree)
+ queue (pop queue)]
+ (if (condition root children)
+ (lazy-seq (cons root (search-with-queue condition queue)))
+ (recur condition (into queue children))))))
+
+(defn breadth-first [condition comb space]
+ (search-with-queue condition (conj fifo (expand [comb space]))))
+
+(defn depth-first [condition comb space]
+ (search-with-queue condition (conj filo (expand [comb space]))))
+
+(defn non-failed-leaf? [root children]
+ (and (not (core/failed? root)) (empty? children)))

No commit comments for this range

Something went wrong with that request. Please try again.