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



(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))))))