source: trunk/source/tests/ansi-tests/rctest/generator.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Jun  6 18:15:50 2003
4;;;; Contains: Generator class and associated generic function definitions
5
6(in-package :rctest)
7
8(compile-and-load "rctest-util.lsp")
9
10(defvar *prototype-class-table* (make-hash-table)
11  "Contains a map from names of classes to prototype instances
12   for those classes.")
13
14(defgeneric prototype (class)
15  ;; Map a class to a prototype instance of the class.  Cache using
16  ;; *prototype-class-table*.
17  (:method ((class standard-class) &aux (name (class-name class)))
18           (or (gethash name *prototype-class-table*)
19               (setf (gethash name *prototype-class-table*)
20                     (make-instance class))))
21  (:method ((class symbol))
22           (prototype (find-class class))))
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26;;; Generators are objects that are used to create random instances.
27
28(defclass generator () ())
29
30(defclass composite-generator (generator)
31  ((subgenerators :type array :initform (make-array '(10)
32                                                    :adjustable t
33                                                    :fill-pointer 0))
34   (cumulative-weights :type array
35                       :initform (make-array '(10)
36                                             :fill-pointer 0
37                                             :adjustable t
38                                             :element-type 'single-float
39                                             :initial-element 0.0f0))
40   ))
41
42(defclass simple-generator (generator) ())
43
44(defgeneric generate (gen size &rest ctxt &key &allow-other-keys)
45  (:method
46   ((gen composite-generator) (size real) &rest ctxt)
47   (let* ((subgens (slot-value gen 'subgenerators))
48          (n (fill-pointer subgens)))
49     (when (<= n 0) (return-from generate (values nil nil)))
50     (let* ((cum-weights (slot-value gen 'cumulative-weights))
51            (total-weight (aref cum-weights (1- n)))
52            (random-weight (random total-weight))
53            ;; Replace POSITION call with a binary search if necessary
54            (index (position random-weight cum-weights :test #'>=)))
55       (loop for i from 1 to 10
56             do (multiple-value-bind (val success?)
57                    (apply #'generate (aref subgens index) size ctxt)
58                  (when success? (return (values val t))))
59             finally (return (values nil nil))))))
60  )
61
62(defmethod generate ((gen symbol) size &rest ctxt &key &allow-other-keys)
63  (apply #'generate (prototype gen) size ctxt))
64
65(defgeneric add-subgenerator (gen subgen weight)
66  (:method
67   ((gen composite-generator) (subgen generator) weight)
68   (let* ((subgens (slot-value gen 'subgenerators))
69          (n (fill-pointer subgens))
70          (cum-weights (slot-value gen 'cumulative-weights))
71          (total-weight (if (> n 0) (aref cum-weights (1- n)) 0.0f0)))
72     (vector-push-extend gen subgens n)
73     (vector-push-extend (+ total-weight weight) cum-weights n)
74     (values))))
75
76(defclass iterative-generator (generator)
77  ((subgenerator :initarg :sub)))
78
79(defclass random-iterative-generator (iterative-generator) ())
80
81(defmethod generate ((gen random-iterative-generator) size &rest ctxt)
82  (if (<= size 1)
83      nil
84    (let ((subgen (slot-value gen 'subgenerator))
85          (subsizes (randomly-partition (1- size) (min (isqrt size) 10))))
86      (loop for subsize in subsizes
87            for (element success) = (multiple-value-list
88                                     (apply #'generate subgen subsize ctxt))
89            when success collect element))))
90
91;;; Macro for defining simple generator objects
92;;; BODY is the body of the method with arguments (gen ctxt size)
93;;; for computing the result.  Inside the body the function FAIL causes
94;;; the generator to return (nil nil).
95
96(defmacro defgenerator (name &key
97                             keys
98                             body
99                             (superclass 'simple-generator)
100                             slots)
101  (let ((rtag (gensym)))
102    (unless (listp keys) (setf keys (list keys)))
103    `(progn
104       (defclass ,name (,superclass) ,slots)
105       (defmethod generate ((gen ,name) (size real) &rest ctxt &key ,@keys)
106         (declare (ignorable gen size ctxt))
107         (block ,rtag
108           (flet ((fail () (return-from ,rtag (values nil nil))))
109             ,body))))))
Note: See TracBrowser for help on using the repository browser.