← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/rctest/generator.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/rctest/generator.lsp
 
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))))))