Changeset 34865 in project for release/4/srfi-27/OO-example.scm


Ignore:
Timestamp:
11/05/17 20:52:24 (3 years ago)
Author:
Kon Lovett
Message:

mv chk bfr 1st use , re-flow

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-27/OO-example.scm

    r34715 r34865  
    1 
    2 ;;; A silly OO version of random distribution generator
    3 
    4 (use srfi-1 srfi-13 coops)
     1(use srfi-1 srfi-13 coops srfi-27-distributions)
    52
    63;; Named (has a name) "concept"
    7 ;;
    84(define-generic (name obj))
    95(define-class <named> () (
    10   (namsym #:reader name) ) )
     6  (namsym reader: name) ) )
    117
    128;; Parameterized extension "concept"
    13 ;;
    14 ;FIXME by having 'src' separate makes dependent on 'ctor' argument order
    159(define-class <parameterized> () (ctor params src))
    1610
    1711;; Moves forward thru a set of values "concept"
    18 ;;
    1912(define-generic (next-value obj))
    20 (define-generic (reset obj))
    21 
     13(define-class <stepper> () (nxtval))
    2214(define-method (next-value (obj <stepper>))
    2315  ((slot-value obj 'nxtval)))
    24 
     16(define-generic (reset obj))
    2517(define-method (reset (obj <stepper>))
    26   (receive (gen _)
    27             (apply
    28               (slot-value obj 'ctor)
    29               `(,@(slot-value obj 'params) ,(slot-value obj 'src)))
     18  (let-values (
     19      ((gen _)
     20        (apply
     21          (slot-value obj 'ctor)
     22          `(,@(slot-value obj 'params) ,(slot-value obj 'src))) ) )
    3023    (set! (slot-value obj 'nxtval) gen) ) )
    3124
    3225;; Parameterized generative set of random values "concept"
    33 ;;
    3426(define-class <random-distribution> (<named> <parameterized> <stepper>) (
    3527  ;holds any value, temporarily
     
    4133;; SRFI 27 API: ({some distribution constructor} arg...)
    4234;;      OO API: (make-random-distribution {some distribution constructor} arg...)
    43 ;;
    4435(define-syntax make-random-distribution
    4536  (syntax-rules ()
     
    4839      (make <random-distribution> 'tmpval (list ?ctor ?arg0 ...)) ) ) )
    4940
    50 ;;
    5141(define-method (initialize-instance (obj <random-distribution>))
    52   ;
    5342  ; The 'ctor' must be a globally defined procedure compiled with
    5443  ; procedure-information. So if following nomenclature then the last
     
    5847  ;
    5948  ; (I do not endorse this kind of "auto-magic". For example only.)
    60   ;
    6149  (let* (
    62       (ctor-form
     50      (tmpval
    6351        (or
    6452          (slot-value obj 'tmpval)
    6553          `(,make-random-normals)) )
    6654      (ctor
    67         (car ctor-form) )
    68       (ctor-args
    69         (cdr ctor-form) )
     55        (car tmpval) )
    7056      (procinfo
    7157        (procedure-information ctor) )
     
    7763          (and-let* ((kndpos (string-index-right procname #\-)))
    7864            (substring/shared procname (add1 kndpos)) ) ) )
    79       ;(<generator-thunk> [<parameters-thunk>])
    8065      (dstr-vals
    81         (receive (apply ctor ctor-args)) )
    82       (genny
    83         (first dstr-vals) )
     66        (receive (apply ctor (cdr tmpval))) )
    8467      (params
    85         (and (<= 2 (length dstr-vals)) (receive ((second dstr-vals))) ) ) )
     68        (and
     69          (<= 2 (length dstr-vals))
     70          (receive ((second dstr-vals)))) ) )
    8671    ;"free" the temp slot
    8772    (set! (slot-value obj 'tmpval) #f)
    8873    ;initialize state
    8974    (set! (slot-value obj 'namsym) (string->symbol procname))
    90     (set! (slot-value obj 'nxtval) genny)
     75    (set! (slot-value obj 'nxtval) (first dstr-vals))
    9176    (set! (slot-value obj 'ctor) ctor)
    92     (set! (slot-value obj 'params) (if (pair? params) (drop-right params 1) '()))
    93     (set! (slot-value obj 'src) (and (pair? params) (last params))) ) )
     77    (set! (slot-value obj 'params) (and params (drop-right params 1)))
     78    (set! (slot-value obj 'src) (and params (last params))) ) )
    9479
    9580#|
    9681(use test)
    97 (use srfi-27-distributions)
    9882
    99 (let ((expn-rd (make-random-distribution make-random-exponentials #:mu 0.5)))
     83(let ((expn-rd (make-random-distribution make-random-exponentials mu: 0.5)))
    10084  (test <random-distribution> (class-of expn-rd))
    10185  (test-assert (number? (next-value expn-rd)))
     
    10589#|
    10690;; Use it
    107 (use srfi-27-distributions coops-extras)
     91(use coops-extras)
    10892
    109 (define expn-rd (make-random-distribution make-random-exponentials #:mu 0.5))
     93(define expn-rd (make-random-distribution make-random-exponentials mu: 0.5))
    11094(describe-object expn-rd)
    11195;coops instance of class `<random-distribution>':
    112 ;tmpval : #f
    113 ;namsym : exponentials
    114 ;params : (0.5)
    115 ;   src : #<procedure (f_1415)>
    116 ;nxtval : #<procedure (f_1037)>
     96;tmpval: #f
     97;namsym: exponentials
     98;  ctor: #<procedure (srfi-27-distributions#make-random-exponentials . tmp302303)>
     99;params: (0.5)
     100;   src: #<procedure>
     101;nxtval: #<procedure (f_1191)>
    117102
    118103(next-value expn-rd) ;=> ...
Note: See TracChangeset for help on using the changeset viewer.