Commit aeb1ecb5 authored by pfdietz's avatar pfdietz

Add more methods for make-random-elememt-of (this is still not called directly)

parent 37a97cab
......@@ -11,10 +11,10 @@
(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
(:documentation
"Create a random elemtn of (TYPE . ARGS), or throw an error if it can't figure out how to do it."))
"Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it."))
(defmethod make-random-element-of ((type cons))
(apply #'make-random-element-of-compound-type type))
(make-random-element-of-compound-type (car type) (cdr type)))
(defmethod make-random-element-of ((type (eql bit))) (random 2))
......@@ -28,6 +28,11 @@
(random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*)))))
(defmethod make-random-elememt-of ((type (eql signed-byte)))
(random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*)))
(- (ash 1 (random *maximum-random-int-bits*)))))
(defmethod make-random-element-of ((type (eql rational)))
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
(n (random r))
......@@ -42,6 +47,42 @@
(1 (- (make-random-element-of 'integer) x))
(6 (random-from-interval (1+ x) (- x))))))
(defmethod make-random-element-of ((type (eql short-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql single-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql double-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql long-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql float)))
(make-random-element-of
(list (random-from-seq #'(short-float single-float double-float long-float)))))
(defmethod make-random-element-of ((type (eql real)))
(make-random-element-of (random-from-seq #(integer rational float))))
(defmethod make-random-element-of ((type (eql ratio)))
(loop for x = (make-random-element-of 'rational)
unless (integerp x) return x))
(defmethod make-random-element-of ((type complex))
(make-random-element-of '(complex real)))
(defmethod make-random-element-of ((type fixnum))
(make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum)))
(defmethod make-random-element-of ((type bignum))
(make-random-element-of `(or (integer * (,most-negative-fixnum))
(integer (,most-positive-fixnum)))))
(defmethod make-random-element-of ((type (eql number)))
(make-random-element-of (random-from-seq #(integer rational float complex))))
(defmethod make-random-element-of ((type (eql character)))
(rcase
(3 (random-from-seq +standard-chars+))
......@@ -52,14 +93,55 @@
(1 (let ((r (random #.(ash 1 24))))
(or (code-char r) (make-random-element-of 'character))))))
(defmethod make-random-element-of ((type (eql standard-character)))
(defmethod make-random-element-of ((type 'base-char))
(random-from-seq +standard-chars+))
(defmethod make-random-element-of ((type 'standard-char))
(random-from-seq +standard-chars+))
(defmethod make-random-element-of ((type (eql bit-vector)))
(make-random-vector 'bit '*))
(defmethod make-random-element-of ((type (eql simple-bit-vector)))
(make-random-vector 'bit '* :simple t))
(defmethod make-random-element-of ((type (eql vector)))
(make-random-vector '*))
(make-random-vector '* '*))
(defmethod make-random-element-of ((type (eql simple-vector)))
(make-random-vector '* :simple t))
(make-random-vector 't '* :simple t))
(defmethod make-random-elemnt-of ((type (eql array)))
(make-random-array '* '*))
(defmethod make-random-elemnt-of ((type (eql simple-array)))
(make-random-array '* '* :simple t))
(defmethod make-random-elememt-of ((type (eql string)))
(make-random-string '*))
(defmethod make-random-elememt-of ((type (eql simple-string)))
(make-random-string '* :simple t))
(defmethod make-random-element-of ((type (eql base-string)))
(make-random-vector 'base-char '*))
(defmethod make-random-element-of ((type (eql simple-base-string)))
(make-random-vector 'base-char '* :simple t))
(defmethod make-random-element-of ((type (eql cons)))
(make-random-element-of '(cons t t)))
(defmethod make-random-element-of ((type (eql null))) nil)
(defmethod make-random-elememt-of ((type (eql list)))
(let ((len (min (random 10) (random 10))))
(loop repeat len collect (make-random-element-of-type t))))
(defmethod make-random-element-of ((type (eql sequence)))
(make-random-element-of '(or list vector)))
;;;;
(defun make-random-vector (length &key simple (element-type '*))
(setq element-type (make-random-array-element-type element-type))
......@@ -80,3 +162,113 @@
(4 t))
element-type))
;;;;
(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons))
(make-random-element-of (random-from-seq args)))
(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons))
(loop for e = (make-random-element-of (car args))
repeat 100
when (or (null (cdr args)) (typep e (cons 'and (cdr args))))
return x
finally (error "Cannot generate a random element of ~A"
(cons 'and args))))
(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t))
(let ((lo (let ((lo (car args)))
(cond
((consp lo) (1+ (car lo)))
((eq lo nil) '*)
(t lo))))
(hi (let ((hi (cadr args)))
(cond
((consp hi) (1- (car hi)))
((eq hi nil) '*)
(t hi)))))
(if (eq lo '*)
(if (eq hi '*)
(let ((x (ash 1 (random *maximum-random-int-bits*))))
(random-from-interval x (- x)))
(random-from-interval (1+ hi)
(- hi (random (ash 1 *maximum-random-int-bits*)))))
(if (eq hi '*)
(random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
lo)
;; May generalize the next case to increase odds
;; of certain integers (near 0, near endpoints, near
;; powers of 2...)
(random-from-interval (1+ hi) lo)))))
(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t))
(make-random-element-of-float-type type args))
(defun make-random-element-of-float-type (type-op args)
(let ((lo (car args))
(hi (cadr args))
lo= hi=)
(cond
((consp lo) nil)
((member lo '(* nil))
(setq lo (most-negative-float type-op))
(setq lo= t))
(t
(assert (typep lo type-op))
(setq lo= t)))
(cond
((consp hi) nil)
((member hi '(* nil))
(setq hi (most-positive-float type-op))
(setq hi= t))
(t
(assert (typep hi type-op))
(setq hi= t)))
(assert (<= lo hi))
(assert (or (< lo hi) (and lo= hi=)))
(let ((limit 100000))
(cond
((or (<= hi 0)
(>= lo 0)
(and (<= (- limit) hi limit) (<= (- limit) lo limit)))
(loop for x = (+ (random (- hi lo)) lo)
do (when (or lo= (/= x lo)) (return x))))
(t
(rcase
(1 (random (min hi (float limit hi))))
(1 (- (random (min (float limit lo) (- lo)))))))))))
(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons))
(let ((modulus (car args)))
(assert (integerp modulus))
(assert (plusp modulus))
(make-random-element-of `(integer 0 (,modulus)))))
(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t))
(if (null args)
(make-random-element-of '(integer 0 *))
(let ((bits (car args)))
(if (eq bits'*)
(make-random-element-of '(integer 0 *))
(progn
(assert (and (integerp bits) (>= bits 1)))
(make-random-element-of `(integer 0 ,(1- (ash 1 bits)))))))))
(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons))
(assert (null (cdr args)))
(car args))
(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons))
(random-from-seq args))
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