Skip to content
Snippets Groups Projects
Commit 63f1f14a authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

restruct: move aux functions to auxiliary

parent 6203b6f0
No related branches found
No related tags found
No related merge requests found
Showing
with 0 additions and 283 deletions
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Dec 28 20:28:03 2004
;;;; Contains: Code to make random elements of types
(in-package :cl-test)
(defgeneric make-random-element-of (type)
(:documentation
"Create a random element of TYPE, or throw an error if it can't figure out how to do it."))
(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
(:documentation
"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))
(make-random-element-of-compound-type (car type) (cdr type)))
(defmethod make-random-element-of ((type (eql bit))) (random 2))
(defmethod make-random-element-of ((type (eql boolean)))
(random-from-seq #(nil t)))
(defmethod make-random-elememt-of ((type (eql symbol)))
(random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
(defmethod make-random-element-of ((type (eql unsigned-byte)))
(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))
(d (loop for x = (random r) unless (zerop x) do (return x))))
(if (coin) (/ n d) (- (/ n d)))))
(defmethod make-random-element-of ((type (eql integer)))
(let* ((b (random *maximum-random-int-bits*))
(x (ash 1 b)))
(rcase
(1 (+ x (make-random-element-of 'integer)))
(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+))
(2 (let ((r (random 256)))
(or (code-char r) (make-random-element-of 'character))))
(1 (let ((r (random #.(ash 1 16))))
(or (code-char r) (make-random-element-of 'character))))
(1 (let ((r (random #.(ash 1 24))))
(or (code-char r) (make-random-element-of '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 '* '*))
(defmethod make-random-element-of ((type (eql simple-vector)))
(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))
(make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length)))
(defun make-random-array (dimensions &key simple (element-type '*))
(setq element-type (make-random-array-element-type element-type))
(make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length)))
(defun make-random-array-element-type (elememt-type)
(if (eq element-type '*)
(rcase
(1 'bit)
(1 `(unsigned-byte (1+ (random *maximum-random-int-bits*))))
(1 `(signed-byte (1+ (random *maximum-random-int-bits*))))
(2 (random-from-seq #(character base-char standard-char)))
;; Put float, complex types here also
(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))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Oct 10 07:13:47 2004
;;;; Contains: Randomized tests on classes
(in-package :cl-test)
(compile-and-load "random-class-aux.lsp")
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment