This is an automated email from the git hooks/post-receive script. apoikos pushed a commit to branch master in repository prismatic-plumbing-clojure.
commit 16b3df3f8683c02d9f58035ca8856070bfa76082 Author: Apollon Oikonomopoulos <[email protected]> Date: Fri Aug 4 16:46:33 2017 -0400 Add generated Clojure code --- src/plumbing/core.clj | 489 +++++++++++++++++++++++++++++++++++++++++++ src/plumbing/fnk/pfnk.clj | 58 +++++ src/plumbing/fnk/schema.clj | 244 +++++++++++++++++++++ src/plumbing/graph.clj | 341 ++++++++++++++++++++++++++++++ src/plumbing/graph_async.clj | 85 ++++++++ src/plumbing/map.clj | 233 +++++++++++++++++++++ 6 files changed, 1450 insertions(+) diff --git a/src/plumbing/core.clj b/src/plumbing/core.clj new file mode 100644 index 0000000..6f026e6 --- /dev/null +++ b/src/plumbing/core.clj @@ -0,0 +1,489 @@ +(ns plumbing.core + "Utility belt for Clojure in the wild" + (:refer-clojure :exclude [update]) + + + + + (:require + [schema.utils :as schema-utils] + [schema.macros :as schema-macros] + [plumbing.fnk.schema :as schema :include-macros true] + [plumbing.fnk.impl :as fnk-impl])) + + (set! *warn-on-reflection* true) + +(def ^:private +none+ + "A sentinel value representing missing portions of the input data." + ::missing) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Maps + +(defmacro for-map + "Like 'for' for building maps. Same bindings except the body should have a + key-expression and value-expression. If a key is repeated, the last + value (according to \"for\" semantics) will be retained. + + (= (for-map [i (range 2) j (range 2)] [i j] (even? (+ i j))) + {[0 0] true, [0 1] false, [1 0] false, [1 1] true}) + + An optional symbol can be passed as a first argument, which will be + bound to the transient map containing the entries produced so far." + ([seq-exprs key-expr val-expr] + `(for-map ~(gensym "m") ~seq-exprs ~key-expr ~val-expr)) + ([m-sym seq-exprs key-expr val-expr] + `(let [m-atom# (atom (transient {}))] + (doseq ~seq-exprs + (let [~m-sym @m-atom#] + (reset! m-atom# (assoc! ~m-sym ~key-expr ~val-expr)))) + (persistent! @m-atom#)))) + +(defmacro -unless-update + "Execute and yield body only if Clojure version preceeds introduction + of 'update' into core namespace." + [body] + `(schema-macros/if-cljs + ~body + ~(when (pos? (compare + [1 7 0] + (mapv #(get *clojure-version* %) + [:major :minor :incremental]))) + body))) + +(-unless-update + (defn update + "Updates the value in map m at k with the function f. + + Like update-in, but for updating a single top-level key. + Any additional args will be passed to f after the value. + + WARNING As of Clojure 1.7 this function exists in clojure.core and + will not be exported by this namespace." + ([m k f] (assoc m k (f (get m k)))) + ([m k f x1] (assoc m k (f (get m k) x1))) + ([m k f x1 x2] (assoc m k (f (get m k) x1 x2))) + ([m k f x1 x2 & xs] (assoc m k (apply f (get m k) x1 x2 xs))))) + +(defn map-vals + "Build map k -> (f v) for [k v] in map, preserving the initial type" + [f m] + (cond + (sorted? m) + (reduce-kv (fn [out-m k v] (assoc out-m k (f v))) (sorted-map) m) + (map? m) + (persistent! (reduce-kv (fn [out-m k v] (assoc! out-m k (f v))) (transient {}) m)) + :else + (for-map [[k v] m] k (f v)))) + +(defn map-keys + "Build map (f k) -> v for [k v] in map m" + [f m] + (if (map? m) + (persistent! (reduce-kv (fn [out-m k v] (assoc! out-m (f k) v)) (transient {}) m)) + (for-map [[k v] m] (f k) v))) + +(defn map-from-keys + "Build map k -> (f k) for keys in ks" + [f ks] + (for-map [k ks] k (f k))) + +(defn map-from-vals + "Build map (f v) -> v for vals in vs" + [f vs] + (for-map [v vs] (f v) v)) + +(defn dissoc-in + "Dissociate this keyseq from m, removing any empty maps created as a result + (including at the top-level)." + [m [k & ks]] + (when m + (if-let [res (and ks (dissoc-in (get m k) ks))] + (assoc m k res) + (let [res (dissoc m k)] + (when-not (empty? res) + res))))) + +(defn ^:deprecated keywordize-map + "DEPRECATED. prefer clojure.walk/keywordize-keys. + + Recursively convert maps in m (including itself) + to have keyword keys instead of string" + [x] + (cond + (map? x) + (for-map [[k v] x] + (if (string? k) (keyword k) k) (keywordize-map v)) + (seq? x) + (map keywordize-map x) + (vector? x) + (mapv keywordize-map x) + :else + x)) + +(defmacro lazy-get + "Like get but lazy about default" + [m k d] + `(if-let [pair# (find ~m ~k)] + (val pair#) + ~d)) + +(defn safe-get + "Like get but throw an exception if not found" + [m k] + (lazy-get + m k + (schema/assert-iae false "Key %s not found in %s" k + (binding [*print-length* 200] + (print-str (mapv key m)))))) + +(defn safe-get-in + "Like get-in but throws exception if not found" + [m ks] + (if (seq ks) + (recur (safe-get m (first ks)) (next ks)) + m)) + +(defn assoc-when + "Like assoc but only assocs when value is truthy" + [m & kvs] + (assert (even? (count kvs))) + (into (or m {}) + (for [[k v] (partition 2 kvs) + :when v] + [k v]))) + +(defn update-in-when + "Like update-in but returns m unchanged if key-seq is not present." + [m key-seq f & args] + (let [found (get-in m key-seq +none+)] + (if-not (identical? +none+ found) + (assoc-in m key-seq (apply f found args)) + m))) + +(defn grouped-map + "Like group-by, but accepts a map-fn that is applied to values before + collected." + [key-fn map-fn coll] + (persistent! + (reduce + (fn [ret x] + (let [k (key-fn x)] + (assoc! ret k (conj (get ret k []) (map-fn x))))) + (transient {}) coll))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Seqs + +(defn aconcat + "Like (apply concat s) but lazier (and shorter) " + [s] + (lazy-cat (first s) (when-let [n (next s)] (aconcat n)))) + +(defn unchunk + "Takes a seqable and returns a lazy sequence that + is maximally lazy and doesn't realize elements due to either + chunking or apply. + + Useful when you don't want chunking, for instance, + (first awesome-website? (map slurp +a-bunch-of-urls+)) + may slurp up to 31 unneed webpages, wherease + (first awesome-website? (map slurp (unchunk +a-bunch-of-urls+))) + is guaranteed to stop slurping after the first awesome website. + + Taken from http://stackoverflow.com/questions/3407876/how-do-i-avoid-clojures-chunking-behavior-for-lazy-seqs-that-i-want-to-short-ci"; + [s] + (when (seq s) + (cons (first s) + (lazy-seq (unchunk (rest s)))))) + +(defn sum + "Return sum of (f x) for each x in xs" + ([f xs] (reduce + (map f xs))) + ([xs] (reduce + xs))) + +(defn singleton + "returns (first xs) when xs has only 1 element" + [xs] + (when-let [xs (seq xs)] + (when-not (next xs) + (first xs)))) + +(defn indexed + "Returns [idx x] for x in seqable s" + [s] + (map-indexed vector s)) + +(defn positions + "Returns indices idx of sequence s where (f (nth s idx))" + [f s] + (keep-indexed (fn [i x] (when (f x) i)) s)) + + +(defn frequencies-fast + "Like clojure.core/frequencies, but faster. + Uses Java's equal/hash, so may produce incorrect results if + given values that are = but not .equal" + [xs] + (let [res (java.util.HashMap.)] + (doseq [x xs] + (.put res x (unchecked-inc (int (or (.get res x) 0))))) + (into {} res))) + + +(defn distinct-fast + "Like clojure.core/distinct, but faster. + Uses Java's equal/hash, so may produce incorrect results if + given values that are = but not .equal" + [xs] + (let [s (java.util.HashSet.)] + (filter #(when-not (.contains s %) (.add s %) true) xs))) + +(defn distinct-by + "Returns elements of xs which return unique + values according to f. If multiple elements of xs return the same + value under f, the first is returned" + [f xs] + (let [s (atom #{})] + (for [x xs + :let [id (f x)] + :when (not (contains? @s id))] + (do (swap! s conj id) + x)))) + + +(defn distinct-id + "Like distinct but uses reference rather than value identity, very clojurey" + [xs] + (let [s (java.util.IdentityHashMap.)] + (doseq [x xs] + (.put s x true)) + (iterator-seq (.iterator (.keySet s))))) + +(defn interleave-all + "Analogy: partition:partition-all :: interleave:interleave-all" + [& colls] + (lazy-seq + ((fn helper [seqs] + (when (seq seqs) + (concat (map first seqs) + (lazy-seq (helper (keep next seqs)))))) + (keep seq colls)))) + +(defn count-when + "Returns # of elements of xs where pred holds" + [pred xs] + (count (filter pred xs))) + +(defn conj-when + "Like conj but ignores non-truthy values" + ([coll x] (if x (conj coll x) coll)) + ([coll x & xs] + (if xs + (recur (conj-when coll x) + (first xs) + (next xs)) + (conj-when coll x)))) + +(defn cons-when + "Like cons but does nothing if x is non-truthy." + [x s] + (if x (cons x s) s)) + +(def rsort-by + "Like sort-by, but prefers higher values rather than lower ones." + (comp reverse sort-by)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Control flow + +(defmacro ?>> + "Conditional double-arrow operation (->> nums (?>> inc-all? (map inc)))" + [do-it? & args] + `(if ~do-it? + (->> ~(last args) ~@(butlast args)) + ~(last args))) + +(defmacro ?> + "Conditional single-arrow operation (-> m (?> add-kv? (assoc :k :v)))" + [arg do-it? & rest] + `(if ~do-it? + (-> ~arg ~@rest) + ~arg)) + +(defmacro fn-> + "Equivalent to `(fn [x] (-> x ~@body))" + [& body] + `(fn [x#] (-> x# ~@body))) + +(defmacro fn->> + "Equivalent to `(fn [x] (->> x ~@body))" + [& body] + `(fn [x#] (->> x# ~@body))) + +(defmacro <- + "Converts a ->> to a -> + + (->> (range 10) (map inc) (<- (doto prn)) (reduce +)) + + Jason W01fe is happy to give a talk anywhere any time on + the calculus of arrow macros" + [& body] + `(-> ~(last body) ~@(butlast body))) + +(defmacro as->> + "Like as->, but can be used in double arrow." + [name & forms-and-expr] + `(as-> ~(last forms-and-expr) ~name ~@(butlast forms-and-expr))) + +(defmacro memoized-fn + "Like fn, but memoized (including recursive calls). + + The clojure.core memoize correctly caches recursive calls when you do a top-level def + of your memoized function, but if you want an anonymous fibonacci function, you must use + memoized-fn rather than memoize to cache the recursive calls." + [name args & body] + `(let [a# (atom {})] + (fn ~name ~args + (let [m# @a# + args# ~args] + (if-let [[_# v#] (find m# args#)] + v# + (let [v# (do ~@body)] + (swap! a# assoc args# v#) + v#)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Miscellaneous + +(defn swap-pair! + "Like swap! but returns a pair [old-val new-val]" + ([a f] + (loop [] + (let [old-val @a + new-val (f old-val)] + (if (compare-and-set! a old-val new-val) + [old-val new-val] + (recur))))) + ([a f & args] + (swap-pair! a #(apply f % args)))) + +(defn get-and-set! + "Like reset! but returns old-val" + [a new-val] + (first (swap-pair! a (constantly new-val)))) + +(defn millis ^long [] + (System/currentTimeMillis) + ) + +(defn mapply + "Like apply, but applies a map to a function with positional map + arguments. Can take optional initial args just like apply." + ([f m] (apply f (apply concat m))) + ([f arg & args] (apply f arg (concat (butlast args) (apply concat (last args)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; fnk + +(defmacro letk + "Keyword let. Accepts an interleaved sequence of binding forms and map forms like: + (letk [[a {b 2} [:f g h] c d {e 4} :as m & more] a-map ...] & body) + a, c, d, and f are required keywords, and letk will barf if not in a-map. + b and e are optional, and will be bound to default values if not present. + g and h are required keys in the map found under :f. + m will be bound to the entire map (a-map). + more will be bound to all the unbound keys (ie (dissoc a-map :a :b :c :d :e)). + :as and & are both optional, but must be at the end in the specified order if present. + The same symbol cannot be bound multiple times within the same destructing level. + + Optional values can reference symbols bound earlier within the same binding, i.e., + (= [2 2] (let [a 1] (letk [[a {b a}] {:a 2}] [a b]))) but + (= [2 1] (let [a 1] (letk [[{b a} a] {:a 2}] [a b]))) + + If present, :as and :& symbols are bound before other symbols within the binding. + + Namespaced keys are supported by specifying fully-qualified key in binding form. The bound + symbol uses the _name_ portion of the namespaced key, i.e, + (= 1 (letk [[a/b] {:a/b 1}] b)). + + Map destructuring bindings can be mixed with ordinary symbol bindings." + [bindings & body] + (schema/assert-iae (vector? bindings) "Letk binding must be a vector") + (schema/assert-iae (even? (count bindings)) "Letk binding must have even number of elements") + (reduce + (fn [cur-body-form [bind-form value-form]] + (if (symbol? bind-form) + `(let [~bind-form ~value-form] ~cur-body-form) + (let [{:keys [map-sym body-form]} (fnk-impl/letk-input-schema-and-body-form + &env + (fnk-impl/ensure-schema-metadata &env bind-form) + [] + cur-body-form)] + `(let [~map-sym ~value-form] ~body-form)))) + `(do ~@body) + (reverse (partition 2 bindings)))) + +(defmacro if-letk + "bindings => binding-form test + + If test is true, evaluates then with binding-form bound to the value of + test, if not, yields else" + ([bindings then] + `(if-letk ~bindings ~then nil)) + ([bindings then else] + (assert (vector? bindings) "if-letk requires a vector for its binding") + (assert (= 2 (count bindings)) "if-letk requires exactly 2 forms in binding vector") + (let [form (bindings 0) tst (bindings 1)] + `(let [temp# ~tst] + (if temp# + (letk [~form temp#] + ~then) + ~else))))) + +(defmacro when-letk + "bindings => binding-form test + + When test is true, evaluates body with binding-form bound to the value of test" + [bindings & body] + `(if-letk ~bindings (do ~@body))) + +(defmacro fnk + "Keyword fn, using letk. Generates a prismatic/schema schematized fn that + accepts a single explicit map i.e., (f {:foo :bar}). + + Explicit top-level map structure will be recorded in output spec, or + to capture implicit structure use an explicit prismatic/schema hint on the + function name. + + Individual inputs can also be schematized by putting :- schemas after the + binding symbol. Schemas can also be used on & more symbols to describe + additional map inputs, or on entire [] bindings to override the automatically + generated schema for the contents (caveat emptor). + + By default, input schemas allow for arbitrary additional mappings + ({s/Keyword s/Any}) unless explicit binding or & more schemas are provided." + [& args] + (let [[name? more-args] (if (symbol? (first args)) + (schema-macros/extract-arrow-schematized-element &env args) + [nil args]) + [bind body] (schema-macros/extract-arrow-schematized-element &env more-args)] + (fnk-impl/fnk-form &env name? bind body &form))) + +(defmacro defnk + "Analogy: fn:fnk :: defn::defnk" + [& defnk-args] + (let [[name args] (schema-macros/extract-arrow-schematized-element &env defnk-args) + take-if (fn [p s] (if (p (first s)) [(first s) (next s)] [nil s])) + [docstring? args] (take-if string? args) + [attr-map? args] (take-if map? args) + [bind body] (schema-macros/extract-arrow-schematized-element &env args)] + (schema/assert-iae (symbol? name) "Name for defnk is not a symbol: %s" name) + (let [f (fnk-impl/fnk-form &env name bind body &form)] + `(def ~(with-meta name (merge (meta name) (assoc-when (or attr-map? {}) :doc docstring?))) + ~f)))) + + (set! *warn-on-reflection* false) + +;;;;;;;;;;;; This file autogenerated from src/plumbing/core.cljx diff --git a/src/plumbing/fnk/pfnk.clj b/src/plumbing/fnk/pfnk.clj new file mode 100644 index 0000000..30b3838 --- /dev/null +++ b/src/plumbing/fnk/pfnk.clj @@ -0,0 +1,58 @@ +(ns plumbing.fnk.pfnk + "Core protocol and helpers for schema.core to extract and attach + input and output schemas to fnks. This protocol says nothing about + how fnks are created, so users are free to create PFnks directly + using fn->fnk, or using custom binding syntax (of which 'fnk' et al + are one possible example)." + (:require + [schema.core :as s :include-macros true] + [plumbing.fnk.schema :as schema :include-macros true])) + + (set! *warn-on-reflection* true) + +(defprotocol PFnk + "Protocol for keyword functions and their specifications, e.g., fnks and graphs." + (io-schemata [this] + "Return a pair of [input-schema output-schema], as specified in plumbing.fnk.schema.")) + +(defn input [^schema.core.FnSchema s] + (let [[[is :as args] :as schemas] (.-input-schemas s)] + (schema/assert-iae (= 1 (count schemas)) "Fnks have a single arity, not %s" (count schemas)) + (schema/assert-iae (= 1 (count args)) "Fnks take a single argument, not %s" (count args)) + (schema/assert-iae (instance? schema.core.One is) "Fnks take a single argument, not variadic") + (let [s (.-schema ^schema.core.One is)] + (schema/assert-iae (map? s) "Fnks take a map argument, not %s" (type s)) + s))) + +(defn output [^schema.core.FnSchema s] + (.-output-schema s)) + +(extend-type clojure.lang.Fn + PFnk + (io-schemata [this] + (assert (fn? this)) + ((juxt input output) (s/fn-schema this)))) + +(defn input-schema [pfnk] + (first (io-schemata pfnk))) + +(defn output-schema [pfnk] + (second (io-schemata pfnk))) + +(defn input-schema-keys [f] + (-> f input-schema schema/explicit-schema-key-map keys)) + +(defn fn->fnk + "Make a keyword function into a PFnk, by associating input and output schema metadata." + ([f io] (fn->fnk f nil io)) + ([f name [input-schema output-schema :as io]] + (vary-meta (s/schematize-fn f (s/=> output-schema input-schema)) assoc :name name))) + +(defn fnk-name + "Get the name of a fnk, if named" + [f] + (:name (meta f))) + + (set! *warn-on-reflection* false) + +;;;;;;;;;;;; This file autogenerated from src/plumbing/fnk/pfnk.cljx diff --git a/src/plumbing/fnk/schema.clj b/src/plumbing/fnk/schema.clj new file mode 100644 index 0000000..3dfe745 --- /dev/null +++ b/src/plumbing/fnk/schema.clj @@ -0,0 +1,244 @@ +(ns plumbing.fnk.schema + "A very simple type system for a subset of schemas consisting of nested + maps with optional or required keyword keys; used by fnk and kin. + + Since schemas are turing-complete and not really designed for type inference, + (and for simplicity) we err on the side of completeness (allowing all legal programs) + at the cost of soundness. + + These operations also bake in some logic specific to reasoning about Graphs, + namely that all input keys to a node must be explicitly mentioned as optional or + required, or provided via `instance`, and will thus deliberately drop extra key + schemas on inputs as appropriate. Output schemas may not have optional keys." + (:require + [schema.core :as s :include-macros true] + [schema.utils :as schema-utils] + [schema.macros :as schema-macros]) + + + + ) + +(def Schema (s/protocol s/Schema)) +(def InputSchema {(s/cond-pre (s/eq s/Keyword) schema.core.OptionalKey s/Keyword) Schema}) +(def OutputSchema Schema) +(def IOSchemata [(s/one InputSchema 'input) (s/one OutputSchema 'output)]) + +(def GraphInputSchema {(s/cond-pre schema.core.OptionalKey s/Keyword) Schema}) +(def MapOutputSchema {s/Keyword Schema}) +(def GraphIOSchemata [(s/one GraphInputSchema 'input) (s/one MapOutputSchema 'output)]) + +;;; Helpers + +(defmacro assert-iae + "Like assert, but throws a RuntimeException in Clojure (not an AssertionError), + and also takes args to format." + [form & format-args] + `(schema-macros/assert! ~form ~@format-args)) + +(defn assert-distinct + "Like (assert (distinct? things)) but with a more helpful error message." + [things] + (let [repeated-things (->> things + frequencies + (filter #(> (val %) 1)) + seq)] + (assert-iae (empty? repeated-things) "Got repeated items (expected distinct): %s" repeated-things))) + +(defn safe-get + "Like (get m k), but throws if k is not present in m." + [m k key-path] + (assert-iae (map? m) + "Expected a map at key-path %s, got type %s" key-path (schema-utils/type-of m)) + (let [[_ v :as p] (find m k)] + (when-not p (throw (ex-info ^String (schema-utils/format* "Key %s not found in %s" k (keys m)) + {:error :missing-key + :key k + :map m}))) + v)) + +(defn non-map-union [s1 s2] + (cond (= s1 s2) s1 + (= s1 s/Any) s2 + (= s2 s/Any) s1 + :else s1)) ;; Punt, just take the first + +(defn non-map-diff + "Return a difference of schmas s1 and s2, where one is not a map. + Punt for now, assuming s2 always satisfies s1." + [s1 s2] + nil) + +(defn map-schema? [m] + (instance? clojure.lang.APersistentMap m) + + ) + +;;; Input schemata + +(s/defn unwrap-schema-form-key :- (s/maybe (s/pair s/Keyword "k" s/Bool "optional?")) + "Given a possibly-unevaluated schema map key form, unpack an explicit keyword + and optional? flag, or return nil for a non-explicit key" + [k] + (cond (s/specific-key? k) + [(s/explicit-schema-key k) (s/required-key? k)] + + ;; Deal with `(s/optional-key k) form from impl + (and (sequential? k) (not (vector? k)) (= (count k) 2) + (= (first k) 'schema.core/optional-key)) + [(second k) false] + + ;; Deal with `(with-meta ...) form from impl + (and (sequential? k) (not (vector? k)) (= (first k) `with-meta)) + (unwrap-schema-form-key (second k)))) + +(s/defn explicit-schema-key-map :- {s/Keyword s/Bool} + "Given a possibly-unevaluated map schema, return a map from bare keyword to true + (for required) or false (for optional)" + [s] + (->> s + keys + (keep unwrap-schema-form-key) + (into {}))) + +(s/defn split-schema-keys :- [(s/one [s/Keyword] 'required) (s/one [s/Keyword] 'optional)] + "Given output of explicit-schema-key-map, split into seq [req opt]." + [s :- {s/Keyword s/Bool}] + (->> s + ((juxt filter remove) val) + (mapv (partial mapv key)))) + +(defn- merge-on-with + "Like merge-with, but also projects keys to a smaller space and merges them similar to the + values." + [key-project key-combine val-combine & maps] + (->> (apply concat maps) + (reduce + (fn [m [k v]] + (let [pk (key-project k)] + (if-let [[ok ov] (get m pk)] + (assoc m pk [(key-combine ok k) (val-combine ov v)]) + (assoc m pk [k v])))) + {}) + vals + (into {}))) + +(s/defn union-input-schemata :- InputSchema + "Returns a minimal input schema schema that entails satisfaction of both s1 and s2" + [i1 :- InputSchema i2 :- InputSchema] + (merge-on-with + #(if (s/specific-key? %) (s/explicit-schema-key %) :extra) + (fn [k1 k2] + (cond (s/required-key? k1) k1 + (s/required-key? k2) k2 + (s/optional-key? k1) (do (assert (= k1 k2)) k1) + (= k1 k2) k1 + :else (assert-iae false "Only one extra schema allowed"))) + (fn [s1 s2] + (if (and (map-schema? s1) (map-schema? s2)) + (union-input-schemata s1 s2) + (non-map-union s1 s2))) + i1 i2)) + +(s/defn required-toplevel-keys :- [s/Keyword] + "Which top-level keys are required (i.e., non-false) by this input schema." + [input-schema :- InputSchema] + (keep + (fn [k] + (when (s/required-key? k) + (s/explicit-schema-key k))) + (keys input-schema))) + + + +;;; Output schemata + + +(defn guess-expr-output-schema + "Guess an output schema for an expr. Currently just looks for literal map structure and + all keyword keys." + [expr] + (if (and (map? expr) (every? keyword? (keys expr))) + (into {} (for [[k v] expr] [k (guess-expr-output-schema v)])) + 'schema.core/Any)) + +;;; Combining inputs and outputs. + + +(defn schema-diff ;; don't validate since it returns better errors. + "Subtract output-schema from input-schema, returning nil if it's possible that an object + satisfying the output-schema satisfies the input-schema, or otherwise a description + of the part(s) of input-schema not met by output-schema. Strict about the map structure + of output-schema matching input-schema, but loose about everything else (only looks at + required keys of output-schema." + [input-schema output-schema] ;; not schematized since it returns more helpful errors + (cond (not (map-schema? input-schema)) + (non-map-diff input-schema output-schema) + + (not (map-schema? output-schema)) + (schema-macros/validation-error input-schema output-schema (list 'map? (s/explain output-schema))) + + :else + (->> (for [[k v] input-schema + :when (s/specific-key? k) + :let [required? (s/required-key? k) + raw-k (s/explicit-schema-key k) + present? (contains? output-schema raw-k)] + :when (or required? present?) + :let [fail (if-not present? + 'missing-required-key + (schema-diff v (get output-schema raw-k)))] + :when fail] + [k fail]) + (into {}) + not-empty))) + +(defn assert-satisfies-schema [input-schema output-schema] + (let [fails (schema-diff input-schema output-schema)] + (when fails (throw (ex-info (str fails) {:error :does-not-satisfy-schema + :failures fails}))))) +(s/defn ^:always-validate compose-schemata + "Given pairs of input and output schemata for fnks f1 and f2, + return a pair of input and output schemata for #(f2 (merge % (f1 %))). + f1's output schema must not contain any optional keys." + [[i2 o2] :- IOSchemata + [i1 o1] :- [(s/one InputSchema 'input) (s/one MapOutputSchema 'output)]] + (assert-satisfies-schema (select-keys i2 (keys o1)) o1) + [(union-input-schemata (apply dissoc i2 (concat (keys o1) (map s/optional-key (keys o1)))) i1) + o2]) + +(defn schema-key [m k] + (cond (contains? m k) + k + + (contains? m (s/optional-key k)) + (s/optional-key k) + + :else nil)) + +(defn possibly-contains? [m k] + (boolean (schema-key m k))) + +(s/defn split-schema + "Return a pair [ks-part non-ks-part], with any extra schema removed." + [s :- InputSchema ks :- [s/Keyword]] + (let [ks (set ks)] + (for [in? [true false]] + (into {} (for [[k v] s + :when (and (s/specific-key? k) + (= in? (contains? ks (s/explicit-schema-key k))))] + [k v]))))) + +(s/defn sequence-schemata :- GraphIOSchemata + "Given pairs of input and output schemata for fnks f1 and f2, and a keyword k, + return a pair of input and output schemata for #(let [v1 (f1 %)] (assoc v1 k (f2 (merge-disjoint % v1))))" + [[i1 o1] :- GraphIOSchemata + [k [i2 o2]] :- [(s/one s/Keyword "key") (s/one IOSchemata "inner-schemas")]] + (assert-iae (not (possibly-contains? i1 k)) "Duplicate key output (possibly due to a misordered graph) %s for input %s from input %s" k (s/explain i2) (s/explain i1)) + (assert-iae (not (possibly-contains? o1 k)) "Node outputs a duplicate key %s given inputs %s" k (s/explain i1)) + (let [[used unused] (split-schema i2 (keys o1))] + (assert-satisfies-schema used o1) + [(union-input-schemata unused i1) + (assoc o1 k o2)])) + +;;;;;;;;;;;; This file autogenerated from src/plumbing/fnk/schema.cljx diff --git a/src/plumbing/graph.clj b/src/plumbing/graph.clj new file mode 100644 index 0000000..0c61b8e --- /dev/null +++ b/src/plumbing/graph.clj @@ -0,0 +1,341 @@ +(ns plumbing.graph + "A Graph is a simple, declarative way to define a composition of functions that is + easy to define, modify, execute, test, and monitor. + + This blog post provides a high-level overview of Graph and its benefits: + http://plumatic.github.io/prismatics-graph-at-strange-loop + + Concretely, a Graph specification is just a Clojure (nested) map with keyword keys + and keyword functions at the leaves. + + A Graph is defined recursively as either: + 1. a keyword function (i.e., fn satisfying PFnk), or + 2. a Clojure map from keywords to (sub)graphs. + + A Graph is a declarative specification of a single keyword function that + produces a map output, where each value in the output is produced by executing + the corresponding keyword function in the Graph. The inputs to the keyword + function are given by the outputs of other nodes in the graph with matching + keywords (mimicking lexical scope in the case of nested maps), or failing that, + from keywords in the input map. + + For more details and examples of Graphs, see test/plumbing/graph_examples_test.cljx." + (:refer-clojure :exclude [compile]) + (:require + [lazymap.core :as lazymap] + [schema.core :as s] + [schema.macros :as schema-macros] + [plumbing.fnk.schema :as schema :include-macros true] + [plumbing.fnk.pfnk :as pfnk] + [plumbing.fnk.impl :as fnk-impl] + [plumbing.graph.positional :as graph-positional] + [plumbing.core :as plumbing :include-macros true] + [plumbing.map :as map]) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Constructing graphs + +(defn working-array-map + "array-map in cljs no longer preserves ordering, replicate the old functionality." + [& args] + (schema-macros/if-cljs + (.fromArray cljs.core/PersistentArrayMap (apply array args) true true) + (apply array-map args))) + +(defn ->graph + "Convert a graph specification into a canonical well-formed 'graph', which + is an array-map with nodes in a correct topological order that will respond + to 'io-schemata' with a specification of the graph inputs and outputs. + + The graph specification can be a Clojure map, in which case the topological + order will be computed (an error will be thrown for cyclic specifications), + or a sequence of key-value pairs that are already in a valid topological order + (an error will be thrown if the order is not valid). Values in the input + sequence are also converted to canonical graphs via recursive calls to ->graph." + [graph-nodes] + (if (or (fn? graph-nodes) (= graph-nodes (::self (meta graph-nodes)))) + graph-nodes + (let [canonical-nodes (plumbing/map-vals ->graph graph-nodes) + graph (->> (if-not (map? graph-nodes) + (map first graph-nodes) + (->> canonical-nodes + (plumbing/map-vals pfnk/input-schema-keys) + map/topological-sort + reverse)) + (mapcat #(find canonical-nodes %)) + (apply working-array-map))] + (assert (every? keyword? (keys graph))) + (with-meta graph + {::io-schemata (update-in (reduce schema/sequence-schemata + [{} {}] + (for [[k node] graph] + [k (pfnk/io-schemata node)])) + [0] assoc s/Keyword s/Any) + ::self graph})))) + +;; Any Clojure map can be treated as a graph directly, without calling ->graph + +(defn io-schemata* [g] + (plumbing/safe-get (meta (->graph g)) ::io-schemata)) + +(extend-protocol pfnk/PFnk + clojure.lang.IPersistentMap + + (io-schemata [g] (io-schemata* g)) + + (io-schemata [g] (io-schemata* g))) + +(defn- split-nodes [s] + (loop [in s out []] + (if-let [[f & r] (seq in)] + (cond (keyword? f) ;; key then value + (recur (next r) (conj out [f (first r)])) + + (fn? f) + (do (schema/assert-iae (pfnk/fnk-name f) "Inline fnks must have a name (to be used as a key)") + (recur r (conj out [(keyword (pfnk/fnk-name f)) f]))) + + :else ;; inline graph + (recur r (into out f))) + out))) + +(defn graph + "An ordered constructor for graphs, which enforces that the Graph is provided + in a valid topological ordering. This is a sanity check, and also enforces + defining graphs in a readable way. Most explicit graphs should be created + with this constructor. + + (graph + :x-plus-1 (fnk [x] (inc x)) + :2-x-plus-2 (fnk [x-plus-1] (* 2 x-plus-1))) + + in addition, an 'inline' graph can be provided in place of a key-value + sequence, which will be merged into the graph at this position. + + a named fnk can also be provided in place of a key-value pair, + where the fnk's name (as a keyword) is the implicit key." + [& nodes] + (let [partitioned (split-nodes nodes)] + (schema/assert-distinct (map first partitioned)) + (->graph partitioned))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compiling and running graphs + + +(defn eager-compile + "Compile graph specification g to a corresponding fnk that is optimized for + speed. Wherever possible, fnks are called positionally, to reduce the + overhead of creating and destructuring maps, and the return value is a + record, which is much faster to create and access than a map. Compilation + is relatively slow, however, due to internal calls to 'eval'." + [g] + (if (fn? g) + g + (let [g (for [[k sub-g] (->graph g)] + [k (eager-compile sub-g)])] + (graph-positional/positional-flat-compile (->graph g))))) + + +(defn positional-eager-compile + "Like eager-compile, but produce a non-keyword function that can be called + with args in the order provided by arg-ks, avoiding the overhead of creating + and destructuring a top-level map. This can yield a substantially faster + fn for Graphs with very computationally inexpensive node fnks." + [g arg-ks] + (fnk-impl/positional-fn (eager-compile g) arg-ks)) + +(defn simple-flat-compile + "Helper method for simple (non-nested) graph compilations that convert a graph + specification to a fnk that returns a Clojure map of the graph node values. + (make-map m) converts an initial Clojure map m to the return type of the fnk, + and (assoc-f m k f) associates the value given by (f) under key k to map m." + [g check-input? make-map assoc-f] + (let [g (->graph g) + req-ks (schema/required-toplevel-keys (pfnk/input-schema g))] + (pfnk/fn->fnk + (fn [m] + (when check-input? + (let [missing-keys (seq (remove #(contains? m %) req-ks))] + (schema/assert-iae (empty? missing-keys) + "Missing top-level keys in graph input: %s" + (set missing-keys)))) + (apply + dissoc + (reduce + (fn [inner [k node-f]] + (schema/assert-iae (not (contains? inner k)) + "Inner graph key %s duplicated" k) + (assoc-f inner k node-f)) + (make-map m) + g) + (keys m))) + (pfnk/io-schemata g)))) + +(defn simple-hierarchical-compile + "Hierarchical extension of simple-nonhierarchical-compile." + [g check-input? make-map assoc-f] + (if (fn? g) + g + (simple-flat-compile + (for [[k sub-g] (->graph g)] + [k (simple-hierarchical-compile sub-g check-input? make-map assoc-f)]) + check-input? make-map assoc-f))) + +(defn restricted-call + "Call fnk f on the subset of keys its input schema explicitly asks for" + [f in-m] + (f (select-keys in-m (pfnk/input-schema-keys f)))) + +(defn interpreted-eager-compile + "Compile graph specification g to a corresponding fnk that returns an + ordinary Clojure map of the node result fns on a given input. The + compilation is much faster than 'eager-compile', but the compiled fn + will typically be much slower." + [g] + (simple-hierarchical-compile + g + true + (fn [m] m) + (fn [m k f] (assoc m k (restricted-call f m))))) + + +(defn lazy-compile + "Compile graph specification g to a corresponding fnk that returns a + lazymap of the node result fns on a given input. This fnk returns + the lazymap immediately, and node values are computed and cached as needed + as values are extracted from the lazymap. Besides this lazy behavior, + the lazymap can be used interchangeably with an ordinary Clojure map. + Required inputs to the graph are checked lazily, so you can omit input + keys not required by unneeded output keys." + [g] + (simple-hierarchical-compile + g + false + (fn [m] (reduce-kv assoc (lazymap/lazy-hash-map) m)) ;; into is extremely slow on lazymaps. + (fn [m k f] (lazymap/delay-assoc m k (delay (restricted-call f m)))))) + + ;; TODO: move out. +(defn par-compile + "Experimental. Launches one future per node at startup; we probably woudln't + use this in production, and will release more sophisticated parallel + compilations later. + + Compile graph specification g to a corresponding fnk that returns a + lazymap of the node result fns on a given input. This fnk returns + the lazymap immediately, and node values are computed and cached in parallel + starting immediately (and attempts to extract values from the lazymap will + block until each value is computed). Besides this lazy behavior, + the lazymap can be used interchangeably with an ordinary Clojure map." + [g] + (simple-hierarchical-compile + g + true + (fn [m] (into (lazymap/lazy-hash-map) m)) + (fn [m k f] (lazymap/delay-assoc m k (future (restricted-call f m)))))) + +(defn compile + "Compile graph specification g to a corresponding fnk using the a default + compile strategy for host. + Clojure: eager-compile + ClojureScript: interpreted-eager-compile" + [g] + (eager-compile g) + ) + +(defn run + "Eagerly run a graph on an input by compiling and then executing on this input." + [g input] + ((interpreted-eager-compile g) input)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Higher-order functions on graphs + +(defn check-comp-partial! + "Check that instance-fn is a valid fn to comp-partial with graph g." + [g instance-fn] + (let [is (pfnk/input-schema g) + os (pfnk/output-schema instance-fn)] + (schema/assert-iae (map? os) "instance-fn must have output metadata") + (let [extra-ks (remove #(schema/possibly-contains? is %) (keys os))] + (schema/assert-iae (empty? extra-ks) "instance-fn provides unused keys: %s" (vec extra-ks))) + (doseq [[k s] os] + (schema/assert-satisfies-schema (or (get is k) (get is (s/optional-key k))) s)))) + +(defn comp-partial-fn + "Return a new pfnk representing the composition #(f (merge % (other %)))" + [f other] + (pfnk/fn->fnk + (fn [m] (f (merge m (other m)))) + (schema/compose-schemata (pfnk/io-schemata f) (pfnk/io-schemata other)))) + +(defn comp-partial + "Experimental. + + An extension of pfnk/comp-partial that supplies new parameters to a subgraph, + useful in composing hierarchical graphs. + + g is a graph, and instance-fn is a fnk that takes arguments from the surrounding + context and produces new parameters that are fed into g. Works by comp-partialing + all leafs that expects any parameter produced by instance-fn with instance-fn, + so beware of expensive instance-fns, or those that expect caching of some sort + (i.e., attempt to generate shared state). + + Throws an error if any parameter supplied by instance-fn is not used by at least + one node in g." + [g instance-fn] + (if (fn? g) + (comp-partial-fn g instance-fn) + (let [os (pfnk/output-schema instance-fn)] + (check-comp-partial! g instance-fn) + (->graph + (map/map-leaves + (fn [node-fn] + (if (some os (pfnk/input-schema-keys node-fn)) + (comp-partial-fn node-fn instance-fn) + node-fn)) + g))))) + +(defmacro instance + "Experimental. + + Convenience macro for comp-partial, used to supply inline parameters to a + subgraph (or fnk). + + Example: + (= {:x 21} + (run (instance {:x (fnk [a] (inc a))} [z] {:a (* z 2)}) + {:z 10}))" + ([g m] `(instance ~g [] ~m)) + ([g bind m] + `(comp-partial ~g (plumbing/fnk ~bind ~m)))) + +(defn profiled + "Modify graph spec g, producing a new graph spec with a new top-level key + 'profile-key'. After each node value is computed, the number of milliseconds + taken to compute its value will be stored under an atom at 'profile-key'." + [profile-key g] + (assert (and (keyword? profile-key) (not (get g profile-key)))) + (->graph + (assoc (map/map-leaves-and-path + (fn [ks f] + (pfnk/fn->fnk + (fn [m] + (let [pm (plumbing/safe-get m profile-key) + start (System/nanoTime) + res (f (dissoc m profile-key))] + (swap! pm assoc-in ks + (/ (- (System/nanoTime) start) 1000000.0) + ) + res)) + [(assoc (pfnk/input-schema f) + profile-key s/Any) + (pfnk/output-schema f)])) + (->graph g)) + profile-key (plumbing/fnk [] (atom {}))))) + +;;;;;;;;;;;; This file autogenerated from src/plumbing/graph.cljx diff --git a/src/plumbing/graph_async.clj b/src/plumbing/graph_async.clj new file mode 100644 index 0000000..fe5a9ff --- /dev/null +++ b/src/plumbing/graph_async.clj @@ -0,0 +1,85 @@ +(ns plumbing.graph-async + + + + (:require + [clojure.core.async :as async :refer [go <! >!]] + + [clojure.core.async.impl.protocols :as async-protocols] + + [plumbing.fnk.pfnk :as pfnk] + [plumbing.fnk.schema :as schema :include-macros true] + [plumbing.core :as plumbing :include-macros true] + [plumbing.graph :as graph :include-macros true])) + +(defn asyncify + "Take a fnk f and return an async version by wrapping non-channel + return values in a channel" + [f] + (pfnk/fn->fnk + (fn [m] + (let [v (f m)] + (if (satisfies? async-protocols/ReadPort v) + v + (go v)))) + (pfnk/io-schemata f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public + +(defn async-compile + "Experimental. + + Compile a hierarchical graph with (some) async fnks into an channel that + contains the computed graph once completed. + + Each fnk can perform async operations by returning a channel that contains + its node value once completed. + + Each node function will be evaluated as its dependencies have been fully + computed." + [g] + (if (fn? g) + (asyncify g) + (let [g (graph/->graph (plumbing/map-vals async-compile g)) + req-ks (schema/required-toplevel-keys (pfnk/input-schema g)) + edges (concat + (for [[k v] g + parent-k (filter g (pfnk/input-schema-keys v))] + [parent-k k]) + (for [k (keys g)] + [k ::done])) + child-map (->> edges + (group-by first) + (plumbing/map-vals #(set (map second %)))) + parent-map (->> edges + (group-by second) + (plumbing/map-vals #(set (map first %))))] + (pfnk/fn->fnk + (fn [m] + (let [missing-keys (seq (remove #(contains? m %) req-ks))] + (schema/assert-iae (empty? missing-keys) + "Missing top-level keys in graph input: %s" + (set missing-keys))) + (let [result (async/chan) + remaining-parents (atom parent-map) + results (atom m) + run-node (fn run-node [k] + (go + (if (= ::done k) + (>! result (select-keys @results (keys g))) + (let [f (g k) + r (<! (f (select-keys @results (pfnk/input-schema-keys f))))] + (swap! results assoc k r) + (doseq [c (child-map k)] + (when (empty? (c (swap! remaining-parents + update-in [c] + disj k))) + (run-node c)))))))] + (doseq [k (keys g)] + (when (empty? (parent-map k)) + (run-node k))) + result)) + (pfnk/io-schemata g))))) + +;;;;;;;;;;;; This file autogenerated from src/plumbing/graph_async.cljx diff --git a/src/plumbing/map.clj b/src/plumbing/map.clj new file mode 100644 index 0000000..026ed31 --- /dev/null +++ b/src/plumbing/map.clj @@ -0,0 +1,233 @@ +(ns plumbing.map + "Common operations on maps (both Clojure immutable and mutable Java stuff)" + (:refer-clojure :exclude [flatten]) + (:require + [plumbing.core :as plumbing :include-macros true] + [plumbing.fnk.schema :as schema :include-macros true] + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Clojure immutable maps + +(defn safe-select-keys + "Like select-keys, but asserts that all keys are present." + [m ks] + (let [missing (remove (partial contains? m) ks)] + (schema/assert-iae (empty? missing) "Keys %s not found in %s" (vec missing) + (binding [*print-length* 200] + (print-str (mapv key m))))) + (select-keys m ks)) + +(defn merge-disjoint + "Like merge, but throws with any key overlap between maps" + ([] {}) + ([m] m) + ([m1 m2] + (let [duplicates (filter (partial contains? m2) (keys m1))] + (schema/assert-iae (empty? duplicates) "Duplicate keys %s" + (vec duplicates))) + (into (or m2 {}) m1)) + ([m1 m2 & maps] + (reduce merge-disjoint m1 (cons m2 maps)))) + +(defn merge-with-key + "Like merge-with, but the merging function takes the key being merged + as the first argument" + [f & maps] + (when (some identity maps) + (let [merge-entry (fn [m e] + (let [k (key e) v (val e)] + (if (contains? m k) + (assoc m k (f k (get m k) v)) + (assoc m k v)))) + merge2 (fn [m1 m2] + (reduce merge-entry (or m1 {}) (seq m2)))] + (reduce merge2 maps)))) + +(defn flatten + "Transform a nested map into a seq of [keyseq leaf-val] pairs" + [m] + (when m + ((fn flatten-helper [keyseq m] + (when m + (if (map? m) + (mapcat (fn [[k v]] (flatten-helper (conj keyseq k) v)) m) + [[keyseq m]]))) + [] m))) + +(defn unflatten + "Transform a seq of [keyseq leaf-val] pairs into a nested map. + If one keyseq is a prefix of another, you're on your own." + [s] + (reduce (fn [m [ks v]] (if (seq ks) (assoc-in m ks v) v)) {} s)) + + +;; TODO: make sure we're safe with false here -- pretty sure we're not. Same for nil. +(defn map-leaves-and-path + "Takes a nested map and returns a nested map with the same shape, where each + (non-map) leaf v is transformed to (f key-seq v). + key-seq is the sequence of keys to reach this leaf, starting at the root." + ([f m] (when m (map-leaves-and-path f [] m))) + ([f ks m] + (if-not (map? m) + (f ks m) + (plumbing/for-map [[k v] m] + k + (map-leaves-and-path f (conj ks k) v))))) + +(defn keep-leaves-and-path + "Takes a nested map and returns a nested map with the same shape, where each + (non-map) leaf v is transformed to (f key-seq v), or removed if it returns nil. + key-seq is the sequence of keys to reach this leaf, starting at the root. + Empty maps produced by this pruning are themselves pruned from the output." + ([f m] (keep-leaves-and-path f [] m)) + ([f ks m] + (if-not (map? m) + (f ks m) + (plumbing/for-map [[k ov] m + :let [nv (keep-leaves-and-path f (conj ks k) ov)] + :when (not (or (nil? nv) (and (map? nv) (empty? nv))))] + k nv)))) + +(defn map-leaves + "Takes a nested map and returns a nested map with the same shape, where each + (non-map) leaf v is transformed to (f v)." + ([f m] (map-leaves-and-path (fn [_ l] (f l)) m))) + +(defn keep-leaves + "Takes a nested map and returns a nested map with the same shape, where each + (non-map) leaf v is transformed to (f v), or removed if it returns nil. + Empty maps produced by this pruning are themselves pruned from the output." + ([f m] (keep-leaves-and-path (fn [_ l] (f l)) m))) + +(defmacro keyword-map + "Expands to a map whose keys are keywords with the same name as the given + symbols, e.g.: + + (let [x 41, y (inc x)] + (keyword-map x y)) + + ;; => {:x 41, :y 42}" + [& syms] + (when-not (every? symbol? syms) + (throw (ex-info "Arguments to keyword-map must be symbols!" {:args syms}))) + (zipmap (map #(keyword (name %)) syms) syms)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Java mutable Maps + + +(do + (defn update-key! + "Transform value in java.util.Map m under key k with fn f." + ([^java.util.Map m k f] + (.put m k (f (.get m k)))) + ([^java.util.Map m k f & args] + (.put m k (apply f (.get m k) args)))) + + (defmacro get! + "Get the value in java.util.Map m under key k. If the key is not present, + set the value to the result of default-expr and return it. Useful for + constructing mutable nested structures on the fly. + + (.add ^List (get! m :k (java.util.ArrayList.)) :foo)" + [m k default-expr] + `(let [^java.util.Map m# ~m k# ~k] + (or (.get m# k#) + (let [nv# ~default-expr] + (.put m# k# nv#) + nv#)))) + + (defn inc-key! + "Increment the value in java.util.Map m under key k by double d." + [^java.util.Map m k ^double d] + (.put m k (if-let [v (.get m k)] + (+ (double v) d) + d))) + + (defn inc-key-in! + "Increment the value in java.util.Map m under key-seq ks by double d, + creating and storing HashMaps under missing keys on the path to this leaf." + [^java.util.Map m ks ^double d] + (if-let [mk (next ks)] + (recur (get! m (first ks) (java.util.HashMap.)) mk d) + (inc-key! m (first ks) d))) + + + (defn ^java.util.HashMap collate + "Take a seq of [k v] counts and sum them up into a HashMap on k." + [flat-counts] + (let [m (java.util.HashMap.)] + (doseq [[k v] flat-counts] + (inc-key! m k v)) + m)) + + (defn ^java.util.HashMap deep-collate + "Take a seq of [kseq v] counts and sum them up into nested HashMaps" + [nested-counts] + (let [m (java.util.HashMap.)] + (doseq [[ks v] nested-counts] + (inc-key-in! m ks v)) + m))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Ops on graphs represented as maps. + + +(defn topological-sort + "Take an adjacency list representation of a graph (a map from node names to + sequences of child node names), and return a topological ordering of the node + names in linear time, or throw an error if the graph is cyclic. + If include-leaves? is false the ordering will only include keys from child-map, + and if true it will also include nodes only named as children in child-map." + [child-map & [include-leaves?]] + (let [e (java.util.HashMap. ^java.util.Map child-map) + re (java.util.HashMap.) + s (java.util.Stack.)] + (doseq [[p children] child-map + c children] + (when include-leaves? (when-not (.containsKey e c) (.put e c nil))) + (update-key! re c #(cons p %))) + (while (not (.isEmpty e)) + ((fn dfs1 [n] + (when (.containsKey e n) + (let [nns (.get e n)] + (.remove e n) + (doseq [nn nns] (dfs1 nn))) + (.push s n))) + (first (keys e)))) + (let [candidate (reverse (seq s))] + (doseq [c candidate + r (.remove re c)] + (when (.containsKey re r) + (throw (IllegalArgumentException. (format "Graph contains a cycle containing %s and %s" c r))))) + candidate))) + + + + + + + + + + + + + + + + + + + + + + + + + + + +;;;;;;;;;;;; This file autogenerated from src/plumbing/map.cljx -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-java/prismatic-plumbing-clojure.git _______________________________________________ pkg-java-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-java-commits
