1+ ; Copyright (c) Rich Hickey, Stuart Halloway, and contributors.
2+ ; All rights reserved.
3+ ; The use and distribution terms for this software are covered by the
4+ ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
5+ ; which can be found in the file epl-v10.html at the root of this distribution.
6+ ; By using this software in any fashion, you are agreeing to be bound by
7+ ; the terms of this license.
8+ ; You must not remove this notice, or any other, from this software.
9+
10+ (ns ^{:author " Stuart Halloway, modified for ClojureCLR by David Miller"
11+ :doc " Data generators for Clojure."
12+ clojure.data.generators
13+ (:refer-clojure :exclude [byte char long int short float double boolean string symbol keyword list vec set hash-map name rand-nth byte-array boolean-array short-array char-array int-array long-array float-array double-array shuffle ulong uint ushort sbyte])
14+ (:require [clojure.core :as core]))
15+
16+ (def ^:dynamic ^System.Random ; ;; ^java.util.Random
17+ *rnd*
18+ " Random instance for use in generators. By consistently using this
19+ instance you can get a repeatable basis for tests."
20+ (System.Random. 42 )) ; ;; (java.util.Random. 42))
21+
22+ (defn- call-through
23+ " Recursively call x until it doesn't return a function."
24+ [x]
25+ (if (fn? x)
26+ (recur (x ))
27+ x))
28+
29+ (defn reps
30+ " Returns sizer repetitions of f (or (f) if f is a fn)."
31+ [sizer f]
32+ (let [count (call-through sizer)]
33+ (if (fn? f)
34+ (repeatedly count f)
35+ (repeat count f))))
36+
37+ (defn geometric
38+ " Geometric distribution with mean 1/p."
39+ ^long [p]
40+ (core/long (Math/Ceiling (/ (Math/Log (.NextDouble *rnd*)) ; ;; Math/ceil Math/log .nextDouble
41+ (Math/Log (- 1.0 p)))))) ; ;; Math/Log
42+ (declare next-long ) ; ;; added
43+ (defn uniform
44+ " Uniform distribution from lo (inclusive) to high (exclusive).
45+ Defaults to range of Java long."
46+ (^long [] (next-long *rnd*)) ; ;; .nextLong
47+ (^long[lo hi] {:pre [(< lo hi)]}
48+ (clojure.core/long (Math/Floor (+ lo (* (.NextDouble *rnd*) (- hi lo))))))) ; ;; Math/floor .nextDouble
49+
50+ (defn float
51+ " Generate af float between 0 and 1 based on *rnd*"
52+ ^double []
53+ (core/float (.NextDouble *rnd*))) ; ;; (.nextFloat *rnd*))
54+
55+ (defn double
56+ " Generate a double between 0 and 1 based on *rnd*."
57+ ^double []
58+ (.NextDouble *rnd*)) ; ;; .nextDouble
59+
60+ (defn rand-nth
61+ " Replacement of core/rand-nth that allows control of the
62+ randomization basis (through binding *rnd*)."
63+ [coll]
64+ (nth coll (uniform 0 (count coll))))
65+
66+ (defn tuple
67+ " Generate a tuple with one element from each generator."
68+ [& generators]
69+ (into [] (map #(% ) generators)))
70+
71+ (defn weighted
72+ " Given a map of generators and weights, return a value from one of
73+ the generators, selecting generator based on weights."
74+ [m]
75+ (let [weights (reductions + (vals m))
76+ total (last weights)
77+ choices (map vector (keys m) weights)]
78+ (let [choice (uniform 0 total)]
79+ (loop [[[c w] & more] choices]
80+ (when w
81+ (if (< choice w)
82+ (call-through c)
83+ (recur more)))))))
84+
85+ (defn one-of
86+ " Generates one of the specs passed in, with equal probability."
87+ ([& specs]
88+ (weighted (zipmap specs (repeat 1 )))))
89+
90+ (def long
91+ " Returns a long based on *rnd*. Same as uniform."
92+ uniform )
93+
94+ (defn int
95+ []
96+ " Returns a long based on *rnd* in the int range."
97+ (uniform Int32/MinValue (inc Int32/MaxValue))) ; ;; Integer/MIN_VALUE Integer/Max_VALUE
98+
99+ (defn short
100+ []
101+ " Returns a long based on *rnd* in the short range."
102+ (uniform Int16/MinValue (inc (core/long Int16/MaxValue)))) ; ;; Short/MIN_VALUE Short/MAX_VALUE
103+
104+ (defn byte
105+ " Returns a long based on *rnd* in the byte range."
106+ ^long []
107+ (uniform Byte/MinValue (inc (core/int Byte/MaxValue)))) ; ;; Byte/MIN_VALUE Byte/MAX_VALUE
108+
109+ (defn boolean
110+ " Returns a bool based on *rnd*."
111+ []
112+ (zero? (.Next *rnd* 0 2 ))) ; ;; (.nextBoolean *rnd*))
113+
114+ (defn printable-ascii-char
115+ " Returns a char based on *rnd* in the printable ascii range."
116+ []
117+ (core/char (uniform 32 127 )))
118+
119+ (defn char
120+ " Returns a character based on *rnd* in the range 0-65536."
121+ []
122+ (core/char (uniform 0 65536 )))
123+
124+ (defn default-sizer
125+ " Default sizer used to run tests. If you want a specific distribution,
126+ create your own and pass it to a fn that wants a sizer."
127+ []
128+ (dec (geometric 0.02 )))
129+
130+ (defn list
131+ " Create a list with elements from f and sized from sizer."
132+ ([f] (list f default-sizer ))
133+ ([f sizer]
134+ (reps sizer f)))
135+
136+ (defmacro primitive-array
137+ [type]
138+ (let [fn-name (core/symbol (str type " -array"
139+ factory-name (core/symbol (str " core/"
140+ cast-name (core/symbol (str " core/"
141+ `(defn ~fn-name
142+ " Create an array with elements from f and sized from sizer."
143+ ([~'f]
144+ (~fn-name ~'f default-sizer ))
145+ ([~'f ~'sizer]
146+ (let [~'arr (~factory-name (call-through ~'sizer))]
147+ (dotimes [~'i (count ~'arr)]
148+ (aset ~'arr ~'i (~cast-name (call-through ~'f))))
149+ ~'arr)))))
150+
151+ (defmacro primitive-arrays
152+ [types]
153+ `(do ~@(map (fn [type] `(primitive-array ~type)) types)))
154+
155+ (primitive-arrays [" byte" " short" " long" " char" " double" " float" " int" " boolean"
156+
157+ #_(defn byte-array
158+ ([f]
159+ (byte-array f default-sizer ))
160+ ([f sizer]
161+ (let [arr (core/byte-array (call-through default-sizer ))]
162+ (dotimes [i (count arr)]
163+ (aset arr i (core/byte (call-through f))))
164+ arr)))
165+
166+ (defn vec
167+ " Create a vec with elements from f and sized from sizer."
168+ ([f] (vec f default-sizer ))
169+ ([f sizer]
170+ (into [] (reps sizer f))))
171+
172+ (defn set
173+ " Create a set with elements from f and sized from sizer."
174+ ([f] (set f default-sizer ))
175+ ([f sizer]
176+ (into #{} (reps sizer f))))
177+
178+ (defn hash-map
179+ " Create a hash-map with keys from fk, vals from fv, and
180+ sized from sizer."
181+ ([fk fv] (hash-map fk fv default-sizer ))
182+ ([fk fv sizer]
183+ (into {}
184+ (zipmap (reps sizer fk)
185+ (reps sizer fv)))))
186+
187+ (defn string
188+ " Create a string with chars from v and sized from sizer."
189+ ([] (string printable-ascii-char))
190+ ([f] (string f default-sizer ))
191+ ([f sizer] (apply str (reps sizer f))))
192+
193+ (def ^:private ascii-alpha
194+ (concat (range 65 (+ 65 26 ))
195+ (range 97 (+ 97 26 ))))
196+
197+ (def ^:private symbol-start
198+ (-> (concat ascii-alpha [\* \+ \! \- \_ \?])
199+ core/vec))
200+
201+ (def ^:private symbol-char
202+ (into symbol-start [\1 \2 \3 \4 \5 \6 \7 \8 \9 \0 ]))
203+
204+ ; ; cannot generate every legal prefix, but at least avoids
205+ ; ; the illegal "-1"
206+ (defn- name-prefix
207+ []
208+ (str (rand-nth [(core/char (rand-nth symbol-start)) " "
209+ (core/char (rand-nth ascii-alpha))))
210+
211+ (defn- name-body
212+ [sizer]
213+ (string #(core/char (rand-nth symbol-char)) sizer))
214+
215+ (defn- name
216+ ([] (name default-sizer ))
217+ ([sizer]
218+ (str (name-prefix )
219+ (name-body sizer))))
220+
221+ (defn symbol
222+ " Create a symbol sized from sizer."
223+ ([] (core/symbol (name )))
224+ ([sizer]
225+ (core/symbol (name sizer))))
226+
227+ (defn keyword
228+ " Create a keyword sized from sizer."
229+ ([] (core/keyword (name )))
230+ ([sizer]
231+ (core/keyword (name sizer))))
232+
233+ (def scalars
234+ [(constantly nil )
235+ byte
236+ long
237+ boolean
238+ printable-ascii-char
239+ string
240+ symbol
241+ keyword])
242+
243+ (defn scalar
244+ " Returns a scalar based on *rnd*."
245+ []
246+ (call-through (rand-nth scalars)))
247+
248+ (def collections
249+ [[vec [scalars]]
250+ [set [scalars]]
251+ [hash-map [scalars scalars]]])
252+
253+ (defn collection
254+ " Returns a collection of scalar elements based on *rnd*."
255+ []
256+ (let [[coll args] (rand-nth collections)]
257+ (apply coll (map rand-nth args))))
258+
259+ (defn anything
260+ " Returns a scalar or collection based on *rnd*."
261+ []
262+ (one-of scalar collection))
263+
264+ (defn ^:private fisher-yates
265+ " http://en.wikipedia.org/wiki/Fisher–Yates_shuffle#The_modern_algorithm"
266+ [coll]
267+ (let [as (object-array coll)]
268+ (loop [i (dec (count as))]
269+ (if (<= 1 i)
270+ (let [j (uniform 0 (inc i))
271+ t (aget as i)]
272+ (aset as i (aget as j))
273+ (aset as j t)
274+ (recur (dec i)))
275+ (into (empty coll) (seq as))))))
276+
277+ (defn shuffle
278+ " Shuffle coll based on *rnd*"
279+ [coll]
280+ ; ; using our own fischer-yates instead of core/shuffle so that
281+ ; ; we'll get the same shuffle, given the same *rnd*.
282+ (fisher-yates coll))
283+
284+ (defn reservoir-sample
285+ " Reservoir sample ct items from coll, using *rnd*."
286+ [ct coll]
287+ (loop [result (transient (core/vec (take ct coll)))
288+ n ct
289+ coll (drop ct coll)]
290+ (if (seq coll)
291+ (let [pos (uniform 0 n)]
292+ (recur (if (< pos ct)
293+ (assoc! result pos (first coll))
294+ result)
295+ (inc n)
296+ (rest coll)))
297+ (persistent! result))))
298+
299+ ; ;; Added
300+
301+ (defn- next-long
302+ " Generate a random 64-bit integer"
303+ ^long [^System.Random rnd]
304+ (let [buffer (core/byte-array 8 )]
305+ (.NextBytes rnd buffer)
306+ (BitConverter/ToInt64 buffer 0 )))
307+
308+ (defn- next-ulong
309+ " Generate a random 64-bit integer"
310+ ^long [^System.Random rnd]
311+ (let [buffer (core/byte-array 8 )]
312+ (.NextBytes rnd buffer)
313+ (long (BitConverter/ToUInt64 buffer 0 ))))
314+
315+ ; ;; TODO: Come back to this, need gvec to define
316+ ; ;;(primitive-arrays ["sbyte" "ushort" "ulong" "uint"])
317+
318+ (defn uint
319+ []
320+ " Returns a long based on *rnd* in the uint range."
321+ (uniform UInt32/MinValue (inc UInt32/MaxValue)))
322+
323+ (defn ushort
324+ []
325+ " Returns a long based on *rnd* in the ushort range."
326+ (uniform UInt16/MinValue (inc UInt16/MaxValue)))
327+
328+ (defn sbyte
329+ []
330+ " Returns a long based on *rnd* in the sbyte range."
331+ (uniform SByte/MinValue (inc SByte/MaxValue)))
332+
333+ (defn ulong
334+ []
335+ " Returns a long based on *rnd* in the ulong range."
336+ (uniform UInt64/MinValue (inc UInt64/MaxValue)))
337+
338+
339+
0 commit comments