source: project/release/4/srfi-27/OO-example.scm @ 34865

(use srfi-1 srfi-13 coops srfi-27-distributions)

;; Named (has a name) "concept"
(define-generic (name obj))
(define-class <named> () (
  (namsym reader: name) ) )

;; Parameterized extension "concept"
(define-class <parameterized> () (ctor params src))

;; Moves forward thru a set of values "concept"
(define-generic (next-value obj))
(define-class <stepper> () (nxtval))
(define-method (next-value (obj <stepper>))
  ((slot-value obj 'nxtval)))
(define-generic (reset obj))
(define-method (reset (obj <stepper>))
  (let-values (
      ((gen _)
        (apply
          (slot-value obj 'ctor)
          `(,@(slot-value obj 'params) ,(slot-value obj 'src))) ) )
    (set! (slot-value obj 'nxtval) gen) ) )

;; Parameterized generative set of random values "concept"
(define-class <random-distribution> (<named> <parameterized> <stepper>) (
  ;holds any value, temporarily
  tmpval ) )

;; Create an instance of <random-distribution> where the arguments are
;; the same as the documented procedural distribution API.
;;
;; SRFI 27 API: ({some distribution constructor} arg...)
;;      OO API: (make-random-distribution {some distribution constructor} arg...)
(define-syntax make-random-distribution
  (syntax-rules ()
    ((_ ?ctor ?arg0 ...)
      ;use tmpval to hold the ctor call form
      (make <random-distribution> 'tmpval (list ?ctor ?arg0 ...)) ) ) )

(define-method (initialize-instance (obj <random-distribution>))
  ; The 'ctor' must be a globally defined procedure compiled with
  ; procedure-information. So if following nomenclature then the last
  ; procedure name element will be the kind of distribution:
  ; make-random-<distribution>. And the <random-source> will be the
  ; last argument.
  ;
  ; (I do not endorse this kind of "auto-magic". For example only.)
  (let* (
      (tmpval
        (or
          (slot-value obj 'tmpval)
          `(,make-random-normals)) )
      (ctor
        (car tmpval) )
      (procinfo
        (procedure-information ctor) )
      (procname
        (and procinfo (pair? procinfo) (symbol->string (car procinfo))))
      (procname
        (and
          procname
          (and-let* ((kndpos (string-index-right procname #\-)))
            (substring/shared procname (add1 kndpos)) ) ) )
      (dstr-vals
        (receive (apply ctor (cdr tmpval))) )
      (params
        (and
          (<= 2 (length dstr-vals))
          (receive ((second dstr-vals)))) ) )
    ;"free" the temp slot
    (set! (slot-value obj 'tmpval) #f)
    ;initialize state
    (set! (slot-value obj 'namsym) (string->symbol procname))
    (set! (slot-value obj 'nxtval) (first dstr-vals))
    (set! (slot-value obj 'ctor) ctor)
    (set! (slot-value obj 'params) (and params (drop-right params 1)))
    (set! (slot-value obj 'src) (and params (last params))) ) )

#|
(use test)

(let ((expn-rd (make-random-distribution make-random-exponentials mu: 0.5)))
  (test <random-distribution> (class-of expn-rd))
  (test-assert (number? (next-value expn-rd)))
)
|#

#|
;; Use it
(use coops-extras)

(define expn-rd (make-random-distribution make-random-exponentials mu: 0.5))
(describe-object expn-rd)
;coops instance of class `<random-distribution>':
;tmpval: #f
;namsym: exponentials
;  ctor: #<procedure (srfi-27-distributions#make-random-exponentials . tmp302303)>
;params: (0.5)
;   src: #<procedure>
;nxtval: #<procedure (f_1191)>

(next-value expn-rd) ;=> ...
|#