From f1998c321a4eec6d75b58d84aa8610971bf21979 Mon Sep 17 00:00:00 2001 From: Brian Picciano Date: Sat, 31 Jul 2021 11:35:39 -0600 Subject: move static files into static sub-dir, refactor nix a bit --- src/assets/viz/1/cljs/core.cljs | 10762 -------------------------------------- 1 file changed, 10762 deletions(-) delete mode 100644 src/assets/viz/1/cljs/core.cljs (limited to 'src/assets/viz/1/cljs/core.cljs') diff --git a/src/assets/viz/1/cljs/core.cljs b/src/assets/viz/1/cljs/core.cljs deleted file mode 100644 index a87e53b..0000000 --- a/src/assets/viz/1/cljs/core.cljs +++ /dev/null @@ -1,10762 +0,0 @@ -; Copyright (c) Rich Hickey. All rights reserved. -; The use and distribution terms for this software are covered by the -; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -; which can be found in the file epl-v10.html at the root of this distribution. -; By using this software in any fashion, you are agreeing to be bound by -; the terms of this license. -; You must not remove this notice, or any other, from this software. - -(ns cljs.core - (:require goog.math.Long - goog.math.Integer - [goog.string :as gstring] - [goog.object :as gobject] - [goog.array :as garray]) - (:import [goog.string StringBuffer])) - -;; next line is auto-generated by the build-script - Do not edit! -(def *clojurescript-version* "1.9.473") - -(def *unchecked-if* false) -(def *warn-on-infer* false) - -(defonce PROTOCOL_SENTINEL #js {}) - -(goog-define - ^{:dynamic true - :doc "Var bound to the name value of the compiler build :target option. - For example, if the compiler build :target is :nodejs, *target* will be bound - to \"nodejs\". *target* is a Google Closure define and can be set by compiler - :closure-defines option."} - *target* "default") - -(def - ^{:dynamic true - :doc "Var bound to the current namespace. Only used for bootstrapping." - :jsdoc ["@type {*}"]} - *ns* nil) - -(def - ^{:dynamic true - :jsdoc ["@type {*}"]} - *out* nil) - -(def - ^{:dynamic true} - *assert* true) - -(defonce - ^{:doc "Each runtime environment provides a different way to print output. - Whatever function *print-fn* is bound to will be passed any - Strings which should be printed." :dynamic true} - *print-fn* - (fn [_] - (throw (js/Error. "No *print-fn* fn set for evaluation environment")))) - -(defonce - ^{:doc "Each runtime environment provides a different way to print error output. - Whatever function *print-err-fn* is bound to will be passed any - Strings which should be printed." :dynamic true} - *print-err-fn* - (fn [_] - (throw (js/Error. "No *print-err-fn* fn set for evaluation environment")))) - -(defn set-print-fn! - "Set *print-fn* to f." - [f] (set! *print-fn* f)) - -(defn set-print-err-fn! - "Set *print-err-fn* to f." - [f] (set! *print-err-fn* f)) - -(def - ^{:dynamic true - :doc "When set to true, output will be flushed whenever a newline is printed. - - Defaults to true."} - *flush-on-newline* true) - -(def - ^{:dynamic true - :doc "When set to logical false will drop newlines from printing calls. - This is to work around the implicit newlines emitted by standard JavaScript - console objects."} - *print-newline* true) - -(def - ^{:dynamic true - :doc "When set to logical false, strings and characters will be printed with - non-alphanumeric characters converted to the appropriate escape sequences. - - Defaults to true"} - *print-readably* true) - -(def - ^{:dynamic true - :doc "If set to logical true, when printing an object, its metadata will also - be printed in a form that can be read back by the reader. - - Defaults to false."} - *print-meta* false) - -(def - ^{:dynamic true - :doc "When set to logical true, objects will be printed in a way that preserves - their type when read in later. - - Defaults to false."} - *print-dup* false) - -(def - ^{:dynamic true - :doc "*print-namespace-maps* controls whether the printer will print - namespace map literal syntax. - - Defaults to false, but the REPL binds it to true."} - *print-namespace-maps* false) - -(def - ^{:dynamic true - :doc "*print-length* controls how many items of each collection the - printer will print. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - number of items of each collection to print. If a collection contains - more items, the printer will print items up to the limit followed by - '...' to represent the remaining items. The root binding is nil - indicating no limit." - :jsdoc ["@type {null|number}"]} - *print-length* nil) - -(def - ^{:dynamic true - :doc "*print-level* controls how many levels deep the printer will - print nested objects. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - level to print. Each argument to print is at level 0; if an argument is a - collection, its items are at level 1; and so on. If an object is a - collection and is at a level greater than or equal to the value bound to - *print-level*, the printer prints '#' to represent it. The root binding - is nil indicating no limit." - :jsdoc ["@type {null|number}"]} - *print-level* nil) - -(defonce - ^{:dynamic true - :jsdoc ["@type {*}"]} - *loaded-libs* nil) - -(defn- pr-opts [] - {:flush-on-newline *flush-on-newline* - :readably *print-readably* - :meta *print-meta* - :dup *print-dup* - :print-length *print-length*}) - -(declare into-array) - -(defn enable-console-print! - "Set *print-fn* to console.log" - [] - (set! *print-newline* false) - (set! *print-fn* - (fn [& args] - (.apply (.-log js/console) js/console (into-array args)))) - (set! *print-err-fn* - (fn [& args] - (.apply (.-error js/console) js/console (into-array args)))) - nil) - -(def - ^{:doc "bound in a repl thread to the most recent value printed"} - *1) - -(def - ^{:doc "bound in a repl thread to the second most recent value printed"} - *2) - -(def - ^{:doc "bound in a repl thread to the third most recent value printed"} - *3) - -(def - ^{:doc "bound in a repl thread to the most recent exception caught by the repl"} - *e) - -(defn truth_ - "Internal - do not use!" - [x] - (cljs.core/truth_ x)) - -(def not-native nil) - -(declare instance? Keyword) - -(defn ^boolean identical? - "Tests if 2 arguments are the same object" - [x y] - (cljs.core/identical? x y)) - -(defn ^boolean nil? - "Returns true if x is nil, false otherwise." - [x] - (coercive-= x nil)) - -(defn ^boolean array? - "Returns true if x is a JavaScript array." - [x] - (if (identical? *target* "nodejs") - (.isArray js/Array x) - (instance? js/Array x))) - -(defn ^boolean number? - "Returns true if x is a JavaScript number." - [x] - (cljs.core/number? x)) - -(defn ^boolean not - "Returns true if x is logical false, false otherwise." - [x] - (cond - (nil? x) true - (false? x) true - :else false)) - -(defn ^boolean some? - "Returns true if x is not nil, false otherwise." - [x] (not (nil? x))) - -(defn ^boolean object? - "Returns true if x's constructor is Object" - [x] - (if-not (nil? x) - (identical? (.-constructor x) js/Object) - false)) - -(defn ^boolean string? - "Returns true if x is a JavaScript string." - [x] - (goog/isString x)) - -(defn ^boolean char? - "Returns true if x is a JavaScript string of length one." - [x] - (and (string? x) (== 1 (.-length x)))) - -(defn ^boolean any? - "Returns true if given any argument." - [x] true) - -(set! *unchecked-if* true) -(defn ^boolean native-satisfies? - "Internal - do not use!" - [p x] - (let [x (if (nil? x) nil x)] - (cond - (aget p (goog/typeOf x)) true - (aget p "_") true - :else false))) -(set! *unchecked-if* false) - -(defn is_proto_ - [x] - (identical? (.-prototype (.-constructor x)) x)) - -(def - ^{:doc "When compiled for a command-line target, whatever function - *main-cli-fn* is set to will be called with the command-line - argv as arguments"} - *main-cli-fn* nil) - -(defn type - "Return x's constructor." - [x] - (when-not (nil? x) - (.-constructor x))) - -(defn missing-protocol [proto obj] - (let [ty (type obj) - ty (if (and ty (.-cljs$lang$type ty)) - (.-cljs$lang$ctorStr ty) - (goog/typeOf obj))] - (js/Error. - (.join (array "No protocol method " proto - " defined for type " ty ": " obj) "")))) - -(defn type->str [ty] - (if-let [s (.-cljs$lang$ctorStr ty)] - s - (str ty))) - -;; INTERNAL - do not use, only for Node.js -(defn load-file [file] - (when-not js/COMPILED - (cljs.core/load-file* file))) - -(if (and (exists? js/Symbol) - (identical? (goog/typeOf js/Symbol) "function")) - (def ITER_SYMBOL (.-iterator js/Symbol)) - (def ITER_SYMBOL "@@iterator")) - -(def ^{:jsdoc ["@enum {string}"]} - CHAR_MAP - #js {"-" "_" - ":" "_COLON_" - "+" "_PLUS_" - ">" "_GT_" - "<" "_LT_" - "=" "_EQ_" - "~" "_TILDE_" - "!" "_BANG_" - "@" "_CIRCA_" - "#" "_SHARP_" - "'" "_SINGLEQUOTE_" - "\\\"" "_DOUBLEQUOTE_" - "%" "_PERCENT_" - "^" "_CARET_" - "&" "_AMPERSAND_" - "*" "_STAR_" - "|" "_BAR_" - "{" "_LBRACE_" - "}" "_RBRACE_" - "[" "_LBRACK_" - "]" "_RBRACK_" - "/" "_SLASH_" - "\\\\" "_BSLASH_" - "?" "_QMARK_"}) - -(def ^{:jsdoc ["@enum {string}"]} - DEMUNGE_MAP - #js {"_" "-" - "_COLON_" ":" - "_PLUS_" "+" - "_GT_" ">" - "_LT_" "<" - "_EQ_" "=" - "_TILDE_" "~" - "_BANG_" "!" - "_CIRCA_" "@" - "_SHARP_" "#" - "_SINGLEQUOTE_" "'" - "_DOUBLEQUOTE_" "\\\"" - "_PERCENT_" "%" - "_CARET_" "^" - "_AMPERSAND_" "&" - "_STAR_" "*" - "_BAR_" "|" - "_LBRACE_" "{" - "_RBRACE_" "}" - "_LBRACK_" "[" - "_RBRACK_" "]" - "_SLASH_" "/" - "_BSLASH_" "\\\\" - "_QMARK_" "?"}) - -(def DEMUNGE_PATTERN nil) - -(defn system-time - "Returns highest resolution time offered by host in milliseconds." - [] - (cond - (and (exists? js/performance) - (not (nil? (. js/performance -now)))) - (.now js/performance) - - (and (exists? js/process) - (not (nil? (. js/process -hrtime)))) - (let [t (.hrtime js/process)] - (/ (+ (* (aget t 0) 1e9) (aget t 1)) 1e6)) - - :else (.getTime (js/Date.)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; arrays ;;;;;;;;;;;;;;;; - -(declare apply) - -(defn ^array make-array - "Construct a JavaScript array of the specified dimensions. Accepts ignored - type argument for compatibility with Clojure. Note that there is no efficient - way to allocate multi-dimensional arrays in JavaScript; as such, this function - will run in polynomial time when called with 3 or more arguments." - ([size] - (js/Array. size)) - ([type size] - (make-array size)) - ([type size & more-sizes] - (let [dims more-sizes - dimarray (make-array size)] - (dotimes [i (alength dimarray)] - (aset dimarray i (apply make-array nil dims))) - dimarray))) - -(defn aclone - "Returns a javascript array, cloned from the passed in array" - [arr] - (let [len (alength arr) - new-arr (make-array len)] - (dotimes [i len] - (aset new-arr i (aget arr i))) - new-arr)) - -(defn ^array array - "Creates a new javascript array. -@param {...*} var_args" ;;array is a special case, don't emulate this doc string - [var-args] ;; [& items] - (let [a (js/Array. (alength (cljs.core/js-arguments)))] - (loop [i 0] - (if (< i (alength a)) - (do - (aset a i (aget (cljs.core/js-arguments) i)) - (recur (inc i))) - a)))) - -(defn aget - "Returns the value at the index." - ([array i] - (cljs.core/aget array i)) - ([array i & idxs] - (apply aget (aget array i) idxs))) - -(defn aset - "Sets the value at the index." - ([array i val] - (cljs.core/aset array i val)) - ([array idx idx2 & idxv] - (apply aset (aget array idx) idx2 idxv))) - -(defn ^number alength - "Returns the length of the array. Works on arrays of all types." - [array] - (cljs.core/alength array)) - -(declare reduce) - -(defn ^array into-array - "Returns an array with components set to the values in aseq. Optional type - argument accepted for compatibility with Clojure." - ([aseq] - (into-array nil aseq)) - ([type aseq] - (reduce (fn [a x] (.push a x) a) (array) aseq))) - -(defn js-invoke - "Invoke JavaScript object method via string. Needed when the - string is not a valid unquoted property name." - [obj s & args] - (.apply (aget obj s) obj (into-array args))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;; core protocols ;;;;;;;;;;;;; - -(defprotocol Fn - "Marker protocol") - -(defprotocol IFn - "Protocol for adding the ability to invoke an object as a function. - For example, a vector can also be used to look up a value: - ([1 2 3 4] 1) => 2" - (-invoke - [this] - [this a] - [this a b] - [this a b c] - [this a b c d] - [this a b c d e] - [this a b c d e f] - [this a b c d e f g] - [this a b c d e f g h] - [this a b c d e f g h i] - [this a b c d e f g h i j] - [this a b c d e f g h i j k] - [this a b c d e f g h i j k l] - [this a b c d e f g h i j k l m] - [this a b c d e f g h i j k l m n] - [this a b c d e f g h i j k l m n o] - [this a b c d e f g h i j k l m n o p] - [this a b c d e f g h i j k l m n o p q] - [this a b c d e f g h i j k l m n o p q r] - [this a b c d e f g h i j k l m n o p q r s] - [this a b c d e f g h i j k l m n o p q r s t] - [this a b c d e f g h i j k l m n o p q r s t rest])) - -(defprotocol ICloneable - "Protocol for cloning a value." - (^clj -clone [value] - "Creates a clone of value.")) - -(defprotocol ICounted - "Protocol for adding the ability to count a collection in constant time." - (^number -count [coll] - "Calculates the count of coll in constant time. Used by cljs.core/count.")) - -(defprotocol IEmptyableCollection - "Protocol for creating an empty collection." - (-empty [coll] - "Returns an empty collection of the same category as coll. Used - by cljs.core/empty.")) - -(defprotocol ICollection - "Protocol for adding to a collection." - (^clj -conj [coll o] - "Returns a new collection of coll with o added to it. The new item - should be added to the most efficient place, e.g. - (conj [1 2 3 4] 5) => [1 2 3 4 5] - (conj '(2 3 4 5) 1) => '(1 2 3 4 5)")) - -#_(defprotocol IOrdinal - (-index [coll])) - -(defprotocol IIndexed - "Protocol for collections to provide indexed-based access to their items." - (-nth [coll n] [coll n not-found] - "Returns the value at the index n in the collection coll. - Returns not-found if index n is out of bounds and not-found is supplied.")) - -(defprotocol ASeq - "Marker protocol indicating an array sequence.") - -(defprotocol ISeq - "Protocol for collections to provide access to their items as sequences." - (-first [coll] - "Returns the first item in the collection coll. Used by cljs.core/first.") - (^clj -rest [coll] - "Returns a new collection of coll without the first item. It should - always return a seq, e.g. - (rest []) => () - (rest nil) => ()")) - -(defprotocol INext - "Protocol for accessing the next items of a collection." - (^clj-or-nil -next [coll] - "Returns a new collection of coll without the first item. In contrast to - rest, it should return nil if there are no more items, e.g. - (next []) => nil - (next nil) => nil")) - -(defprotocol ILookup - "Protocol for looking up a value in a data structure." - (-lookup [o k] [o k not-found] - "Use k to look up a value in o. If not-found is supplied and k is not - a valid value that can be used for look up, not-found is returned.")) - -(defprotocol IAssociative - "Protocol for adding associativity to collections." - (^boolean -contains-key? [coll k] - "Returns true if k is a key in coll.") - #_(-entry-at [coll k]) - (^clj -assoc [coll k v] - "Returns a new collection of coll with a mapping from key k to - value v added to it.")) - -(defprotocol IMap - "Protocol for adding mapping functionality to collections." - #_(-assoc-ex [coll k v]) - (^clj -dissoc [coll k] - "Returns a new collection of coll without the mapping for key k.")) - -(defprotocol IMapEntry - "Protocol for examining a map entry." - (-key [coll] - "Returns the key of the map entry.") - (-val [coll] - "Returns the value of the map entry.")) - -(defprotocol ISet - "Protocol for adding set functionality to a collection." - (^clj -disjoin [coll v] - "Returns a new collection of coll that does not contain v.")) - -(defprotocol IStack - "Protocol for collections to provide access to their items as stacks. The top - of the stack should be accessed in the most efficient way for the different - data structures." - (-peek [coll] - "Returns the item from the top of the stack. Is used by cljs.core/peek.") - (^clj -pop [coll] - "Returns a new stack without the item on top of the stack. Is used - by cljs.core/pop.")) - -(defprotocol IVector - "Protocol for adding vector functionality to collections." - (^clj -assoc-n [coll n val] - "Returns a new vector with value val added at position n.")) - -(defprotocol IDeref - "Protocol for adding dereference functionality to a reference." - (-deref [o] - "Returns the value of the reference o.")) - -(defprotocol IDerefWithTimeout - (-deref-with-timeout [o msec timeout-val])) - -(defprotocol IMeta - "Protocol for accessing the metadata of an object." - (^clj-or-nil -meta [o] - "Returns the metadata of object o.")) - -(defprotocol IWithMeta - "Protocol for adding metadata to an object." - (^clj -with-meta [o meta] - "Returns a new object with value of o and metadata meta added to it.")) - -(defprotocol IReduce - "Protocol for seq types that can reduce themselves. - Called by cljs.core/reduce." - (-reduce [coll f] [coll f start] - "f should be a function of 2 arguments. If start is not supplied, - returns the result of applying f to the first 2 items in coll, then - applying f to that result and the 3rd item, etc.")) - -(defprotocol IKVReduce - "Protocol for associative types that can reduce themselves - via a function of key and val. Called by cljs.core/reduce-kv." - (-kv-reduce [coll f init] - "Reduces an associative collection and returns the result. f should be - a function that takes three arguments.")) - -(defprotocol IEquiv - "Protocol for adding value comparison functionality to a type." - (^boolean -equiv [o other] - "Returns true if o and other are equal, false otherwise.")) - -(defprotocol IHash - "Protocol for adding hashing functionality to a type." - (-hash [o] - "Returns the hash code of o.")) - -(defprotocol ISeqable - "Protocol for adding the ability to a type to be transformed into a sequence." - (^clj-or-nil -seq [o] - "Returns a seq of o, or nil if o is empty.")) - -(defprotocol ISequential - "Marker interface indicating a persistent collection of sequential items") - -(defprotocol IList - "Marker interface indicating a persistent list") - -(defprotocol IRecord - "Marker interface indicating a record object") - -(defprotocol IReversible - "Protocol for reversing a seq." - (^clj -rseq [coll] - "Returns a seq of the items in coll in reversed order.")) - -(defprotocol ISorted - "Protocol for a collection which can represent their items - in a sorted manner. " - (^clj -sorted-seq [coll ascending?] - "Returns a sorted seq from coll in either ascending or descending order.") - (^clj -sorted-seq-from [coll k ascending?] - "Returns a sorted seq from coll in either ascending or descending order. - If ascending is true, the result should contain all items which are > or >= - than k. If ascending is false, the result should contain all items which - are < or <= than k, e.g. - (-sorted-seq-from (sorted-set 1 2 3 4 5) 3 true) => (3 4 5) - (-sorted-seq-from (sorted-set 1 2 3 4 5) 3 false) => (3 2 1)") - (-entry-key [coll entry] - "Returns the key for entry.") - (-comparator [coll] - "Returns the comparator for coll.")) - -(defprotocol IWriter - "Protocol for writing. Currently only implemented by StringBufferWriter." - (-write [writer s] - "Writes s with writer and returns the result.") - (-flush [writer] - "Flush writer.")) - -(defprotocol IPrintWithWriter - "The old IPrintable protocol's implementation consisted of building a giant - list of strings to concatenate. This involved lots of concat calls, - intermediate vectors, and lazy-seqs, and was very slow in some older JS - engines. IPrintWithWriter implements printing via the IWriter protocol, so it - be implemented efficiently in terms of e.g. a StringBuffer append." - (-pr-writer [o writer opts])) - -(defprotocol IPending - "Protocol for types which can have a deferred realization. Currently only - implemented by Delay and LazySeq." - (^boolean -realized? [x] - "Returns true if a value for x has been produced, false otherwise.")) - -(defprotocol IWatchable - "Protocol for types that can be watched. Currently only implemented by Atom." - (-notify-watches [this oldval newval] - "Calls all watchers with this, oldval and newval.") - (-add-watch [this key f] - "Adds a watcher function f to this. Keys must be unique per reference, - and can be used to remove the watch with -remove-watch.") - (-remove-watch [this key] - "Removes watcher that corresponds to key from this.")) - -(defprotocol IEditableCollection - "Protocol for collections which can transformed to transients." - (^clj -as-transient [coll] - "Returns a new, transient version of the collection, in constant time.")) - -(defprotocol ITransientCollection - "Protocol for adding basic functionality to transient collections." - (^clj -conj! [tcoll val] - "Adds value val to tcoll and returns tcoll.") - (^clj -persistent! [tcoll] - "Creates a persistent data structure from tcoll and returns it.")) - -(defprotocol ITransientAssociative - "Protocol for adding associativity to transient collections." - (^clj -assoc! [tcoll key val] - "Returns a new transient collection of tcoll with a mapping from key to - val added to it.")) - -(defprotocol ITransientMap - "Protocol for adding mapping functionality to transient collections." - (^clj -dissoc! [tcoll key] - "Returns a new transient collection of tcoll without the mapping for key.")) - -(defprotocol ITransientVector - "Protocol for adding vector functionality to transient collections." - (^clj -assoc-n! [tcoll n val] - "Returns tcoll with value val added at position n.") - (^clj -pop! [tcoll] - "Returns tcoll with the last item removed from it.")) - -(defprotocol ITransientSet - "Protocol for adding set functionality to a transient collection." - (^clj -disjoin! [tcoll v] - "Returns tcoll without v.")) - -(defprotocol IComparable - "Protocol for values that can be compared." - (^number -compare [x y] - "Returns a negative number, zero, or a positive number when x is logically - 'less than', 'equal to', or 'greater than' y.")) - -(defprotocol IChunk - "Protocol for accessing the items of a chunk." - (-drop-first [coll] - "Return a new chunk of coll with the first item removed.")) - -(defprotocol IChunkedSeq - "Protocol for accessing a collection as sequential chunks." - (-chunked-first [coll] - "Returns the first chunk in coll.") - (-chunked-rest [coll] - "Return a new collection of coll with the first chunk removed.")) - -(defprotocol IChunkedNext - "Protocol for accessing the chunks of a collection." - (-chunked-next [coll] - "Returns a new collection of coll without the first chunk.")) - -(defprotocol INamed - "Protocol for adding a name." - (^string -name [x] - "Returns the name String of x.") - (^string -namespace [x] - "Returns the namespace String of x.")) - -(defprotocol IAtom - "Marker protocol indicating an atom.") - -(defprotocol IReset - "Protocol for adding resetting functionality." - (-reset! [o new-value] - "Sets the value of o to new-value.")) - -(defprotocol ISwap - "Protocol for adding swapping functionality." - (-swap! [o f] [o f a] [o f a b] [o f a b xs] - "Swaps the value of o to be (apply f current-value-of-atom args).")) - -(defprotocol IVolatile - "Protocol for adding volatile functionality." - (-vreset! [o new-value] - "Sets the value of volatile o to new-value without regard for the - current value. Returns new-value.")) - -(defprotocol IIterable - "Protocol for iterating over a collection." - (-iterator [coll] - "Returns an iterator for coll.")) - -;; Printing support - -(deftype StringBufferWriter [sb] - IWriter - (-write [_ s] (.append sb s)) - (-flush [_] nil)) - -(defn pr-str* - "Support so that collections can implement toString without - loading all the printing machinery." - [^not-native obj] - (let [sb (StringBuffer.) - writer (StringBufferWriter. sb)] - (-pr-writer obj writer (pr-opts)) - (-flush writer) - (str sb))) - -;;;;;;;;;;;;;;;;;;; Murmur3 ;;;;;;;;;;;;;;; - -;;http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/Integer.java -(defn ^number int-rotate-left [x n] - (bit-or - (bit-shift-left x n) - (unsigned-bit-shift-right x (- n)))) - -;; http://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/imul -(if (and (exists? Math/imul) - (not (zero? (Math/imul 0xffffffff 5)))) - (defn ^number imul [a b] (Math/imul a b)) - (defn ^number imul [a b] - (let [ah (bit-and (unsigned-bit-shift-right a 16) 0xffff) - al (bit-and a 0xffff) - bh (bit-and (unsigned-bit-shift-right b 16) 0xffff) - bl (bit-and b 0xffff)] - (bit-or - (+ (* al bl) - (unsigned-bit-shift-right - (bit-shift-left (+ (* ah bl) (* al bh)) 16) 0)) 0)))) - -;; http://smhasher.googlecode.com/svn/trunk/MurmurHash3.cpp -(def m3-seed 0) -(def m3-C1 (int 0xcc9e2d51)) -(def m3-C2 (int 0x1b873593)) - -(defn ^number m3-mix-K1 [k1] - (-> (int k1) (imul m3-C1) (int-rotate-left 15) (imul m3-C2))) - -(defn ^number m3-mix-H1 [h1 k1] - (int (-> (int h1) (bit-xor (int k1)) (int-rotate-left 13) (imul 5) (+ (int 0xe6546b64))))) - -(defn ^number m3-fmix [h1 len] - (as-> (int h1) h1 - (bit-xor h1 len) - (bit-xor h1 (unsigned-bit-shift-right h1 16)) - (imul h1 (int 0x85ebca6b)) - (bit-xor h1 (unsigned-bit-shift-right h1 13)) - (imul h1 (int 0xc2b2ae35)) - (bit-xor h1 (unsigned-bit-shift-right h1 16)))) - -(defn ^number m3-hash-int [in] - (if (zero? in) - in - (let [k1 (m3-mix-K1 in) - h1 (m3-mix-H1 m3-seed k1)] - (m3-fmix h1 4)))) - -(defn ^number m3-hash-unencoded-chars [in] - (let [h1 (loop [i 1 h1 m3-seed] - (if (< i (alength in)) - (recur (+ i 2) - (m3-mix-H1 h1 - (m3-mix-K1 - (bit-or (.charCodeAt in (dec i)) - (bit-shift-left (.charCodeAt in i) 16))))) - h1)) - h1 (if (== (bit-and (alength in) 1) 1) - (bit-xor h1 (m3-mix-K1 (.charCodeAt in (dec (alength in))))) - h1)] - (m3-fmix h1 (imul 2 (alength in))))) - -;;;;;;;;;;;;;;;;;;; symbols ;;;;;;;;;;;;;;; - -(declare list Symbol = compare) - -;; Simple caching of string hashcode -(def string-hash-cache (js-obj)) -(def string-hash-cache-count 0) - -;;http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/String.java -(defn hash-string* [s] - (if-not (nil? s) - (let [len (alength s)] - (if (pos? len) - (loop [i 0 hash 0] - (if (< i len) - (recur (inc i) (+ (imul 31 hash) (.charCodeAt s i))) - hash)) - 0)) - 0)) - -(defn add-to-string-hash-cache [k] - (let [h (hash-string* k)] - (aset string-hash-cache k h) - (set! string-hash-cache-count (inc string-hash-cache-count)) - h)) - -(defn hash-string [k] - (when (> string-hash-cache-count 255) - (set! string-hash-cache (js-obj)) - (set! string-hash-cache-count 0)) - (if (nil? k) - 0 - (let [h (aget string-hash-cache k)] - (if (number? h) - h - (add-to-string-hash-cache k))))) - -(defn hash - "Returns the hash code of its argument. Note this is the hash code - consistent with =." - [o] - (cond - (implements? IHash o) - (-hash ^not-native o) - - (number? o) - (if (js/isFinite o) - (js-mod (Math/floor o) 2147483647) - (case o - Infinity - 2146435072 - -Infinity - -1048576 - 2146959360)) - - ;; note: mirrors Clojure's behavior on the JVM, where the hashCode is - ;; 1231 for true and 1237 for false - ;; http://docs.oracle.com/javase/7/docs/api/java/lang/Boolean.html#hashCode%28%29 - (true? o) 1231 - - (false? o) 1237 - - (string? o) - (m3-hash-int (hash-string o)) - - (instance? js/Date o) - (.valueOf o) - - (nil? o) 0 - - :else - (-hash o))) - -(defn hash-combine [seed hash] - ; a la boost - (bit-xor seed - (+ hash 0x9e3779b9 - (bit-shift-left seed 6) - (bit-shift-right seed 2)))) - -(defn ^boolean instance? - "Evaluates x and tests if it is an instance of the type - c. Returns true or false" - [c x] - (cljs.core/instance? c x)) - -(defn ^boolean symbol? - "Return true if x is a Symbol" - [x] - (instance? Symbol x)) - -(defn- hash-symbol [sym] - (hash-combine - (m3-hash-unencoded-chars (.-name sym)) - (hash-string (.-ns sym)))) - -(defn- compare-symbols [a b] - (cond - (identical? (.-str a) (.-str b)) 0 - (and (not (.-ns a)) (.-ns b)) -1 - (.-ns a) (if-not (.-ns b) - 1 - (let [nsc (garray/defaultCompare (.-ns a) (.-ns b))] - (if (== 0 nsc) - (garray/defaultCompare (.-name a) (.-name b)) - nsc))) - :default (garray/defaultCompare (.-name a) (.-name b)))) - -(declare get) - -(deftype Symbol [ns name str ^:mutable _hash _meta] - Object - (toString [_] str) - (equiv [this other] (-equiv this other)) - - IEquiv - (-equiv [_ other] - (if (instance? Symbol other) - (identical? str (.-str other)) - false)) - - IFn - (-invoke [sym coll] - (get coll sym)) - (-invoke [sym coll not-found] - (get coll sym not-found)) - - IMeta - (-meta [_] _meta) - - IWithMeta - (-with-meta [_ new-meta] (Symbol. ns name str _hash new-meta)) - - IHash - (-hash [sym] - (caching-hash sym hash-symbol _hash)) - - INamed - (-name [_] name) - (-namespace [_] ns) - - IPrintWithWriter - (-pr-writer [o writer _] (-write writer str))) - -(defn symbol - "Returns a Symbol with the given namespace and name." - ([name] - (if (symbol? name) - name - (let [idx (.indexOf name "/")] - (if (< idx 1) - (symbol nil name) - (symbol (.substring name 0 idx) - (.substring name (inc idx) (. name -length))))))) - ([ns name] - (let [sym-str (if-not (nil? ns) - (str ns "/" name) - name)] - (Symbol. ns name sym-str nil nil)))) - -(deftype Var [val sym _meta] - Object - (isMacro [_] - (. (val) -cljs$lang$macro)) - (toString [_] - (str "#'" sym)) - IDeref - (-deref [_] (val)) - IMeta - (-meta [_] _meta) - IWithMeta - (-with-meta [_ new-meta] - (Var. val sym new-meta)) - IEquiv - (-equiv [this other] - (if (instance? Var other) - (= (.-sym this) (.-sym other)) - false)) - IHash - (-hash [_] - (hash-symbol sym)) - Fn - IFn - (-invoke [_] - ((val))) - (-invoke [_ a] - ((val) a)) - (-invoke [_ a b] - ((val) a b)) - (-invoke [_ a b c] - ((val) a b c)) - (-invoke [_ a b c d] - ((val) a b c d)) - (-invoke [_ a b c d e] - ((val) a b c d e)) - (-invoke [_ a b c d e f] - ((val) a b c d e f)) - (-invoke [_ a b c d e f g] - ((val) a b c d e f g)) - (-invoke [_ a b c d e f g h] - ((val) a b c d e f g h)) - (-invoke [_ a b c d e f g h i] - ((val) a b c d e f g h i)) - (-invoke [_ a b c d e f g h i j] - ((val) a b c d e f g h i j)) - (-invoke [_ a b c d e f g h i j k] - ((val) a b c d e f g h i j k)) - (-invoke [_ a b c d e f g h i j k l] - ((val) a b c d e f g h i j k l)) - (-invoke [_ a b c d e f g h i j k l m] - ((val) a b c d e f g h i j k l m)) - (-invoke [_ a b c d e f g h i j k l m n] - ((val) a b c d e f g h i j k l m n)) - (-invoke [_ a b c d e f g h i j k l m n o] - ((val) a b c d e f g h i j k l m n o)) - (-invoke [_ a b c d e f g h i j k l m n o p] - ((val) a b c d e f g h i j k l m n o p)) - (-invoke [_ a b c d e f g h i j k l m n o p q] - ((val) a b c d e f g h i j k l m n o p q)) - (-invoke [_ a b c d e f g h i j k l m n o p q r] - ((val) a b c d e f g h i j k l m n o p q r)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s] - ((val) a b c d e f g h i j k l m n o p q r s)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s t] - ((val) a b c d e f g h i j k l m n o p q r s t)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s t rest] - (apply (val) a b c d e f g h i j k l m n o p q r s t rest))) - -(defn ^boolean var? - "Returns true if v is of type cljs.core.Var" - [v] - (instance? cljs.core.Var v)) - -;;;;;;;;;;;;;;;;;;; fundamentals ;;;;;;;;;;;;;;; - -(declare array-seq prim-seq IndexedSeq) - -(defn ^boolean iterable? - "Return true if x implements IIterable protocol." - [x] - (satisfies? IIterable x)) - -(defn clone - "Clone the supplied value which must implement ICloneable." - [value] - (-clone value)) - -(defn ^boolean cloneable? - "Return true if x implements ICloneable protocol." - [value] - (satisfies? ICloneable value)) - -(defn ^seq seq - "Returns a seq on the collection. If the collection is - empty, returns nil. (seq nil) returns nil. seq also works on - Strings." - [coll] - (when-not (nil? coll) - (cond - (implements? ISeqable coll) - (-seq ^not-native coll) - - (array? coll) - (when-not (zero? (alength coll)) - (IndexedSeq. coll 0 nil)) - - (string? coll) - (when-not (zero? (alength coll)) - (IndexedSeq. coll 0 nil)) - - (native-satisfies? ISeqable coll) - (-seq coll) - - :else (throw (js/Error. (str coll " is not ISeqable")))))) - -(defn first - "Returns the first item in the collection. Calls seq on its - argument. If coll is nil, returns nil." - [coll] - (when-not (nil? coll) - (if (implements? ISeq coll) - (-first ^not-native coll) - (let [s (seq coll)] - (when-not (nil? s) - (-first s)))))) - -(defn ^seq rest - "Returns a possibly empty seq of the items after the first. Calls seq on its - argument." - [coll] - (if-not (nil? coll) - (if (implements? ISeq coll) - (-rest ^not-native coll) - (let [s (seq coll)] - (if s - (-rest ^not-native s) - ()))) - ())) - -(defn ^seq next - "Returns a seq of the items after the first. Calls seq on its - argument. If there are no more items, returns nil" - [coll] - (when-not (nil? coll) - (if (implements? INext coll) - (-next ^not-native coll) - (seq (rest coll))))) - -(defn ^boolean = - "Equality. Returns true if x equals y, false if not. Compares - numbers and collections in a type-independent manner. Clojure's immutable data - structures define -equiv (and thus =) as a value, not an identity, - comparison." - ([x] true) - ([x y] - (if (nil? x) - (nil? y) - (or (identical? x y) - ^boolean (-equiv x y)))) - ([x y & more] - (if (= x y) - (if (next more) - (recur y (first more) (next more)) - (= y (first more))) - false))) - -;; EXPERIMENTAL: subject to change -(deftype ES6Iterator [^:mutable s] - Object - (next [_] - (if-not (nil? s) - (let [x (first s)] - (set! s (next s)) - #js {:value x :done false}) - #js {:value nil :done true}))) - -(defn es6-iterator - "EXPERIMENTAL: Return a ES2015 compatible iterator for coll." - [coll] - (ES6Iterator. (seq coll))) - -(declare es6-iterator-seq) - -(deftype ES6IteratorSeq [value iter ^:mutable _rest] - ISeqable - (-seq [this] this) - ISeq - (-first [_] value) - (-rest [_] - (when (nil? _rest) - (set! _rest (es6-iterator-seq iter))) - _rest)) - -(defn es6-iterator-seq - "EXPERIMENTAL: Given an ES2015 compatible iterator return a seq." - [iter] - (let [v (.next iter)] - (if (.-done v) - () - (ES6IteratorSeq. (.-value v) iter nil)))) - -;;;;;;;;;;;;;;;;;;; Murmur3 Helpers ;;;;;;;;;;;;;;;; - -(defn ^number mix-collection-hash - "Mix final collection hash for ordered or unordered collections. - hash-basis is the combined collection hash, count is the number - of elements included in the basis. Note this is the hash code - consistent with =, different from .hashCode. - See http://clojure.org/data_structures#hash for full algorithms." - [hash-basis count] - (let [h1 m3-seed - k1 (m3-mix-K1 hash-basis) - h1 (m3-mix-H1 h1 k1)] - (m3-fmix h1 count))) - -(defn ^number hash-ordered-coll - "Returns the hash code, consistent with =, for an external ordered - collection implementing Iterable. - See http://clojure.org/data_structures#hash for full algorithms." - [coll] - (loop [n 0 hash-code 1 coll (seq coll)] - (if-not (nil? coll) - (recur (inc n) (bit-or (+ (imul 31 hash-code) (hash (first coll))) 0) - (next coll)) - (mix-collection-hash hash-code n)))) - -(def ^:private empty-ordered-hash - (mix-collection-hash 1 0)) - -(defn ^number hash-unordered-coll - "Returns the hash code, consistent with =, for an external unordered - collection implementing Iterable. For maps, the iterator should - return map entries whose hash is computed as - (hash-ordered-coll [k v]). - See http://clojure.org/data_structures#hash for full algorithms." - [coll] - (loop [n 0 hash-code 0 coll (seq coll)] - (if-not (nil? coll) - (recur (inc n) (bit-or (+ hash-code (hash (first coll))) 0) (next coll)) - (mix-collection-hash hash-code n)))) - -(def ^:private empty-unordered-hash - (mix-collection-hash 0 0)) - -;;;;;;;;;;;;;;;;;;; protocols on primitives ;;;;;;;; -(declare hash-map list equiv-sequential) - -(extend-type nil - ICounted - (-count [_] 0)) - -;; TODO: we should remove this and handle date equality checking -;; by some other means, probably by adding a new primitive type -;; case to the hash table lookup - David - -(extend-type js/Date - IEquiv - (-equiv [o other] - (and (instance? js/Date other) - (== (.valueOf o) (.valueOf other)))) - - IComparable - (-compare [this other] - (if (instance? js/Date other) - (garray/defaultCompare (.valueOf this) (.valueOf other)) - (throw (js/Error. (str "Cannot compare " this " to " other)))))) - -(defprotocol Inst - (inst-ms* [inst])) - -(extend-protocol Inst - js/Date - (inst-ms* [inst] (.getTime inst))) - -(defn inst-ms - "Return the number of milliseconds since January 1, 1970, 00:00:00 GMT" - [inst] - (inst-ms* inst)) - -(defn ^boolean inst? - "Return true if x satisfies Inst" - [x] - (satisfies? Inst x)) - -(extend-type number - IEquiv - (-equiv [x o] (identical? x o))) - -(declare with-meta) - -(extend-type function - Fn - IMeta - (-meta [_] nil)) - -(extend-type default - IHash - (-hash [o] - (goog/getUid o))) - -;;this is primitive because & emits call to array-seq -(defn inc - "Returns a number one greater than num." - [x] (cljs.core/+ x 1)) - -(declare deref) - -(deftype Reduced [val] - IDeref - (-deref [o] val)) - -(defn reduced - "Wraps x in a way such that a reduce will terminate with the value x" - [x] - (Reduced. x)) - -(defn ^boolean reduced? - "Returns true if x is the result of a call to reduced" - [r] - (instance? Reduced r)) - -(defn ensure-reduced - "If x is already reduced?, returns it, else returns (reduced x)" - [x] - (if (reduced? x) x (reduced x))) - -(defn unreduced - "If x is reduced?, returns (deref x), else returns x" - [x] - (if (reduced? x) (deref x) x)) - -;; generic to all refs -;; (but currently hard-coded to atom!) -(defn deref - "Also reader macro: @var/@atom/@delay. Returns the - most-recently-committed value of ref. When applied to a var - or atom, returns its current state. When applied to a delay, forces - it if not already forced. See also - realized?." - [o] - (-deref o)) - -(defn- ci-reduce - "Accepts any collection which satisfies the ICount and IIndexed protocols and -reduces them without incurring seq initialization" - ([cicoll f] - (let [cnt (-count cicoll)] - (if (zero? cnt) - (f) - (loop [val (-nth cicoll 0), n 1] - (if (< n cnt) - (let [nval (f val (-nth cicoll n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val))))) - ([cicoll f val] - (let [cnt (-count cicoll)] - (loop [val val, n 0] - (if (< n cnt) - (let [nval (f val (-nth cicoll n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val)))) - ([cicoll f val idx] - (let [cnt (-count cicoll)] - (loop [val val, n idx] - (if (< n cnt) - (let [nval (f val (-nth cicoll n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val))))) - -(defn- array-reduce - ([arr f] - (let [cnt (alength arr)] - (if (zero? (alength arr)) - (f) - (loop [val (aget arr 0), n 1] - (if (< n cnt) - (let [nval (f val (aget arr n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val))))) - ([arr f val] - (let [cnt (alength arr)] - (loop [val val, n 0] - (if (< n cnt) - (let [nval (f val (aget arr n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val)))) - ([arr f val idx] - (let [cnt (alength arr)] - (loop [val val, n idx] - (if (< n cnt) - (let [nval (f val (aget arr n))] - (if (reduced? nval) - @nval - (recur nval (inc n)))) - val))))) - -(declare hash-coll cons drop count nth RSeq List) - -(defn ^boolean counted? - "Returns true if coll implements count in constant time" - [x] (satisfies? ICounted x)) - -(defn ^boolean indexed? - "Returns true if coll implements nth in constant time" - [x] (satisfies? IIndexed x)) - -(defn- -indexOf - ([coll x] - (-indexOf coll x 0)) - ([coll x start] - (let [len (count coll)] - (if (>= start len) - -1 - (loop [idx (cond - (pos? start) start - (neg? start) (max 0 (+ start len)) - :else start)] - (if (< idx len) - (if (= (nth coll idx) x) - idx - (recur (inc idx))) - -1)))))) - -(defn- -lastIndexOf - ([coll x] - (-lastIndexOf coll x (count coll))) - ([coll x start] - (let [len (count coll)] - (if (zero? len) - -1 - (loop [idx (cond - (pos? start) (min (dec len) start) - (neg? start) (+ len start) - :else start)] - (if (>= idx 0) - (if (= (nth coll idx) x) - idx - (recur (dec idx))) - -1)))))) - -(deftype IndexedSeqIterator [arr ^:mutable i] - Object - (hasNext [_] - (< i (alength arr))) - (next [_] - (let [ret (aget arr i)] - (set! i (inc i)) - ret))) - -(deftype IndexedSeq [arr i meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [_] (IndexedSeq. arr i meta)) - - ISeqable - (-seq [this] - (when (< i (alength arr)) - this)) - - IMeta - (-meta [coll] meta) - IWithMeta - (-with-meta [coll new-meta] - (IndexedSeq. arr i new-meta)) - - ASeq - ISeq - (-first [_] (aget arr i)) - (-rest [_] (if (< (inc i) (alength arr)) - (IndexedSeq. arr (inc i) nil) - (list))) - - INext - (-next [_] (if (< (inc i) (alength arr)) - (IndexedSeq. arr (inc i) nil) - nil)) - - ICounted - (-count [_] - (max 0 (- (alength arr) i))) - - IIndexed - (-nth [coll n] - (let [i (+ n i)] - (if (and (<= 0 i) (< i (alength arr))) - (aget arr i) - (throw (js/Error. "Index out of bounds"))))) - (-nth [coll n not-found] - (let [i (+ n i)] - (if (and (<= 0 i) (< i (alength arr))) - (aget arr i) - not-found))) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IIterable - (-iterator [coll] - (IndexedSeqIterator. arr i)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (.-EMPTY List)) - - IReduce - (-reduce [coll f] - (array-reduce arr f (aget arr i) (inc i))) - (-reduce [coll f start] - (array-reduce arr f start i)) - - IHash - (-hash [coll] (hash-ordered-coll coll)) - - IReversible - (-rseq [coll] - (let [c (-count coll)] - (if (pos? c) - (RSeq. coll (dec c) nil))))) - -(es6-iterable IndexedSeq) - -(defn prim-seq - "Create seq from a primitive JavaScript Array-like." - ([prim] - (prim-seq prim 0)) - ([prim i] - (when (< i (alength prim)) - (IndexedSeq. prim i nil)))) - -(defn array-seq - "Create a seq from a JavaScript array." - ([array] - (prim-seq array 0)) - ([array i] - (prim-seq array i))) - -(declare with-meta seq-reduce) - -(deftype RSeq [ci i meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [_] (RSeq. ci i meta)) - - IMeta - (-meta [coll] meta) - IWithMeta - (-with-meta [coll new-meta] - (RSeq. ci i new-meta)) - - ISeqable - (-seq [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ISeq - (-first [coll] - (-nth ci i)) - (-rest [coll] - (if (pos? i) - (RSeq. ci (dec i) nil) - ())) - - INext - (-next [coll] - (when (pos? i) - (RSeq. ci (dec i) nil))) - - ICounted - (-count [coll] (inc i)) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - IHash - (-hash [coll] (hash-ordered-coll coll)) - - IReduce - (-reduce [col f] (seq-reduce f col)) - (-reduce [col f start] (seq-reduce f start col))) - -(es6-iterable RSeq) - -(defn second - "Same as (first (next x))" - [coll] - (first (next coll))) - -(defn ffirst - "Same as (first (first x))" - [coll] - (first (first coll))) - -(defn nfirst - "Same as (next (first x))" - [coll] - (next (first coll))) - -(defn fnext - "Same as (first (next x))" - [coll] - (first (next coll))) - -(defn nnext - "Same as (next (next x))" - [coll] - (next (next coll))) - -(defn last - "Return the last item in coll, in linear time" - [s] - (let [sn (next s)] - (if-not (nil? sn) - (recur sn) - (first s)))) - -(extend-type default - IEquiv - (-equiv [x o] (identical? x o))) - -(defn conj - "conj[oin]. Returns a new collection with the xs - 'added'. (conj nil item) returns (item). The 'addition' may - happen at different 'places' depending on the concrete type." - ([] []) - ([coll] coll) - ([coll x] - (if-not (nil? coll) - (-conj coll x) - (list x))) - ([coll x & xs] - (if xs - (recur (conj coll x) (first xs) (next xs)) - (conj coll x)))) - -(defn empty - "Returns an empty collection of the same category as coll, or nil" - [coll] - (when-not (nil? coll) - (-empty coll))) - -(defn- accumulating-seq-count [coll] - (loop [s (seq coll) acc 0] - (if (counted? s) ; assumes nil is counted, which it currently is - (+ acc (-count s)) - (recur (next s) (inc acc))))) - -(defn count - "Returns the number of items in the collection. (count nil) returns - 0. Also works on strings, arrays, and Maps" - [coll] - (if-not (nil? coll) - (cond - (implements? ICounted coll) - (-count ^not-native coll) - - (array? coll) - (alength coll) - - (string? coll) - (alength coll) - - (implements? ISeqable coll) - (accumulating-seq-count coll) - - :else (-count coll)) - 0)) - -(defn- linear-traversal-nth - ([coll n] - (cond - (nil? coll) (throw (js/Error. "Index out of bounds")) - (zero? n) (if (seq coll) - (first coll) - (throw (js/Error. "Index out of bounds"))) - (indexed? coll) (-nth coll n) - (seq coll) (recur (next coll) (dec n)) - :else (throw (js/Error. "Index out of bounds")))) - ([coll n not-found] - (cond - (nil? coll) not-found - (zero? n) (if (seq coll) - (first coll) - not-found) - (indexed? coll) (-nth coll n not-found) - (seq coll) (recur (next coll) (dec n) not-found) - :else not-found))) - -(defn nth - "Returns the value at the index. get returns nil if index out of - bounds, nth throws an exception unless not-found is supplied. nth - also works for strings, arrays, regex Matchers and Lists, and, - in O(n) time, for sequences." - ([coll n] - (cond - (not (number? n)) - (throw (js/Error. "Index argument to nth must be a number")) - - (nil? coll) - coll - - (implements? IIndexed coll) - (-nth ^not-native coll n) - - (array? coll) - (if (and (>= n 0) (< n (.-length coll))) - (aget coll n) - (throw (js/Error. "Index out of bounds"))) - - (string? coll) - (if (and (>= n 0) (< n (.-length coll))) - (.charAt coll n) - (throw (js/Error. "Index out of bounds"))) - - (implements? ISeq coll) - (linear-traversal-nth coll n) - - (native-satisfies? IIndexed coll) - (-nth coll n) - - :else - (throw (js/Error. (str "nth not supported on this type " - (type->str (type coll))))))) - ([coll n not-found] - (cond - (not (number? n)) - (throw (js/Error. "Index argument to nth must be a number.")) - - (nil? coll) - not-found - - (implements? IIndexed coll) - (-nth ^not-native coll n not-found) - - (array? coll) - (if (and (>= n 0) (< n (.-length coll))) - (aget coll n) - not-found) - - (string? coll) - (if (and (>= n 0) (< n (.-length coll))) - (.charAt coll n) - not-found) - - (implements? ISeq coll) - (linear-traversal-nth coll n not-found) - - (native-satisfies? IIndexed coll) - (-nth coll n) - - :else - (throw (js/Error. (str "nth not supported on this type " - (type->str (type coll)))))))) - -(defn nthrest - "Returns the nth rest of coll, coll when n is 0." - [coll n] - (loop [n n xs coll] - (if (and (pos? n) (seq xs)) - (recur (dec n) (rest xs)) - xs))) - -(defn get - "Returns the value mapped to key, not-found or nil if key not present." - ([o k] - (when-not (nil? o) - (cond - (implements? ILookup o) - (-lookup ^not-native o k) - - (array? o) - (when (and (some? k) (< k (.-length o))) - (aget o (int k))) - - (string? o) - (when (and (some? k) (< k (.-length o))) - (.charAt o (int k))) - - (native-satisfies? ILookup o) - (-lookup o k) - - :else nil))) - ([o k not-found] - (if-not (nil? o) - (cond - (implements? ILookup o) - (-lookup ^not-native o k not-found) - - (array? o) - (if (and (some? k) (>= k 0) (< k (.-length o))) - (aget o (int k)) - not-found) - - (string? o) - (if (and (some? k) (>= k 0) (< k (.-length o))) - (.charAt o (int k)) - not-found) - - (native-satisfies? ILookup o) - (-lookup o k not-found) - - :else not-found) - not-found))) - -(declare PersistentHashMap) - -(defn assoc - "assoc[iate]. When applied to a map, returns a new map of the - same (hashed/sorted) type, that contains the mapping of key(s) to - val(s). When applied to a vector, returns a new vector that - contains val at index." - ([coll k v] - (if-not (nil? coll) - (-assoc coll k v) - (hash-map k v))) - ([coll k v & kvs] - (let [ret (assoc coll k v)] - (if kvs - (recur ret (first kvs) (second kvs) (nnext kvs)) - ret)))) - -(defn dissoc - "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, - that does not contain a mapping for key(s)." - ([coll] coll) - ([coll k] - (when-not (nil? coll) - (-dissoc coll k))) - ([coll k & ks] - (when-not (nil? coll) - (let [ret (dissoc coll k)] - (if ks - (recur ret (first ks) (next ks)) - ret))))) - -(defn ^boolean fn? - "Return true if f is a JavaScript function or satisfies the Fn protocol." - [f] - (or ^boolean (goog/isFunction f) (satisfies? Fn f))) - -(deftype MetaFn [afn meta] - IMeta - (-meta [_] meta) - IWithMeta - (-with-meta [_ new-meta] - (MetaFn. afn new-meta)) - Fn - IFn - (-invoke [_] - (afn)) - (-invoke [_ a] - (afn a)) - (-invoke [_ a b] - (afn a b)) - (-invoke [_ a b c] - (afn a b c)) - (-invoke [_ a b c d] - (afn a b c d)) - (-invoke [_ a b c d e] - (afn a b c d e)) - (-invoke [_ a b c d e f] - (afn a b c d e f)) - (-invoke [_ a b c d e f g] - (afn a b c d e f g)) - (-invoke [_ a b c d e f g h] - (afn a b c d e f g h)) - (-invoke [_ a b c d e f g h i] - (afn a b c d e f g h i)) - (-invoke [_ a b c d e f g h i j] - (afn a b c d e f g h i j)) - (-invoke [_ a b c d e f g h i j k] - (afn a b c d e f g h i j k)) - (-invoke [_ a b c d e f g h i j k l] - (afn a b c d e f g h i j k l)) - (-invoke [_ a b c d e f g h i j k l m] - (afn a b c d e f g h i j k l m)) - (-invoke [_ a b c d e f g h i j k l m n] - (afn a b c d e f g h i j k l m n)) - (-invoke [_ a b c d e f g h i j k l m n o] - (afn a b c d e f g h i j k l m n o)) - (-invoke [_ a b c d e f g h i j k l m n o p] - (afn a b c d e f g h i j k l m n o p)) - (-invoke [_ a b c d e f g h i j k l m n o p q] - (afn a b c d e f g h i j k l m n o p q)) - (-invoke [_ a b c d e f g h i j k l m n o p q r] - (afn a b c d e f g h i j k l m n o p q r)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s] - (afn a b c d e f g h i j k l m n o p q r s)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s t] - (afn a b c d e f g h i j k l m n o p q r s t)) - (-invoke [_ a b c d e f g h i j k l m n o p q r s t rest] - (apply afn a b c d e f g h i j k l m n o p q r s t rest))) - -(defn with-meta - "Returns an object of the same type and value as obj, with - map m as its metadata." - [o meta] - (if ^boolean (goog/isFunction o) - (MetaFn. o meta) - (when-not (nil? o) - (-with-meta o meta)))) - -(defn meta - "Returns the metadata of obj, returns nil if there is no metadata." - [o] - (when (and (not (nil? o)) - (satisfies? IMeta o)) - (-meta o))) - -(defn peek - "For a list or queue, same as first, for a vector, same as, but much - more efficient than, last. If the collection is empty, returns nil." - [coll] - (when-not (nil? coll) - (-peek coll))) - -(defn pop - "For a list or queue, returns a new list/queue without the first - item, for a vector, returns a new vector without the last item. - Note - not the same as next/butlast." - [coll] - (when-not (nil? coll) - (-pop coll))) - -(defn disj - "disj[oin]. Returns a new set of the same (hashed/sorted) type, that - does not contain key(s)." - ([coll] coll) - ([coll k] - (when-not (nil? coll) - (-disjoin coll k))) - ([coll k & ks] - (when-not (nil? coll) - (let [ret (disj coll k)] - (if ks - (recur ret (first ks) (next ks)) - ret))))) - -(defn ^boolean empty? - "Returns true if coll has no items - same as (not (seq coll)). - Please use the idiom (seq x) rather than (not (empty? x))" - [coll] (or (nil? coll) - (not (seq coll)))) - -(defn ^boolean coll? - "Returns true if x satisfies ICollection" - [x] - (if (nil? x) - false - (satisfies? ICollection x))) - -(defn ^boolean set? - "Returns true if x satisfies ISet" - [x] - (if (nil? x) - false - (satisfies? ISet x))) - -(defn ^boolean associative? - "Returns true if coll implements Associative" - [x] (satisfies? IAssociative x)) - -(defn ^boolean sequential? - "Returns true if coll satisfies ISequential" - [x] (satisfies? ISequential x)) - -(defn ^boolean sorted? - "Returns true if coll satisfies ISorted" - [x] (satisfies? ISorted x)) - -(defn ^boolean reduceable? - "Returns true if coll satisfies IReduce" - [x] (satisfies? IReduce x)) - -(defn ^boolean map? - "Return true if x satisfies IMap" - [x] - (if (nil? x) - false - (satisfies? IMap x))) - -(defn ^boolean record? - "Return true if x satisfies IRecord" - [x] - (satisfies? IRecord x)) - -(defn ^boolean vector? - "Return true if x satisfies IVector" - [x] (satisfies? IVector x)) - -(declare ChunkedCons ChunkedSeq) - -(defn ^boolean chunked-seq? - "Return true if x is satisfies IChunkedSeq." - [x] (implements? IChunkedSeq x)) - -;;;;;;;;;;;;;;;;;;;; js primitives ;;;;;;;;;;;; -(defn js-obj - "Create JavaSript object from an even number arguments representing - interleaved keys and values." - ([] - (cljs.core/js-obj)) - ([& keyvals] - (apply gobject/create keyvals))) - -(defn js-keys - "Return the JavaScript keys for an object." - [obj] - (let [keys (array)] - (gobject/forEach obj (fn [val key obj] (.push keys key))) - keys)) - -(defn js-delete - "Delete a property from a JavaScript object." - [obj key] - (cljs.core/js-delete obj key)) - -(defn- array-copy - ([from i to j len] - (loop [i i j j len len] - (if (zero? len) - to - (do (aset to j (aget from i)) - (recur (inc i) (inc j) (dec len))))))) - -(defn- array-copy-downward - ([from i to j len] - (loop [i (+ i (dec len)) j (+ j (dec len)) len len] - (if (zero? len) - to - (do (aset to j (aget from i)) - (recur (dec i) (dec j) (dec len))))))) - -;;;;;;;;;;;;;;;; preds ;;;;;;;;;;;;;;;;;; - -(def ^:private lookup-sentinel (js-obj)) - -(defn ^boolean false? - "Returns true if x is the value false, false otherwise." - [x] (cljs.core/false? x)) - -(defn ^boolean true? - "Returns true if x is the value true, false otherwise." - [x] (cljs.core/true? x)) - -(defn ^boolean boolean? - "Return true if x is a Boolean" - [x] (or (cljs.core/true? x) (cljs.core/false? x))) - -(defn ^boolean undefined? - "Returns true if x identical to the JavaScript undefined value." - [x] - (cljs.core/undefined? x)) - -(defn ^boolean seq? - "Return true if s satisfies ISeq" - [s] - (if (nil? s) - false - (satisfies? ISeq s))) - -(defn ^boolean seqable? - "Return true if the seq function is supported for s" - [s] - (or - (satisfies? ISeqable s) - (array? s) - (string? s))) - -(defn ^boolean boolean - "Coerce to boolean" - [x] - (cond - (nil? x) false - (false? x) false - :else true)) - -(defn ^boolean ifn? - "Returns true if f returns true for fn? or satisfies IFn." - [f] - (or (fn? f) (satisfies? IFn f))) - -(defn ^boolean integer? - "Returns true if n is a JavaScript number with no decimal part." - [n] - (and (number? n) - (not ^boolean (js/isNaN n)) - (not (identical? n js/Infinity)) - (== (js/parseFloat n) (js/parseInt n 10)))) - -(defn ^boolean int? - "Return true if x satisfies integer? or is an instance of goog.math.Integer - or goog.math.Long." - [x] - (or (integer? x) - (instance? goog.math.Integer x) - (instance? goog.math.Long x))) - -(defn ^boolean pos-int? - "Return true if x satisfies int? and is positive." - [x] - (cond - (integer? x) (pos? x) - - (instance? goog.math.Integer x) - (and (not (.isNegative x)) - (not (.isZero x))) - - (instance? goog.math.Long x) - (and (not (.isNegative x)) - (not (.isZero x))) - - :else false)) - -(defn ^boolean neg-int? - "Return true if x satisfies int? and is positive." - [x] - (cond - (integer? x) (neg? x) - - (instance? goog.math.Integer x) - (.isNegative x) - - (instance? goog.math.Long x) - (.isNegative x) - - :else false)) - -(defn ^boolean nat-int? - "Return true if x satisfies int? and is a natural integer value." - [x] - (cond - (integer? x) - (or (not (neg? x)) (zero? x)) - - (instance? goog.math.Integer x) - (or (not (.isNegative x)) (.isZero x)) - - (instance? goog.math.Long x) - (or (not (.isNegative x)) (.isZero x)) - - :else false)) - -(defn ^boolean float? - "Returns true for JavaScript numbers, false otherwise." - [x] - (number? x)) - -(defn ^boolean double? - "Returns true for JavaScript numbers, false otherwise." - [x] - (number? x)) - -(defn ^boolean infinite? - "Returns true for Infinity and -Infinity values." - [x] - (or (identical? x js/Number.POSITIVE_INFINITY) - (identical? x js/Number.NEGATIVE_INFINITY))) - -(defn ^boolean contains? - "Returns true if key is present in the given collection, otherwise - returns false. Note that for numerically indexed collections like - vectors and arrays, this tests if the numeric key is within the - range of indexes. 'contains?' operates constant or logarithmic time; - it will not perform a linear search for a value. See also 'some'." - [coll v] - (if (identical? (get coll v lookup-sentinel) lookup-sentinel) - false - true)) - -(defn find - "Returns the map entry for key, or nil if key not present." - [coll k] - (when (and (not (nil? coll)) - (associative? coll) - (contains? coll k)) - [k (get coll k)])) - -(defn ^boolean distinct? - "Returns true if no two of the arguments are =" - ([x] true) - ([x y] (not (= x y))) - ([x y & more] - (if (not (= x y)) - (loop [s #{x y} xs more] - (let [x (first xs) - etc (next xs)] - (if xs - (if (contains? s x) - false - (recur (conj s x) etc)) - true))) - false))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Seq fns ;;;;;;;;;;;;;;;; - -(defn ^number compare - "Comparator. Returns a negative number, zero, or a positive number - when x is logically 'less than', 'equal to', or 'greater than' - y. Uses IComparable if available and google.array.defaultCompare for objects - of the same type and special-cases nil to be less than any other object." - [x y] - (cond - (identical? x y) 0 - - (nil? x) -1 - - (nil? y) 1 - - (number? x) (if (number? y) - (garray/defaultCompare x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))) - - (satisfies? IComparable x) - (-compare x y) - - :else - (if (and (or (string? x) (array? x) (true? x) (false? x)) - (identical? (type x) (type y))) - (garray/defaultCompare x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))))) - -(defn ^:private compare-indexed - "Compare indexed collection." - ([xs ys] - (let [xl (count xs) - yl (count ys)] - (cond - (< xl yl) -1 - (> xl yl) 1 - (== xl 0) 0 - :else (compare-indexed xs ys xl 0)))) - ([xs ys len n] - (let [d (compare (nth xs n) (nth ys n))] - (if (and (zero? d) (< (+ n 1) len)) - (recur xs ys len (inc n)) - d)))) - -(defn ^:private fn->comparator - "Given a fn that might be boolean valued or a comparator, - return a fn that is a comparator." - [f] - (if (= f compare) - compare - (fn [x y] - (let [r (f x y)] - (if (number? r) - r - (if r - -1 - (if (f y x) 1 0))))))) - -(declare to-array) - -(defn sort - "Returns a sorted sequence of the items in coll. Comp can be - boolean-valued comparison function, or a -/0/+ valued comparator. - Comp defaults to compare." - ([coll] - (sort compare coll)) - ([comp coll] - (if (seq coll) - (let [a (to-array coll)] - ;; matching Clojure's stable sort, though docs don't promise it - (garray/stableSort a (fn->comparator comp)) - (seq a)) - ()))) - -(defn sort-by - "Returns a sorted sequence of the items in coll, where the sort - order is determined by comparing (keyfn item). Comp can be - boolean-valued comparison funcion, or a -/0/+ valued comparator. - Comp defaults to compare." - ([keyfn coll] - (sort-by keyfn compare coll)) - ([keyfn comp coll] - (sort (fn [x y] ((fn->comparator comp) (keyfn x) (keyfn y))) coll))) - -; simple reduce based on seqs, used as default -(defn- seq-reduce - ([f coll] - (if-let [s (seq coll)] - (reduce f (first s) (next s)) - (f))) - ([f val coll] - (loop [val val, coll (seq coll)] - (if coll - (let [nval (f val (first coll))] - (if (reduced? nval) - @nval - (recur nval (next coll)))) - val)))) - -(declare vec) - -(defn shuffle - "Return a random permutation of coll" - [coll] - (let [a (to-array coll)] - (garray/shuffle a) - (vec a))) - -(defn reduce - "f should be a function of 2 arguments. If val is not supplied, - returns the result of applying f to the first 2 items in coll, then - applying f to that result and the 3rd item, etc. If coll contains no - items, f must accept no arguments as well, and reduce returns the - result of calling f with no arguments. If coll has only 1 item, it - is returned and f is not called. If val is supplied, returns the - result of applying f to val and the first item in coll, then - applying f to that result and the 2nd item, etc. If coll contains no - items, returns val and f is not called." - ([f coll] - (cond - (implements? IReduce coll) - (-reduce ^not-native coll f) - - (array? coll) - (array-reduce coll f) - - (string? coll) - (array-reduce coll f) - - (native-satisfies? IReduce coll) - (-reduce coll f) - - :else - (seq-reduce f coll))) - ([f val coll] - (cond - (implements? IReduce coll) - (-reduce ^not-native coll f val) - - (array? coll) - (array-reduce coll f val) - - (string? coll) - (array-reduce coll f val) - - (native-satisfies? IReduce coll) - (-reduce coll f val) - - :else - (seq-reduce f val coll)))) - -(defn reduce-kv - "Reduces an associative collection. f should be a function of 3 - arguments. Returns the result of applying f to init, the first key - and the first value in coll, then applying f to that result and the - 2nd key and value, etc. If coll contains no entries, returns init - and f is not called. Note that reduce-kv is supported on vectors, - where the keys will be the ordinals." - ([f init coll] - (if-not (nil? coll) - (-kv-reduce coll f init) - init))) - -(defn identity - "Returns its argument." - [x] x) - -(defn completing - "Takes a reducing function f of 2 args and returns a fn suitable for - transduce by adding an arity-1 signature that calls cf (default - - identity) on the result argument." - ([f] (completing f identity)) - ([f cf] - (fn - ([] (f)) - ([x] (cf x)) - ([x y] (f x y))))) - -(defn transduce - "reduce with a transformation of f (xf). If init is not - supplied, (f) will be called to produce it. f should be a reducing - step function that accepts both 1 and 2 arguments, if it accepts - only 2 you can add the arity-1 with 'completing'. Returns the result - of applying (the transformed) xf to init and the first item in coll, - then applying xf to that result and the 2nd item, etc. If coll - contains no items, returns init and f is not called. Note that - certain transforms may inject or skip items." - ([xform f coll] (transduce xform f (f) coll)) - ([xform f init coll] - (let [f (xform f) - ret (reduce f init coll)] - (f ret)))) - -;;; Math - variadic forms will not work until the following implemented: -;;; first, next, reduce - -(defn ^number + - "Returns the sum of nums. (+) returns 0." - ([] 0) - ([x] x) - ([x y] (cljs.core/+ x y)) - ([x y & more] - (reduce + (cljs.core/+ x y) more))) - -(defn ^number - - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result." - ([x] (cljs.core/- x)) - ([x y] (cljs.core/- x y)) - ([x y & more] (reduce - (cljs.core/- x y) more))) - -(defn ^number * - "Returns the product of nums. (*) returns 1." - ([] 1) - ([x] x) - ([x y] (cljs.core/* x y)) - ([x y & more] (reduce * (cljs.core/* x y) more))) - -(declare divide) - -(defn ^number / - "If no denominators are supplied, returns 1/numerator, - else returns numerator divided by all of the denominators." - ([x] (/ 1 x)) - ([x y] (cljs.core/divide x y)) ;; FIXME: waiting on cljs.core// - ([x y & more] (reduce / (/ x y) more))) - -(defn ^boolean < - "Returns non-nil if nums are in monotonically increasing order, - otherwise false." - ([x] true) - ([x y] (cljs.core/< x y)) - ([x y & more] - (if (cljs.core/< x y) - (if (next more) - (recur y (first more) (next more)) - (cljs.core/< y (first more))) - false))) - -(defn ^boolean <= - "Returns non-nil if nums are in monotonically non-decreasing order, - otherwise false." - ([x] true) - ([x y] (cljs.core/<= x y)) - ([x y & more] - (if (cljs.core/<= x y) - (if (next more) - (recur y (first more) (next more)) - (cljs.core/<= y (first more))) - false))) - -(defn ^boolean > - "Returns non-nil if nums are in monotonically decreasing order, - otherwise false." - ([x] true) - ([x y] (cljs.core/> x y)) - ([x y & more] - (if (cljs.core/> x y) - (if (next more) - (recur y (first more) (next more)) - (cljs.core/> y (first more))) - false))) - -(defn ^boolean >= - "Returns non-nil if nums are in monotonically non-increasing order, - otherwise false." - ([x] true) - ([x y] (cljs.core/>= x y)) - ([x y & more] - (if (cljs.core/>= x y) - (if (next more) - (recur y (first more) (next more)) - (cljs.core/>= y (first more))) - false))) - -(defn dec - "Returns a number one less than num." - [x] (- x 1)) - -(defn ^number max - "Returns the greatest of the nums." - ([x] x) - ([x y] (cljs.core/max x y)) - ([x y & more] - (reduce max (cljs.core/max x y) more))) - -(defn ^number min - "Returns the least of the nums." - ([x] x) - ([x y] (cljs.core/min x y)) - ([x y & more] - (reduce min (cljs.core/min x y) more))) - -(defn ^number byte [x] x) - -(defn char - "Coerce to char" - [x] - (cond - (number? x) (.fromCharCode js/String x) - (and (string? x) (== (.-length x) 1)) x - :else (throw (js/Error. "Argument to char must be a character or number")))) - -(defn ^number short [x] x) -(defn ^number float [x] x) -(defn ^number double [x] x) - -(defn ^number unchecked-byte [x] x) -(defn ^number unchecked-char [x] x) -(defn ^number unchecked-short [x] x) -(defn ^number unchecked-float [x] x) -(defn ^number unchecked-double [x] x) - -(defn ^number unchecked-add - "Returns the sum of nums. (+) returns 0." - ([] 0) - ([x] x) - ([x y] (cljs.core/unchecked-add x y)) - ([x y & more] (reduce unchecked-add (cljs.core/unchecked-add x y) more))) - -(defn ^number unchecked-add-int - "Returns the sum of nums. (+) returns 0." - ([] 0) - ([x] x) - ([x y] (cljs.core/unchecked-add-int x y)) - ([x y & more] (reduce unchecked-add-int (cljs.core/unchecked-add-int x y) more))) - -(defn unchecked-dec - "Returns a number one less than x, an int." - [x] - (cljs.core/unchecked-dec x)) - -(defn unchecked-dec-int - "Returns a number one less than x, an int." - [x] - (cljs.core/unchecked-dec-int x)) - -(defn ^number unchecked-divide-int - "If no denominators are supplied, returns 1/numerator, - else returns numerator divided by all of the denominators." - ([x] (unchecked-divide-int 1 x)) - ([x y] (cljs.core/divide x y)) ;; FIXME: waiting on cljs.core// - ([x y & more] (reduce unchecked-divide-int (unchecked-divide-int x y) more))) - -(defn unchecked-inc [x] - (cljs.core/unchecked-inc x)) - -(defn unchecked-inc-int [x] - (cljs.core/unchecked-inc-int x)) - -(defn ^number unchecked-multiply - "Returns the product of nums. (*) returns 1." - ([] 1) - ([x] x) - ([x y] (cljs.core/unchecked-multiply x y)) - ([x y & more] (reduce unchecked-multiply (cljs.core/unchecked-multiply x y) more))) - -(defn ^number unchecked-multiply-int - "Returns the product of nums. (*) returns 1." - ([] 1) - ([x] x) - ([x y] (cljs.core/unchecked-multiply-int x y)) - ([x y & more] (reduce unchecked-multiply-int (cljs.core/unchecked-multiply-int x y) more))) - -(defn unchecked-negate [x] - (cljs.core/unchecked-negate x)) - -(defn unchecked-negate-int [x] - (cljs.core/unchecked-negate-int x)) - -(declare mod) - -(defn unchecked-remainder-int [x n] - (cljs.core/unchecked-remainder-int x n)) - -(defn ^number unchecked-subtract - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result." - ([x] (cljs.core/unchecked-subtract x)) - ([x y] (cljs.core/unchecked-subtract x y)) - ([x y & more] (reduce unchecked-subtract (cljs.core/unchecked-subtract x y) more))) - -(defn ^number unchecked-subtract-int - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result." - ([x] (cljs.core/unchecked-subtract-int x)) - ([x y] (cljs.core/unchecked-subtract-int x y)) - ([x y & more] (reduce unchecked-subtract-int (cljs.core/unchecked-subtract-int x y) more))) - -(defn- ^number fix [q] - (if (>= q 0) - (Math/floor q) - (Math/ceil q))) - -(defn int - "Coerce to int by stripping decimal places." - [x] - (bit-or x 0)) - -(defn unchecked-int - "Coerce to int by stripping decimal places." - [x] - (fix x)) - -(defn long - "Coerce to long by stripping decimal places. Identical to `int'." - [x] - (fix x)) - -(defn unchecked-long - "Coerce to long by stripping decimal places. Identical to `int'." - [x] - (fix x)) - -(defn booleans [x] x) -(defn bytes [x] x) -(defn chars [x] x) -(defn shorts [x] x) -(defn ints [x] x) -(defn floats [x] x) -(defn doubles [x] x) -(defn longs [x] x) - -(defn js-mod - "Modulus of num and div with original javascript behavior. i.e. bug for negative numbers" - [n d] - (cljs.core/js-mod n d)) - -(defn mod - "Modulus of num and div. Truncates toward negative infinity." - [n d] - (js-mod (+ (js-mod n d) d) d)) - -(defn quot - "quot[ient] of dividing numerator by denominator." - [n d] - (let [rem (js-mod n d)] - (fix (/ (- n rem) d)))) - -(defn rem - "remainder of dividing numerator by denominator." - [n d] - (let [q (quot n d)] - (- n (* d q)))) - -(defn bit-xor - "Bitwise exclusive or" - ([x y] (cljs.core/bit-xor x y)) - ([x y & more] - (reduce bit-xor (cljs.core/bit-xor x y) more))) - -(defn bit-and - "Bitwise and" - ([x y] (cljs.core/bit-and x y)) - ([x y & more] - (reduce bit-and (cljs.core/bit-and x y) more))) - -(defn bit-or - "Bitwise or" - ([x y] (cljs.core/bit-or x y)) - ([x y & more] - (reduce bit-or (cljs.core/bit-or x y) more))) - -(defn bit-and-not - "Bitwise and with complement" - ([x y] (cljs.core/bit-and-not x y)) - ([x y & more] - (reduce bit-and-not (cljs.core/bit-and-not x y) more))) - -(defn bit-clear - "Clear bit at index n" - [x n] - (cljs.core/bit-clear x n)) - -(defn bit-flip - "Flip bit at index n" - [x n] - (cljs.core/bit-flip x n)) - -(defn bit-not - "Bitwise complement" - [x] (cljs.core/bit-not x)) - -(defn bit-set - "Set bit at index n" - [x n] - (cljs.core/bit-set x n)) - -(defn ^boolean bit-test - "Test bit at index n" - [x n] - (cljs.core/bit-test x n)) - -(defn bit-shift-left - "Bitwise shift left" - [x n] (cljs.core/bit-shift-left x n)) - -(defn bit-shift-right - "Bitwise shift right" - [x n] (cljs.core/bit-shift-right x n)) - -(defn bit-shift-right-zero-fill - "DEPRECATED: Bitwise shift right with zero fill" - [x n] (cljs.core/bit-shift-right-zero-fill x n)) - -(defn unsigned-bit-shift-right - "Bitwise shift right with zero fill" - [x n] (cljs.core/unsigned-bit-shift-right x n)) - -(defn bit-count - "Counts the number of bits set in n" - [v] - (let [v (- v (bit-and (bit-shift-right v 1) 0x55555555)) - v (+ (bit-and v 0x33333333) (bit-and (bit-shift-right v 2) 0x33333333))] - (bit-shift-right (* (bit-and (+ v (bit-shift-right v 4)) 0xF0F0F0F) 0x1010101) 24))) - -(defn ^boolean == - "Returns non-nil if nums all have the equivalent - value, otherwise false. Behavior on non nums is - undefined." - ([x] true) - ([x y] (-equiv x y)) - ([x y & more] - (if (== x y) - (if (next more) - (recur y (first more) (next more)) - (== y (first more))) - false))) - -(defn ^boolean pos? - "Returns true if num is greater than zero, else false" - [x] (cljs.core/pos? x)) - -(defn ^boolean zero? - "Returns true if num is zero, else false" - [x] - (cljs.core/zero? x)) - -(defn ^boolean neg? - "Returns true if num is less than zero, else false" - [x] (cljs.core/neg? x)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; protocols for host types ;;;;;; - -(defn nthnext - "Returns the nth next of coll, (seq coll) when n is 0." - [coll n] - (loop [n n xs (seq coll)] - (if (and xs (pos? n)) - (recur (dec n) (next xs)) - xs))) - -;;;;;;;;;;;;;;;;;;;;;;;;;; basics ;;;;;;;;;;;;;;;;;; - -(defn str - "With no args, returns the empty string. With one arg x, returns - x.toString(). (str nil) returns the empty string. With more than - one arg, returns the concatenation of the str values of the args." - ([] "") - ([x] (if (nil? x) - "" - (.join #js [x] ""))) - ([x & ys] - (loop [sb (StringBuffer. (str x)) more ys] - (if more - (recur (. sb (append (str (first more)))) (next more)) - (.toString sb))))) - -(defn subs - "Returns the substring of s beginning at start inclusive, and ending - at end (defaults to length of string), exclusive." - ([s start] (.substring s start)) - ([s start end] (.substring s start end))) - -(declare map name) - -(defn- equiv-sequential - "Assumes x is sequential. Returns true if x equals y, otherwise - returns false." - [x y] - (boolean - (when (sequential? y) - (if (and (counted? x) (counted? y) - (not (== (count x) (count y)))) - false - (loop [xs (seq x) ys (seq y)] - (cond (nil? xs) (nil? ys) - (nil? ys) false - (= (first xs) (first ys)) (recur (next xs) (next ys)) - :else false)))))) - -(defn- hash-coll [coll] - (if (seq coll) - (loop [res (hash (first coll)) s (next coll)] - (if (nil? s) - res - (recur (hash-combine res (hash (first s))) (next s)))) - 0)) - -(declare key val) - -(defn- hash-imap [m] - ;; a la clojure.lang.APersistentMap - (loop [h 0 s (seq m)] - (if s - (let [e (first s)] - (recur (js-mod (+ h (bit-xor (hash (key e)) (hash (val e)))) - 4503599627370496) - (next s))) - h))) - -(defn- hash-iset [s] - ;; a la clojure.lang.APersistentSet - (loop [h 0 s (seq s)] - (if s - (let [e (first s)] - (recur (js-mod (+ h (hash e)) 4503599627370496) - (next s))) - h))) - -(declare name chunk-first chunk-rest) - -(defn- extend-object! - "Takes a JavaScript object and a map of names to functions and - attaches said functions as methods on the object. Any references to - JavaScript's implicit this (via the this-as macro) will resolve to the - object that the function is attached." - [obj fn-map] - (doseq [[key-name f] fn-map] - (let [str-name (name key-name)] - (aset obj str-name f))) - obj) - -;;;;;;;;;;;;;;;; cons ;;;;;;;;;;;;;;;; -(deftype List [meta first rest count ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x count)) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IList - - ICloneable - (-clone [_] (List. meta first rest count __hash)) - - IWithMeta - (-with-meta [coll meta] (List. meta first rest count __hash)) - - IMeta - (-meta [coll] meta) - - ASeq - ISeq - (-first [coll] first) - (-rest [coll] - (if (== count 1) - () - rest)) - - INext - (-next [coll] - (if (== count 1) - nil - rest)) - - IStack - (-peek [coll] first) - (-pop [coll] (-rest coll)) - - ICollection - (-conj [coll o] (List. meta o coll (inc count) nil)) - - IEmptyableCollection - (-empty [coll] (-with-meta (.-EMPTY List) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] coll) - - ICounted - (-count [coll] count) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn ^boolean list? - "Returns true if x implements IList" - [x] - (satisfies? IList x)) - -(es6-iterable List) - -(deftype EmptyList [meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IList - - ICloneable - (-clone [_] (EmptyList. meta)) - - IWithMeta - (-with-meta [coll meta] (EmptyList. meta)) - - IMeta - (-meta [coll] meta) - - ISeq - (-first [coll] nil) - (-rest [coll] ()) - - INext - (-next [coll] nil) - - IStack - (-peek [coll] nil) - (-pop [coll] (throw (js/Error. "Can't pop empty list"))) - - ICollection - (-conj [coll o] (List. meta o nil 1 nil)) - - IEmptyableCollection - (-empty [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] - (if (or (list? other) - (sequential? other)) - (nil? (seq other)) - false)) - - IHash - (-hash [coll] empty-ordered-hash) - - ISeqable - (-seq [coll] nil) - - ICounted - (-count [coll] 0) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(set! (.-EMPTY List) (EmptyList. nil)) - -(es6-iterable EmptyList) - -(defn ^boolean reversible? - "Returns true if coll satisfies? IReversible." - [coll] - (satisfies? IReversible coll)) - -(defn ^seq rseq - "Returns, in constant time, a seq of the items in rev (which - can be a vector or sorted-map), in reverse order. If rev is empty returns nil" - [rev] - (-rseq rev)) - -(defn reverse - "Returns a seq of the items in coll in reverse order. Not lazy." - [coll] - (if (reversible? coll) - (rseq coll) - (reduce conj () coll))) - -(defn list - "Creates a new list containing the items." - [& xs] - (let [arr (if (and (instance? IndexedSeq xs) (zero? (.-i xs))) - (.-arr xs) - (let [arr (array)] - (loop [^not-native xs xs] - (if-not (nil? xs) - (do - (.push arr (-first xs)) - (recur (-next xs))) - arr))))] - (loop [i (alength arr) ^not-native r ()] - (if (> i 0) - (recur (dec i) (-conj r (aget arr (dec i)))) - r)))) - -(deftype Cons [meta first rest ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IList - - ICloneable - (-clone [_] (Cons. meta first rest __hash)) - - IWithMeta - (-with-meta [coll meta] (Cons. meta first rest __hash)) - - IMeta - (-meta [coll] meta) - - ASeq - ISeq - (-first [coll] first) - (-rest [coll] (if (nil? rest) () rest)) - - INext - (-next [coll] - (if (nil? rest) nil (seq rest))) - - ICollection - (-conj [coll o] (Cons. nil o coll nil)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] coll) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable Cons) - -(defn cons - "Returns a new seq where x is the first element and coll is the rest." - [x coll] - (if (or (nil? coll) - (implements? ISeq coll)) - (Cons. nil x coll nil) - (Cons. nil x (seq coll) nil))) - -(defn hash-keyword [k] - (int (+ (hash-symbol k) 0x9e3779b9))) - -(defn- compare-keywords [a b] - (cond - (identical? (.-fqn a) (.-fqn b)) 0 - (and (not (.-ns a)) (.-ns b)) -1 - (.-ns a) (if-not (.-ns b) - 1 - (let [nsc (garray/defaultCompare (.-ns a) (.-ns b))] - (if (== 0 nsc) - (garray/defaultCompare (.-name a) (.-name b)) - nsc))) - :default (garray/defaultCompare (.-name a) (.-name b)))) - -(deftype Keyword [ns name fqn ^:mutable _hash] - Object - (toString [_] (str ":" fqn)) - (equiv [this other] - (-equiv this other)) - - IEquiv - (-equiv [_ other] - (if (instance? Keyword other) - (identical? fqn (.-fqn other)) - false)) - IFn - (-invoke [kw coll] - (get coll kw)) - (-invoke [kw coll not-found] - (get coll kw not-found)) - - IHash - (-hash [this] - (caching-hash this hash-keyword _hash)) - - INamed - (-name [_] name) - (-namespace [_] ns) - - IPrintWithWriter - (-pr-writer [o writer _] (-write writer (str ":" fqn)))) - -(defn ^boolean keyword? - "Return true if x is a Keyword" - [x] - (instance? Keyword x)) - -(defn ^boolean keyword-identical? - "Efficient test to determine that two keywords are identical." - [x y] - (if (identical? x y) - true - (if (and (keyword? x) (keyword? y)) - (identical? (.-fqn x) (.-fqn y)) - false))) - -(defn ^boolean symbol-identical? - "Efficient test to determine that two symbols are identical." - [x y] - (if (identical? x y) - true - (if (and (symbol? x) (symbol? y)) - (identical? (.-str x) (.-str y)) - false))) - -(defn namespace - "Returns the namespace String of a symbol or keyword, or nil if not present." - [x] - (if (implements? INamed x) - (-namespace ^not-native x) - (throw (js/Error. (str "Doesn't support namespace: " x))))) - -(defn ^boolean ident? - "Return true if x is a symbol or keyword" - [x] (or (keyword? x) (symbol? x))) - -(defn ^boolean simple-ident? - "Return true if x is a symbol or keyword without a namespace" - [x] (and (ident? x) (nil? (namespace x)))) - -(defn ^boolean qualified-ident? - "Return true if x is a symbol or keyword with a namespace" - [x] (and (ident? x) (namespace x) true)) - -(defn ^boolean simple-symbol? - "Return true if x is a symbol without a namespace" - [x] (and (symbol? x) (nil? (namespace x)))) - -(defn ^boolean qualified-symbol? - "Return true if x is a symbol with a namespace" - [x] (and (symbol? x) (namespace x) true)) - -(defn ^boolean simple-keyword? - "Return true if x is a keyword without a namespace" - [x] (and (keyword? x) (nil? (namespace x)))) - -(defn ^boolean qualified-keyword? - "Return true if x is a keyword with a namespace" - [x] (and (keyword? x) (namespace x) true)) - -(defn keyword - "Returns a Keyword with the given namespace and name. Do not use : - in the keyword strings, it will be added automatically." - ([name] (cond - (keyword? name) name - (symbol? name) (Keyword. - (cljs.core/namespace name) - (cljs.core/name name) (.-str name) nil) - (string? name) (let [parts (.split name "/")] - (if (== (alength parts) 2) - (Keyword. (aget parts 0) (aget parts 1) name nil) - (Keyword. nil (aget parts 0) name nil))))) - ([ns name] - (let [ns (cond - (keyword? ns) (cljs.core/name ns) - (symbol? ns) (cljs.core/name ns) - :else ns) - name (cond - (keyword? name) (cljs.core/name name) - (symbol? name) (cljs.core/name name) - :else name)] - (Keyword. ns name (str (when ns (str ns "/")) name) nil)))) - - -(deftype LazySeq [meta ^:mutable fn ^:mutable s ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (sval [coll] - (if (nil? fn) - s - (do - (set! s (fn)) - (set! fn nil) - s))) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IPending - (-realized? [coll] - (not fn)) - - IWithMeta - (-with-meta [coll meta] (LazySeq. meta fn s __hash)) - - IMeta - (-meta [coll] meta) - - ISeq - (-first [coll] - (-seq coll) - (when-not (nil? s) - (first s))) - (-rest [coll] - (-seq coll) - (if-not (nil? s) - (rest s) - ())) - - INext - (-next [coll] - (-seq coll) - (when-not (nil? s) - (next s))) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] - (.sval coll) - (when-not (nil? s) - (loop [ls s] - (if (instance? LazySeq ls) - (recur (.sval ls)) - (do (set! s ls) - (seq s)))))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable LazySeq) - -(declare ArrayChunk) - -(deftype ChunkBuffer [^:mutable buf ^:mutable end] - Object - (add [_ o] - (aset buf end o) - (set! end (inc end))) - - (chunk [_ o] - (let [ret (ArrayChunk. buf 0 end)] - (set! buf nil) - ret)) - - ICounted - (-count [_] end)) - -(defn chunk-buffer [capacity] - (ChunkBuffer. (make-array capacity) 0)) - -(deftype ArrayChunk [arr off end] - ICounted - (-count [_] (- end off)) - - IIndexed - (-nth [coll i] - (aget arr (+ off i))) - (-nth [coll i not-found] - (if (and (>= i 0) (< i (- end off))) - (aget arr (+ off i)) - not-found)) - - IChunk - (-drop-first [coll] - (if (== off end) - (throw (js/Error. "-drop-first of empty chunk")) - (ArrayChunk. arr (inc off) end))) - - IReduce - (-reduce [coll f] - (array-reduce arr f (aget arr off) (inc off))) - (-reduce [coll f start] - (array-reduce arr f start off))) - -(defn array-chunk - ([arr] - (ArrayChunk. arr 0 (alength arr))) - ([arr off] - (ArrayChunk. arr off (alength arr))) - ([arr off end] - (ArrayChunk. arr off end))) - -(deftype ChunkedCons [chunk more meta ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IWithMeta - (-with-meta [coll m] - (ChunkedCons. chunk more m __hash)) - - IMeta - (-meta [coll] meta) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ISeqable - (-seq [coll] coll) - - ASeq - ISeq - (-first [coll] (-nth chunk 0)) - (-rest [coll] - (if (> (-count chunk) 1) - (ChunkedCons. (-drop-first chunk) more meta nil) - (if (nil? more) - () - more))) - - INext - (-next [coll] - (if (> (-count chunk) 1) - (ChunkedCons. (-drop-first chunk) more meta nil) - (let [more (-seq more)] - (when-not (nil? more) - more)))) - - IChunkedSeq - (-chunked-first [coll] chunk) - (-chunked-rest [coll] - (if (nil? more) - () - more)) - - IChunkedNext - (-chunked-next [coll] - (if (nil? more) - nil - more)) - - ICollection - (-conj [this o] - (cons o this)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash))) - -(es6-iterable ChunkedCons) - -(defn chunk-cons [chunk rest] - (if (zero? (-count chunk)) - rest - (ChunkedCons. chunk rest nil nil))) - -(defn chunk-append [b x] - (.add b x)) - -(defn chunk [b] - (.chunk b)) - -(defn chunk-first [s] - (-chunked-first s)) - -(defn chunk-rest [s] - (-chunked-rest s)) - -(defn chunk-next [s] - (if (implements? IChunkedNext s) - (-chunked-next s) - (seq (-chunked-rest s)))) - -;;;;;;;;;;;;;;;; - -(defn to-array - "Naive impl of to-array as a start." - [s] - (let [ary (array)] - (loop [s s] - (if (seq s) - (do (. ary push (first s)) - (recur (next s))) - ary)))) - -(defn to-array-2d - "Returns a (potentially-ragged) 2-dimensional array - containing the contents of coll." - [coll] - (let [ret (make-array (count coll))] - (loop [i 0 xs (seq coll)] - (when xs - (aset ret i (to-array (first xs))) - (recur (inc i) (next xs)))) - ret)) - -(defn int-array - "Creates an array of ints. Does not coerce array, provided for compatibility - with Clojure." - ([size-or-seq] - (if (number? size-or-seq) - (int-array size-or-seq nil) - (into-array size-or-seq))) - ([size init-val-or-seq] - (let [a (make-array size)] - (if (seq? init-val-or-seq) - (let [s (seq init-val-or-seq)] - (loop [i 0 s s] - (if (and s (< i size)) - (do - (aset a i (first s)) - (recur (inc i) (next s))) - a))) - (do - (dotimes [i size] - (aset a i init-val-or-seq)) - a))))) - -(defn long-array - "Creates an array of longs. Does not coerce array, provided for compatibility - with Clojure." - ([size-or-seq] - (if (number? size-or-seq) - (long-array size-or-seq nil) - (into-array size-or-seq))) - ([size init-val-or-seq] - (let [a (make-array size)] - (if (seq? init-val-or-seq) - (let [s (seq init-val-or-seq)] - (loop [i 0 s s] - (if (and s (< i size)) - (do - (aset a i (first s)) - (recur (inc i) (next s))) - a))) - (do - (dotimes [i size] - (aset a i init-val-or-seq)) - a))))) - -(defn double-array - "Creates an array of doubles. Does not coerce array, provided for compatibility - with Clojure." - ([size-or-seq] - (if (number? size-or-seq) - (double-array size-or-seq nil) - (into-array size-or-seq))) - ([size init-val-or-seq] - (let [a (make-array size)] - (if (seq? init-val-or-seq) - (let [s (seq init-val-or-seq)] - (loop [i 0 s s] - (if (and s (< i size)) - (do - (aset a i (first s)) - (recur (inc i) (next s))) - a))) - (do - (dotimes [i size] - (aset a i init-val-or-seq)) - a))))) - -(defn object-array - "Creates an array of objects. Does not coerce array, provided for compatibility - with Clojure." - ([size-or-seq] - (if (number? size-or-seq) - (object-array size-or-seq nil) - (into-array size-or-seq))) - ([size init-val-or-seq] - (let [a (make-array size)] - (if (seq? init-val-or-seq) - (let [s (seq init-val-or-seq)] - (loop [i 0 s s] - (if (and s (< i size)) - (do - (aset a i (first s)) - (recur (inc i) (next s))) - a))) - (do - (dotimes [i size] - (aset a i init-val-or-seq)) - a))))) - -(defn bounded-count - "If coll is counted? returns its count, else will count at most the first n - elements of coll using its seq" - {:added "1.9"} - [n coll] - (if (counted? coll) - (count coll) - (loop [i 0 s (seq coll)] - (if (and (not (nil? s)) (< i n)) - (recur (inc i) (next s)) - i)))) - -(defn spread - [arglist] - (cond - (nil? arglist) nil - (nil? (next arglist)) (seq (first arglist)) - :else (cons (first arglist) - (spread (next arglist))))) - -(defn concat - "Returns a lazy seq representing the concatenation of the elements in the supplied colls." - ([] (lazy-seq nil)) - ([x] (lazy-seq x)) - ([x y] - (lazy-seq - (let [s (seq x)] - (if s - (if (chunked-seq? s) - (chunk-cons (chunk-first s) (concat (chunk-rest s) y)) - (cons (first s) (concat (rest s) y))) - y)))) - ([x y & zs] - (let [cat (fn cat [xys zs] - (lazy-seq - (let [xys (seq xys)] - (if xys - (if (chunked-seq? xys) - (chunk-cons (chunk-first xys) - (cat (chunk-rest xys) zs)) - (cons (first xys) (cat (rest xys) zs))) - (when zs - (cat (first zs) (next zs)))))))] - (cat (concat x y) zs)))) - -(defn list* - "Creates a new list containing the items prepended to the rest, the - last of which will be treated as a sequence." - ([args] (seq args)) - ([a args] (cons a args)) - ([a b args] (cons a (cons b args))) - ([a b c args] (cons a (cons b (cons c args)))) - ([a b c d & more] - (cons a (cons b (cons c (cons d (spread more))))))) - - -;;; Transients - -(defn transient - "Returns a new, transient version of the collection, in constant time." - [coll] - (-as-transient coll)) - -(defn persistent! - "Returns a new, persistent version of the transient collection, in - constant time. The transient collection cannot be used after this - call, any such use will throw an exception." - [tcoll] - (-persistent! tcoll)) - -(defn conj! - "Adds val to the transient collection, and return tcoll. The 'addition' - may happen at different 'places' depending on the concrete type." - ([] (transient [])) - ([tcoll] tcoll) - ([tcoll val] - (-conj! tcoll val)) - ([tcoll val & vals] - (let [ntcoll (-conj! tcoll val)] - (if vals - (recur ntcoll (first vals) (next vals)) - ntcoll)))) - -(defn assoc! - "When applied to a transient map, adds mapping of key(s) to - val(s). When applied to a transient vector, sets the val at index. - Note - index must be <= (count vector). Returns coll." - ([tcoll key val] - (-assoc! tcoll key val)) - ([tcoll key val & kvs] - (let [ntcoll (-assoc! tcoll key val)] - (if kvs - (recur ntcoll (first kvs) (second kvs) (nnext kvs)) - ntcoll)))) - -(defn dissoc! - "Returns a transient map that doesn't contain a mapping for key(s)." - ([tcoll key] - (-dissoc! tcoll key)) - ([tcoll key & ks] - (let [ntcoll (-dissoc! tcoll key)] - (if ks - (recur ntcoll (first ks) (next ks)) - ntcoll)))) - -(defn pop! - "Removes the last item from a transient vector. If - the collection is empty, throws an exception. Returns tcoll" - [tcoll] - (-pop! tcoll)) - -(defn disj! - "disj[oin]. Returns a transient set of the same (hashed/sorted) type, that - does not contain key(s)." - ([tcoll val] - (-disjoin! tcoll val)) - ([tcoll val & vals] - (let [ntcoll (-disjoin! tcoll val)] - (if vals - (recur ntcoll (first vals) (next vals)) - ntcoll)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; apply ;;;;;;;;;;;;;;;; - -;; see core.clj -(gen-apply-to) - -(set! *unchecked-if* true) -(defn apply - "Applies fn f to the argument list formed by prepending intervening arguments to args." - ([f args] - (let [fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count (inc fixed-arity) args)] - (if (<= bc fixed-arity) - (apply-to f bc args) - (.cljs$lang$applyTo f args))) - (.apply f f (to-array args))))) - ([f x args] - (let [arglist (list* x args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count (inc fixed-arity) arglist)] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f x y args] - (let [arglist (list* x y args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count (inc fixed-arity) arglist)] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f x y z args] - (let [arglist (list* x y z args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count (inc fixed-arity) arglist)] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f a b c d & args] - (let [arglist (cons a (cons b (cons c (cons d (spread args))))) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count (inc fixed-arity) arglist)] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist)))))) -(set! *unchecked-if* false) - -(defn vary-meta - "Returns an object of the same type and value as obj, with - (apply f (meta obj) args) as its metadata." - ([obj f] - (with-meta obj (f (meta obj)))) - ([obj f a] - (with-meta obj (f (meta obj) a))) - ([obj f a b] - (with-meta obj (f (meta obj) a b))) - ([obj f a b c] - (with-meta obj (f (meta obj) a b c))) - ([obj f a b c d] - (with-meta obj (f (meta obj) a b c d))) - ([obj f a b c d & args] - (with-meta obj (apply f (meta obj) a b c d args)))) - -(defn ^boolean not= - "Same as (not (= obj1 obj2))" - ([x] false) - ([x y] (not (= x y))) - ([x y & more] - (not (apply = x y more)))) - -(defn not-empty - "If coll is empty, returns nil, else coll" - [coll] (when (seq coll) coll)) - -(defn nil-iter [] - (reify - Object - (hasNext [_] false) - (next [_] (js/Error. "No such element")) - (remove [_] (js/Error. "Unsupported operation")))) - -(deftype StringIter [s ^:mutable i] - Object - (hasNext [_] (< i (alength s))) - (next [_] - (let [ret (.charAt s i)] - (set! i (inc i)) - ret)) - (remove [_] (js/Error. "Unsupported operation"))) - -(defn string-iter [x] - (StringIter. x 0)) - -(deftype ArrayIter [arr ^:mutable i] - Object - (hasNext [_] (< i (alength arr))) - (next [_] - (let [ret (aget arr i)] - (set! i (inc i)) - ret)) - (remove [_] (js/Error. "Unsupported operation"))) - -(defn array-iter [x] - (ArrayIter. x 0)) - -(def INIT #js {}) -(def START #js {}) - -(deftype SeqIter [^:mutable _seq ^:mutable _next] - Object - (hasNext [_] - (if (identical? _seq INIT) - (do - (set! _seq START) - (set! _next (seq _next))) - (if (identical? _seq _next) - (set! _next (next _seq)))) - (not (nil? _next))) - (next [this] - (if-not ^boolean (.hasNext this) - (throw (js/Error. "No such element")) - (do - (set! _seq _next) - (first _next)))) - (remove [_] (js/Error. "Unsupported operation"))) - -(defn seq-iter [coll] - (SeqIter. INIT coll)) - -(defn iter [coll] - (cond - (nil? coll) (nil-iter) - (string? coll) (string-iter coll) - (array? coll) (array-iter coll) - (iterable? coll) (-iterator coll) - (seqable? coll) (seq-iter coll) - :else (throw (js/Error. (str "Cannot create iterator from " coll))))) - -(declare LazyTransformer) - -(defn lazy-transformer [stepper] - (LazyTransformer. stepper nil nil nil)) - -(deftype Stepper [xform iter] - Object - (step [this lt] - (loop [] - (if (and (not (nil? (.-stepper lt))) - (.hasNext iter)) - (if (reduced? (xform lt (.next iter))) - (when-not (nil? (.-rest lt)) - (set! (.. lt -rest -stepper) nil)) - (recur)))) - (when-not (nil? (.-stepper lt)) - (xform lt)))) - -(defn stepper [xform iter] - (letfn [(stepfn - ([result] - (let [lt (if (reduced? result) - @result - result)] - (set! (.-stepper lt) nil) - result)) - ([result input] - (let [lt result] - (set! (.-first lt) input) - (set! (.-rest lt) (lazy-transformer (.-stepper lt))) - (set! (.-stepper lt) nil) - (.-rest lt))))] - (Stepper. (xform stepfn) iter))) - -(deftype MultiStepper [xform iters nexts] - Object - (hasNext [_] - (loop [iters (seq iters)] - (if-not (nil? iters) - (let [iter (first iters)] - (if-not ^boolean (.hasNext iter) - false - (recur (next iters)))) - true))) - (next [_] - (dotimes [i (alength iters)] - (aset nexts i (.next (aget iters i)))) - (prim-seq nexts 0)) - (step [this lt] - (loop [] - (if (and (not (nil? (.-stepper lt))) - (.hasNext this)) - (if (reduced? (apply xform (cons lt (.next this)))) - (when-not (nil? (.-rest lt)) - (set! (.. lt -rest -stepper) nil)) - (recur)))) - (when-not (nil? (.-stepper lt)) - (xform lt)))) - -(defn multi-stepper - ([xform iters] - (multi-stepper xform iters - (make-array (alength iters)))) - ([xform iters nexts] - (letfn [(stepfn - ([result] - (let [lt (if (reduced? result) - @result - result)] - (set! (.-stepper lt) nil) - lt)) - ([result input] - (let [lt result] - (set! (.-first lt) input) - (set! (.-rest lt) (lazy-transformer (.-stepper lt))) - (set! (.-stepper lt) nil) - (.-rest lt))))] - (MultiStepper. (xform stepfn) iters nexts)))) - -(deftype LazyTransformer [^:mutable stepper ^:mutable first ^:mutable rest meta] - Object - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IWithMeta - (-with-meta [this new-meta] - (LazyTransformer. stepper first rest new-meta)) - - IMeta - (-meta [this] meta) - - ICollection - (-conj [this o] - (cons o (-seq this))) - - IEmptyableCollection - (-empty [this] - ()) - - ISequential - IEquiv - (-equiv [this other] - (let [s (-seq this)] - (if-not (nil? s) - (equiv-sequential this other) - (and (sequential? other) - (nil? (seq other)))))) - - IHash - (-hash [this] - (hash-ordered-coll this)) - - ISeqable - (-seq [this] - (when-not (nil? stepper) - (.step stepper this)) - (if (nil? rest) - nil - this)) - - ISeq - (-first [this] - (when-not (nil? stepper) - (-seq this)) - (if (nil? rest) - nil - first)) - - (-rest [this] - (when-not (nil? stepper) - (-seq this)) - (if (nil? rest) - () - rest)) - - INext - (-next [this] - (when-not (nil? stepper) - (-seq this)) - (if (nil? rest) - nil - (-seq rest)))) - -(es6-iterable LazyTransformer) - -(set! (.-create LazyTransformer) - (fn [xform coll] - (LazyTransformer. (stepper xform (iter coll)) nil nil nil))) - -(set! (.-createMulti LazyTransformer) - (fn [xform colls] - (let [iters (array)] - (doseq [coll colls] - (.push iters (iter coll))) - (LazyTransformer. - (multi-stepper xform iters (make-array (alength iters))) - nil nil nil)))) - -(defn sequence - "Coerces coll to a (possibly empty) sequence, if it is not already - one. Will not force a lazy seq. (sequence nil) yields (), When a - transducer is supplied, returns a lazy sequence of applications of - the transform to the items in coll(s), i.e. to the set of first - items of each coll, followed by the set of second - items in each coll, until any one of the colls is exhausted. Any - remaining items in other colls are ignored. The transform should accept - number-of-colls arguments" - ([coll] - (if (seq? coll) - coll - (or (seq coll) ()))) - ([xform coll] - (.create LazyTransformer xform coll)) - ([xform coll & colls] - (.createMulti LazyTransformer xform (to-array (cons coll colls))))) - -(defn ^boolean every? - "Returns true if (pred x) is logical true for every x in coll, else - false." - [pred coll] - (cond - (nil? (seq coll)) true - (pred (first coll)) (recur pred (next coll)) - :else false)) - -(defn ^boolean not-every? - "Returns false if (pred x) is logical true for every x in - coll, else true." - [pred coll] (not (every? pred coll))) - -(defn some - "Returns the first logical true value of (pred x) for any x in coll, - else nil. One common idiom is to use a set as pred, for example - this will return :fred if :fred is in the sequence, otherwise nil: - (some #{:fred} coll)" - [pred coll] - (when (seq coll) - (or (pred (first coll)) (recur pred (next coll))))) - -(defn ^boolean not-any? - "Returns false if (pred x) is logical true for any x in coll, - else true." - [pred coll] (not (some pred coll))) - -(defn ^boolean even? - "Returns true if n is even, throws an exception if n is not an integer" - [n] (if (integer? n) - (zero? (bit-and n 1)) - (throw (js/Error. (str "Argument must be an integer: " n))))) - -(defn ^boolean odd? - "Returns true if n is odd, throws an exception if n is not an integer" - [n] (not (even? n))) - -(defn ^boolean complement - "Takes a fn f and returns a fn that takes the same arguments as f, - has the same effects, if any, and returns the opposite truth value." - [f] - (fn - ([] (not (f))) - ([x] (not (f x))) - ([x y] (not (f x y))) - ([x y & zs] (not (apply f x y zs))))) - -(defn constantly - "Returns a function that takes any number of arguments and returns x." - [x] (fn [& args] x)) - -(defn comp - "Takes a set of functions and returns a fn that is the composition - of those fns. The returned fn takes a variable number of args, - applies the rightmost of fns to the args, the next - fn (right-to-left) to the result, etc." - ([] identity) - ([f] f) - ([f g] - (fn - ([] (f (g))) - ([x] (f (g x))) - ([x y] (f (g x y))) - ([x y z] (f (g x y z))) - ([x y z & args] (f (apply g x y z args))))) - ([f g h] - (fn - ([] (f (g (h)))) - ([x] (f (g (h x)))) - ([x y] (f (g (h x y)))) - ([x y z] (f (g (h x y z)))) - ([x y z & args] (f (g (apply h x y z args)))))) - ([f1 f2 f3 & fs] - (let [fs (reverse (list* f1 f2 f3 fs))] - (fn [& args] - (loop [ret (apply (first fs) args) fs (next fs)] - (if fs - (recur ((first fs) ret) (next fs)) - ret)))))) - -(defn partial - "Takes a function f and fewer than the normal arguments to f, and - returns a fn that takes a variable number of additional args. When - called, the returned function calls f with args + additional args." - ([f] f) - ([f arg1] - (fn - ([] (f arg1)) - ([x] (f arg1 x)) - ([x y] (f arg1 x y)) - ([x y z] (f arg1 x y z)) - ([x y z & args] (apply f arg1 x y z args)))) - ([f arg1 arg2] - (fn - ([] (f arg1 arg2)) - ([x] (f arg1 arg2 x)) - ([x y] (f arg1 arg2 x y)) - ([x y z] (f arg1 arg2 x y z)) - ([x y z & args] (apply f arg1 arg2 x y z args)))) - ([f arg1 arg2 arg3] - (fn - ([] (f arg1 arg2 arg3)) - ([x] (f arg1 arg2 arg3 x)) - ([x y] (f arg1 arg2 arg3 x y)) - ([x y z] (f arg1 arg2 arg3 x y z)) - ([x y z & args] (apply f arg1 arg2 arg3 x y z args)))) - ([f arg1 arg2 arg3 & more] - (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) - -(defn fnil - "Takes a function f, and returns a function that calls f, replacing - a nil first argument to f with the supplied value x. Higher arity - versions can replace arguments in the second and third - positions (y, z). Note that the function f can take any number of - arguments, not just the one(s) being nil-patched." - ([f x] - (fn - ([a] (f (if (nil? a) x a))) - ([a b] (f (if (nil? a) x a) b)) - ([a b c] (f (if (nil? a) x a) b c)) - ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) - ([f x y] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) - ([f x y z] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) - -(declare volatile!) - -(defn map-indexed - "Returns a lazy sequence consisting of the result of applying f to 0 - and the first item of coll, followed by applying f to 1 and the second - item in coll, etc, until coll is exhausted. Thus function f should - accept 2 arguments, index and item. Returns a stateful transducer when - no collection is provided." - ([f] - (fn [rf] - (let [i (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (rf result (f (vswap! i inc) input))))))) - ([f coll] - (letfn [(mapi [idx coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (chunk-append b (f (+ idx i) (-nth c i)))) - (chunk-cons (chunk b) (mapi (+ idx size) (chunk-rest s)))) - (cons (f idx (first s)) (mapi (inc idx) (rest s)))))))] - (mapi 0 coll)))) - -(defn keep - "Returns a lazy sequence of the non-nil results of (f item). Note, - this means false return values will be included. f must be free of - side-effects. Returns a transducer when no collection is provided." - ([f] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [v (f input)] - (if (nil? v) - result - (rf result v))))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (let [x (f (-nth c i))] - (when-not (nil? x) - (chunk-append b x)))) - (chunk-cons (chunk b) (keep f (chunk-rest s)))) - (let [x (f (first s))] - (if (nil? x) - (keep f (rest s)) - (cons x (keep f (rest s)))))))))) - -;; ============================================================================= -;; Atom - -(deftype Atom [state meta validator watches] - Object - (equiv [this other] - (-equiv this other)) - - IAtom - - IEquiv - (-equiv [o other] (identical? o other)) - - IDeref - (-deref [_] state) - - IMeta - (-meta [_] meta) - - IWatchable - (-notify-watches [this oldval newval] - (doseq [[key f] watches] - (f key this oldval newval))) - (-add-watch [this key f] - (set! (.-watches this) (assoc watches key f)) - this) - (-remove-watch [this key] - (set! (.-watches this) (dissoc watches key))) - - IHash - (-hash [this] (goog/getUid this))) - -(defn atom - "Creates and returns an Atom with an initial value of x and zero or - more options (in any order): - - :meta metadata-map - - :validator validate-fn - - If metadata-map is supplied, it will be come the metadata on the - atom. validate-fn must be nil or a side-effect-free fn of one - argument, which will be passed the intended new state on any state - change. If the new state is unacceptable, the validate-fn should - return false or throw an Error. If either of these error conditions - occur, then the value of the atom will not change." - ([x] (Atom. x nil nil nil)) - ([x & {:keys [meta validator]}] (Atom. x meta validator nil))) - -(declare pr-str) - -(defn reset! - "Sets the value of atom to newval without regard for the - current value. Returns new-value." - [a new-value] - (if (instance? Atom a) - (let [validate (.-validator a)] - (when-not (nil? validate) - (when-not (validate new-value) - (throw (js/Error. "Validator rejected reference state")))) - (let [old-value (.-state a)] - (set! (.-state a) new-value) - (when-not (nil? (.-watches a)) - (-notify-watches a old-value new-value)) - new-value)) - (-reset! a new-value))) - -(defn swap! - "Atomically swaps the value of atom to be: - (apply f current-value-of-atom args). Note that f may be called - multiple times, and thus should be free of side effects. Returns - the value that was swapped in." - ([a f] - (if (instance? Atom a) - (reset! a (f (.-state a))) - (-swap! a f))) - ([a f x] - (if (instance? Atom a) - (reset! a (f (.-state a) x)) - (-swap! a f x))) - ([a f x y] - (if (instance? Atom a) - (reset! a (f (.-state a) x y)) - (-swap! a f x y))) - ([a f x y & more] - (if (instance? Atom a) - (reset! a (apply f (.-state a) x y more)) - (-swap! a f x y more)))) - -(defn compare-and-set! - "Atomically sets the value of atom to newval if and only if the - current value of the atom is equal to oldval. Returns true if - set happened, else false." - [^not-native a oldval newval] - (if (= (-deref a) oldval) - (do (reset! a newval) true) - false)) - -(defn set-validator! - "Sets the validator-fn for an atom. validator-fn must be nil or a - side-effect-free fn of one argument, which will be passed the intended - new state on any state change. If the new state is unacceptable, the - validator-fn should return false or throw an Error. If the current state - is not acceptable to the new validator, an Error will be thrown and the - validator will not be changed." - [iref val] - (set! (.-validator iref) val)) - -(defn get-validator - "Gets the validator-fn for a var/ref/agent/atom." - [iref] - (.-validator iref)) - -(deftype Volatile [^:mutable state] - IVolatile - (-vreset! [_ new-state] - (set! state new-state)) - - IDeref - (-deref [_] state)) - -(defn volatile! - "Creates and returns a Volatile with an initial value of val." - [val] - (Volatile. val)) - -(defn ^boolean volatile? - "Returns true if x is a volatile." - [x] (instance? Volatile x)) - -(defn vreset! - "Sets the value of volatile to newval without regard for the - current value. Returns newval." - [vol newval] (-vreset! vol newval)) - -(defn keep-indexed - "Returns a lazy sequence of the non-nil results of (f index item). Note, - this means false return values will be included. f must be free of - side-effects. Returns a stateful transducer when no collection is - provided." - ([f] - (fn [rf] - (let [ia (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [i (vswap! ia inc) - v (f i input)] - (if (nil? v) - result - (rf result v)))))))) - ([f coll] - (letfn [(keepi [idx coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (let [x (f (+ idx i) (-nth c i))] - (when-not (nil? x) - (chunk-append b x)))) - (chunk-cons (chunk b) (keepi (+ idx size) (chunk-rest s)))) - (let [x (f idx (first s))] - (if (nil? x) - (keepi (inc idx) (rest s)) - (cons x (keepi (inc idx) (rest s)))))))))] - (keepi 0 coll)))) - -(defn every-pred - "Takes a set of predicates and returns a function f that returns true if all of its - composing predicates return a logical true value against all of its arguments, else it returns - false. Note that f is short-circuiting in that it will stop execution on the first - argument that triggers a logical false result against the original predicates." - ([p] - (fn ep1 - ([] true) - ([x] (boolean (p x))) - ([x y] (boolean (and (p x) (p y)))) - ([x y z] (boolean (and (p x) (p y) (p z)))) - ([x y z & args] (boolean (and (ep1 x y z) - (every? p args)))))) - ([p1 p2] - (fn ep2 - ([] true) - ([x] (boolean (and (p1 x) (p2 x)))) - ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y)))) - ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z)))) - ([x y z & args] (boolean (and (ep2 x y z) - (every? #(and (p1 %) (p2 %)) args)))))) - ([p1 p2 p3] - (fn ep3 - ([] true) - ([x] (boolean (and (p1 x) (p2 x) (p3 x)))) - ([x y] (boolean (and (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y)))) - ([x y z] (boolean (and (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y) (p1 z) (p2 z) (p3 z)))) - ([x y z & args] (boolean (and (ep3 x y z) - (every? #(and (p1 %) (p2 %) (p3 %)) args)))))) - ([p1 p2 p3 & ps] - (let [ps (list* p1 p2 p3 ps)] - (fn epn - ([] true) - ([x] (every? #(% x) ps)) - ([x y] (every? #(and (% x) (% y)) ps)) - ([x y z] (every? #(and (% x) (% y) (% z)) ps)) - ([x y z & args] (boolean (and (epn x y z) - (every? #(every? % args) ps)))))))) - -(defn some-fn - "Takes a set of predicates and returns a function f that returns the first logical true value - returned by one of its composing predicates against any of its arguments, else it returns - logical false. Note that f is short-circuiting in that it will stop execution on the first - argument that triggers a logical true result against the original predicates." - ([p] - (fn sp1 - ([] nil) - ([x] (p x)) - ([x y] (or (p x) (p y))) - ([x y z] (or (p x) (p y) (p z))) - ([x y z & args] (or (sp1 x y z) - (some p args))))) - ([p1 p2] - (fn sp2 - ([] nil) - ([x] (or (p1 x) (p2 x))) - ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y))) - ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z))) - ([x y z & args] (or (sp2 x y z) - (some #(or (p1 %) (p2 %)) args))))) - ([p1 p2 p3] - (fn sp3 - ([] nil) - ([x] (or (p1 x) (p2 x) (p3 x))) - ([x y] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y))) - ([x y z] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y) (p1 z) (p2 z) (p3 z))) - ([x y z & args] (or (sp3 x y z) - (some #(or (p1 %) (p2 %) (p3 %)) args))))) - ([p1 p2 p3 & ps] - (let [ps (list* p1 p2 p3 ps)] - (fn spn - ([] nil) - ([x] (some #(% x) ps)) - ([x y] (some #(or (% x) (% y)) ps)) - ([x y z] (some #(or (% x) (% y) (% z)) ps)) - ([x y z & args] (or (spn x y z) - (some #(some % args) ps))))))) - -(defn map - "Returns a lazy sequence consisting of the result of applying f to - the set of first items of each coll, followed by applying f to the - set of second items in each coll, until any one of the colls is - exhausted. Any remaining items in other colls are ignored. Function - f should accept number-of-colls arguments. Returns a transducer when - no collection is provided." - ([f] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (rf result (f input))) - ([result input & inputs] - (rf result (apply f input inputs)))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (chunk-append b (f (-nth c i)))) - (chunk-cons (chunk b) (map f (chunk-rest s)))) - (cons (f (first s)) (map f (rest s))))))) - ([f c1 c2] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2)] - (when (and s1 s2) - (cons (f (first s1) (first s2)) - (map f (rest s1) (rest s2))))))) - ([f c1 c2 c3] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2) s3 (seq c3)] - (when (and s1 s2 s3) - (cons (f (first s1) (first s2) (first s3)) - (map f (rest s1) (rest s2) (rest s3))))))) - ([f c1 c2 c3 & colls] - (let [step (fn step [cs] - (lazy-seq - (let [ss (map seq cs)] - (when (every? identity ss) - (cons (map first ss) (step (map rest ss)))))))] - (map #(apply f %) (step (conj colls c3 c2 c1)))))) - -(defn take - "Returns a lazy sequence of the first n items in coll, or all items if - there are fewer than n. Returns a stateful transducer when - no collection is provided." - ([n] - {:pre [(number? n)]} - (fn [rf] - (let [na (volatile! n)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [n @na - nn (vswap! na dec) - result (if (pos? n) - (rf result input) - result)] - (if (not (pos? nn)) - (ensure-reduced result) - result))))))) - ([n coll] - {:pre [(number? n)]} - (lazy-seq - (when (pos? n) - (when-let [s (seq coll)] - (cons (first s) (take (dec n) (rest s)))))))) - -(defn drop - "Returns a lazy sequence of all but the first n items in coll. - Returns a stateful transducer when no collection is provided." - ([n] - {:pre [(number? n)]} - (fn [rf] - (let [na (volatile! n)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [n @na] - (vswap! na dec) - (if (pos? n) - result - (rf result input)))))))) - ([n coll] - {:pre [(number? n)]} - (let [step (fn [n coll] - (let [s (seq coll)] - (if (and (pos? n) s) - (recur (dec n) (rest s)) - s)))] - (lazy-seq (step n coll))))) - -(defn drop-last - "Return a lazy sequence of all but the last n (default 1) items in coll" - ([s] (drop-last 1 s)) - ([n s] (map (fn [x _] x) s (drop n s)))) - -(defn take-last - "Returns a seq of the last n items in coll. Depending on the type - of coll may be no better than linear time. For vectors, see also subvec." - [n coll] - (loop [s (seq coll), lead (seq (drop n coll))] - (if lead - (recur (next s) (next lead)) - s))) - -(defn drop-while - "Returns a lazy sequence of the items in coll starting from the - first item for which (pred item) returns logical false. Returns a - stateful transducer when no collection is provided." - ([pred] - (fn [rf] - (let [da (volatile! true)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [drop? @da] - (if (and drop? (pred input)) - result - (do - (vreset! da nil) - (rf result input))))))))) - ([pred coll] - (let [step (fn [pred coll] - (let [s (seq coll)] - (if (and s (pred (first s))) - (recur pred (rest s)) - s)))] - (lazy-seq (step pred coll))))) - -(defn cycle - "Returns a lazy (infinite!) sequence of repetitions of the items in coll." - [coll] (lazy-seq - (when-let [s (seq coll)] - (concat s (cycle s))))) - -(defn split-at - "Returns a vector of [(take n coll) (drop n coll)]" - [n coll] - [(take n coll) (drop n coll)]) - -(defn repeat - "Returns a lazy (infinite!, or length n if supplied) sequence of xs." - ([x] (lazy-seq (cons x (repeat x)))) - ([n x] (take n (repeat x)))) - -(defn replicate - "DEPRECATED: Use 'repeat' instead. - Returns a lazy seq of n xs." - [n x] (take n (repeat x))) - -(defn repeatedly - "Takes a function of no args, presumably with side effects, and - returns an infinite (or length n if supplied) lazy sequence of calls - to it" - ([f] (lazy-seq (cons (f) (repeatedly f)))) - ([n f] (take n (repeatedly f)))) - -(defn iterate - "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must be free of side-effects" - {:added "1.0"} - [f x] (cons x (lazy-seq (iterate f (f x))))) - -(defn interleave - "Returns a lazy seq of the first item in each coll, then the second etc." - ([c1 c2] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2)] - (when (and s1 s2) - (cons (first s1) (cons (first s2) - (interleave (rest s1) (rest s2)))))))) - ([c1 c2 & colls] - (lazy-seq - (let [ss (map seq (conj colls c2 c1))] - (when (every? identity ss) - (concat (map first ss) (apply interleave (map rest ss)))))))) - -(defn interpose - "Returns a lazy seq of the elements of coll separated by sep. - Returns a stateful transducer when no collection is provided." - ([sep] - (fn [rf] - (let [started (volatile! false)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if @started - (let [sepr (rf result sep)] - (if (reduced? sepr) - sepr - (rf sepr input))) - (do - (vreset! started true) - (rf result input)))))))) - ([sep coll] (drop 1 (interleave (repeat sep) coll)))) - - - -(defn- flatten1 - "Take a collection of collections, and return a lazy seq - of items from the inner collection" - [colls] - (let [cat (fn cat [coll colls] - (lazy-seq - (if-let [coll (seq coll)] - (cons (first coll) (cat (rest coll) colls)) - (when (seq colls) - (cat (first colls) (rest colls))))))] - (cat nil colls))) - -(declare cat) - -(defn mapcat - "Returns the result of applying concat to the result of applying map - to f and colls. Thus function f should return a collection. Returns - a transducer when no collections are provided" - {:added "1.0" - :static true} - ([f] (comp (map f) cat)) - ([f & colls] - (apply concat (apply map f colls)))) - -(defn filter - "Returns a lazy sequence of the items in coll for which - (pred item) returns true. pred must be free of side-effects. - Returns a transducer when no collection is provided." - ([pred] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (pred input) - (rf result input) - result))))) - ([pred coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (when (pred (-nth c i)) - (chunk-append b (-nth c i)))) - (chunk-cons (chunk b) (filter pred (chunk-rest s)))) - (let [f (first s) r (rest s)] - (if (pred f) - (cons f (filter pred r)) - (filter pred r)))))))) - -(defn remove - "Returns a lazy sequence of the items in coll for which - (pred item) returns false. pred must be free of side-effects. - Returns a transducer when no collection is provided." - ([pred] (filter (complement pred))) - ([pred coll] - (filter (complement pred) coll))) - -(defn tree-seq - "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. - branch? must be a fn of one arg that returns true if passed a node - that can have children (but may not). children must be a fn of one - arg that returns a sequence of the children. Will only be called on - nodes for which branch? returns true. Root is the root node of the - tree." - [branch? children root] - (let [walk (fn walk [node] - (lazy-seq - (cons node - (when (branch? node) - (mapcat walk (children node))))))] - (walk root))) - -(defn flatten - "Takes any nested combination of sequential things (lists, vectors, - etc.) and returns their contents as a single, flat sequence. - (flatten nil) returns nil." - [x] - (filter #(not (sequential? %)) - (rest (tree-seq sequential? seq x)))) - -(defn into - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined. A transducer may be supplied." - ([] []) - ([to] to) - ([to from] - (if-not (nil? to) - (if (implements? IEditableCollection to) - (with-meta (persistent! (reduce -conj! (transient to) from)) (meta to)) - (reduce -conj to from)) - (reduce conj () from))) - ([to xform from] - (if (implements? IEditableCollection to) - (with-meta (persistent! (transduce xform conj! (transient to) from)) (meta to)) - (transduce xform conj to from)))) - -(defn mapv - "Returns a vector consisting of the result of applying f to the - set of first items of each coll, followed by applying f to the set - of second items in each coll, until any one of the colls is - exhausted. Any remaining items in other colls are ignored. Function - f should accept number-of-colls arguments." - ([f coll] - (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll) - persistent!)) - ([f c1 c2] - (into [] (map f c1 c2))) - ([f c1 c2 c3] - (into [] (map f c1 c2 c3))) - ([f c1 c2 c3 & colls] - (into [] (apply map f c1 c2 c3 colls)))) - -(defn filterv - "Returns a vector of the items in coll for which - (pred item) returns true. pred must be free of side-effects." - [pred coll] - (-> (reduce (fn [v o] (if (pred o) (conj! v o) v)) - (transient []) - coll) - persistent!)) - -(defn partition - "Returns a lazy sequence of lists of n items each, at offsets step - apart. If step is not supplied, defaults to n, i.e. the partitions - do not overlap. If a pad collection is supplied, use its elements as - necessary to complete last partition up to n items. In case there are - not enough padding elements, return a partition with less than n items." - ([n coll] - (partition n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (take n s)] - (when (== n (count p)) - (cons p (partition n step (drop step s)))))))) - ([n step pad coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (take n s)] - (if (== n (count p)) - (cons p (partition n step pad (drop step s))) - (list (take n (concat p pad))))))))) - -(defn get-in - "Returns the value in a nested associative structure, - where ks is a sequence of keys. Returns nil if the key is not present, - or the not-found value if supplied." - {:added "1.2" - :static true} - ([m ks] - (reduce get m ks)) - ([m ks not-found] - (loop [sentinel lookup-sentinel - m m - ks (seq ks)] - (if-not (nil? ks) - (let [m (get m (first ks) sentinel)] - (if (identical? sentinel m) - not-found - (recur sentinel m (next ks)))) - m)))) - -(defn assoc-in - "Associates a value in a nested associative structure, where ks is a - sequence of keys and v is the new value and returns a new nested structure. - If any levels do not exist, hash-maps will be created." - [m [k & ks] v] - (if ks - (assoc m k (assoc-in (get m k) ks v)) - (assoc m k v))) - -(defn update-in - "'Updates' a value in a nested associative structure, where ks is a - sequence of keys and f is a function that will take the old value - and any supplied args and return the new value, and returns a new - nested structure. If any levels do not exist, hash-maps will be - created." - ([m [k & ks] f] - (if ks - (assoc m k (update-in (get m k) ks f)) - (assoc m k (f (get m k))))) - ([m [k & ks] f a] - (if ks - (assoc m k (update-in (get m k) ks f a)) - (assoc m k (f (get m k) a)))) - ([m [k & ks] f a b] - (if ks - (assoc m k (update-in (get m k) ks f a b)) - (assoc m k (f (get m k) a b)))) - ([m [k & ks] f a b c] - (if ks - (assoc m k (update-in (get m k) ks f a b c)) - (assoc m k (f (get m k) a b c)))) - ([m [k & ks] f a b c & args] - (if ks - (assoc m k (apply update-in (get m k) ks f a b c args)) - (assoc m k (apply f (get m k) a b c args))))) - -(defn update - "'Updates' a value in an associative structure, where k is a - key and f is a function that will take the old value - and any supplied args and return the new value, and returns a new - structure. If the key does not exist, nil is passed as the old value." - ([m k f] - (assoc m k (f (get m k)))) - ([m k f x] - (assoc m k (f (get m k) x))) - ([m k f x y] - (assoc m k (f (get m k) x y))) - ([m k f x y z] - (assoc m k (f (get m k) x y z))) - ([m k f x y z & more] - (assoc m k (apply f (get m k) x y z more)))) - -;;; PersistentVector - -(deftype VectorNode [edit arr]) - -(defn- pv-fresh-node [edit] - (VectorNode. edit (make-array 32))) - -(defn- pv-aget [node idx] - (aget (.-arr node) idx)) - -(defn- pv-aset [node idx val] - (aset (.-arr node) idx val)) - -(defn- pv-clone-node [node] - (VectorNode. (.-edit node) (aclone (.-arr node)))) - -(defn- tail-off [pv] - (let [cnt (.-cnt pv)] - (if (< cnt 32) - 0 - (bit-shift-left (bit-shift-right-zero-fill (dec cnt) 5) 5)))) - -(defn- new-path [edit level node] - (loop [ll level - ret node] - (if (zero? ll) - ret - (let [embed ret - r (pv-fresh-node edit) - _ (pv-aset r 0 embed)] - (recur (- ll 5) r))))) - -(defn- push-tail [pv level parent tailnode] - (let [ret (pv-clone-node parent) - subidx (bit-and (bit-shift-right-zero-fill (dec (.-cnt pv)) level) 0x01f)] - (if (== 5 level) - (do - (pv-aset ret subidx tailnode) - ret) - (let [child (pv-aget parent subidx)] - (if-not (nil? child) - (let [node-to-insert (push-tail pv (- level 5) child tailnode)] - (pv-aset ret subidx node-to-insert) - ret) - (let [node-to-insert (new-path nil (- level 5) tailnode)] - (pv-aset ret subidx node-to-insert) - ret)))))) - -(defn- vector-index-out-of-bounds [i cnt] - (throw (js/Error. (str "No item " i " in vector of length " cnt)))) - -(defn- first-array-for-longvec [pv] - ;; invariants: (count pv) > 32. - (loop [node (.-root pv) - level (.-shift pv)] - (if (pos? level) - (recur (pv-aget node 0) (- level 5)) - (.-arr node)))) - -(defn- unchecked-array-for [pv i] - ;; invariant: i is a valid index of pv (use array-for if unknown). - (if (>= i (tail-off pv)) - (.-tail pv) - (loop [node (.-root pv) - level (.-shift pv)] - (if (pos? level) - (recur (pv-aget node (bit-and (bit-shift-right-zero-fill i level) 0x01f)) - (- level 5)) - (.-arr node))))) - -(defn- array-for [pv i] - (if (and (<= 0 i) (< i (.-cnt pv))) - (unchecked-array-for pv i) - (vector-index-out-of-bounds i (.-cnt pv)))) - -(defn- do-assoc [pv level node i val] - (let [ret (pv-clone-node node)] - (if (zero? level) - (do - (pv-aset ret (bit-and i 0x01f) val) - ret) - (let [subidx (bit-and (bit-shift-right-zero-fill i level) 0x01f)] - (pv-aset ret subidx (do-assoc pv (- level 5) (pv-aget node subidx) i val)) - ret)))) - -(defn- pop-tail [pv level node] - (let [subidx (bit-and (bit-shift-right-zero-fill (- (.-cnt pv) 2) level) 0x01f)] - (cond - (> level 5) (let [new-child (pop-tail pv (- level 5) (pv-aget node subidx))] - (if (and (nil? new-child) (zero? subidx)) - nil - (let [ret (pv-clone-node node)] - (pv-aset ret subidx new-child) - ret))) - (zero? subidx) nil - :else (let [ret (pv-clone-node node)] - (pv-aset ret subidx nil) - ret)))) - -(deftype RangedIterator [^:mutable i ^:mutable base ^:mutable arr v start end] - Object - (hasNext [this] - (< i end)) - (next [this] - (when (== (- i base) 32) - (set! arr (unchecked-array-for v i)) - (set! base (+ base 32))) - (let [ret (aget arr (bit-and i 0x01f))] - (set! i (inc i)) - ret))) - -(defn ranged-iterator [v start end] - (let [i start] - (RangedIterator. i (- i (js-mod i 32)) - (when (< start (count v)) - (unchecked-array-for v i)) - v start end))) - -(declare tv-editable-root tv-editable-tail TransientVector deref - pr-sequential-writer pr-writer chunked-seq) - -(deftype PersistentVector [meta cnt shift root tail ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [_] (PersistentVector. meta cnt shift root tail __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentVector. meta cnt shift root tail __hash)) - - IMeta - (-meta [coll] meta) - - IStack - (-peek [coll] - (when (> cnt 0) - (-nth coll (dec cnt)))) - (-pop [coll] - (cond - (zero? cnt) (throw (js/Error. "Can't pop empty vector")) - (== 1 cnt) (-with-meta (.-EMPTY PersistentVector) meta) - (< 1 (- cnt (tail-off coll))) - (PersistentVector. meta (dec cnt) shift root (.slice tail 0 -1) nil) - :else (let [new-tail (unchecked-array-for coll (- cnt 2)) - nr (pop-tail coll shift root) - new-root (if (nil? nr) (.-EMPTY-NODE PersistentVector) nr) - cnt-1 (dec cnt)] - (if (and (< 5 shift) (nil? (pv-aget new-root 1))) - (PersistentVector. meta cnt-1 (- shift 5) (pv-aget new-root 0) new-tail nil) - (PersistentVector. meta cnt-1 shift new-root new-tail nil))))) - - ICollection - (-conj [coll o] - (if (< (- cnt (tail-off coll)) 32) - (let [len (alength tail) - new-tail (make-array (inc len))] - (dotimes [i len] - (aset new-tail i (aget tail i))) - (aset new-tail len o) - (PersistentVector. meta (inc cnt) shift root new-tail nil)) - (let [root-overflow? (> (bit-shift-right-zero-fill cnt 5) (bit-shift-left 1 shift)) - new-shift (if root-overflow? (+ shift 5) shift) - new-root (if root-overflow? - (let [n-r (pv-fresh-node nil)] - (pv-aset n-r 0 root) - (pv-aset n-r 1 (new-path nil shift (VectorNode. nil tail))) - n-r) - (push-tail coll shift root (VectorNode. nil tail)))] - (PersistentVector. meta (inc cnt) new-shift new-root (array o) nil)))) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY PersistentVector) meta)) - - ISequential - IEquiv - (-equiv [coll other] - (if (instance? PersistentVector other) - (if (== cnt (count other)) - (let [me-iter (-iterator coll) - you-iter (-iterator other)] - (loop [] - (if ^boolean (.hasNext me-iter) - (let [x (.next me-iter) - y (.next you-iter)] - (if (= x y) - (recur) - false)) - true))) - false) - (equiv-sequential coll other))) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] - (cond - (zero? cnt) nil - (<= cnt 32) (IndexedSeq. tail 0 nil) - :else (chunked-seq coll (first-array-for-longvec coll) 0 0))) - - ICounted - (-count [coll] cnt) - - IIndexed - (-nth [coll n] - (aget (array-for coll n) (bit-and n 0x01f))) - (-nth [coll n not-found] - (if (and (<= 0 n) (< n cnt)) - (aget (unchecked-array-for coll n) (bit-and n 0x01f)) - not-found)) - - ILookup - (-lookup [coll k] (-lookup coll k nil)) - (-lookup [coll k not-found] (if (number? k) - (-nth coll k not-found) - not-found)) - - IMapEntry - (-key [coll] - (-nth coll 0)) - (-val [coll] - (-nth coll 1)) - - IAssociative - (-assoc [coll k v] - (if (number? k) - (-assoc-n coll k v) - (throw (js/Error. "Vector's key for assoc must be a number.")))) - - IVector - (-assoc-n [coll n val] - (cond - (and (<= 0 n) (< n cnt)) - (if (<= (tail-off coll) n) - (let [new-tail (aclone tail)] - (aset new-tail (bit-and n 0x01f) val) - (PersistentVector. meta cnt shift root new-tail nil)) - (PersistentVector. meta cnt shift (do-assoc coll shift root n val) tail nil)) - (== n cnt) (-conj coll val) - :else (throw (js/Error. (str "Index " n " out of bounds [0," cnt "]"))))) - - IReduce - (-reduce [v f] - (ci-reduce v f)) - (-reduce [v f init] - (loop [i 0 init init] - (if (< i cnt) - (let [arr (unchecked-array-for v i) - len (alength arr) - init (loop [j 0 init init] - (if (< j len) - (let [init (f init (aget arr j))] - (if (reduced? init) - init - (recur (inc j) init))) - init))] - (if (reduced? init) - @init - (recur (+ i len) init))) - init))) - - IKVReduce - (-kv-reduce [v f init] - (loop [i 0 init init] - (if (< i cnt) - (let [arr (unchecked-array-for v i) - len (alength arr) - init (loop [j 0 init init] - (if (< j len) - (let [init (f init (+ j i) (aget arr j))] - (if (reduced? init) - init - (recur (inc j) init))) - init))] - (if (reduced? init) - @init - (recur (+ i len) init))) - init))) - - IFn - (-invoke [coll k] - (-nth coll k)) - (-invoke [coll k not-found] - (-nth coll k not-found)) - - IEditableCollection - (-as-transient [coll] - (TransientVector. cnt shift (tv-editable-root root) (tv-editable-tail tail))) - - IReversible - (-rseq [coll] - (if (pos? cnt) - (RSeq. coll (dec cnt) nil))) - - IIterable - (-iterator [this] - (ranged-iterator this 0 cnt))) - -(set! (.-EMPTY-NODE PersistentVector) (VectorNode. nil (make-array 32))) - -(set! (.-EMPTY PersistentVector) - (PersistentVector. nil 0 5 (.-EMPTY-NODE PersistentVector) (array) empty-ordered-hash)) - -(set! (.-fromArray PersistentVector) - (fn [xs ^boolean no-clone] - (let [l (alength xs) - xs (if no-clone xs (aclone xs))] - (if (< l 32) - (PersistentVector. nil l 5 (.-EMPTY-NODE PersistentVector) xs nil) - (let [node (.slice xs 0 32) - v (PersistentVector. nil 32 5 (.-EMPTY-NODE PersistentVector) node nil)] - (loop [i 32 out (-as-transient v)] - (if (< i l) - (recur (inc i) (conj! out (aget xs i))) - (persistent! out)))))))) - -(es6-iterable PersistentVector) - -(defn vec - "Creates a new vector containing the contents of coll. JavaScript arrays - will be aliased and should not be modified." - [coll] - (if (array? coll) - (.fromArray PersistentVector coll true) - (-persistent! - (reduce -conj! - (-as-transient (.-EMPTY PersistentVector)) - coll)))) - -(defn vector - "Creates a new vector containing the args." - [& args] - (if (and (instance? IndexedSeq args) (zero? (.-i args))) - (.fromArray PersistentVector (.-arr args) true) - (vec args))) - -(declare subvec) - -(deftype ChunkedSeq [vec node i off meta ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IWithMeta - (-with-meta [coll m] - (chunked-seq vec node i off m)) - IMeta - (-meta [coll] meta) - - ISeqable - (-seq [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ASeq - ISeq - (-first [coll] - (aget node off)) - (-rest [coll] - (if (< (inc off) (alength node)) - (let [s (chunked-seq vec node i (inc off))] - (if (nil? s) - () - s)) - (-chunked-rest coll))) - - INext - (-next [coll] - (if (< (inc off) (alength node)) - (let [s (chunked-seq vec node i (inc off))] - (if (nil? s) - nil - s)) - (-chunked-next coll))) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] - (with-meta (.-EMPTY PersistentVector) meta)) - - IChunkedSeq - (-chunked-first [coll] - (array-chunk node off)) - (-chunked-rest [coll] - (let [end (+ i (alength node))] - (if (< end (-count vec)) - (chunked-seq vec (unchecked-array-for vec end) end 0) - ()))) - - IChunkedNext - (-chunked-next [coll] - (let [end (+ i (alength node))] - (when (< end (-count vec)) - (chunked-seq vec (unchecked-array-for vec end) end 0)))) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IReduce - (-reduce [coll f] - (ci-reduce (subvec vec (+ i off) (count vec)) f)) - - (-reduce [coll f start] - (ci-reduce (subvec vec (+ i off) (count vec)) f start))) - -(es6-iterable ChunkedSeq) - -(defn chunked-seq - ([vec i off] (ChunkedSeq. vec (array-for vec i) i off nil nil)) - ([vec node i off] (ChunkedSeq. vec node i off nil nil)) - ([vec node i off meta] - (ChunkedSeq. vec node i off meta nil))) - -(declare build-subvec) - -(deftype Subvec [meta v start end ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [_] (Subvec. meta v start end __hash)) - - IWithMeta - (-with-meta [coll meta] (build-subvec meta v start end __hash)) - - IMeta - (-meta [coll] meta) - - IStack - (-peek [coll] - (-nth v (dec end))) - (-pop [coll] - (if (== start end) - (throw (js/Error. "Can't pop empty vector")) - (build-subvec meta v start (dec end) nil))) - - ICollection - (-conj [coll o] - (build-subvec meta (-assoc-n v end o) start (inc end) nil)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY PersistentVector) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] - (let [subvec-seq (fn subvec-seq [i] - (when-not (== i end) - (cons (-nth v i) - (lazy-seq - (subvec-seq (inc i))))))] - (subvec-seq start))) - - IReversible - (-rseq [coll] - (if-not (== start end) - (RSeq. coll (dec (- end start)) nil))) - - ICounted - (-count [coll] (- end start)) - - IIndexed - (-nth [coll n] - (if (or (neg? n) (<= end (+ start n))) - (vector-index-out-of-bounds n (- end start)) - (-nth v (+ start n)))) - (-nth [coll n not-found] - (if (or (neg? n) (<= end (+ start n))) - not-found - (-nth v (+ start n) not-found))) - - ILookup - (-lookup [coll k] (-lookup coll k nil)) - (-lookup [coll k not-found] (if (number? k) - (-nth coll k not-found) - not-found)) - - IAssociative - (-assoc [coll key val] - (if (number? key) - (-assoc-n coll key val) - (throw (js/Error. "Subvec's key for assoc must be a number.")))) - - IVector - (-assoc-n [coll n val] - (let [v-pos (+ start n)] - (if (or (neg? n) (<= (inc end) v-pos)) - (throw (js/Error. (str "Index " n " out of bounds [0," (-count coll) "]"))) - (build-subvec meta (assoc v v-pos val) start (max end (inc v-pos)) nil)))) - - IReduce - (-reduce [coll f] - (ci-reduce coll f)) - (-reduce [coll f start] - (ci-reduce coll f start)) - - IKVReduce - (-kv-reduce [coll f init] - (loop [i start j 0 init init] - (if (< i end) - (let [init (f init j (-nth v i))] - (if (reduced? init) - @init - (recur (inc i) (inc j) init))) - init))) - - IFn - (-invoke [coll k] - (-nth coll k)) - (-invoke [coll k not-found] - (-nth coll k not-found)) - - IIterable - (-iterator [coll] - (ranged-iterator v start end))) - -(es6-iterable Subvec) - -(defn- build-subvec [meta v start end __hash] - (if (instance? Subvec v) - (recur meta (.-v v) (+ (.-start v) start) (+ (.-start v) end) __hash) - (let [c (count v)] - (when (or (neg? start) - (neg? end) - (> start c) - (> end c)) - (throw (js/Error. "Index out of bounds"))) - (Subvec. meta v start end __hash)))) - -(defn subvec - "Returns a persistent vector of the items in vector from - start (inclusive) to end (exclusive). If end is not supplied, - defaults to (count vector). This operation is O(1) and very fast, as - the resulting vector shares structure with the original and no - trimming is done." - ([v start] - (subvec v start (count v))) - ([v start end] - (build-subvec nil v start end nil))) - -(defn- tv-ensure-editable [edit node] - (if (identical? edit (.-edit node)) - node - (VectorNode. edit (aclone (.-arr node))))) - -(defn- tv-editable-root [node] - (VectorNode. (js-obj) (aclone (.-arr node)))) - -(defn- tv-editable-tail [tl] - (let [ret (make-array 32)] - (array-copy tl 0 ret 0 (alength tl)) - ret)) - -(defn- tv-push-tail [tv level parent tail-node] - (let [ret (tv-ensure-editable (.. tv -root -edit) parent) - subidx (bit-and (bit-shift-right-zero-fill (dec (.-cnt tv)) level) 0x01f)] - (pv-aset ret subidx - (if (== level 5) - tail-node - (let [child (pv-aget ret subidx)] - (if-not (nil? child) - (tv-push-tail tv (- level 5) child tail-node) - (new-path (.. tv -root -edit) (- level 5) tail-node))))) - ret)) - -(defn- tv-pop-tail [tv level node] - (let [node (tv-ensure-editable (.. tv -root -edit) node) - subidx (bit-and (bit-shift-right-zero-fill (- (.-cnt tv) 2) level) 0x01f)] - (cond - (> level 5) (let [new-child (tv-pop-tail - tv (- level 5) (pv-aget node subidx))] - (if (and (nil? new-child) (zero? subidx)) - nil - (do (pv-aset node subidx new-child) - node))) - (zero? subidx) nil - :else (do (pv-aset node subidx nil) - node)))) - -(defn- unchecked-editable-array-for [tv i] - ;; invariant: i is a valid index of tv. - (if (>= i (tail-off tv)) - (.-tail tv) - (let [root (.-root tv)] - (loop [node root - level (.-shift tv)] - (if (pos? level) - (recur (tv-ensure-editable - (.-edit root) - (pv-aget node - (bit-and (bit-shift-right-zero-fill i level) - 0x01f))) - (- level 5)) - (.-arr node)))))) - -(deftype TransientVector [^:mutable cnt - ^:mutable shift - ^:mutable root - ^:mutable tail] - ITransientCollection - (-conj! [tcoll o] - (if ^boolean (.-edit root) - (if (< (- cnt (tail-off tcoll)) 32) - (do (aset tail (bit-and cnt 0x01f) o) - (set! cnt (inc cnt)) - tcoll) - (let [tail-node (VectorNode. (.-edit root) tail) - new-tail (make-array 32)] - (aset new-tail 0 o) - (set! tail new-tail) - (if (> (bit-shift-right-zero-fill cnt 5) - (bit-shift-left 1 shift)) - (let [new-root-array (make-array 32) - new-shift (+ shift 5)] - (aset new-root-array 0 root) - (aset new-root-array 1 (new-path (.-edit root) shift tail-node)) - (set! root (VectorNode. (.-edit root) new-root-array)) - (set! shift new-shift) - (set! cnt (inc cnt)) - tcoll) - (let [new-root (tv-push-tail tcoll shift root tail-node)] - (set! root new-root) - (set! cnt (inc cnt)) - tcoll)))) - (throw (js/Error. "conj! after persistent!")))) - - (-persistent! [tcoll] - (if ^boolean (.-edit root) - (do (set! (.-edit root) nil) - (let [len (- cnt (tail-off tcoll)) - trimmed-tail (make-array len)] - (array-copy tail 0 trimmed-tail 0 len) - (PersistentVector. nil cnt shift root trimmed-tail nil))) - (throw (js/Error. "persistent! called twice")))) - - ITransientAssociative - (-assoc! [tcoll key val] - (if (number? key) - (-assoc-n! tcoll key val) - (throw (js/Error. "TransientVector's key for assoc! must be a number.")))) - - ITransientVector - (-assoc-n! [tcoll n val] - (if ^boolean (.-edit root) - (cond - (and (<= 0 n) (< n cnt)) - (if (<= (tail-off tcoll) n) - (do (aset tail (bit-and n 0x01f) val) - tcoll) - (let [new-root - ((fn go [level node] - (let [node (tv-ensure-editable (.-edit root) node)] - (if (zero? level) - (do (pv-aset node (bit-and n 0x01f) val) - node) - (let [subidx (bit-and (bit-shift-right-zero-fill n level) - 0x01f)] - (pv-aset node subidx - (go (- level 5) (pv-aget node subidx))) - node)))) - shift root)] - (set! root new-root) - tcoll)) - (== n cnt) (-conj! tcoll val) - :else - (throw - (js/Error. - (str "Index " n " out of bounds for TransientVector of length" cnt)))) - (throw (js/Error. "assoc! after persistent!")))) - - (-pop! [tcoll] - (if ^boolean (.-edit root) - (cond - (zero? cnt) (throw (js/Error. "Can't pop empty vector")) - (== 1 cnt) (do (set! cnt 0) tcoll) - (pos? (bit-and (dec cnt) 0x01f)) (do (set! cnt (dec cnt)) tcoll) - :else - (let [new-tail (unchecked-editable-array-for tcoll (- cnt 2)) - new-root (let [nr (tv-pop-tail tcoll shift root)] - (if-not (nil? nr) - nr - (VectorNode. (.-edit root) (make-array 32))))] - (if (and (< 5 shift) (nil? (pv-aget new-root 1))) - (let [new-root (tv-ensure-editable (.-edit root) (pv-aget new-root 0))] - (set! root new-root) - (set! shift (- shift 5)) - (set! cnt (dec cnt)) - (set! tail new-tail) - tcoll) - (do (set! root new-root) - (set! cnt (dec cnt)) - (set! tail new-tail) - tcoll)))) - (throw (js/Error. "pop! after persistent!")))) - - ICounted - (-count [coll] - (if ^boolean (.-edit root) - cnt - (throw (js/Error. "count after persistent!")))) - - IIndexed - (-nth [coll n] - (if ^boolean (.-edit root) - (aget (array-for coll n) (bit-and n 0x01f)) - (throw (js/Error. "nth after persistent!")))) - - (-nth [coll n not-found] - (if (and (<= 0 n) (< n cnt)) - (-nth coll n) - not-found)) - - ILookup - (-lookup [coll k] (-lookup coll k nil)) - - (-lookup [coll k not-found] (if (number? k) - (-nth coll k not-found) - not-found)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - - (-invoke [coll k not-found] - (-lookup coll k not-found))) - -;;; PersistentQueue ;;; - -(deftype PersistentQueueIter [^:mutable fseq riter] - Object - (hasNext [_] - (or (and (some? fseq) (seq fseq)) (and (some? riter) (.hasNext riter)))) - (next [_] - (cond - (some? fseq) - (let [ret (first fseq)] - (set! fseq (next fseq)) - ret) - (and (some? riter) ^boolean (.hasNext riter)) - (.next riter) - :else (throw (js/Error. "No such element")))) - (remove [_] (js/Error. "Unsupported operation"))) - -(deftype PersistentQueueSeq [meta front rear ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IWithMeta - (-with-meta [coll meta] (PersistentQueueSeq. meta front rear __hash)) - - IMeta - (-meta [coll] meta) - - ISeq - (-first [coll] (first front)) - (-rest [coll] - (if-let [f1 (next front)] - (PersistentQueueSeq. meta f1 rear nil) - (if (nil? rear) - (-empty coll) - (PersistentQueueSeq. meta rear nil nil)))) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] coll)) - -(es6-iterable PersistentQueueSeq) - -(deftype PersistentQueue [meta count front rear ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [coll] (PersistentQueue. meta count front rear __hash)) - - IIterable - (-iterator [coll] - (PersistentQueueIter. front (-iterator rear))) - - IWithMeta - (-with-meta [coll meta] (PersistentQueue. meta count front rear __hash)) - - IMeta - (-meta [coll] meta) - - ISeq - (-first [coll] (first front)) - (-rest [coll] (rest (seq coll))) - - IStack - (-peek [coll] (first front)) - (-pop [coll] - (if front - (if-let [f1 (next front)] - (PersistentQueue. meta (dec count) f1 rear nil) - (PersistentQueue. meta (dec count) (seq rear) [] nil)) - coll)) - - ICollection - (-conj [coll o] - (if front - (PersistentQueue. meta (inc count) front (conj (or rear []) o) nil) - (PersistentQueue. meta (inc count) (conj front o) [] nil))) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY PersistentQueue) meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - ISeqable - (-seq [coll] - (let [rear (seq rear)] - (if (or front rear) - (PersistentQueueSeq. nil front (seq rear) nil)))) - - ICounted - (-count [coll] count)) - -(set! (.-EMPTY PersistentQueue) (PersistentQueue. nil 0 nil [] empty-ordered-hash)) - -(es6-iterable PersistentQueue) - -(deftype NeverEquiv [] - Object - (equiv [this other] - (-equiv this other)) - IEquiv - (-equiv [o other] false)) - -(def ^:private never-equiv (NeverEquiv.)) - -(defn- ^boolean equiv-map - "Assumes y is a map. Returns true if x equals y, otherwise returns - false." - [x y] - (boolean - (when (map? y) - ; assume all maps are counted - (when (== (count x) (count y)) - (every? (fn [xkv] (= (get y (first xkv) never-equiv) - (second xkv))) - x))))) - - -(defn- scan-array [incr k array] - (let [len (alength array)] - (loop [i 0] - (when (< i len) - (if (identical? k (aget array i)) - i - (recur (+ i incr))))))) - -; The keys field is an array of all keys of this map, in no particular -; order. Any string, keyword, or symbol key is used as a property name -; to store the value in strobj. If a key is assoc'ed when that same -; key already exists in strobj, the old value is overwritten. If a -; non-string key is assoc'ed, return a HashMap object instead. - -(defn- obj-map-compare-keys [a b] - (let [a (hash a) - b (hash b)] - (cond - (< a b) -1 - (> a b) 1 - :else 0))) - -(defn- obj-map->hash-map [m k v] - (let [ks (.-keys m) - len (alength ks) - so (.-strobj m) - mm (meta m)] - (loop [i 0 - out (transient (.-EMPTY PersistentHashMap))] - (if (< i len) - (let [k (aget ks i)] - (recur (inc i) (assoc! out k (aget so k)))) - (with-meta (persistent! (assoc! out k v)) mm))))) - -;;; ObjMap - DEPRECATED - -(defn- obj-clone [obj ks] - (let [new-obj (js-obj) - l (alength ks)] - (loop [i 0] - (when (< i l) - (let [k (aget ks i)] - (aset new-obj k (aget obj k)) - (recur (inc i))))) - new-obj)) - -(deftype ObjMap [meta keys strobj update-count ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - IWithMeta - (-with-meta [coll meta] (ObjMap. meta keys strobj update-count __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll entry] - (if (vector? entry) - (-assoc coll (-nth entry 0) (-nth entry 1)) - (reduce -conj - coll - entry))) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY ObjMap) meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - ISeqable - (-seq [coll] - (when (pos? (alength keys)) - (map #(vector % (aget strobj %)) - (.sort keys obj-map-compare-keys)))) - - ICounted - (-count [coll] (alength keys)) - - ILookup - (-lookup [coll k] (-lookup coll k nil)) - (-lookup [coll k not-found] - (if (and ^boolean (goog/isString k) - (not (nil? (scan-array 1 k keys)))) - (aget strobj k) - not-found)) - - IAssociative - (-assoc [coll k v] - (if ^boolean (goog/isString k) - (if (or (> update-count (.-HASHMAP_THRESHOLD ObjMap)) - (>= (alength keys) (.-HASHMAP_THRESHOLD ObjMap))) - (obj-map->hash-map coll k v) - (if-not (nil? (scan-array 1 k keys)) - (let [new-strobj (obj-clone strobj keys)] - (aset new-strobj k v) - (ObjMap. meta keys new-strobj (inc update-count) nil)) ; overwrite - (let [new-strobj (obj-clone strobj keys) ; append - new-keys (aclone keys)] - (aset new-strobj k v) - (.push new-keys k) - (ObjMap. meta new-keys new-strobj (inc update-count) nil)))) - ;; non-string key. game over. - (obj-map->hash-map coll k v))) - (-contains-key? [coll k] - (if (and ^boolean (goog/isString k) - (not (nil? (scan-array 1 k keys)))) - true - false)) - - IKVReduce - (-kv-reduce [coll f init] - (let [len (alength keys)] - (loop [keys (.sort keys obj-map-compare-keys) - init init] - (if (seq keys) - (let [k (first keys) - init (f init k (aget strobj k))] - (if (reduced? init) - @init - (recur (rest keys) init))) - init)))) - - IMap - (-dissoc [coll k] - (if (and ^boolean (goog/isString k) - (not (nil? (scan-array 1 k keys)))) - (let [new-keys (aclone keys) - new-strobj (obj-clone strobj keys)] - (.splice new-keys (scan-array 1 k new-keys) 1) - (js-delete new-strobj k) - (ObjMap. meta new-keys new-strobj (inc update-count) nil)) - coll)) ; key not found, return coll unchanged - - IFn - (-invoke [coll k] - (-lookup coll k)) - (-invoke [coll k not-found] - (-lookup coll k not-found)) - - IEditableCollection - (-as-transient [coll] - (transient (into (hash-map) coll)))) - -(set! (.-EMPTY ObjMap) (ObjMap. nil (array) (js-obj) 0 empty-unordered-hash)) - -(set! (.-HASHMAP_THRESHOLD ObjMap) 8) - -(set! (.-fromObject ObjMap) (fn [ks obj] (ObjMap. nil ks obj 0 nil))) - -;; Record Iterator -(deftype RecordIter [^:mutable i record base-count fields ext-map-iter] - Object - (hasNext [_] - (or (< i base-count) (.hasNext ext-map-iter))) - (next [_] - (if (< i base-count) - (let [k (nth fields i)] - (set! i (inc i)) - [k (-lookup record k)]) - (.next ext-map-iter))) - (remove [_] (js/Error. "Unsupported operation"))) - -;; EXPERIMENTAL: subject to change -(deftype ES6EntriesIterator [^:mutable s] - Object - (next [_] - (if-not (nil? s) - (let [[k v] (first s)] - (set! s (next s)) - #js {:value #js [k v] :done false}) - #js {:value nil :done true}))) - -(defn es6-entries-iterator [coll] - (ES6EntriesIterator. (seq coll))) - -;; EXPERIMENTAL: subject to change -(deftype ES6SetEntriesIterator [^:mutable s] - Object - (next [_] - (if-not (nil? s) - (let [x (first s)] - (set! s (next s)) - #js {:value #js [x x] :done false}) - #js {:value nil :done true}))) - -(defn es6-set-entries-iterator [coll] - (ES6SetEntriesIterator. (seq coll))) - -;;; PersistentArrayMap - -(defn- array-index-of-nil? [arr] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (nil? (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn- array-index-of-keyword? [arr k] - (let [len (alength arr) - kstr (.-fqn k)] - (loop [i 0] - (cond - (<= len i) -1 - (and (keyword? (aget arr i)) - (identical? kstr (.-fqn (aget arr i)))) i - :else (recur (+ i 2)))))) - -(defn- array-index-of-symbol? [arr k] - (let [len (alength arr) - kstr (.-str k)] - (loop [i 0] - (cond - (<= len i) -1 - (and (symbol? (aget arr i)) - (identical? kstr (.-str (aget arr i)))) i - :else (recur (+ i 2)))))) - -(defn- array-index-of-identical? [arr k] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (identical? k (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn- array-index-of-equiv? [arr k] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (= k (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn array-index-of [arr k] - (cond - (keyword? k) (array-index-of-keyword? arr k) - - (or ^boolean (goog/isString k) (number? k)) - (array-index-of-identical? arr k) - - (symbol? k) (array-index-of-symbol? arr k) - - (nil? k) - (array-index-of-nil? arr) - - :else (array-index-of-equiv? arr k))) - -(defn- array-map-index-of [m k] - (array-index-of (.-arr m) k)) - -(defn- array-extend-kv [arr k v] - (let [l (alength arr) - narr (make-array (+ l 2))] - (loop [i 0] - (when (< i l) - (aset narr i (aget arr i)) - (recur (inc i)))) - (aset narr l k) - (aset narr (inc l) v) - narr)) - -(defn- array-map-extend-kv [m k v] - (array-extend-kv (.-arr m) k v)) - -(declare TransientArrayMap) - -(deftype PersistentArrayMapSeq [arr i _meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] - (PersistentArrayMapSeq. arr i new-meta)) - - ICounted - (-count [coll] - (/ (- (alength arr) i) 2)) - - ISeqable - (-seq [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) _meta)) - - IHash - (-hash [coll] (hash-ordered-coll coll)) - - ISeq - (-first [coll] - [(aget arr i) (aget arr (inc i))]) - - (-rest [coll] - (if (< i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr (+ i 2) _meta) - ())) - - INext - (-next [coll] - (when (< i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr (+ i 2) _meta))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable PersistentArrayMapSeq) - -(defn persistent-array-map-seq [arr i _meta] - (when (<= i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr i _meta))) - -(declare keys vals) - -(deftype PersistentArrayMapIterator [arr ^:mutable i cnt] - Object - (hasNext [_] - (< i cnt)) - (next [_] - (let [ret [(aget arr i) (aget arr (inc i))]] - (set! i (+ i 2)) - ret))) - -(deftype PersistentArrayMap [meta cnt arr ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - ;; EXPERIMENTAL: subject to change - (keys [coll] - (es6-iterator (keys coll))) - (entries [coll] - (es6-entries-iterator (seq coll))) - (values [coll] - (es6-iterator (vals coll))) - (has [coll k] - (contains? coll k)) - (get [coll k not-found] - (-lookup coll k not-found)) - (forEach [coll f] - (doseq [[k v] coll] - (f v k))) - - ICloneable - (-clone [_] (PersistentArrayMap. meta cnt arr __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentArrayMap. meta cnt arr __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll entry] - (if (vector? entry) - (-assoc coll (-nth entry 0) (-nth entry 1)) - (loop [ret coll es (seq entry)] - (if (nil? es) - ret - (let [e (first es)] - (if (vector? e) - (recur (-assoc ret (-nth e 0) (-nth e 1)) - (next es)) - (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) - - IEmptyableCollection - (-empty [coll] (-with-meta (.-EMPTY PersistentArrayMap) meta)) - - IEquiv - (-equiv [coll other] - (if (implements? IMap other) - (let [alen (alength arr) - ^not-native other other] - (if (== cnt (-count other)) - (loop [i 0] - (if (< i alen) - (let [v (-lookup other (aget arr i) lookup-sentinel)] - (if-not (identical? v lookup-sentinel) - (if (= (aget arr (inc i)) v) - (recur (+ i 2)) - false) - false)) - true)) - false)) - (equiv-map coll other))) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - IIterable - (-iterator [this] - (PersistentArrayMapIterator. arr 0 (* cnt 2))) - - ISeqable - (-seq [coll] - (persistent-array-map-seq arr 0 nil)) - - ICounted - (-count [coll] cnt) - - ILookup - (-lookup [coll k] - (-lookup coll k nil)) - - (-lookup [coll k not-found] - (let [idx (array-map-index-of coll k)] - (if (== idx -1) - not-found - (aget arr (inc idx))))) - - IAssociative - (-assoc [coll k v] - (let [idx (array-map-index-of coll k)] - (cond - (== idx -1) - (if (< cnt (.-HASHMAP-THRESHOLD PersistentArrayMap)) - (let [arr (array-map-extend-kv coll k v)] - (PersistentArrayMap. meta (inc cnt) arr nil)) - (-> (into (.-EMPTY PersistentHashMap) coll) - (-assoc k v) - (-with-meta meta))) - - (identical? v (aget arr (inc idx))) - coll - - :else - (let [arr (doto (aclone arr) - (aset (inc idx) v))] - (PersistentArrayMap. meta cnt arr nil))))) - - (-contains-key? [coll k] - (not (== (array-map-index-of coll k) -1))) - - IMap - (-dissoc [coll k] - (let [idx (array-map-index-of coll k)] - (if (>= idx 0) - (let [len (alength arr) - new-len (- len 2)] - (if (zero? new-len) - (-empty coll) - (let [new-arr (make-array new-len)] - (loop [s 0 d 0] - (cond - (>= s len) (PersistentArrayMap. meta (dec cnt) new-arr nil) - (= k (aget arr s)) (recur (+ s 2) d) - :else (do (aset new-arr d (aget arr s)) - (aset new-arr (inc d) (aget arr (inc s))) - (recur (+ s 2) (+ d 2)))))))) - coll))) - - IKVReduce - (-kv-reduce [coll f init] - (let [len (alength arr)] - (loop [i 0 init init] - (if (< i len) - (let [init (f init (aget arr i) (aget arr (inc i)))] - (if (reduced? init) - @init - (recur (+ i 2) init))) - init)))) - - IReduce - (-reduce [coll f] - (seq-reduce f coll)) - (-reduce [coll f start] - (seq-reduce f start coll)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - - (-invoke [coll k not-found] - (-lookup coll k not-found)) - - IEditableCollection - (-as-transient [coll] - (TransientArrayMap. (js-obj) (alength arr) (aclone arr)))) - -(set! (.-EMPTY PersistentArrayMap) (PersistentArrayMap. nil 0 (array) empty-unordered-hash)) - -(set! (.-HASHMAP-THRESHOLD PersistentArrayMap) 8) - -(set! (.-fromArray PersistentArrayMap) - (fn [arr ^boolean no-clone ^boolean no-check] - (as-> (if no-clone arr (aclone arr)) arr - (if no-check - arr - (let [ret (array)] - (loop [i 0] - (when (< i (alength arr)) - (let [k (aget arr i) - v (aget arr (inc i)) - idx (array-index-of ret k)] - (when (== idx -1) - (.push ret k) - (.push ret v))) - (recur (+ i 2)))) - ret)) - (let [cnt (/ (alength arr) 2)] - (PersistentArrayMap. nil cnt arr nil))))) - -(set! (.-createWithCheck PersistentArrayMap) - (fn [arr] - (let [ret (array)] - (loop [i 0] - (when (< i (alength arr)) - (let [k (aget arr i) - v (aget arr (inc i)) - idx (array-index-of ret k)] - (if (== idx -1) - (doto ret (.push k) (.push v)) - (throw (js/Error. (str "Duplicate key: " k))))) - (recur (+ i 2)))) - (let [cnt (/ (alength arr) 2)] - (PersistentArrayMap. nil cnt arr nil))))) - -(set! (.-createAsIfByAssoc PersistentArrayMap) - (fn [arr] - (let [ret (array)] - (loop [i 0] - (when (< i (alength arr)) - (let [k (aget arr i) - v (aget arr (inc i)) - idx (array-index-of ret k)] - (if (== idx -1) - (doto ret (.push k) (.push v)) - (aset ret (inc idx) v))) - (recur (+ i 2)))) - (PersistentArrayMap. nil (/ (alength ret) 2) ret nil)))) - -(es6-iterable PersistentArrayMap) - -(declare array->transient-hash-map) - -(deftype TransientArrayMap [^:mutable editable? - ^:mutable len - arr] - ICounted - (-count [tcoll] - (if editable? - (quot len 2) - (throw (js/Error. "count after persistent!")))) - - ILookup - (-lookup [tcoll k] - (-lookup tcoll k nil)) - - (-lookup [tcoll k not-found] - (if editable? - (let [idx (array-map-index-of tcoll k)] - (if (== idx -1) - not-found - (aget arr (inc idx)))) - (throw (js/Error. "lookup after persistent!")))) - - ITransientCollection - (-conj! [tcoll o] - (if editable? - (if (satisfies? IMapEntry o) - (-assoc! tcoll (key o) (val o)) - (loop [es (seq o) tcoll tcoll] - (if-let [e (first es)] - (recur (next es) - (-assoc! tcoll (key e) (val e))) - tcoll))) - (throw (js/Error. "conj! after persistent!")))) - - (-persistent! [tcoll] - (if editable? - (do (set! editable? false) - (PersistentArrayMap. nil (quot len 2) arr nil)) - (throw (js/Error. "persistent! called twice")))) - - ITransientAssociative - (-assoc! [tcoll key val] - (if editable? - (let [idx (array-map-index-of tcoll key)] - (if (== idx -1) - (if (<= (+ len 2) (* 2 (.-HASHMAP-THRESHOLD PersistentArrayMap))) - (do (set! len (+ len 2)) - (.push arr key) - (.push arr val) - tcoll) - (assoc! (array->transient-hash-map len arr) key val)) - (if (identical? val (aget arr (inc idx))) - tcoll - (do (aset arr (inc idx) val) - tcoll)))) - (throw (js/Error. "assoc! after persistent!")))) - - ITransientMap - (-dissoc! [tcoll key] - (if editable? - (let [idx (array-map-index-of tcoll key)] - (when (>= idx 0) - (aset arr idx (aget arr (- len 2))) - (aset arr (inc idx) (aget arr (dec len))) - (doto arr .pop .pop) - (set! len (- len 2))) - tcoll) - (throw (js/Error. "dissoc! after persistent!"))))) - -(declare TransientHashMap PersistentHashMap) - -(defn- array->transient-hash-map [len arr] - (loop [out (transient (.-EMPTY PersistentHashMap)) - i 0] - (if (< i len) - (recur (assoc! out (aget arr i) (aget arr (inc i))) (+ i 2)) - out))) - -;;; PersistentHashMap - -(deftype Box [^:mutable val]) - -(declare create-inode-seq create-array-node-seq reset! create-node atom deref) - -(defn ^boolean key-test [key other] - (cond - (identical? key other) true - (keyword-identical? key other) true - :else (= key other))) - -(defn- mask [hash shift] - (bit-and (bit-shift-right-zero-fill hash shift) 0x01f)) - -(defn- clone-and-set - ([arr i a] - (doto (aclone arr) - (aset i a))) - ([arr i a j b] - (doto (aclone arr) - (aset i a) - (aset j b)))) - -(defn- remove-pair [arr i] - (let [new-arr (make-array (- (alength arr) 2))] - (array-copy arr 0 new-arr 0 (* 2 i)) - (array-copy arr (* 2 (inc i)) new-arr (* 2 i) (- (alength new-arr) (* 2 i))) - new-arr)) - -(defn- bitmap-indexed-node-index [bitmap bit] - (bit-count (bit-and bitmap (dec bit)))) - -(defn- bitpos [hash shift] - (bit-shift-left 1 (mask hash shift))) - -(defn- edit-and-set - ([inode edit i a] - (let [editable (.ensure-editable inode edit)] - (aset (.-arr editable) i a) - editable)) - ([inode edit i a j b] - (let [editable (.ensure-editable inode edit)] - (aset (.-arr editable) i a) - (aset (.-arr editable) j b) - editable))) - -(defn- inode-kv-reduce [arr f init] - (let [len (alength arr)] - (loop [i 0 init init] - (if (< i len) - (let [init (let [k (aget arr i)] - (if-not (nil? k) - (f init k (aget arr (inc i))) - (let [node (aget arr (inc i))] - (if-not (nil? node) - (.kv-reduce node f init) - init))))] - (if (reduced? init) - @init - (recur (+ i 2) init))) - init)))) - -(declare ArrayNode) - - (deftype NodeIterator [arr ^:mutable i ^:mutable next-entry ^:mutable next-iter] - Object - (advance [this] - (let [len (alength arr)] - (loop [] - (if (< i len) - (let [key (aget arr i) - node-or-val (aget arr (inc i)) - ^boolean found - (cond (some? key) - (set! next-entry [key node-or-val]) - (some? node-or-val) - (let [new-iter (-iterator node-or-val)] - (if ^boolean (.hasNext new-iter) - (set! next-iter new-iter) - false)) - :else false)] - (set! i (+ i 2)) - (if found true (recur))) - false)))) - (hasNext [this] - (or (some? next-entry) (some? next-iter) (.advance this))) - (next [this] - (cond - (some? next-entry) - (let [ret next-entry] - (set! next-entry nil) - ret) - (some? next-iter) - (let [ret (.next next-iter)] - (when-not ^boolean (.hasNext next-iter) - (set! next-iter nil)) - ret) - ^boolean (.advance this) - (.next this) - :else (throw (js/Error. "No such element")))) - (remove [_] (js/Error. "Unsupported operation"))) - -(deftype BitmapIndexedNode [edit ^:mutable bitmap ^:mutable arr] - Object - (inode-assoc [inode shift hash key val added-leaf?] - (let [bit (bitpos hash shift) - idx (bitmap-indexed-node-index bitmap bit)] - (if (zero? (bit-and bitmap bit)) - (let [n (bit-count bitmap)] - (if (>= n 16) - (let [nodes (make-array 32) - jdx (mask hash shift)] - (aset nodes jdx (.inode-assoc (.-EMPTY BitmapIndexedNode) (+ shift 5) hash key val added-leaf?)) - (loop [i 0 j 0] - (if (< i 32) - (if (zero? (bit-and (bit-shift-right-zero-fill bitmap i) 1)) - (recur (inc i) j) - (do (aset nodes i - (if-not (nil? (aget arr j)) - (.inode-assoc (.-EMPTY BitmapIndexedNode) - (+ shift 5) (cljs.core/hash (aget arr j)) (aget arr j) (aget arr (inc j)) added-leaf?) - (aget arr (inc j)))) - (recur (inc i) (+ j 2)))))) - (ArrayNode. nil (inc n) nodes)) - (let [new-arr (make-array (* 2 (inc n)))] - (array-copy arr 0 new-arr 0 (* 2 idx)) - (aset new-arr (* 2 idx) key) - (aset new-arr (inc (* 2 idx)) val) - (array-copy arr (* 2 idx) new-arr (* 2 (inc idx)) (* 2 (- n idx))) - (set! (.-val added-leaf?) true) - (BitmapIndexedNode. nil (bit-or bitmap bit) new-arr)))) - (let [key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) - (let [n (.inode-assoc val-or-node (+ shift 5) hash key val added-leaf?)] - (if (identical? n val-or-node) - inode - (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) n)))) - - (key-test key key-or-nil) - (if (identical? val val-or-node) - inode - (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) val))) - - :else - (do (set! (.-val added-leaf?) true) - (BitmapIndexedNode. nil bitmap - (clone-and-set arr (* 2 idx) nil (inc (* 2 idx)) - (create-node (+ shift 5) key-or-nil val-or-node hash key val))))))))) - - (inode-without [inode shift hash key] - (let [bit (bitpos hash shift)] - (if (zero? (bit-and bitmap bit)) - inode - (let [idx (bitmap-indexed-node-index bitmap bit) - key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) - (let [n (.inode-without val-or-node (+ shift 5) hash key)] - (cond (identical? n val-or-node) inode - (not (nil? n)) (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) n)) - (== bitmap bit) nil - :else (BitmapIndexedNode. nil (bit-xor bitmap bit) (remove-pair arr idx)))) - (key-test key key-or-nil) - (BitmapIndexedNode. nil (bit-xor bitmap bit) (remove-pair arr idx)) - :else inode))))) - - (inode-lookup [inode shift hash key not-found] - (let [bit (bitpos hash shift)] - (if (zero? (bit-and bitmap bit)) - not-found - (let [idx (bitmap-indexed-node-index bitmap bit) - key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) (.inode-lookup val-or-node (+ shift 5) hash key not-found) - (key-test key key-or-nil) val-or-node - :else not-found))))) - - (inode-find [inode shift hash key not-found] - (let [bit (bitpos hash shift)] - (if (zero? (bit-and bitmap bit)) - not-found - (let [idx (bitmap-indexed-node-index bitmap bit) - key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) (.inode-find val-or-node (+ shift 5) hash key not-found) - (key-test key key-or-nil) [key-or-nil val-or-node] - :else not-found))))) - - (inode-seq [inode] - (create-inode-seq arr)) - - (ensure-editable [inode e] - (if (identical? e edit) - inode - (let [n (bit-count bitmap) - new-arr (make-array (if (neg? n) 4 (* 2 (inc n))))] - (array-copy arr 0 new-arr 0 (* 2 n)) - (BitmapIndexedNode. e bitmap new-arr)))) - - (edit-and-remove-pair [inode e bit i] - (if (== bitmap bit) - nil - (let [editable (.ensure-editable inode e) - earr (.-arr editable) - len (alength earr)] - (set! (.-bitmap editable) (bit-xor bit (.-bitmap editable))) - (array-copy earr (* 2 (inc i)) - earr (* 2 i) - (- len (* 2 (inc i)))) - (aset earr (- len 2) nil) - (aset earr (dec len) nil) - editable))) - - (inode-assoc! [inode edit shift hash key val added-leaf?] - (let [bit (bitpos hash shift) - idx (bitmap-indexed-node-index bitmap bit)] - (if (zero? (bit-and bitmap bit)) - (let [n (bit-count bitmap)] - (cond - (< (* 2 n) (alength arr)) - (let [editable (.ensure-editable inode edit) - earr (.-arr editable)] - (set! (.-val added-leaf?) true) - (array-copy-downward earr (* 2 idx) - earr (* 2 (inc idx)) - (* 2 (- n idx))) - (aset earr (* 2 idx) key) - (aset earr (inc (* 2 idx)) val) - (set! (.-bitmap editable) (bit-or (.-bitmap editable) bit)) - editable) - - (>= n 16) - (let [nodes (make-array 32) - jdx (mask hash shift)] - (aset nodes jdx (.inode-assoc! (.-EMPTY BitmapIndexedNode) edit (+ shift 5) hash key val added-leaf?)) - (loop [i 0 j 0] - (if (< i 32) - (if (zero? (bit-and (bit-shift-right-zero-fill bitmap i) 1)) - (recur (inc i) j) - (do (aset nodes i - (if-not (nil? (aget arr j)) - (.inode-assoc! (.-EMPTY BitmapIndexedNode) - edit (+ shift 5) (cljs.core/hash (aget arr j)) (aget arr j) (aget arr (inc j)) added-leaf?) - (aget arr (inc j)))) - (recur (inc i) (+ j 2)))))) - (ArrayNode. edit (inc n) nodes)) - - :else - (let [new-arr (make-array (* 2 (+ n 4)))] - (array-copy arr 0 new-arr 0 (* 2 idx)) - (aset new-arr (* 2 idx) key) - (aset new-arr (inc (* 2 idx)) val) - (array-copy arr (* 2 idx) new-arr (* 2 (inc idx)) (* 2 (- n idx))) - (set! (.-val added-leaf?) true) - (let [editable (.ensure-editable inode edit)] - (set! (.-arr editable) new-arr) - (set! (.-bitmap editable) (bit-or (.-bitmap editable) bit)) - editable)))) - (let [key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) - (let [n (.inode-assoc! val-or-node edit (+ shift 5) hash key val added-leaf?)] - (if (identical? n val-or-node) - inode - (edit-and-set inode edit (inc (* 2 idx)) n))) - - (key-test key key-or-nil) - (if (identical? val val-or-node) - inode - (edit-and-set inode edit (inc (* 2 idx)) val)) - - :else - (do (set! (.-val added-leaf?) true) - (edit-and-set inode edit (* 2 idx) nil (inc (* 2 idx)) - (create-node edit (+ shift 5) key-or-nil val-or-node hash key val)))))))) - - (inode-without! [inode edit shift hash key removed-leaf?] - (let [bit (bitpos hash shift)] - (if (zero? (bit-and bitmap bit)) - inode - (let [idx (bitmap-indexed-node-index bitmap bit) - key-or-nil (aget arr (* 2 idx)) - val-or-node (aget arr (inc (* 2 idx)))] - (cond (nil? key-or-nil) - (let [n (.inode-without! val-or-node edit (+ shift 5) hash key removed-leaf?)] - (cond (identical? n val-or-node) inode - (not (nil? n)) (edit-and-set inode edit (inc (* 2 idx)) n) - (== bitmap bit) nil - :else (.edit-and-remove-pair inode edit bit idx))) - (key-test key key-or-nil) - (do (aset removed-leaf? 0 true) - (.edit-and-remove-pair inode edit bit idx)) - :else inode))))) - - (kv-reduce [inode f init] - (inode-kv-reduce arr f init)) - - IIterable - (-iterator [coll] - (NodeIterator. arr 0 nil nil))) - -(set! (.-EMPTY BitmapIndexedNode) (BitmapIndexedNode. nil 0 (make-array 0))) - -(defn- pack-array-node [array-node edit idx] - (let [arr (.-arr array-node) - len (alength arr) - new-arr (make-array (* 2 (dec (.-cnt array-node))))] - (loop [i 0 j 1 bitmap 0] - (if (< i len) - (if (and (not (== i idx)) - (not (nil? (aget arr i)))) - (do (aset new-arr j (aget arr i)) - (recur (inc i) (+ j 2) (bit-or bitmap (bit-shift-left 1 i)))) - (recur (inc i) j bitmap)) - (BitmapIndexedNode. edit bitmap new-arr))))) - -(deftype ArrayNodeIterator [arr ^:mutable i ^:mutable next-iter] - Object - (hasNext [this] - (let [len (alength arr)] - (loop [] - (if-not (and (some? next-iter) ^boolean (.hasNext next-iter)) - (if (< i len) - (let [node (aget arr i)] - (set! i (inc i)) - (when (some? node) - (set! next-iter (-iterator node))) - (recur)) - false) - true)))) - (next [this] - (if ^boolean (.hasNext this) - (.next next-iter) - (throw (js/Error. "No such element")))) - (remove [_] (js/Error. "Unsupported operation"))) - -(deftype ArrayNode [edit ^:mutable cnt ^:mutable arr] - Object - (inode-assoc [inode shift hash key val added-leaf?] - (let [idx (mask hash shift) - node (aget arr idx)] - (if (nil? node) - (ArrayNode. nil (inc cnt) (clone-and-set arr idx (.inode-assoc (.-EMPTY BitmapIndexedNode) (+ shift 5) hash key val added-leaf?))) - (let [n (.inode-assoc node (+ shift 5) hash key val added-leaf?)] - (if (identical? n node) - inode - (ArrayNode. nil cnt (clone-and-set arr idx n))))))) - - (inode-without [inode shift hash key] - (let [idx (mask hash shift) - node (aget arr idx)] - (if-not (nil? node) - (let [n (.inode-without node (+ shift 5) hash key)] - (cond - (identical? n node) - inode - - (nil? n) - (if (<= cnt 8) - (pack-array-node inode nil idx) - (ArrayNode. nil (dec cnt) (clone-and-set arr idx n))) - - :else - (ArrayNode. nil cnt (clone-and-set arr idx n)))) - inode))) - - (inode-lookup [inode shift hash key not-found] - (let [idx (mask hash shift) - node (aget arr idx)] - (if-not (nil? node) - (.inode-lookup node (+ shift 5) hash key not-found) - not-found))) - - (inode-find [inode shift hash key not-found] - (let [idx (mask hash shift) - node (aget arr idx)] - (if-not (nil? node) - (.inode-find node (+ shift 5) hash key not-found) - not-found))) - - (inode-seq [inode] - (create-array-node-seq arr)) - - (ensure-editable [inode e] - (if (identical? e edit) - inode - (ArrayNode. e cnt (aclone arr)))) - - (inode-assoc! [inode edit shift hash key val added-leaf?] - (let [idx (mask hash shift) - node (aget arr idx)] - (if (nil? node) - (let [editable (edit-and-set inode edit idx (.inode-assoc! (.-EMPTY BitmapIndexedNode) edit (+ shift 5) hash key val added-leaf?))] - (set! (.-cnt editable) (inc (.-cnt editable))) - editable) - (let [n (.inode-assoc! node edit (+ shift 5) hash key val added-leaf?)] - (if (identical? n node) - inode - (edit-and-set inode edit idx n)))))) - - (inode-without! [inode edit shift hash key removed-leaf?] - (let [idx (mask hash shift) - node (aget arr idx)] - (if (nil? node) - inode - (let [n (.inode-without! node edit (+ shift 5) hash key removed-leaf?)] - (cond - (identical? n node) - inode - - (nil? n) - (if (<= cnt 8) - (pack-array-node inode edit idx) - (let [editable (edit-and-set inode edit idx n)] - (set! (.-cnt editable) (dec (.-cnt editable))) - editable)) - - :else - (edit-and-set inode edit idx n)))))) - - (kv-reduce [inode f init] - (let [len (alength arr)] ; actually 32 - (loop [i 0 init init] - (if (< i len) - (let [node (aget arr i)] - (if-not (nil? node) - (let [init (.kv-reduce node f init)] - (if (reduced? init) - @init - (recur (inc i) init))) - (recur (inc i) init))) - init)))) - - IIterable - (-iterator [coll] - (ArrayNodeIterator. arr 0 nil))) - -(defn- hash-collision-node-find-index [arr cnt key] - (let [lim (* 2 cnt)] - (loop [i 0] - (if (< i lim) - (if (key-test key (aget arr i)) - i - (recur (+ i 2))) - -1)))) - -(deftype HashCollisionNode [edit - ^:mutable collision-hash - ^:mutable cnt - ^:mutable arr] - Object - (inode-assoc [inode shift hash key val added-leaf?] - (if (== hash collision-hash) - (let [idx (hash-collision-node-find-index arr cnt key)] - (if (== idx -1) - (let [len (* 2 cnt) - new-arr (make-array (+ len 2))] - (array-copy arr 0 new-arr 0 len) - (aset new-arr len key) - (aset new-arr (inc len) val) - (set! (.-val added-leaf?) true) - (HashCollisionNode. nil collision-hash (inc cnt) new-arr)) - (if (= (aget arr (inc idx)) val) - inode - (HashCollisionNode. nil collision-hash cnt (clone-and-set arr (inc idx) val))))) - (.inode-assoc (BitmapIndexedNode. nil (bitpos collision-hash shift) (array nil inode)) - shift hash key val added-leaf?))) - - (inode-without [inode shift hash key] - (let [idx (hash-collision-node-find-index arr cnt key)] - (cond (== idx -1) inode - (== cnt 1) nil - :else (HashCollisionNode. nil collision-hash (dec cnt) (remove-pair arr (quot idx 2)))))) - - (inode-lookup [inode shift hash key not-found] - (let [idx (hash-collision-node-find-index arr cnt key)] - (cond (< idx 0) not-found - (key-test key (aget arr idx)) (aget arr (inc idx)) - :else not-found))) - - (inode-find [inode shift hash key not-found] - (let [idx (hash-collision-node-find-index arr cnt key)] - (cond (< idx 0) not-found - (key-test key (aget arr idx)) [(aget arr idx) (aget arr (inc idx))] - :else not-found))) - - (inode-seq [inode] - (create-inode-seq arr)) - - (ensure-editable [inode e] - (if (identical? e edit) - inode - (let [new-arr (make-array (* 2 (inc cnt)))] - (array-copy arr 0 new-arr 0 (* 2 cnt)) - (HashCollisionNode. e collision-hash cnt new-arr)))) - - (ensure-editable-array [inode e count array] - (if (identical? e edit) - (do (set! arr array) - (set! cnt count) - inode) - (HashCollisionNode. edit collision-hash count array))) - - (inode-assoc! [inode edit shift hash key val added-leaf?] - (if (== hash collision-hash) - (let [idx (hash-collision-node-find-index arr cnt key)] - (if (== idx -1) - (if (> (alength arr) (* 2 cnt)) - (let [editable (edit-and-set inode edit (* 2 cnt) key (inc (* 2 cnt)) val)] - (set! (.-val added-leaf?) true) - (set! (.-cnt editable) (inc (.-cnt editable))) - editable) - (let [len (alength arr) - new-arr (make-array (+ len 2))] - (array-copy arr 0 new-arr 0 len) - (aset new-arr len key) - (aset new-arr (inc len) val) - (set! (.-val added-leaf?) true) - (.ensure-editable-array inode edit (inc cnt) new-arr))) - (if (identical? (aget arr (inc idx)) val) - inode - (edit-and-set inode edit (inc idx) val)))) - (.inode-assoc! (BitmapIndexedNode. edit (bitpos collision-hash shift) (array nil inode nil nil)) - edit shift hash key val added-leaf?))) - - (inode-without! [inode edit shift hash key removed-leaf?] - (let [idx (hash-collision-node-find-index arr cnt key)] - (if (== idx -1) - inode - (do (aset removed-leaf? 0 true) - (if (== cnt 1) - nil - (let [editable (.ensure-editable inode edit) - earr (.-arr editable)] - (aset earr idx (aget earr (- (* 2 cnt) 2))) - (aset earr (inc idx) (aget earr (dec (* 2 cnt)))) - (aset earr (dec (* 2 cnt)) nil) - (aset earr (- (* 2 cnt) 2) nil) - (set! (.-cnt editable) (dec (.-cnt editable))) - editable)))))) - - (kv-reduce [inode f init] - (inode-kv-reduce arr f init)) - - IIterable - (-iterator [coll] - (NodeIterator. arr 0 nil nil))) - -(defn- create-node - ([shift key1 val1 key2hash key2 val2] - (let [key1hash (hash key1)] - (if (== key1hash key2hash) - (HashCollisionNode. nil key1hash 2 (array key1 val1 key2 val2)) - (let [added-leaf? (Box. false)] - (-> (.-EMPTY BitmapIndexedNode) - (.inode-assoc shift key1hash key1 val1 added-leaf?) - (.inode-assoc shift key2hash key2 val2 added-leaf?)))))) - ([edit shift key1 val1 key2hash key2 val2] - (let [key1hash (hash key1)] - (if (== key1hash key2hash) - (HashCollisionNode. nil key1hash 2 (array key1 val1 key2 val2)) - (let [added-leaf? (Box. false)] - (-> (.-EMPTY BitmapIndexedNode) - (.inode-assoc! edit shift key1hash key1 val1 added-leaf?) - (.inode-assoc! edit shift key2hash key2 val2 added-leaf?))))))) - -(deftype NodeSeq [meta nodes i s ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] (NodeSeq. meta nodes i s __hash)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - ISequential - ISeq - (-first [coll] - (if (nil? s) - [(aget nodes i) (aget nodes (inc i))] - (first s))) - - (-rest [coll] - (let [ret (if (nil? s) - (create-inode-seq nodes (+ i 2) nil) - (create-inode-seq nodes i (next s)))] - (if-not (nil? ret) ret ()))) - - ISeqable - (-seq [this] this) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable NodeSeq) - -(defn- create-inode-seq - ([nodes] - (create-inode-seq nodes 0 nil)) - ([nodes i s] - (if (nil? s) - (let [len (alength nodes)] - (loop [j i] - (if (< j len) - (if-not (nil? (aget nodes j)) - (NodeSeq. nil nodes j nil nil) - (if-let [node (aget nodes (inc j))] - (if-let [node-seq (.inode-seq node)] - (NodeSeq. nil nodes (+ j 2) node-seq nil) - (recur (+ j 2))) - (recur (+ j 2))))))) - (NodeSeq. nil nodes i s nil)))) - -(deftype ArrayNodeSeq [meta nodes i s ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] (ArrayNodeSeq. meta nodes i s __hash)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - ISequential - ISeq - (-first [coll] (first s)) - (-rest [coll] - (let [ret (create-array-node-seq nil nodes i (next s))] - (if-not (nil? ret) ret ()))) - - ISeqable - (-seq [this] this) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable ArrayNodeSeq) - -(defn- create-array-node-seq - ([nodes] (create-array-node-seq nil nodes 0 nil)) - ([meta nodes i s] - (if (nil? s) - (let [len (alength nodes)] - (loop [j i] - (if (< j len) - (if-let [nj (aget nodes j)] - (if-let [ns (.inode-seq nj)] - (ArrayNodeSeq. meta nodes (inc j) ns nil) - (recur (inc j))) - (recur (inc j)))))) - (ArrayNodeSeq. meta nodes i s nil)))) - -(declare TransientHashMap) - -(deftype HashMapIter [nil-val root-iter ^:mutable seen] - Object - (hasNext [_] - (or (not ^boolean seen) ^boolean (.hasNext root-iter))) - (next [_] - (if-not ^boolean seen - (do - (set! seen true) - [nil nil-val]) - (.next root-iter))) - (remove [_] (js/Error. "Unsupported operation"))) - -(deftype PersistentHashMap [meta cnt root ^boolean has-nil? nil-val ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - ;; EXPERIMENTAL: subject to change - (keys [coll] - (es6-iterator (keys coll))) - (entries [coll] - (es6-entries-iterator (seq coll))) - (values [coll] - (es6-iterator (vals coll))) - (has [coll k] - (contains? coll k)) - (get [coll k not-found] - (-lookup coll k not-found)) - (forEach [coll f] - (doseq [[k v] coll] - (f v k))) - - ICloneable - (-clone [_] (PersistentHashMap. meta cnt root has-nil? nil-val __hash)) - - IIterable - (-iterator [coll] - (let [root-iter (if ^boolean root (-iterator root) (nil-iter))] - (if has-nil? - (HashMapIter. nil-val root-iter false) - root-iter))) - - IWithMeta - (-with-meta [coll meta] (PersistentHashMap. meta cnt root has-nil? nil-val __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll entry] - (if (vector? entry) - (-assoc coll (-nth entry 0) (-nth entry 1)) - (loop [ret coll es (seq entry)] - (if (nil? es) - ret - (let [e (first es)] - (if (vector? e) - (recur (-assoc ret (-nth e 0) (-nth e 1)) - (next es)) - (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) - - IEmptyableCollection - (-empty [coll] (-with-meta (.-EMPTY PersistentHashMap) meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - ISeqable - (-seq [coll] - (when (pos? cnt) - (let [s (if-not (nil? root) (.inode-seq root))] - (if has-nil? - (cons [nil nil-val] s) - s)))) - - ICounted - (-count [coll] cnt) - - ILookup - (-lookup [coll k] - (-lookup coll k nil)) - - (-lookup [coll k not-found] - (cond (nil? k) (if has-nil? - nil-val - not-found) - (nil? root) not-found - :else (.inode-lookup root 0 (hash k) k not-found))) - - IAssociative - (-assoc [coll k v] - (if (nil? k) - (if (and has-nil? (identical? v nil-val)) - coll - (PersistentHashMap. meta (if has-nil? cnt (inc cnt)) root true v nil)) - (let [added-leaf? (Box. false) - new-root (-> (if (nil? root) - (.-EMPTY BitmapIndexedNode) - root) - (.inode-assoc 0 (hash k) k v added-leaf?))] - (if (identical? new-root root) - coll - (PersistentHashMap. meta (if ^boolean (.-val added-leaf?) (inc cnt) cnt) new-root has-nil? nil-val nil))))) - - (-contains-key? [coll k] - (cond (nil? k) has-nil? - (nil? root) false - :else (not (identical? (.inode-lookup root 0 (hash k) k lookup-sentinel) - lookup-sentinel)))) - - IMap - (-dissoc [coll k] - (cond (nil? k) (if has-nil? - (PersistentHashMap. meta (dec cnt) root false nil nil) - coll) - (nil? root) coll - :else - (let [new-root (.inode-without root 0 (hash k) k)] - (if (identical? new-root root) - coll - (PersistentHashMap. meta (dec cnt) new-root has-nil? nil-val nil))))) - - IKVReduce - (-kv-reduce [coll f init] - (let [init (if has-nil? (f init nil nil-val) init)] - (cond - (reduced? init) @init - (not (nil? root)) (.kv-reduce root f init) - :else init))) - - IFn - (-invoke [coll k] - (-lookup coll k)) - - (-invoke [coll k not-found] - (-lookup coll k not-found)) - - IEditableCollection - (-as-transient [coll] - (TransientHashMap. (js-obj) root cnt has-nil? nil-val))) - -(set! (.-EMPTY PersistentHashMap) (PersistentHashMap. nil 0 nil false nil empty-unordered-hash)) - -(set! (.-fromArray PersistentHashMap) - (fn [arr ^boolean no-clone] - (let [arr (if no-clone arr (aclone arr)) - len (alength arr)] - (loop [i 0 ret (transient (.-EMPTY PersistentHashMap))] - (if (< i len) - (recur (+ i 2) - (-assoc! ret (aget arr i) (aget arr (inc i)))) - (-persistent! ret)))))) - -(set! (.-fromArrays PersistentHashMap) - (fn [ks vs] - (let [len (alength ks)] - (loop [i 0 ^not-native out (transient (.-EMPTY PersistentHashMap))] - (if (< i len) - (recur (inc i) (-assoc! out (aget ks i) (aget vs i))) - (persistent! out)))))) - -(set! (.-createWithCheck PersistentHashMap) - (fn [arr] - (let [len (alength arr) - ret (transient (.-EMPTY PersistentHashMap))] - (loop [i 0] - (when (< i len) - (-assoc! ret (aget arr i) (aget arr (inc i))) - (if (not= (-count ret) (inc (/ i 2))) - (throw (js/Error. (str "Duplicate key: " (aget arr i)))) - (recur (+ i 2))))) - (-persistent! ret)))) - -(es6-iterable PersistentHashMap) - -(deftype TransientHashMap [^:mutable ^boolean edit - ^:mutable root - ^:mutable count - ^:mutable ^boolean has-nil? - ^:mutable nil-val] - Object - (conj! [tcoll o] - (if edit - (if (satisfies? IMapEntry o) - (.assoc! tcoll (key o) (val o)) - (loop [es (seq o) tcoll tcoll] - (if-let [e (first es)] - (recur (next es) - (.assoc! tcoll (key e) (val e))) - tcoll))) - (throw (js/Error. "conj! after persistent")))) - - (assoc! [tcoll k v] - (if edit - (if (nil? k) - (do (if (identical? nil-val v) - nil - (set! nil-val v)) - (if has-nil? - nil - (do (set! count (inc count)) - (set! has-nil? true))) - tcoll) - (let [added-leaf? (Box. false) - node (-> (if (nil? root) - (.-EMPTY BitmapIndexedNode) - root) - (.inode-assoc! edit 0 (hash k) k v added-leaf?))] - (if (identical? node root) - nil - (set! root node)) - (if ^boolean (.-val added-leaf?) - (set! count (inc count))) - tcoll)) - (throw (js/Error. "assoc! after persistent!")))) - - (without! [tcoll k] - (if edit - (if (nil? k) - (if has-nil? - (do (set! has-nil? false) - (set! nil-val nil) - (set! count (dec count)) - tcoll) - tcoll) - (if (nil? root) - tcoll - (let [removed-leaf? (Box. false) - node (.inode-without! root edit 0 (hash k) k removed-leaf?)] - (if (identical? node root) - nil - (set! root node)) - (if (aget removed-leaf? 0) - (set! count (dec count))) - tcoll))) - (throw (js/Error. "dissoc! after persistent!")))) - - (persistent! [tcoll] - (if edit - (do (set! edit nil) - (PersistentHashMap. nil count root has-nil? nil-val nil)) - (throw (js/Error. "persistent! called twice")))) - - ICounted - (-count [coll] - (if edit - count - (throw (js/Error. "count after persistent!")))) - - ILookup - (-lookup [tcoll k] - (if (nil? k) - (if has-nil? - nil-val) - (if (nil? root) - nil - (.inode-lookup root 0 (hash k) k)))) - - (-lookup [tcoll k not-found] - (if (nil? k) - (if has-nil? - nil-val - not-found) - (if (nil? root) - not-found - (.inode-lookup root 0 (hash k) k not-found)))) - - ITransientCollection - (-conj! [tcoll val] (.conj! tcoll val)) - - (-persistent! [tcoll] (.persistent! tcoll)) - - ITransientAssociative - (-assoc! [tcoll key val] (.assoc! tcoll key val)) - - ITransientMap - (-dissoc! [tcoll key] (.without! tcoll key))) - -;;; PersistentTreeMap - -(defn- tree-map-seq-push [node stack ^boolean ascending?] - (loop [t node stack stack] - (if-not (nil? t) - (recur (if ascending? (.-left t) (.-right t)) - (conj stack t)) - stack))) - -(deftype PersistentTreeMapSeq [meta stack ^boolean ascending? cnt ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ISeqable - (-seq [this] this) - - ISequential - ISeq - (-first [this] (peek stack)) - (-rest [this] - (let [t (first stack) - next-stack (tree-map-seq-push (if ascending? (.-right t) (.-left t)) - (next stack) - ascending?)] - (if-not (nil? next-stack) - (PersistentTreeMapSeq. nil next-stack ascending? (dec cnt) nil) - ()))) - - ICounted - (-count [coll] - (if (neg? cnt) - (inc (count (next coll))) - cnt)) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) meta)) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] - (PersistentTreeMapSeq. meta stack ascending? cnt __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable PersistentTreeMapSeq) - -(defn- create-tree-map-seq [tree ascending? cnt] - (PersistentTreeMapSeq. nil (tree-map-seq-push tree nil ascending?) ascending? cnt nil)) - -(declare RedNode BlackNode) - -(defn- balance-left [key val ins right] - (if (instance? RedNode ins) - (cond - (instance? RedNode (.-left ins)) - (RedNode. (.-key ins) (.-val ins) - (.blacken (.-left ins)) - (BlackNode. key val (.-right ins) right nil) - nil) - - (instance? RedNode (.-right ins)) - (RedNode. (.. ins -right -key) (.. ins -right -val) - (BlackNode. (.-key ins) (.-val ins) - (.-left ins) - (.. ins -right -left) - nil) - (BlackNode. key val - (.. ins -right -right) - right - nil) - nil) - - :else - (BlackNode. key val ins right nil)) - (BlackNode. key val ins right nil))) - -(defn- balance-right [key val left ins] - (if (instance? RedNode ins) - (cond - (instance? RedNode (.-right ins)) - (RedNode. (.-key ins) (.-val ins) - (BlackNode. key val left (.-left ins) nil) - (.blacken (.-right ins)) - nil) - - (instance? RedNode (.-left ins)) - (RedNode. (.. ins -left -key) (.. ins -left -val) - (BlackNode. key val left (.. ins -left -left) nil) - (BlackNode. (.-key ins) (.-val ins) - (.. ins -left -right) - (.-right ins) - nil) - nil) - - :else - (BlackNode. key val left ins nil)) - (BlackNode. key val left ins nil))) - -(defn- balance-left-del [key val del right] - (cond - (instance? RedNode del) - (RedNode. key val (.blacken del) right nil) - - (instance? BlackNode right) - (balance-right key val del (.redden right)) - - (and (instance? RedNode right) (instance? BlackNode (.-left right))) - (RedNode. (.. right -left -key) (.. right -left -val) - (BlackNode. key val del (.. right -left -left) nil) - (balance-right (.-key right) (.-val right) - (.. right -left -right) - (.redden (.-right right))) - nil) - - :else - (throw (js/Error. "red-black tree invariant violation")))) - -(defn- balance-right-del [key val left del] - (cond - (instance? RedNode del) - (RedNode. key val left (.blacken del) nil) - - (instance? BlackNode left) - (balance-left key val (.redden left) del) - - (and (instance? RedNode left) (instance? BlackNode (.-right left))) - (RedNode. (.. left -right -key) (.. left -right -val) - (balance-left (.-key left) (.-val left) - (.redden (.-left left)) - (.. left -right -left)) - (BlackNode. key val (.. left -right -right) del nil) - nil) - - :else - (throw (js/Error. "red-black tree invariant violation")))) - -(defn- tree-map-kv-reduce [node f init] - (let [init (if-not (nil? (.-left node)) - (tree-map-kv-reduce (.-left node) f init) - init)] - (if (reduced? init) - @init - (let [init (f init (.-key node) (.-val node))] - (if (reduced? init) - @init - (let [init (if-not (nil? (.-right node)) - (tree-map-kv-reduce (.-right node) f init) - init)] - (if (reduced? init) - @init - init))))))) - -(deftype BlackNode [key val left right ^:mutable __hash] - Object - (add-left [node ins] - (.balance-left ins node)) - - (add-right [node ins] - (.balance-right ins node)) - - (remove-left [node del] - (balance-left-del key val del right)) - - (remove-right [node del] - (balance-right-del key val left del)) - - (blacken [node] node) - - (redden [node] (RedNode. key val left right nil)) - - (balance-left [node parent] - (BlackNode. (.-key parent) (.-val parent) node (.-right parent) nil)) - - (balance-right [node parent] - (BlackNode. (.-key parent) (.-val parent) (.-left parent) node nil)) - - (replace [node key val left right] - (BlackNode. key val left right nil)) - - (kv-reduce [node f init] - (tree-map-kv-reduce node f init)) - - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMapEntry - (-key [node] key) - (-val [node] val) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IMeta - (-meta [node] nil) - - IWithMeta - (-with-meta [node meta] - (with-meta [key val] meta)) - - IStack - (-peek [node] val) - - (-pop [node] [key]) - - ICollection - (-conj [node o] [key val o]) - - IEmptyableCollection - (-empty [node] []) - - ISequential - ISeqable - (-seq [node] (list key val)) - - ICounted - (-count [node] 2) - - IIndexed - (-nth [node n] - (cond (== n 0) key - (== n 1) val - :else nil)) - - (-nth [node n not-found] - (cond (== n 0) key - (== n 1) val - :else not-found)) - - ILookup - (-lookup [node k] (-nth node k nil)) - (-lookup [node k not-found] (-nth node k not-found)) - - IAssociative - (-assoc [node k v] - (assoc [key val] k v)) - - IVector - (-assoc-n [node n v] - (-assoc-n [key val] n v)) - - IReduce - (-reduce [node f] - (ci-reduce node f)) - - (-reduce [node f start] - (ci-reduce node f start)) - - IFn - (-invoke [node k] - (-lookup node k)) - - (-invoke [node k not-found] - (-lookup node k not-found))) - -(es6-iterable BlackNode) - -(deftype RedNode [key val left right ^:mutable __hash] - Object - (add-left [node ins] - (RedNode. key val ins right nil)) - - (add-right [node ins] - (RedNode. key val left ins nil)) - - (remove-left [node del] - (RedNode. key val del right nil)) - - (remove-right [node del] - (RedNode. key val left del nil)) - - (blacken [node] - (BlackNode. key val left right nil)) - - (redden [node] - (throw (js/Error. "red-black tree invariant violation"))) - - (balance-left [node parent] - (cond - (instance? RedNode left) - (RedNode. key val - (.blacken left) - (BlackNode. (.-key parent) (.-val parent) right (.-right parent) nil) - nil) - - (instance? RedNode right) - (RedNode. (.-key right) (.-val right) - (BlackNode. key val left (.-left right) nil) - (BlackNode. (.-key parent) (.-val parent) - (.-right right) - (.-right parent) - nil) - nil) - - :else - (BlackNode. (.-key parent) (.-val parent) node (.-right parent) nil))) - - (balance-right [node parent] - (cond - (instance? RedNode right) - (RedNode. key val - (BlackNode. (.-key parent) (.-val parent) - (.-left parent) - left - nil) - (.blacken right) - nil) - - (instance? RedNode left) - (RedNode. (.-key left) (.-val left) - (BlackNode. (.-key parent) (.-val parent) - (.-left parent) - (.-left left) - nil) - (BlackNode. key val (.-right left) right nil) - nil) - - :else - (BlackNode. (.-key parent) (.-val parent) (.-left parent) node nil))) - - (replace [node key val left right] - (RedNode. key val left right nil)) - - (kv-reduce [node f init] - (tree-map-kv-reduce node f init)) - - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMapEntry - (-key [node] key) - (-val [node] val) - - IHash - (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IMeta - (-meta [node] nil) - - IWithMeta - (-with-meta [node meta] - (with-meta [key val] meta)) - - IStack - (-peek [node] val) - - (-pop [node] [key]) - - ICollection - (-conj [node o] [key val o]) - - IEmptyableCollection - (-empty [node] []) - - ISequential - ISeqable - (-seq [node] (list key val)) - - ICounted - (-count [node] 2) - - IIndexed - (-nth [node n] - (cond (== n 0) key - (== n 1) val - :else nil)) - - (-nth [node n not-found] - (cond (== n 0) key - (== n 1) val - :else not-found)) - - ILookup - (-lookup [node k] (-nth node k nil)) - (-lookup [node k not-found] (-nth node k not-found)) - - IAssociative - (-assoc [node k v] - (assoc [key val] k v)) - - IVector - (-assoc-n [node n v] - (-assoc-n [key val] n v)) - - IReduce - (-reduce [node f] - (ci-reduce node f)) - - (-reduce [node f start] - (ci-reduce node f start)) - - IFn - (-invoke [node k] - (-lookup node k)) - - (-invoke [node k not-found] - (-lookup node k not-found))) - -(es6-iterable RedNode) - -(defn- tree-map-add [comp tree k v found] - (if (nil? tree) - (RedNode. k v nil nil nil) - (let [c (comp k (.-key tree))] - (cond - (zero? c) - (do (aset found 0 tree) - nil) - - (neg? c) - (let [ins (tree-map-add comp (.-left tree) k v found)] - (if-not (nil? ins) - (.add-left tree ins))) - - :else - (let [ins (tree-map-add comp (.-right tree) k v found)] - (if-not (nil? ins) - (.add-right tree ins))))))) - -(defn- tree-map-append [left right] - (cond - (nil? left) - right - - (nil? right) - left - - (instance? RedNode left) - (if (instance? RedNode right) - (let [app (tree-map-append (.-right left) (.-left right))] - (if (instance? RedNode app) - (RedNode. (.-key app) (.-val app) - (RedNode. (.-key left) (.-val left) - (.-left left) - (.-left app) - nil) - (RedNode. (.-key right) (.-val right) - (.-right app) - (.-right right) - nil) - nil) - (RedNode. (.-key left) (.-val left) - (.-left left) - (RedNode. (.-key right) (.-val right) app (.-right right) nil) - nil))) - (RedNode. (.-key left) (.-val left) - (.-left left) - (tree-map-append (.-right left) right) - nil)) - - (instance? RedNode right) - (RedNode. (.-key right) (.-val right) - (tree-map-append left (.-left right)) - (.-right right) - nil) - - :else - (let [app (tree-map-append (.-right left) (.-left right))] - (if (instance? RedNode app) - (RedNode. (.-key app) (.-val app) - (BlackNode. (.-key left) (.-val left) - (.-left left) - (.-left app) - nil) - (BlackNode. (.-key right) (.-val right) - (.-right app) - (.-right right) - nil) - nil) - (balance-left-del (.-key left) (.-val left) - (.-left left) - (BlackNode. (.-key right) (.-val right) - app - (.-right right) - nil)))))) - -(defn- tree-map-remove [comp tree k found] - (if-not (nil? tree) - (let [c (comp k (.-key tree))] - (cond - (zero? c) - (do (aset found 0 tree) - (tree-map-append (.-left tree) (.-right tree))) - - (neg? c) - (let [del (tree-map-remove comp (.-left tree) k found)] - (if (or (not (nil? del)) (not (nil? (aget found 0)))) - (if (instance? BlackNode (.-left tree)) - (balance-left-del (.-key tree) (.-val tree) del (.-right tree)) - (RedNode. (.-key tree) (.-val tree) del (.-right tree) nil)))) - - :else - (let [del (tree-map-remove comp (.-right tree) k found)] - (if (or (not (nil? del)) (not (nil? (aget found 0)))) - (if (instance? BlackNode (.-right tree)) - (balance-right-del (.-key tree) (.-val tree) (.-left tree) del) - (RedNode. (.-key tree) (.-val tree) (.-left tree) del nil)))))))) - -(defn- tree-map-replace [comp tree k v] - (let [tk (.-key tree) - c (comp k tk)] - (cond (zero? c) (.replace tree tk v (.-left tree) (.-right tree)) - (neg? c) (.replace tree tk (.-val tree) (tree-map-replace comp (.-left tree) k v) (.-right tree)) - :else (.replace tree tk (.-val tree) (.-left tree) (tree-map-replace comp (.-right tree) k v))))) - -(declare key) - -(deftype PersistentTreeMap [comp tree cnt meta ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - ;; EXPERIMENTAL: subject to change - (keys [coll] - (es6-iterator (keys coll))) - (entries [coll] - (es6-entries-iterator (seq coll))) - (values [coll] - (es6-iterator (vals coll))) - (has [coll k] - (contains? coll k)) - (get [coll k not-found] - (-lookup coll k not-found)) - (forEach [coll f] - (doseq [[k v] coll] - (f v k))) - - (entry-at [coll k] - (loop [t tree] - (if-not (nil? t) - (let [c (comp k (.-key t))] - (cond (zero? c) t - (neg? c) (recur (.-left t)) - :else (recur (.-right t))))))) - - ICloneable - (-clone [_] (PersistentTreeMap. comp tree cnt meta __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentTreeMap. comp tree cnt meta __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll entry] - (if (vector? entry) - (-assoc coll (-nth entry 0) (-nth entry 1)) - (loop [ret coll es (seq entry)] - (if (nil? es) - ret - (let [e (first es)] - (if (vector? e) - (recur (-assoc ret (-nth e 0) (-nth e 1)) - (next es)) - (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) - - IEmptyableCollection - (-empty [coll] (PersistentTreeMap. comp nil 0 meta 0)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - ICounted - (-count [coll] cnt) - - IKVReduce - (-kv-reduce [coll f init] - (if-not (nil? tree) - (tree-map-kv-reduce tree f init) - init)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - - (-invoke [coll k not-found] - (-lookup coll k not-found)) - - ISeqable - (-seq [coll] - (if (pos? cnt) - (create-tree-map-seq tree true cnt))) - - IReversible - (-rseq [coll] - (if (pos? cnt) - (create-tree-map-seq tree false cnt))) - - ILookup - (-lookup [coll k] - (-lookup coll k nil)) - - (-lookup [coll k not-found] - (let [n (.entry-at coll k)] - (if-not (nil? n) - (.-val n) - not-found))) - - IAssociative - (-assoc [coll k v] - (let [found (array nil) - t (tree-map-add comp tree k v found)] - (if (nil? t) - (let [found-node (nth found 0)] - (if (= v (.-val found-node)) - coll - (PersistentTreeMap. comp (tree-map-replace comp tree k v) cnt meta nil))) - (PersistentTreeMap. comp (.blacken t) (inc cnt) meta nil)))) - - (-contains-key? [coll k] - (not (nil? (.entry-at coll k)))) - - IMap - (-dissoc [coll k] - (let [found (array nil) - t (tree-map-remove comp tree k found)] - (if (nil? t) - (if (nil? (nth found 0)) - coll - (PersistentTreeMap. comp nil 0 meta nil)) - (PersistentTreeMap. comp (.blacken t) (dec cnt) meta nil)))) - - ISorted - (-sorted-seq [coll ascending?] - (if (pos? cnt) - (create-tree-map-seq tree ascending? cnt))) - - (-sorted-seq-from [coll k ascending?] - (if (pos? cnt) - (loop [stack nil t tree] - (if-not (nil? t) - (let [c (comp k (.-key t))] - (cond - (zero? c) (PersistentTreeMapSeq. nil (conj stack t) ascending? -1 nil) - ascending? (if (neg? c) - (recur (conj stack t) (.-left t)) - (recur stack (.-right t))) - :else (if (pos? c) - (recur (conj stack t) (.-right t)) - (recur stack (.-left t))))) - (when-not (nil? stack) - (PersistentTreeMapSeq. nil stack ascending? -1 nil)))))) - - (-entry-key [coll entry] (key entry)) - - (-comparator [coll] comp)) - -(set! (.-EMPTY PersistentTreeMap) (PersistentTreeMap. compare nil 0 nil empty-unordered-hash)) - -(es6-iterable PersistentTreeMap) - -(defn hash-map - "keyval => key val - Returns a new hash map with supplied mappings." - [& keyvals] - (loop [in (seq keyvals), out (transient (.-EMPTY PersistentHashMap))] - (if in - (recur (nnext in) (assoc! out (first in) (second in))) - (persistent! out)))) - -(defn array-map - "keyval => key val - Returns a new array map with supplied mappings." - [& keyvals] - (let [arr (if (and (instance? IndexedSeq keyvals) (zero? (.-i keyvals))) - (.-arr keyvals) - (into-array keyvals))] - (.createAsIfByAssoc PersistentArrayMap arr true false))) - -(defn obj-map - "keyval => key val - Returns a new object map with supplied mappings." - [& keyvals] - (let [ks (array) - obj (js-obj)] - (loop [kvs (seq keyvals)] - (if kvs - (do (.push ks (first kvs)) - (aset obj (first kvs) (second kvs)) - (recur (nnext kvs))) - (.fromObject ObjMap ks obj))))) - -(defn sorted-map - "keyval => key val - Returns a new sorted map with supplied mappings." - ([& keyvals] - (loop [in (seq keyvals) out (.-EMPTY PersistentTreeMap)] - (if in - (recur (nnext in) (assoc out (first in) (second in))) - out)))) - -(defn sorted-map-by - "keyval => key val - Returns a new sorted map with supplied mappings, using the supplied comparator." - ([comparator & keyvals] - (loop [in (seq keyvals) - out (PersistentTreeMap. (fn->comparator comparator) nil 0 nil 0)] - (if in - (recur (nnext in) (assoc out (first in) (second in))) - out)))) - -(deftype KeySeq [^not-native mseq _meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] (KeySeq. mseq new-meta)) - - ISeqable - (-seq [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) _meta)) - - IHash - (-hash [coll] (hash-ordered-coll coll)) - - ISeq - (-first [coll] - (let [^not-native me (-first mseq)] - (-key me))) - - (-rest [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (if-not (nil? nseq) - (KeySeq. nseq _meta) - ()))) - - INext - (-next [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (when-not (nil? nseq) - (KeySeq. nseq _meta)))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable KeySeq) - -(defn keys - "Returns a sequence of the map's keys." - [hash-map] - (when-let [mseq (seq hash-map)] - (KeySeq. mseq nil))) - -(defn key - "Returns the key of the map entry." - [map-entry] - (-key map-entry)) - -(deftype ValSeq [^not-native mseq _meta] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] (ValSeq. mseq new-meta)) - - ISeqable - (-seq [coll] coll) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY List) _meta)) - - IHash - (-hash [coll] (hash-ordered-coll coll)) - - ISeq - (-first [coll] - (let [^not-native me (-first mseq)] - (-val me))) - - (-rest [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (if-not (nil? nseq) - (ValSeq. nseq _meta) - ()))) - - INext - (-next [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (when-not (nil? nseq) - (ValSeq. nseq _meta)))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(es6-iterable ValSeq) - -(defn vals - "Returns a sequence of the map's values." - [hash-map] - (when-let [mseq (seq hash-map)] - (ValSeq. mseq nil))) - -(defn val - "Returns the value in the map entry." - [map-entry] - (-val map-entry)) - -(defn merge - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping from - the latter (left-to-right) will be the mapping in the result." - [& maps] - (when (some identity maps) - (reduce #(conj (or %1 {}) %2) maps))) - -(defn merge-with - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping(s) - from the latter (left-to-right) will be combined with the mapping in - the result by calling (f val-in-result val-in-latter)." - [f & maps] - (when (some identity maps) - (let [merge-entry (fn [m e] - (let [k (first e) v (second e)] - (if (contains? m k) - (assoc m k (f (get m k) v)) - (assoc m k v)))) - merge2 (fn [m1 m2] - (reduce merge-entry (or m1 {}) (seq m2)))] - (reduce merge2 maps)))) - -(defn select-keys - "Returns a map containing only those entries in map whose key is in keys" - [map keyseq] - (loop [ret {} keys (seq keyseq)] - (if keys - (let [key (first keys) - entry (get map key ::not-found)] - (recur - (if (not= entry ::not-found) - (assoc ret key entry) - ret) - (next keys))) - (with-meta ret (meta map))))) - -;;; PersistentHashSet - -(declare TransientHashSet) - -(deftype HashSetIter [iter] - Object - (hasNext [_] - (.hasNext iter)) - (next [_] - (if ^boolean (.hasNext iter) - (aget (.-tail (.next iter)) 0) - (throw (js/Error. "No such element")))) - (remove [_] (js/Error. "Unsupported operation"))) - -(deftype PersistentHashSet [meta hash-map ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - ;; EXPERIMENTAL: subject to change - (keys [coll] - (es6-iterator (seq coll))) - (entries [coll] - (es6-set-entries-iterator (seq coll))) - (values [coll] - (es6-iterator (seq coll))) - (has [coll k] - (contains? coll k)) - (forEach [coll f] - (doseq [[k v] coll] - (f v k))) - - ICloneable - (-clone [_] (PersistentHashSet. meta hash-map __hash)) - - IIterable - (-iterator [coll] - (HashSetIter. (-iterator hash-map))) - - IWithMeta - (-with-meta [coll meta] (PersistentHashSet. meta hash-map __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll o] - (PersistentHashSet. meta (assoc hash-map o nil) nil)) - - IEmptyableCollection - (-empty [coll] (with-meta (.-EMPTY PersistentHashSet) meta)) - - IEquiv - (-equiv [coll other] - (and - (set? other) - (== (count coll) (count other)) - (every? #(contains? coll %) - other))) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - ISeqable - (-seq [coll] (keys hash-map)) - - ICounted - (-count [coll] (-count hash-map)) - - ILookup - (-lookup [coll v] - (-lookup coll v nil)) - (-lookup [coll v not-found] - (if (-contains-key? hash-map v) - v - not-found)) - - ISet - (-disjoin [coll v] - (PersistentHashSet. meta (-dissoc hash-map v) nil)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - (-invoke [coll k not-found] - (-lookup coll k not-found)) - - IEditableCollection - (-as-transient [coll] (TransientHashSet. (-as-transient hash-map)))) - -(set! (.-EMPTY PersistentHashSet) - (PersistentHashSet. nil (.-EMPTY PersistentArrayMap) empty-unordered-hash)) - -(set! (.-fromArray PersistentHashSet) - (fn [items ^boolean no-clone] - (let [len (alength items)] - (if (<= len (.-HASHMAP-THRESHOLD PersistentArrayMap)) - (let [arr (if no-clone items (aclone items))] - (loop [i 0 - out (transient (.-EMPTY PersistentArrayMap))] - (if (< i len) - (recur (inc i) (-assoc! out (aget items i) nil)) - (PersistentHashSet. nil (-persistent! out) nil)))) - (loop [i 0 - out (transient (.-EMPTY PersistentHashSet))] - (if (< i len) - (recur (inc i) (-conj! out (aget items i))) - (-persistent! out))))))) - -(set! (.-createWithCheck PersistentHashSet) - (fn [items] - (let [len (alength items) - t (-as-transient (.-EMPTY PersistentHashSet))] - (dotimes [i len] - (-conj! t (aget items i)) - (when-not (= (count t) (inc i)) - (throw (js/Error. (str "Duplicate key: " (aget items i)))))) - (-persistent! t)))) - -(set! (.-createAsIfByAssoc PersistentHashSet) - (fn [items] - (let [len (alength items) - t (-as-transient (.-EMPTY PersistentHashSet))] - (dotimes [i len] (-conj! t (aget items i))) - (-persistent! t)))) - -(es6-iterable PersistentHashSet) - -(deftype TransientHashSet [^:mutable transient-map] - ITransientCollection - (-conj! [tcoll o] - (set! transient-map (assoc! transient-map o nil)) - tcoll) - - (-persistent! [tcoll] - (PersistentHashSet. nil (persistent! transient-map) nil)) - - ITransientSet - (-disjoin! [tcoll v] - (set! transient-map (dissoc! transient-map v)) - tcoll) - - ICounted - (-count [tcoll] (count transient-map)) - - ILookup - (-lookup [tcoll v] - (-lookup tcoll v nil)) - - (-lookup [tcoll v not-found] - (if (identical? (-lookup transient-map v lookup-sentinel) lookup-sentinel) - not-found - v)) - - IFn - (-invoke [tcoll k] - (if (identical? (-lookup transient-map k lookup-sentinel) lookup-sentinel) - nil - k)) - - (-invoke [tcoll k not-found] - (if (identical? (-lookup transient-map k lookup-sentinel) lookup-sentinel) - not-found - k))) - -(deftype PersistentTreeSet [meta tree-map ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - - ;; EXPERIMENTAL: subject to change - (keys [coll] - (es6-iterator (seq coll))) - (entries [coll] - (es6-set-entries-iterator (seq coll))) - (values [coll] - (es6-iterator (seq coll))) - (has [coll k] - (contains? coll k)) - (forEach [coll f] - (doseq [[k v] coll] - (f v k))) - - ICloneable - (-clone [_] (PersistentTreeSet. meta tree-map __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentTreeSet. meta tree-map __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll o] - (PersistentTreeSet. meta (assoc tree-map o nil) nil)) - - IEmptyableCollection - (-empty [coll] (PersistentTreeSet. meta (-empty tree-map) 0)) - - IEquiv - (-equiv [coll other] - (and - (set? other) - (== (count coll) (count other)) - (every? #(contains? coll %) - other))) - - IHash - (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) - - ISeqable - (-seq [coll] (keys tree-map)) - - ISorted - (-sorted-seq [coll ascending?] - (map key (-sorted-seq tree-map ascending?))) - - (-sorted-seq-from [coll k ascending?] - (map key (-sorted-seq-from tree-map k ascending?))) - - (-entry-key [coll entry] entry) - - (-comparator [coll] (-comparator tree-map)) - - IReversible - (-rseq [coll] - (if (pos? (count tree-map)) - (map key (rseq tree-map)))) - - ICounted - (-count [coll] (count tree-map)) - - ILookup - (-lookup [coll v] - (-lookup coll v nil)) - (-lookup [coll v not-found] - (let [n (.entry-at tree-map v)] - (if-not (nil? n) - (.-key n) - not-found))) - - ISet - (-disjoin [coll v] - (PersistentTreeSet. meta (dissoc tree-map v) nil)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - (-invoke [coll k not-found] - (-lookup coll k not-found))) - -(set! (.-EMPTY PersistentTreeSet) - (PersistentTreeSet. nil (.-EMPTY PersistentTreeMap) empty-unordered-hash)) - -(es6-iterable PersistentTreeSet) - -(defn set-from-indexed-seq [iseq] - (let [arr (.-arr iseq) - ret (areduce arr i ^not-native res (-as-transient #{}) - (-conj! res (aget arr i)))] - (-persistent! ^not-native ret))) - -(defn set - "Returns a set of the distinct elements of coll." - [coll] - (let [in (seq coll)] - (cond - (nil? in) #{} - - (and (instance? IndexedSeq in) (zero? (.-i in))) - (.createAsIfByAssoc PersistentHashSet (.-arr in)) - - :else - (loop [^not-native in in - ^not-native out (-as-transient #{})] - (if-not (nil? in) - (recur (next in) (-conj! out (-first in))) - (persistent! out)))))) - -(defn hash-set - "Returns a new hash set with supplied keys. Any equal keys are - handled as if by repeated uses of conj." - ([] #{}) - ([& keys] (set keys))) - -(defn sorted-set - "Returns a new sorted set with supplied keys." - ([& keys] - (reduce -conj (.-EMPTY PersistentTreeSet) keys))) - -(defn sorted-set-by - "Returns a new sorted set with supplied keys, using the supplied comparator." - ([comparator & keys] - (reduce -conj - (PersistentTreeSet. nil (sorted-map-by comparator) 0) - keys))) - -(defn replace - "Given a map of replacement pairs and a vector/collection, returns a - vector/seq with any elements = a key in smap replaced with the - corresponding val in smap. Returns a transducer when no collection - is provided." - ([smap] - (map #(if-let [e (find smap %)] (val e) %))) - ([smap coll] - (if (vector? coll) - (let [n (count coll)] - (reduce (fn [v i] - (if-let [e (find smap (nth v i))] - (assoc v i (second e)) - v)) - coll (take n (iterate inc 0)))) - (map #(if-let [e (find smap %)] (second e) %) coll)))) - -(defn distinct - "Returns a lazy sequence of the elements of coll with duplicates removed. - Returns a stateful transducer when no collection is provided." - ([] - (fn [rf] - (let [seen (volatile! #{})] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (contains? @seen input) - result - (do (vswap! seen conj input) - (rf result input)))))))) - ([coll] - (let [step (fn step [xs seen] - (lazy-seq - ((fn [[f :as xs] seen] - (when-let [s (seq xs)] - (if (contains? seen f) - (recur (rest s) seen) - (cons f (step (rest s) (conj seen f)))))) - xs seen)))] - (step coll #{})))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn butlast - "Return a seq of all but the last item in coll, in linear time" - [s] - (loop [ret [] s s] - (if (next s) - (recur (conj ret (first s)) (next s)) - (seq ret)))) - -(defn name - "Returns the name String of a string, symbol or keyword." - [x] - (if (implements? INamed x) - (-name ^not-native x) - (if (string? x) - x - (throw (js/Error. (str "Doesn't support name: " x)))))) - -(defn zipmap - "Returns a map with the keys mapped to the corresponding vals." - [keys vals] - (loop [map (transient {}) - ks (seq keys) - vs (seq vals)] - (if (and ks vs) - (recur (assoc! map (first ks) (first vs)) - (next ks) - (next vs)) - (persistent! map)))) - -(defn max-key - "Returns the x for which (k x), a number, is greatest." - ([k x] x) - ([k x y] (if (> (k x) (k y)) x y)) - ([k x y & more] - (reduce #(max-key k %1 %2) (max-key k x y) more))) - -(defn min-key - "Returns the x for which (k x), a number, is least." - ([k x] x) - ([k x y] (if (< (k x) (k y)) x y)) - ([k x y & more] - (reduce #(min-key k %1 %2) (min-key k x y) more))) - -(deftype ArrayList [^:mutable arr] - Object - (add [_ x] (.push arr x)) - (size [_] (alength arr)) - (clear [_] (set! arr (array))) - (isEmpty [_] (zero? (alength arr))) - (toArray [_] arr)) - -(defn array-list [] - (ArrayList. (array))) - -(defn partition-all - "Returns a lazy sequence of lists like partition, but may include - partitions with fewer than n items at the end. Returns a stateful - transducer when no collection is provided." - ([n] - (fn [rf] - (let [a (array-list)] - (fn - ([] (rf)) - ([result] - (let [result (if (.isEmpty a) - result - (let [v (vec (.toArray a))] - ;;clear first! - (.clear a) - (unreduced (rf result v))))] - (rf result))) - ([result input] - (.add a input) - (if (== n (.size a)) - (let [v (vec (.toArray a))] - (.clear a) - (rf result v)) - result)))))) - ([n coll] - (partition-all n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (cons (take n s) (partition-all n step (drop step s))))))) - -(defn take-while - "Returns a lazy sequence of successive items from coll while - (pred item) returns true. pred must be free of side-effects. - Returns a transducer when no collection is provided." - ([pred] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (pred input) - (rf result input) - (reduced result)))))) - ([pred coll] - (lazy-seq - (when-let [s (seq coll)] - (when (pred (first s)) - (cons (first s) (take-while pred (rest s)))))))) - -(defn mk-bound-fn - [sc test key] - (fn [e] - (let [comp (-comparator sc)] - (test (comp (-entry-key sc e) key) 0)))) - -(defn subseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - ([sc test key] - (let [include (mk-bound-fn sc test key)] - (if (#{> >=} test) - (when-let [[e :as s] (-sorted-seq-from sc key true)] - (if (include e) s (next s))) - (take-while include (-sorted-seq sc true))))) - ([sc start-test start-key end-test end-key] - (when-let [[e :as s] (-sorted-seq-from sc start-key true)] - (take-while (mk-bound-fn sc end-test end-key) - (if ((mk-bound-fn sc start-test start-key) e) s (next s)))))) - -(defn rsubseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a reverse seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - ([sc test key] - (let [include (mk-bound-fn sc test key)] - (if (#{< <=} test) - (when-let [[e :as s] (-sorted-seq-from sc key false)] - (if (include e) s (next s))) - (take-while include (-sorted-seq sc false))))) - ([sc start-test start-key end-test end-key] - (when-let [[e :as s] (-sorted-seq-from sc end-key false)] - (take-while (mk-bound-fn sc start-test start-key) - (if ((mk-bound-fn sc end-test end-key) e) s (next s)))))) - -(deftype RangeIterator [^:mutable i end step] - Object - (hasNext [_] - (if (pos? step) - (< i end) - (> i end))) - (next [_] - (let [ret i] - (set! i (+ i step)) - ret))) - -(deftype Range [meta start end step ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - (equiv [this other] - (-equiv this other)) - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ICloneable - (-clone [_] (Range. meta start end step __hash)) - - IWithMeta - (-with-meta [rng meta] (Range. meta start end step __hash)) - - IMeta - (-meta [rng] meta) - - ISeqable - (-seq [rng] - (cond - (pos? step) (when (< start end) rng) - (neg? step) (when (> start end) rng) - :else (when-not (== start end) rng))) - - ISeq - (-first [rng] - (when-not (nil? (-seq rng)) start)) - (-rest [rng] - (if-not (nil? (-seq rng)) - (Range. meta (+ start step) end step nil) - ())) - - IIterable - (-iterator [_] - (RangeIterator. start end step)) - - INext - (-next [rng] - (if (pos? step) - (when (< (+ start step) end) - (Range. meta (+ start step) end step nil)) - (when (> (+ start step) end) - (Range. meta (+ start step) end step nil)))) - - ICollection - (-conj [rng o] (cons o rng)) - - IEmptyableCollection - (-empty [rng] (with-meta (.-EMPTY List) meta)) - - ISequential - IEquiv - (-equiv [rng other] (equiv-sequential rng other)) - - IHash - (-hash [rng] (caching-hash rng hash-ordered-coll __hash)) - - ICounted - (-count [rng] - (if-not (-seq rng) - 0 - (Math/ceil (/ (- end start) step)))) - - IIndexed - (-nth [rng n] - (if (< n (-count rng)) - (+ start (* n step)) - (if (and (> start end) (zero? step)) - start - (throw (js/Error. "Index out of bounds"))))) - (-nth [rng n not-found] - (if (< n (-count rng)) - (+ start (* n step)) - (if (and (> start end) (zero? step)) - start - not-found))) - - IReduce - (-reduce [rng f] (ci-reduce rng f)) - (-reduce [rng f init] - (loop [i start ret init] - (if (if (pos? step) (< i end) (> i end)) - (let [ret (f ret i)] - (if (reduced? ret) - @ret - (recur (+ i step) ret))) - ret)))) - -(es6-iterable Range) - -(defn range - "Returns a lazy seq of nums from start (inclusive) to end - (exclusive), by step, where start defaults to 0, step to 1, - and end to infinity." - ([] (range 0 (.-MAX_VALUE js/Number) 1)) - ([end] (range 0 end 1)) - ([start end] (range start end 1)) - ([start end step] (Range. nil start end step nil))) - -(defn take-nth - "Returns a lazy seq of every nth item in coll. Returns a stateful - transducer when no collection is provided." - ([n] - {:pre [(number? n)]} - (fn [rf] - (let [ia (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [i (vswap! ia inc)] - (if (zero? (rem i n)) - (rf result input) - result))))))) - ([n coll] - {:pre [(number? n)]} - (lazy-seq - (when-let [s (seq coll)] - (cons (first s) (take-nth n (drop n s))))))) - -(defn split-with - "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" - [pred coll] - [(take-while pred coll) (drop-while pred coll)]) - -(defn partition-by - "Applies f to each value in coll, splitting it each time f returns a - new value. Returns a lazy seq of partitions. Returns a stateful - transducer when no collection is provided." - ([f] - (fn [rf] - (let [a (array-list) - pa (volatile! ::none)] - (fn - ([] (rf)) - ([result] - (let [result (if (.isEmpty a) - result - (let [v (vec (.toArray a))] - ;;clear first! - (.clear a) - (unreduced (rf result v))))] - (rf result))) - ([result input] - (let [pval @pa - val (f input)] - (vreset! pa val) - (if (or (keyword-identical? pval ::none) - (= val pval)) - (do - (.add a input) - result) - (let [v (vec (.toArray a))] - (.clear a) - (let [ret (rf result v)] - (when-not (reduced? ret) - (.add a input)) - ret))))))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (let [fst (first s) - fv (f fst) - run (cons fst (take-while #(= fv (f %)) (next s)))] - (cons run (partition-by f (seq (drop (count run) s))))))))) - -(defn frequencies - "Returns a map from distinct items in coll to the number of times - they appear." - [coll] - (persistent! - (reduce (fn [counts x] - (assoc! counts x (inc (get counts x 0)))) - (transient {}) coll))) - -(defn reductions - "Returns a lazy seq of the intermediate values of the reduction (as - per reduce) of coll by f, starting with init." - ([f coll] - (lazy-seq - (if-let [s (seq coll)] - (reductions f (first s) (rest s)) - (list (f))))) - ([f init coll] - (if (reduced? init) - (list @init) - (cons init - (lazy-seq - (when-let [s (seq coll)] - (reductions f (f init (first s)) (rest s)))))))) - -(defn juxt - "Takes a set of functions and returns a fn that is the juxtaposition - of those fns. The returned fn takes a variable number of args, and - returns a vector containing the result of applying each fn to the - args (left-to-right). - ((juxt a b c) x) => [(a x) (b x) (c x)]" - ([f] - (fn - ([] (vector (f))) - ([x] (vector (f x))) - ([x y] (vector (f x y))) - ([x y z] (vector (f x y z))) - ([x y z & args] (vector (apply f x y z args))))) - ([f g] - (fn - ([] (vector (f) (g))) - ([x] (vector (f x) (g x))) - ([x y] (vector (f x y) (g x y))) - ([x y z] (vector (f x y z) (g x y z))) - ([x y z & args] (vector (apply f x y z args) (apply g x y z args))))) - ([f g h] - (fn - ([] (vector (f) (g) (h))) - ([x] (vector (f x) (g x) (h x))) - ([x y] (vector (f x y) (g x y) (h x y))) - ([x y z] (vector (f x y z) (g x y z) (h x y z))) - ([x y z & args] (vector (apply f x y z args) (apply g x y z args) (apply h x y z args))))) - ([f g h & fs] - (let [fs (list* f g h fs)] - (fn - ([] (reduce #(conj %1 (%2)) [] fs)) - ([x] (reduce #(conj %1 (%2 x)) [] fs)) - ([x y] (reduce #(conj %1 (%2 x y)) [] fs)) - ([x y z] (reduce #(conj %1 (%2 x y z)) [] fs)) - ([x y z & args] (reduce #(conj %1 (apply %2 x y z args)) [] fs)))))) - -(defn dorun - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. dorun can - be used to force any effects. Walks through the successive nexts of - the seq, does not retain the head and returns nil." - ([coll] - (when (seq coll) - (recur (next coll)))) - ([n coll] - (when (and (seq coll) (pos? n)) - (recur (dec n) (next coll))))) - -(defn doall - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. doall can - be used to force any effects. Walks through the successive nexts of - the seq, retains the head and returns it, thus causing the entire - seq to reside in memory at one time." - ([coll] - (dorun coll) - coll) - ([n coll] - (dorun n coll) - coll)) - -;;;;;;;;;;;;;;;;;;;;;;;;; Regular Expressions ;;;;;;;;;; - -(defn ^boolean regexp? - "Returns true if x is a JavaScript RegExp instance." - [x] - (instance? js/RegExp x)) - -(defn re-matches - "Returns the result of (re-find re s) if re fully matches s." - [re s] - (if (string? s) - (let [matches (.exec re s)] - (when (= (first matches) s) - (if (== (count matches) 1) - (first matches) - (vec matches)))) - (throw (js/TypeError. "re-matches must match against a string.")))) - - -(defn re-find - "Returns the first regex match, if any, of s to re, using - re.exec(s). Returns a vector, containing first the matching - substring, then any capturing groups if the regular expression contains - capturing groups." - [re s] - (if (string? s) - (let [matches (.exec re s)] - (when-not (nil? matches) - (if (== (count matches) 1) - (first matches) - (vec matches)))) - (throw (js/TypeError. "re-find must match against a string.")))) - -(defn re-seq - "Returns a lazy sequence of successive matches of re in s." - [re s] - (let [match-data (re-find re s) - match-idx (.search s re) - match-str (if (coll? match-data) (first match-data) match-data) - post-match (subs s (+ match-idx (count match-str)))] - (when match-data (lazy-seq (cons match-data (when (seq post-match) (re-seq re post-match))))))) - -(defn re-pattern - "Returns an instance of RegExp which has compiled the provided string." - [s] - (if (instance? js/RegExp s) - s - (let [[prefix flags] (re-find #"^\(\?([idmsux]*)\)" s) - pattern (subs s (count prefix))] - (js/RegExp. pattern (or flags ""))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Printing ;;;;;;;;;;;;;;;; - -(defn pr-sequential-writer [writer print-one begin sep end opts coll] - (binding [*print-level* (when-not (nil? *print-level*) (dec *print-level*))] - (if (and (not (nil? *print-level*)) (neg? *print-level*)) - (-write writer "#") - (do - (-write writer begin) - (if (zero? (:print-length opts)) - (when (seq coll) - (-write writer (or (:more-marker opts) "..."))) - (do - (when (seq coll) - (print-one (first coll) writer opts)) - (loop [coll (next coll) n (dec (:print-length opts))] - (if (and coll (or (nil? n) (not (zero? n)))) - (do - (-write writer sep) - (print-one (first coll) writer opts) - (recur (next coll) (dec n))) - (when (and (seq coll) (zero? n)) - (-write writer sep) - (-write writer (or (:more-marker opts) "..."))))))) - (-write writer end))))) - -(defn write-all [writer & ss] - (doseq [s ss] - (-write writer s))) - -(defn string-print [x] - (*print-fn* x) - nil) - -(defn flush [] ;stub - nil) - -(def ^:private char-escapes - (js-obj - "\"" "\\\"" - "\\" "\\\\" - "\b" "\\b" - "\f" "\\f" - "\n" "\\n" - "\r" "\\r" - "\t" "\\t")) - -(defn ^:private quote-string - [s] - (str \" - (.replace s (js/RegExp "[\\\\\"\b\f\n\r\t]" "g") - (fn [match] (aget char-escapes match))) - \")) - -(declare print-map) - -(defn ^boolean print-meta? [opts obj] - (and (boolean (get opts :meta)) - (implements? IMeta obj) - (not (nil? (meta obj))))) - -(defn- pr-writer-impl - [obj writer opts] - (cond - (nil? obj) (-write writer "nil") - :else - (do - (when (print-meta? opts obj) - (-write writer "^") - (pr-writer (meta obj) writer opts) - (-write writer " ")) - (cond - ;; handle CLJS ctors - ^boolean (.-cljs$lang$type obj) - (.cljs$lang$ctorPrWriter obj obj writer opts) - - ; Use the new, more efficient, IPrintWithWriter interface when possible. - (implements? IPrintWithWriter obj) - (-pr-writer ^not-native obj writer opts) - - (or (true? obj) (false? obj) (number? obj)) - (-write writer (str obj)) - - (object? obj) - (do - (-write writer "#js ") - (print-map - (map (fn [k] [(keyword k) (aget obj k)]) (js-keys obj)) - pr-writer writer opts)) - - (array? obj) - (pr-sequential-writer writer pr-writer "#js [" " " "]" opts obj) - - ^boolean (goog/isString obj) - (if (:readably opts) - (-write writer (quote-string obj)) - (-write writer obj)) - - ^boolean (goog/isFunction obj) - (let [name (.-name obj) - name (if (or (nil? name) (gstring/isEmpty name)) - "Function" - name)] - (write-all writer "#object[" name " \"" (str obj) "\"]")) - - (instance? js/Date obj) - (let [normalize (fn [n len] - (loop [ns (str n)] - (if (< (count ns) len) - (recur (str "0" ns)) - ns)))] - (write-all writer - "#inst \"" - (str (.getUTCFullYear obj)) "-" - (normalize (inc (.getUTCMonth obj)) 2) "-" - (normalize (.getUTCDate obj) 2) "T" - (normalize (.getUTCHours obj) 2) ":" - (normalize (.getUTCMinutes obj) 2) ":" - (normalize (.getUTCSeconds obj) 2) "." - (normalize (.getUTCMilliseconds obj) 3) "-" - "00:00\"")) - - (regexp? obj) (write-all writer "#\"" (.-source obj) "\"") - - :else - (if (.. obj -constructor -cljs$lang$ctorStr) - (write-all writer - "#object[" (.replace (.. obj -constructor -cljs$lang$ctorStr) - (js/RegExp. "/" "g") ".") "]") - (let [name (.. obj -constructor -name) - name (if (or (nil? name) (gstring/isEmpty name)) - "Object" - name)] - (write-all writer "#object[" name " " (str obj) "]"))))))) - -(defn- pr-writer - "Prefer this to pr-seq, because it makes the printing function - configurable, allowing efficient implementations such as appending - to a StringBuffer." - [obj writer opts] - (if-let [alt-impl (:alt-impl opts)] - (alt-impl obj writer (assoc opts :fallback-impl pr-writer-impl)) - (pr-writer-impl obj writer opts))) - -(defn pr-seq-writer [objs writer opts] - (pr-writer (first objs) writer opts) - (doseq [obj (next objs)] - (-write writer " ") - (pr-writer obj writer opts))) - -(defn- pr-sb-with-opts [objs opts] - (let [sb (StringBuffer.) - writer (StringBufferWriter. sb)] - (pr-seq-writer objs writer opts) - (-flush writer) - sb)) - -(defn pr-str-with-opts - "Prints a sequence of objects to a string, observing all the - options given in opts" - [objs opts] - (if (empty? objs) - "" - (str (pr-sb-with-opts objs opts)))) - -(defn prn-str-with-opts - "Same as pr-str-with-opts followed by (newline)" - [objs opts] - (if (empty? objs) - "\n" - (let [sb (pr-sb-with-opts objs opts)] - (.append sb \newline) - (str sb)))) - -(defn- pr-with-opts - "Prints a sequence of objects using string-print, observing all - the options given in opts" - [objs opts] - (string-print (pr-str-with-opts objs opts))) - -(defn newline - "Prints a newline using *print-fn*" - ([] (newline nil)) - ([opts] - (string-print "\n") - (when (get opts :flush-on-newline) - (flush)))) - -(defn pr-str - "pr to a string, returning it. Fundamental entrypoint to IPrintWithWriter." - [& objs] - (pr-str-with-opts objs (pr-opts))) - -(defn prn-str - "Same as pr-str followed by (newline)" - [& objs] - (prn-str-with-opts objs (pr-opts))) - -(defn pr - "Prints the object(s) using string-print. Prints the - object(s), separated by spaces if there is more than one. - By default, pr and prn print in a way that objects can be - read by the reader" - [& objs] - (pr-with-opts objs (pr-opts))) - -(def ^{:doc - "Prints the object(s) using string-print. - print and println produce output for human consumption."} - print - (fn cljs-core-print [& objs] - (pr-with-opts objs (assoc (pr-opts) :readably false)))) - -(defn print-str - "print to a string, returning it" - [& objs] - (pr-str-with-opts objs (assoc (pr-opts) :readably false))) - -(defn println - "Same as print followed by (newline)" - [& objs] - (pr-with-opts objs (assoc (pr-opts) :readably false)) - (when *print-newline* - (newline (pr-opts)))) - -(defn println-str - "println to a string, returning it" - [& objs] - (prn-str-with-opts objs (assoc (pr-opts) :readably false))) - -(defn prn - "Same as pr followed by (newline)." - [& objs] - (pr-with-opts objs (pr-opts)) - (when *print-newline* - (newline (pr-opts)))) - -(defn- strip-ns - [named] - (if (symbol? named) - (symbol nil (name named)) - (keyword nil (name named)))) - -(defn- lift-ns - "Returns [lifted-ns lifted-map] or nil if m can't be lifted." - [m] - (when *print-namespace-maps* - (loop [ns nil - [[k v :as entry] & entries] (seq m) - lm (empty m)] - (if entry - (when (or (keyword? k) (symbol? k)) - (if ns - (when (= ns (namespace k)) - (recur ns entries (assoc lm (strip-ns k) v))) - (when-let [new-ns (namespace k)] - (recur new-ns entries (assoc lm (strip-ns k) v))))) - [ns lm])))) - -(defn print-prefix-map [prefix m print-one writer opts] - (pr-sequential-writer - writer - (fn [e w opts] - (do (print-one (key e) w opts) - (-write w \space) - (print-one (val e) w opts))) - (str prefix "{") ", " "}" - opts (seq m))) - -(defn print-map [m print-one writer opts] - (let [[ns lift-map] (lift-ns m)] - (if ns - (print-prefix-map (str "#:" ns) lift-map print-one writer opts) - (print-prefix-map nil m print-one writer opts)))) - -(extend-protocol IPrintWithWriter - LazySeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - LazyTransformer - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - IndexedSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - RSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - PersistentQueue - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#queue [" " " "]" opts (seq coll))) - - PersistentQueueSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - PersistentTreeMapSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - NodeSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - ArrayNodeSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - List - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - Cons - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - EmptyList - (-pr-writer [coll writer opts] (-write writer "()")) - - PersistentVector - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) - - ChunkedCons - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - ChunkedSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - Subvec - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) - - BlackNode - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) - - RedNode - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) - - ObjMap - (-pr-writer [coll writer opts] - (print-map coll pr-writer writer opts)) - - KeySeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - ValSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - PersistentArrayMapSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - PersistentArrayMap - (-pr-writer [coll writer opts] - (print-map coll pr-writer writer opts)) - - PersistentHashMap - (-pr-writer [coll writer opts] - (print-map coll pr-writer writer opts)) - - PersistentTreeMap - (-pr-writer [coll writer opts] - (print-map coll pr-writer writer opts)) - - PersistentHashSet - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#{" " " "}" opts coll)) - - PersistentTreeSet - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#{" " " "}" opts coll)) - - Range - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - ES6IteratorSeq - (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) - - Atom - (-pr-writer [a writer opts] - (-write writer "#object [cljs.core.Atom ") - (pr-writer {:val (.-state a)} writer opts) - (-write writer "]")) - - Volatile - (-pr-writer [a writer opts] - (-write writer "#object [cljs.core.Volatile ") - (pr-writer {:val (.-state a)} writer opts) - (-write writer "]")) - - Var - (-pr-writer [a writer opts] - (-write writer "#'") - (pr-writer (.-sym a) writer opts))) - -;; IComparable -(extend-protocol IComparable - Symbol - (-compare [x y] - (if (symbol? y) - (compare-symbols x y) - (throw (js/Error. (str "Cannot compare " x " to " y))))) - - Keyword - (-compare [x y] - (if (keyword? y) - (compare-keywords x y) - (throw (js/Error. (str "Cannot compare " x " to " y))))) - - Subvec - (-compare [x y] - (if (vector? y) - (compare-indexed x y) - (throw (js/Error. (str "Cannot compare " x " to " y))))) - - PersistentVector - (-compare [x y] - (if (vector? y) - (compare-indexed x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Reference Types ;;;;;;;;;;;;;;;; - -(defn alter-meta! - "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: - - (apply f its-current-meta args) - - f must be free of side-effects" - [iref f & args] - (set! (.-meta iref) (apply f (.-meta iref) args))) - -(defn reset-meta! - "Atomically resets the metadata for an atom" - [iref m] - (set! (.-meta iref) m)) - -(defn add-watch - "Adds a watch function to an atom reference. The watch fn must be a - fn of 4 args: a key, the reference, its old-state, its - new-state. Whenever the reference's state might have been changed, - any registered watches will have their functions called. The watch - fn will be called synchronously. Note that an atom's state - may have changed again prior to the fn call, so use old/new-state - rather than derefing the reference. Keys must be unique per - reference, and can be used to remove the watch with remove-watch, - but are otherwise considered opaque by the watch mechanism. Bear in - mind that regardless of the result or action of the watch fns the - atom's value will change. Example: - - (def a (atom 0)) - (add-watch a :inc (fn [k r o n] (assert (== 0 n)))) - (swap! a inc) - ;; Assertion Error - (deref a) - ;=> 1" - [iref key f] - (-add-watch iref key f) - iref) - -(defn remove-watch - "Removes a watch (set by add-watch) from a reference" - [iref key] - (-remove-watch iref key) - iref) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; gensym ;;;;;;;;;;;;;;;; -;; Internal - do not use! -(def - ^{:jsdoc ["@type {*}"]} - gensym_counter nil) - -(defn gensym - "Returns a new symbol with a unique name. If a prefix string is - supplied, the name is prefix# where # is some unique number. If - prefix is not supplied, the prefix is 'G__'." - ([] (gensym "G__")) - ([prefix-string] - (when (nil? gensym_counter) - (set! gensym_counter (atom 0))) - (symbol (str prefix-string (swap! gensym_counter inc))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fixtures ;;;;;;;;;;;;;;;; - -(def fixture1 1) -(def fixture2 2) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Delay ;;;;;;;;;;;;;;;;;;;; - -(deftype Delay [^:mutable f ^:mutable value] - IDeref - (-deref [_] - (when f - (set! value (f)) - (set! f nil)) - value) - - IPending - (-realized? [x] - (not f))) - -(defn ^boolean delay? - "returns true if x is a Delay created with delay" - [x] (instance? Delay x)) - -(defn force - "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" - [x] - (if (delay? x) - (deref x) - x)) - -(defn ^boolean realized? - "Returns true if a value has been produced for a delay or lazy sequence." - [x] - (-realized? x)) - -(defn- preserving-reduced - [rf] - #(let [ret (rf %1 %2)] - (if (reduced? ret) - (reduced ret) - ret))) - -(defn cat - "A transducer which concatenates the contents of each input, which must be a - collection, into the reduction." - {:added "1.7"} - [rf] - (let [rf1 (preserving-reduced rf)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (reduce rf1 result input))))) - -(defn halt-when - "Returns a transducer that ends transduction when pred returns true - for an input. When retf is supplied it must be a fn of 2 arguments - - it will be passed the (completed) result so far and the input that - triggered the predicate, and its return value (if it does not throw - an exception) will be the return value of the transducer. If retf - is not supplied, the input that triggered the predicate will be - returned. If the predicate never returns true the transduction is - unaffected." - {:added "1.9"} - ([pred] (halt-when pred nil)) - ([pred retf] - (fn [rf] - (fn - ([] (rf)) - ([result] - (if (and (map? result) (contains? result ::halt)) - (::halt result) - (rf result))) - ([result input] - (if (pred input) - (reduced {::halt (if retf (retf (rf result) input) input)}) - (rf result input))))))) - -(defn dedupe - "Returns a lazy sequence removing consecutive duplicates in coll. - Returns a transducer when no collection is provided." - ([] - (fn [rf] - (let [pa (volatile! ::none)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [prior @pa] - (vreset! pa input) - (if (= prior input) - result - (rf result input)))))))) - ([coll] (sequence (dedupe) coll))) - -(declare rand) - -(defn random-sample - "Returns items from coll with random probability of prob (0.0 - - 1.0). Returns a transducer when no collection is provided." - ([prob] - (filter (fn [_] (< (rand) prob)))) - ([prob coll] - (filter (fn [_] (< (rand) prob)) coll))) - -(deftype Eduction [xform coll] - Object - (indexOf [coll x] - (-indexOf coll x 0)) - (indexOf [coll x start] - (-indexOf coll x start)) - (lastIndexOf [coll x] - (-lastIndexOf coll x (count coll))) - (lastIndexOf [coll x start] - (-lastIndexOf coll x start)) - - ISequential - - ISeqable - (-seq [_] (seq (sequence xform coll))) - - IReduce - (-reduce [_ f] (transduce xform (completing f) coll)) - (-reduce [_ f init] (transduce xform (completing f) init coll)) - - IPrintWithWriter - (-pr-writer [coll writer opts] - (pr-sequential-writer writer pr-writer "(" " " ")" opts coll))) - -(es6-iterable Eduction) - -(defn eduction - "Returns a reducible/iterable application of the transducers - to the items in coll. Transducers are applied in order as if - combined with comp. Note that these applications will be - performed every time reduce/iterator is called." - {:arglists '([xform* coll])} - [& xforms] - (Eduction. (apply comp (butlast xforms)) (last xforms))) - -(defn run! - "Runs the supplied procedure (via reduce), for purposes of side - effects, on successive items in the collection. Returns nil" - [proc coll] - (reduce #(proc %2) nil coll) - nil) - -(defprotocol IEncodeJS - (-clj->js [x] "Recursively transforms clj values to JavaScript") - (-key->js [x] "Transforms map keys to valid JavaScript keys. Arbitrary keys are - encoded to their string representation via (pr-str x)")) - -(declare clj->js) - -(defn key->js [k] - (if (satisfies? IEncodeJS k) - (-clj->js k) - (if (or (string? k) - (number? k) - (keyword? k) - (symbol? k)) - (clj->js k) - (pr-str k)))) - -(defn clj->js - "Recursively transforms ClojureScript values to JavaScript. - sets/vectors/lists become Arrays, Keywords and Symbol become Strings, - Maps become Objects. Arbitrary keys are encoded to by key->js." - [x] - (when-not (nil? x) - (if (satisfies? IEncodeJS x) - (-clj->js x) - (cond - (keyword? x) (name x) - (symbol? x) (str x) - (map? x) (let [m (js-obj)] - (doseq [[k v] x] - (aset m (key->js k) (clj->js v))) - m) - (coll? x) (let [arr (array)] - (doseq [x (map clj->js x)] - (.push arr x)) - arr) - :else x)))) - -(defprotocol IEncodeClojure - (-js->clj [x options] "Transforms JavaScript values to Clojure")) - -(defn js->clj - "Recursively transforms JavaScript arrays into ClojureScript - vectors, and JavaScript objects into ClojureScript maps. With - option ':keywordize-keys true' will convert object fields from - strings to keywords." - ([x] (js->clj x :keywordize-keys false)) - ([x & opts] - (let [{:keys [keywordize-keys]} opts - keyfn (if keywordize-keys keyword str) - f (fn thisfn [x] - (cond - (satisfies? IEncodeClojure x) - (-js->clj x (apply array-map opts)) - - (seq? x) - (doall (map thisfn x)) - - (coll? x) - (into (empty x) (map thisfn x)) - - (array? x) - (vec (map thisfn x)) - - (identical? (type x) js/Object) - (into {} (for [k (js-keys x)] - [(keyfn k) (thisfn (aget x k))])) - - :else x))] - (f x)))) - -(defn memoize - "Returns a memoized version of a referentially transparent function. The - memoized version of the function keeps a cache of the mapping from arguments - to results and, when calls with the same arguments are repeated often, has - higher performance at the expense of higher memory use." - [f] - (let [mem (atom {})] - (fn [& args] - (let [v (get @mem args lookup-sentinel)] - (if (identical? v lookup-sentinel) - (let [ret (apply f args)] - (swap! mem assoc args ret) - ret) - v))))) - -(defn trampoline - "trampoline can be used to convert algorithms requiring mutual - recursion without stack consumption. Calls f with supplied args, if - any. If f returns a fn, calls that fn with no arguments, and - continues to repeat, until the return value is not a fn, then - returns that non-fn value. Note that if you want to return a fn as a - final value, you must wrap it in some data structure and unpack it - after trampoline returns." - ([f] - (let [ret (f)] - (if (fn? ret) - (recur ret) - ret))) - ([f & args] - (trampoline #(apply f args)))) - -(defn rand - "Returns a random floating point number between 0 (inclusive) and - n (default 1) (exclusive)." - ([] (rand 1)) - ([n] (* (Math/random) n))) - -(defn rand-int - "Returns a random integer between 0 (inclusive) and n (exclusive)." - [n] (Math/floor (* (Math/random) n))) - -(defn rand-nth - "Return a random element of the (sequential) collection. Will have - the same performance characteristics as nth for the given - collection." - [coll] - (nth coll (rand-int (count coll)))) - -(defn group-by - "Returns a map of the elements of coll keyed by the result of - f on each element. The value at each key will be a vector of the - corresponding elements, in the order they appeared in coll." - [f coll] - (persistent! - (reduce - (fn [ret x] - (let [k (f x)] - (assoc! ret k (conj (get ret k []) x)))) - (transient {}) coll))) - -(defn make-hierarchy - "Creates a hierarchy object for use with derive, isa? etc." - [] {:parents {} :descendants {} :ancestors {}}) - -(def - ^{:private true - :jsdoc ["@type {*}"]} - -global-hierarchy nil) - -(defn- get-global-hierarchy [] - (when (nil? -global-hierarchy) - (set! -global-hierarchy (atom (make-hierarchy)))) - -global-hierarchy) - -(defn- swap-global-hierarchy! [f & args] - (apply swap! (get-global-hierarchy) f args)) - -(defn ^boolean isa? - "Returns true if (= child parent), or child is directly or indirectly derived from - parent, either via a JavaScript type inheritance relationship or a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy" - ([child parent] (isa? @(get-global-hierarchy) child parent)) - ([h child parent] - (or (= child parent) - ;; (and (class? parent) (class? child) - ;; (. ^Class parent isAssignableFrom child)) - (contains? ((:ancestors h) child) parent) - ;;(and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child))) - (and (vector? parent) (vector? child) - (== (count parent) (count child)) - (loop [ret true i 0] - (if (or (not ret) (== i (count parent))) - ret - (recur (isa? h (child i) (parent i)) (inc i)))))))) - -(defn parents - "Returns the immediate parents of tag, either via a JavaScript type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - ([tag] (parents @(get-global-hierarchy) tag)) - ([h tag] (not-empty (get (:parents h) tag)))) - -(defn ancestors - "Returns the immediate and indirect parents of tag, either via a JavaScript type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - ([tag] (ancestors @(get-global-hierarchy) tag)) - ([h tag] (not-empty (get (:ancestors h) tag)))) - -(defn descendants - "Returns the immediate and indirect children of tag, through a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy. Note: does not work on JavaScript type inheritance - relationships." - ([tag] (descendants @(get-global-hierarchy) tag)) - ([h tag] (not-empty (get (:descendants h) tag)))) - -(defn derive - "Establishes a parent/child relationship between parent and - tag. Parent must be a namespace-qualified symbol or keyword and - child can be either a namespace-qualified symbol or keyword or a - class. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - ([tag parent] - (assert (namespace parent)) - ;; (assert (or (class? tag) (and (instance? cljs.core.Named tag) (namespace tag)))) - (swap-global-hierarchy! derive tag parent) nil) - ([h tag parent] - (assert (not= tag parent)) - ;; (assert (or (class? tag) (instance? clojure.lang.Named tag))) - ;; (assert (instance? clojure.lang.INamed tag)) - ;; (assert (instance? clojure.lang.INamed parent)) - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) - tf (fn [m source sources target targets] - (reduce (fn [ret k] - (assoc ret k - (reduce conj (get targets k #{}) (cons target (targets target))))) - m (cons source (sources source))))] - (or - (when-not (contains? (tp tag) parent) - (when (contains? (ta tag) parent) - (throw (js/Error. (str tag "already has" parent "as ancestor")))) - (when (contains? (ta parent) tag) - (throw (js/Error. (str "Cyclic derivation:" parent "has" tag "as ancestor")))) - {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)}) - h)))) - -(defn underive - "Removes a parent/child relationship between parent and - tag. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - ([tag parent] - (swap-global-hierarchy! underive tag parent) - nil) - ([h tag parent] - (let [parentMap (:parents h) - childsParents (if (parentMap tag) - (disj (parentMap tag) parent) #{}) - newParents (if (not-empty childsParents) - (assoc parentMap tag childsParents) - (dissoc parentMap tag)) - deriv-seq (flatten (map #(cons (first %) (interpose (first %) (second %))) - (seq newParents)))] - (if (contains? (parentMap tag) parent) - (reduce #(apply derive %1 %2) (make-hierarchy) - (partition 2 deriv-seq)) - h)))) - -(defn- reset-cache - [method-cache method-table cached-hierarchy hierarchy] - (swap! method-cache (fn [_] (deref method-table))) - (swap! cached-hierarchy (fn [_] (deref hierarchy)))) - -(defn- prefers* - [x y prefer-table] - (let [xprefs (@prefer-table x)] - (or - (when (and xprefs (xprefs y)) - true) - (loop [ps (parents y)] - (when (pos? (count ps)) - (when (prefers* x (first ps) prefer-table) - true) - (recur (rest ps)))) - (loop [ps (parents x)] - (when (pos? (count ps)) - (when (prefers* (first ps) y prefer-table) - true) - (recur (rest ps)))) - false))) - -(defn- dominates - [x y prefer-table hierarchy] - (or (prefers* x y prefer-table) (isa? hierarchy x y))) - -(defn- find-and-cache-best-method - [name dispatch-val hierarchy method-table prefer-table method-cache cached-hierarchy] - (let [best-entry (reduce (fn [be [k _ :as e]] - (if (isa? @hierarchy dispatch-val k) - (let [be2 (if (or (nil? be) (dominates k (first be) prefer-table @hierarchy)) - e - be)] - (when-not (dominates (first be2) k prefer-table @hierarchy) - (throw (js/Error. - (str "Multiple methods in multimethod '" name - "' match dispatch value: " dispatch-val " -> " k - " and " (first be2) ", and neither is preferred")))) - be2) - be)) - nil @method-table)] - (when best-entry - (if (= @cached-hierarchy @hierarchy) - (do - (swap! method-cache assoc dispatch-val (second best-entry)) - (second best-entry)) - (do - (reset-cache method-cache method-table cached-hierarchy hierarchy) - (find-and-cache-best-method name dispatch-val hierarchy method-table prefer-table - method-cache cached-hierarchy)))))) - -(defprotocol IMultiFn - (-reset [mf]) - (-add-method [mf dispatch-val method]) - (-remove-method [mf dispatch-val]) - (-prefer-method [mf dispatch-val dispatch-val-y]) - (-get-method [mf dispatch-val]) - (-methods [mf]) - (-prefers [mf]) - (-default-dispatch-val [mf]) - (-dispatch-fn [mf])) - -(defn- throw-no-method-error [name dispatch-val] - (throw (js/Error. (str "No method in multimethod '" name "' for dispatch value: " dispatch-val)))) - -(deftype MultiFn [name dispatch-fn default-dispatch-val hierarchy - method-table prefer-table method-cache cached-hierarchy] - IFn - (-invoke [mf] - (let [dispatch-val (dispatch-fn) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn))) - (-invoke [mf a] - (let [dispatch-val (dispatch-fn a) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a))) - (-invoke [mf a b] - (let [dispatch-val (dispatch-fn a b) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b))) - (-invoke [mf a b c] - (let [dispatch-val (dispatch-fn a b c) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c))) - (-invoke [mf a b c d] - (let [dispatch-val (dispatch-fn a b c d) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d))) - (-invoke [mf a b c d e] - (let [dispatch-val (dispatch-fn a b c d e) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e))) - (-invoke [mf a b c d e f] - (let [dispatch-val (dispatch-fn a b c d e f) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f))) - (-invoke [mf a b c d e f g] - (let [dispatch-val (dispatch-fn a b c d e f g) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g))) - (-invoke [mf a b c d e f g h] - (let [dispatch-val (dispatch-fn a b c d e f g h) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h))) - (-invoke [mf a b c d e f g h i] - (let [dispatch-val (dispatch-fn a b c d e f g h i) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i))) - (-invoke [mf a b c d e f g h i j] - (let [dispatch-val (dispatch-fn a b c d e f g h i j) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j))) - (-invoke [mf a b c d e f g h i j k] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k))) - (-invoke [mf a b c d e f g h i j k l] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l))) - (-invoke [mf a b c d e f g h i j k l m] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m))) - (-invoke [mf a b c d e f g h i j k l m n] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n))) - (-invoke [mf a b c d e f g h i j k l m n o] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o))) - (-invoke [mf a b c d e f g h i j k l m n o p] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o p))) - (-invoke [mf a b c d e f g h i j k l m n o p q] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o p q))) - (-invoke [mf a b c d e f g h i j k l m n o p q r] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o p q r))) - (-invoke [mf a b c d e f g h i j k l m n o p q r s] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r s) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o p q r s))) - (-invoke [mf a b c d e f g h i j k l m n o p q r s t] - (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r s t) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (target-fn a b c d e f g h i j k l m n o p q r s t))) - (-invoke [mf a b c d e f g h i j k l m n o p q r s t rest] - (let [dispatch-val (apply dispatch-fn a b c d e f g h i j k l m n o p q r s t rest) - target-fn (-get-method mf dispatch-val)] - (when-not target-fn - (throw-no-method-error name dispatch-val)) - (apply target-fn a b c d e f g h i j k l m n o p q r s t rest))) - - IMultiFn - (-reset [mf] - (swap! method-table (fn [mf] {})) - (swap! method-cache (fn [mf] {})) - (swap! prefer-table (fn [mf] {})) - (swap! cached-hierarchy (fn [mf] nil)) - mf) - - (-add-method [mf dispatch-val method] - (swap! method-table assoc dispatch-val method) - (reset-cache method-cache method-table cached-hierarchy hierarchy) - mf) - - (-remove-method [mf dispatch-val] - (swap! method-table dissoc dispatch-val) - (reset-cache method-cache method-table cached-hierarchy hierarchy) - mf) - - (-get-method [mf dispatch-val] - (when-not (= @cached-hierarchy @hierarchy) - (reset-cache method-cache method-table cached-hierarchy hierarchy)) - (if-let [target-fn (@method-cache dispatch-val)] - target-fn - (if-let [target-fn (find-and-cache-best-method name dispatch-val hierarchy method-table - prefer-table method-cache cached-hierarchy)] - target-fn - (@method-table default-dispatch-val)))) - - (-prefer-method [mf dispatch-val-x dispatch-val-y] - (when (prefers* dispatch-val-x dispatch-val-y prefer-table) - (throw (js/Error. (str "Preference conflict in multimethod '" name "': " dispatch-val-y - " is already preferred to " dispatch-val-x)))) - (swap! prefer-table - (fn [old] - (assoc old dispatch-val-x - (conj (get old dispatch-val-x #{}) - dispatch-val-y)))) - (reset-cache method-cache method-table cached-hierarchy hierarchy)) - - (-methods [mf] @method-table) - (-prefers [mf] @prefer-table) - (-default-dispatch-val [mf] default-dispatch-val) - (-dispatch-fn [mf] dispatch-fn) - - INamed - (-name [this] (-name name)) - (-namespace [this] (-namespace name)) - - IHash - (-hash [this] (goog/getUid this))) - -(defn remove-all-methods - "Removes all of the methods of multimethod." - [multifn] - (-reset multifn)) - -(defn remove-method - "Removes the method of multimethod associated with dispatch-value." - [multifn dispatch-val] - (-remove-method multifn dispatch-val)) - -(defn prefer-method - "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y - when there is a conflict" - [multifn dispatch-val-x dispatch-val-y] - (-prefer-method multifn dispatch-val-x dispatch-val-y)) - -(defn methods - "Given a multimethod, returns a map of dispatch values -> dispatch fns" - [multifn] (-methods multifn)) - -(defn get-method - "Given a multimethod and a dispatch value, returns the dispatch fn - that would apply to that value, or nil if none apply and no default" - [multifn dispatch-val] (-get-method multifn dispatch-val)) - -(defn prefers - "Given a multimethod, returns a map of preferred value -> set of other values" - [multifn] (-prefers multifn)) - -(defn default-dispatch-val - "Given a multimethod, return it's default-dispatch-val." - [multifn] (-default-dispatch-val multifn)) - -(defn dispatch-fn - "Given a multimethod, return it's dispatch-fn." - [multifn] (-dispatch-fn multifn)) - -;; UUID -(defprotocol IUUID "A marker protocol for UUIDs") - -(deftype UUID [uuid ^:mutable __hash] - IUUID - - Object - (toString [_] uuid) - (equiv [this other] - (-equiv this other)) - - IEquiv - (-equiv [_ other] - (and (instance? UUID other) (identical? uuid (.-uuid other)))) - - IPrintWithWriter - (-pr-writer [_ writer _] - (-write writer (str "#uuid \"" uuid "\""))) - - IHash - (-hash [this] - (when (nil? __hash) - (set! __hash (hash uuid))) - __hash) - - IComparable - (-compare [_ other] - (garray/defaultCompare uuid (.-uuid other)))) - -(defn uuid [s] - (UUID. s nil)) - -(defn random-uuid [] - (letfn [(hex [] (.toString (rand-int 16) 16))] - (let [rhex (.toString (bit-or 0x8 (bit-and 0x3 (rand-int 16))) 16)] - (uuid - (str (hex) (hex) (hex) (hex) - (hex) (hex) (hex) (hex) "-" - (hex) (hex) (hex) (hex) "-" - "4" (hex) (hex) (hex) "-" - rhex (hex) (hex) (hex) "-" - (hex) (hex) (hex) (hex) - (hex) (hex) (hex) (hex) - (hex) (hex) (hex) (hex)))))) - -(defn ^boolean uuid? - [x] (implements? IUUID x)) - -;;; ExceptionInfo - -(defn- pr-writer-ex-info [obj writer opts] - (-write writer "#error {:message ") - (pr-writer (.-message obj) writer opts) - (when (.-data obj) - (-write writer ", :data ") - (pr-writer (.-data obj) writer opts)) - (when (.-cause obj) - (-write writer ", :cause ") - (pr-writer (.-cause obj) writer opts)) - (-write writer "}")) - -(defn ^{:jsdoc ["@constructor"]} - ExceptionInfo [message data cause] - (let [e (js/Error. message)] - (this-as this - (set! (.-message this) message) - (set! (.-data this) data) - (set! (.-cause this) cause) - (do - (set! (.-name this) (.-name e)) - ;; non-standard - (set! (.-description this) (.-description e)) - (set! (.-number this) (.-number e)) - (set! (.-fileName this) (.-fileName e)) - (set! (.-lineNumber this) (.-lineNumber e)) - (set! (.-columnNumber this) (.-columnNumber e)) - (set! (.-stack this) (.-stack e))) - this))) - -(set! (.. ExceptionInfo -prototype -__proto__) js/Error.prototype) - -(extend-type ExceptionInfo - IPrintWithWriter - (-pr-writer [obj writer opts] - (pr-writer-ex-info obj writer opts))) - -(set! (.. ExceptionInfo -prototype -toString) - (fn [] - (this-as this (pr-str* this)))) - -(defn ex-info - "Create an instance of ExceptionInfo, an Error type that carries a - map of additional data." - ([msg data] (ex-info msg data nil)) - ([msg data cause] - (ExceptionInfo. msg data cause))) - -(defn ex-data - "Returns exception data (a map) if ex is an ExceptionInfo. - Otherwise returns nil." - [ex] - (when (instance? ExceptionInfo ex) - (.-data ex))) - -(defn ex-message - "Returns the message attached to the given Error / ExceptionInfo object. - For non-Errors returns nil." - [ex] - (when (instance? js/Error ex) - (.-message ex))) - -(defn ex-cause - "Returns exception cause (an Error / ExceptionInfo) if ex is an - ExceptionInfo. - Otherwise returns nil." - [ex] - (when (instance? ExceptionInfo ex) - (.-cause ex))) - -(defn comparator - "Returns an JavaScript compatible comparator based upon pred." - [pred] - (fn [x y] - (cond (pred x y) -1 (pred y x) 1 :else 0))) - -(defn ^boolean special-symbol? - "Returns true if x names a special form" - [x] - (contains? - '#{if def fn* do let* loop* letfn* throw try catch finally - recur new set! ns deftype* defrecord* . js* & quote var ns*} - x)) - -(defn test - "test [v] finds fn at key :test in var metadata and calls it, - presuming failure will throw exception" - [v] - (let [f (.-cljs$lang$test v)] - (if f - (do (f) :ok) - :no-test))) - - -(deftype TaggedLiteral [tag form] - Object - (toString [coll] - (pr-str* coll)) - - IEquiv - (-equiv [this other] - (and (instance? TaggedLiteral other) - (= tag (.-tag other)) - (= form (.-form other)))) - - IHash - (-hash [this] - (+ (* 31 (hash tag)) - (hash form))) - - ILookup - (-lookup [this v] - (-lookup this v nil)) - (-lookup [this v not-found] - (case v - :tag tag - :form form - not-found)) - - IPrintWithWriter - (-pr-writer [o writer opts] - (-write writer (str "#" tag " ")) - (pr-writer form writer opts))) - -(defn ^boolean tagged-literal? - "Return true if the value is the data representation of a tagged literal" - [value] - (instance? TaggedLiteral value)) - -(defn tagged-literal - "Construct a data representation of a tagged literal from a - tag symbol and a form." - [tag form] - {:pre [(symbol? tag)]} - (TaggedLiteral. tag form)) - -(def - ^{:private true - :jsdoc ["@type {*}"]} - js-reserved-arr - #js ["abstract" "boolean" "break" "byte" "case" - "catch" "char" "class" "const" "continue" - "debugger" "default" "delete" "do" "double" - "else" "enum" "export" "extends" "final" - "finally" "float" "for" "function" "goto" "if" - "implements" "import" "in" "instanceof" "int" - "interface" "let" "long" "native" "new" - "package" "private" "protected" "public" - "return" "short" "static" "super" "switch" - "synchronized" "this" "throw" "throws" - "transient" "try" "typeof" "var" "void" - "volatile" "while" "with" "yield" "methods" - "null"]) - -(def - ^{:jsdoc ["@type {null|Object}"]} - js-reserved nil) - -(defn- js-reserved? [x] - (when (nil? js-reserved) - (set! js-reserved - (reduce #(do (gobject/set %1 %2 true) %1) - #js {} js-reserved-arr))) - (.hasOwnProperty js-reserved x)) - -(defn- demunge-pattern [] - (when-not DEMUNGE_PATTERN - (set! DEMUNGE_PATTERN - (let [ks (sort (fn [a b] (- (. b -length) (. a -length))) - (js-keys DEMUNGE_MAP))] - (loop [ks ks ret ""] - (if (seq ks) - (recur - (next ks) - (str - (cond-> ret - (not (identical? ret "")) (str "|")) - (first ks))) - (str ret "|\\$")))))) - DEMUNGE_PATTERN) - -(defn- munge-str [name] - (let [sb (StringBuffer.)] - (loop [i 0] - (if (< i (. name -length)) - (let [c (.charAt name i) - sub (gobject/get CHAR_MAP c)] - (if-not (nil? sub) - (.append sb sub) - (.append sb c)) - (recur (inc i))))) - (.toString sb))) - -(defn munge [name] - (let [name' (munge-str (str name)) - name' (cond - (identical? name' "..") "_DOT__DOT_" - (js-reserved? name') (str name' "$") - :else name')] - (if (symbol? name) - (symbol name') - (str name')))) - -(defn- demunge-str [munged-name] - (let [r (js/RegExp. (demunge-pattern) "g") - munged-name (if (gstring/endsWith munged-name "$") - (.substring munged-name 0 (dec (. munged-name -length))) - munged-name)] - (loop [ret "" last-match-end 0] - (if-let [match (.exec r munged-name)] - (let [[x] match] - (recur - (str ret - (.substring munged-name last-match-end - (- (. r -lastIndex) (. x -length))) - (if (identical? x "$") "/" (gobject/get DEMUNGE_MAP x))) - (. r -lastIndex))) - (str ret - (.substring munged-name last-match-end (.-length munged-name))))))) - -(defn demunge [name] - ((if (symbol? name) symbol str) - (let [name' (str name)] - (if (identical? name' "_DOT__DOT_") - ".." - (demunge-str (str name)))))) - -;; ----------------------------------------------------------------------------- -;; Bootstrap helpers - incompatible with advanced compilation - -(defn- ns-lookup - "Bootstrap only." - [ns-obj k] - (fn [] (gobject/get ns-obj k))) - -;; Bootstrap only -(deftype Namespace [obj name] - Object - (findInternedVar [this sym] - (let [k (munge (str sym))] - (when ^boolean (gobject/containsKey obj k) - (let [var-sym (symbol (str name) (str sym)) - var-meta {:ns this}] - (Var. (ns-lookup obj k) var-sym var-meta))))) - (getName [_] name) - (toString [_] - (str name)) - IEquiv - (-equiv [_ other] - (if (instance? Namespace other) - (= name (.-name other)) - false)) - IHash - (-hash [_] - (hash name))) - -(def - ^{:doc "Bootstrap only." :jsdoc ["@type {*}"]} - NS_CACHE nil) - -(defn- find-ns-obj* - "Bootstrap only." - [ctxt xs] - (cond - (nil? ctxt) nil - (nil? xs) ctxt - :else (recur (gobject/get ctxt (first xs)) (next xs)))) - -(defn find-ns-obj - "Bootstrap only." - [ns] - (let [munged-ns (munge (str ns)) - segs (.split munged-ns ".")] - (case *target* - "nodejs" (if ^boolean js/COMPILED - ; Under simple optimizations on nodejs, namespaces will be in module - ; rather than global scope and must be accessed by a direct call to eval. - ; The first segment may refer to an undefined variable, so its evaluation - ; may throw ReferenceError. - (find-ns-obj* - (try - (js/eval (first segs)) - (catch js/ReferenceError e - nil)) - (next segs)) - (find-ns-obj* js/global segs)) - "default" (find-ns-obj* goog/global segs) - (throw (js/Error. (str "find-ns-obj not supported for target " *target*)))))) - -(defn ns-interns* - "Bootstrap only." - [sym] - (let [ns-obj (find-ns-obj sym) - ns (Namespace. ns-obj sym)] - (letfn [(step [ret k] - (let [var-sym (symbol (demunge k))] - (assoc ret - var-sym (Var. #(gobject/get ns-obj k) - (symbol (str sym) (str var-sym)) {:ns ns}))))] - (reduce step {} (js-keys ns-obj))))) - -(defn create-ns - "Bootstrap only." - ([sym] - (create-ns sym (find-ns-obj sym))) - ([sym ns-obj] - (Namespace. ns-obj sym))) - -(defn find-ns - "Bootstrap only." - [ns] - (when (nil? NS_CACHE) - (set! NS_CACHE (atom {}))) - (let [the-ns (get @NS_CACHE ns)] - (if-not (nil? the-ns) - the-ns - (let [ns-obj (find-ns-obj ns)] - (when-not (nil? ns-obj) - (let [new-ns (create-ns ns ns-obj)] - (swap! NS_CACHE assoc ns new-ns) - new-ns)))))) - -(defn find-macros-ns - "Bootstrap only." - [ns] - (when (nil? NS_CACHE) - (set! NS_CACHE (atom {}))) - (let [the-ns (get @NS_CACHE ns)] - (if-not (nil? the-ns) - the-ns - (let [ns-str (str ns) - ns (if (not ^boolean (gstring/contains ns-str "$macros")) - (symbol (str ns-str "$macros")) - ns) - ns-obj (find-ns-obj ns)] - (when-not (nil? ns-obj) - (let [new-ns (create-ns ns ns-obj)] - (swap! NS_CACHE assoc ns new-ns) - new-ns)))))) - -(defn ns-name - "Bootstrap only." - [ns-obj] - (.-name ns-obj)) -- cgit v1.2.3