Commit cd5783a2 authored by pfdietz's avatar pfdietz

Improvements for random-element-of-type

parent 44790863
......@@ -280,6 +280,39 @@
(let ((d (loop for x = (random r) unless (zerop x) do (return x))))
(if (coin) (/ n d) (- (/ n d))))))
(defun make-random-nonnegative-rational ()
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
(n (random r)))
(assert (>= r 2))
(let ((d (loop for x = (random r) unless (zerop x) do (return x))))
(/ n d))))
(defun make-random-positive-rational ()
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
(n (1+ (random r))))
(assert (>= r 2))
(let ((d (loop for x = (random r) unless (zerop x) do (return x))))
(/ n d))))
(defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)
(assert (rationalp upper-limit))
(assert (not (minusp upper-limit)))
(cond
((= upper-limit 0) 0)
((<= upper-limit 1/1000000)
(/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)
1000000))
((>= upper-limit 1000000)
(* (random 1000000)
(make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))
(t
(assert (< 1/1000000 upper-limit 1000000))
(let ((x 0))
(loop do (setq x (* upper-limit (rational (random 1.0))))
while (or (and (not lower-inclusive) (zerop x))
(and (not upper-inclusive) (= x upper-limit)))
finally (return x))))))
(defun make-random-float ()
(rcase
(1 (random most-positive-short-float))
......@@ -490,7 +523,7 @@
`(boole ,op ,e1 ,e2)))))
;; n-ary ops
(40
(20
(let* ((op (random-from-seq #(+ - * logand min max
logior values lcm gcd logxor)))
(nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
......@@ -1164,6 +1197,44 @@
;; powers of 2...)
(random-from-interval (1+ hi) lo)))))
(rational
(or
(let ((r (make-random-element-of-type 'rational)))
(and (typep r type) r))
(let ((lo (cadr type))
(hi (caddr type))
lo= hi=)
(cond
((consp lo) nil)
((member lo '(* nil))
(setq lo nil)
(setq lo= nil))
(t
(assert (typep lo 'rational))
(setq lo= t)))
(cond
((consp hi) nil)
((member hi '(* nil))
(setq hi nil)
(setq hi= nil))
(t
(assert (typep hi 'rational))
(setq hi= t)))
(assert (or (null lo) (null hi) (<= lo hi)))
(assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
(cond
((null lo)
(cond
((null hi) (make-random-rational))
(hi= (- hi (make-random-nonnegative-rational)))
(t (- hi (make-random-positive-rational)))))
((null hi)
(cond
(lo= (+ lo (make-random-nonnegative-rational)))
(t (+ lo (make-random-positive-rational)))))
(t
(+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))
((single-float double-float long-float short-float)
(let ((lo (cadr type))
(hi (caddr type))
......@@ -1265,11 +1336,14 @@
when (typep c type)
return c)))))
)))
((typep type 'class)
(make-random-element-of-type (class-name type)))
(t
(ecase type
(bit (random 2))
(boolean (random-from-seq #(nil t)))
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
(keyword (random-from-seq #(:a :b :c :d :e :f :g :h :i :j)))
(unsigned-byte (random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*))) 0))
(signed-byte (random-from-interval
......@@ -1283,7 +1357,7 @@
((float)
(make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float))))
((real) (make-random-element-of-type (random-from-seq #(integer rational float))))
((number) (make-random-element-of-type (random-from-seq #(integer rational float complex))))
((number) (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex))))
((bit-vector) (make-random-vector 'bit '*))
((simple-bit-vector) (make-random-vector 'bit '* :simple t))
((vector) (make-random-vector '* '*))
......@@ -1298,10 +1372,12 @@
((base-char standard-char)
(random-from-seq +standard-chars+))
((character) (make-random-character))
((extended-char) (loop for x = (make-random-character) when (typep x 'extended-char) return x))
;; Default
((atom t *) (make-random-element-of-type
(random-from-seq #(real symbol boolean integer unsigned-byte complex character
(string 1) (bit-vector 1) complex))))
(random-from-seq #(real symbol boolean integer unsigned-byte
#-ecl complex character
(string 1) (bit-vector 1)))))
((null) nil)
((fixnum)
(random-from-interval (1+ most-positive-fixnum) most-negative-fixnum))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment