;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Jun  8 06:56:15 2003
;;;; Contains: Aux. functions and macros used for randomization

(in-package :cl-test)

(declaim (special +standard-chars+ *cl-symbols-vector*))

(defvar *maximum-random-int-bits*
  (max 36 (1+ (integer-length most-positive-fixnum))))

(defun random-from-seq (seq)
  "Generate a random member of a sequence."
  (let ((len (length seq)))
    (assert (> len 0))
    (elt seq (random len))))

(defmacro random-case (&body cases)
  (let ((len (length cases)))
    (assert (> len 0))
    `(case (random ,len)
       ,@(loop for i from 0 for e in cases collect `(,i ,e))
       (t (error "Can't happen?! (in random-case)~%")))))

(defmacro rcase (&body cases)
  "Usage: (RCASE (<weight> <form>+)+), where <weight> is a positive real
   indicating the relative probability of executing the associated implicit
   progn."
  (assert cases)
  (let* ((weights (mapcar #'car cases))
	 (cumulative-weights (let ((sum 0))
			       (loop for w in weights collect (incf sum w))))
	 (total (car (last cumulative-weights)))
	 (r (gensym)))
    (assert (every #'plusp weights))
    (when (typep total 'ratio) (setf total (coerce total 'double-float)))
    `(let ((,r (random ,total)))
       (cond
	,@(loop for case in (butlast cases)
		for cw in cumulative-weights
		collect `((< ,r ,cw) ,@(cdr case)))
	(t ,@(cdar (last cases)))))))

(defmacro rselect (cumulative-frequency-array &rest cases)
  (let ((len (length cases))
	(a (gensym "A"))
	(max (gensym "MAX"))
	(r (gensym "R"))
	(p (gensym "P"))
	(done (gensym "DONE")))
    (assert (> len 0))
    `(let ((,a ,cumulative-frequency-array))
       (assert (eql ,len (length ,a)))
       (let* ((,max (aref ,a ,(1- len)))
	      (,r (random ,max)))
	 (block ,done
	  ,@(loop for i from 0
		  for c in cases
		  collect 
		  `(let ((,p (aref ,a ,i)))
		     (when (< ,r ,p) (return-from ,done ,c))))
	  (error "Should not happen!"))))))

(defun make-random-integer-range (&optional var)
  "Generate a list (LO HI) of integers, LO <= HI.  This is used
   for generating integer types."
  (declare (ignore var))
  (rcase
   (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
		      (- (random r) (floor (/ r 2))))))
	(let ((x (%r))
	      (y (%r)))
	  (list (min x y) (max x y)))))
   (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))
	     (b2 (floor (/ b 2))))
	(let ((x (- (random b) b2))
	      (y (- (random b) b2)))
	  (list (min x y) (max x y)))))))

(defun random-nonnegative-real ()
  (if (coin 3)
      (random-case
       (/ (random 10000) (1+ (random 1000)))
       (/ (random 1000000) (1+ (random 100000)))
       (/ (random 100000000) (1+ (random 10000000)))
       (/ (random 1000000000000) (1+ (random 10000000))))
    (random (random-case
	     1000
	     100000
	     10000000
	     1000000000
	     (expt 2.0s0 (random 15))
	     (expt 2.0f0 (random 32))
	     (expt 2.0d0 (random 32))
	     (expt 2.0l0 (random 32))))))

(defun make-random-integer ()
  (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
    (rcase
     (6 (- (random r) (floor (/ r 2))))
     (1 (- r (random (min 10 r))))
     (1 (+ (floor (/ r 2)) (random (min 10 r)))))))

(defun make-random-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))))
      (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))
   (1 (random most-positive-single-float))
   (1 (random most-positive-double-float))
   (1 (random most-positive-long-float))))

(defun make-random-symbol ()
  (rcase
   (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
   (2 (random-from-seq *cl-symbols-vector*))
   (1 (gensym))))

(defun random-real ()
  (if (coin) (random-nonnegative-real)
    (- (random-nonnegative-real))))

(defun random-fixnum ()
  (+ (random (1+ (- most-positive-fixnum most-negative-fixnum)))
     most-negative-fixnum))

(defun random-thing (n)
  (if (<= n 1)
      (random-leaf)
    (rcase
     (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2))))
     (1 (apply #'vector (mapcar #'random-thing
				(random-partition (1- n) (max 10 (1- n))))))
     )))

(defparameter *use-random-byte* t)
(defparameter *random-readable* nil)

(defun make-random-string (size-spec &key simple)
  (let*
      ((size (if (eql size-spec '*) (random 30) size-spec))
       (use-random-byte nil)
       (etype 'character)
       (s (random-case
	   (progn
	     (setf use-random-byte *use-random-byte*)
	     (make-string size :element-type 'character))
	   (progn
	     (setf use-random-byte *use-random-byte*)
	     (make-array size :element-type 'character
			 :initial-element #\a))
	   (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char))
		       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
		       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
		       :initial-element #\a)
	   (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char))
		       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
		       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
		       :initial-element #\a))))
    (if (coin)
	(dotimes (i size)
	  (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4))))
      (dotimes (i size)
	(setf (char s i)
	      (or (and (eql etype 'character)
		       use-random-byte
		       (or (code-char (random (min char-code-limit (ash 1 16))))
			   (code-char (random 256))))
		  (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
		       (random 62))))))
    (when (and (not simple) (not *random-readable*) (coin 5))
      (let ((len (+ (random (1+ size)) size)))
	(setq s (make-random-string len))
	(setq etype (array-element-type s))
	(setq s (make-array size
			    :element-type etype
			    :displaced-to s
			    :displaced-index-offset (random (1+ (- len size)))))))
      
    s))

(defun random-leaf ()
  (rcase
   (1 (let ((k (ash 1 (1+ (random 40)))))
	(random-from-interval k (- k))))
   (1 (random-from-seq +standard-chars+))
   (1 (random-real))
   (1 (make-random-string (random 20)))
   (1 (gensym))
   (1 (make-symbol (make-random-string (random 20))))
   (1 (random-from-seq *cl-symbols-vector*))))

(defun random-from-interval (upper &optional (lower (- upper)))
  (+ (random (- upper lower)) lower))

(defun coin (&optional (n 2))
  "Flip an n-sided coin."
  (eql (random n) 0))

;;; Randomly permute a sequence
(defun random-permute (seq)
  (setq seq (copy-seq seq))
  (let ((len (length seq)))
    (loop for i from len downto 2
	  do (let ((r (random i)))
	       (rotatef (elt seq r) (elt seq (1- i))))))
  seq)

(defun binomial-distribution-test (n fn)
  (let* ((count (loop repeat n count (funcall fn)))
	 (sigma (/ (sqrt n) 2.0))
	 (bound (* sigma 6))
	 (expected (/ n 2.0)))
    (<= (- expected bound)
	count
	(+ expected bound))))

(defun random-partition* (n p)
  "Partition n into p numbers, each >= 0.  Return list of numbers."
  (assert (<= 1 p))
  (cond
   ((= p 1) (list n))
   ((= n 0) (make-list p :initial-element 0))
   (t (let* ((r (random p))
	     (n1 (random (1+ n))))
	(cond
	 ((= r 0)
	  (cons n1 (random-partition* (- n n1) (1- p))))
	 ((= r (1- p))
	  (append (random-partition* (- n n1) (1- p)) (list n1)))
	 (t
	  (let* ((n2 (random (1+ (- n n1))))
		 (n3 (- n n1 n2)))
	    (append (random-partition* n2 r)
		    (list n1)
		    (random-partition* n3 (- p 1 r))))))))))

(defun random-partition (n p)
  "Partition n into p numbers, each >= 1 (if possible.)"
  (cond
   ((<= n p)
    (make-list p :initial-element 1))
   (t (mapcar #'1+ (random-partition* (- n p) p)))))


;;; Random method combination
;;; Methods in this method combination take a single method qualifier,
;;; which is a positive integer.  Each method is invoked
;;; with probability proportional to its qualifier.
;;;
;;; Inside a method, a throw to the symbol FAIL causes
;;; the application to repeat.  This enables methods to abort
;;; and retry the random selection process.

(defun positive-integer-qualifier-p (qualifiers)
  (typep qualifiers '(cons (integer 1) null)))

(define-method-combination randomized nil ((method-list positive-integer-qualifier-p))
  (assert method-list)
  (let ((clauses (mapcar #'(lambda (method)
			     (let ((weight (car (method-qualifiers method))))
			       `(,weight (call-method ,method))))
			 method-list)))
  `(loop (catch 'fail (return (rcase ,@clauses))))))