From fcf82c40c13198360892c62db5110ebdd4f87440 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Wed, 6 Jul 2005 12:48:05 +0000 Subject: [PATCH] Added RANDOMIZED method combination, I intend to rewrite MAKE-RANDOM-TYPE-CONTAINING to use this --- ansi-tests/random-aux.lsp | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index 8c0306b9..831ba156 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -34,6 +34,7 @@ (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) @@ -257,3 +258,23 @@ (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)))))) -- GitLab