/[gcl]/gcl/ansi-tests/random-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-aux.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by pfdietz, Fri Jul 1 12:34:36 2005 UTC revision 1.13 by pfdietz, Wed Jul 6 12:48:05 2005 UTC
# Line 34  Line 34 
34           (total (car (last cumulative-weights)))           (total (car (last cumulative-weights)))
35           (r (gensym)))           (r (gensym)))
36      (assert (every #'plusp weights))      (assert (every #'plusp weights))
37        (when (typep total 'ratio) (setf total (coerce total 'double-float)))
38      `(let ((,r (random ,total)))      `(let ((,r (random ,total)))
39         (cond         (cond
40          ,@(loop for case in (butlast cases)          ,@(loop for case in (butlast cases)
# Line 257  Line 258 
258      (make-list p :initial-element 1))      (make-list p :initial-element 1))
259     (t (mapcar #'1+ (random-partition* (- n p) p)))))     (t (mapcar #'1+ (random-partition* (- n p) p)))))
260    
261    
262    ;;; Random method combination
263    ;;; Methods in this method combination take a single method qualifier,
264    ;;; which is a positive integer.  Each method is invoked
265    ;;; with probability proportional to its qualifier.
266    ;;;
267    ;;; Inside a method, a throw to the symbol FAIL causes
268    ;;; the application to repeat.  This enables methods to abort
269    ;;; and retry the random selection process.
270    
271    (defun positive-integer-qualifier-p (qualifiers)
272      (typep qualifiers '(cons (integer 1) null)))
273    
274    (define-method-combination randomized nil ((method-list positive-integer-qualifier-p))
275      (assert method-list)
276      (let ((clauses (mapcar #'(lambda (method)
277                                 (let ((weight (car (method-qualifiers method))))
278                                   `(,weight (call-method ,method))))
279                             method-list)))
280      `(loop (catch 'fail (return (rcase ,@clauses))))))

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26