Changeset 30701 in project


Ignore:
Timestamp:
04/14/14 09:56:57 (7 years ago)
Author:
Ivan Raikov
Message:

picnic: initial support for perturbation components

Location:
release/4/picnic/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/picnic/trunk/examples/GLHP.picnic

    r30700 r30701  
    9797         
    9898         (component (type section) (name ParallelFibers)
    99 #|
    100          (component (type perturbation)
    101 
    102                     (define pc (gid origin init)
    103                       (let ((freq (randomUniform (1.0 ~ (PFlength / 40.0) ~ init))))
    104 
    105                         ;; SineCurve (frequency, amplitude)
    106                         (SineCurve (freq 1.0))))
    107 
    108                     (const n = 4)
    109 
    110                     (output pc n)
    111                      
    112                     )
    113 
    114          (component (type perturbation)
    115 
    116                     (define pc (gid origin init)
    117                       (let ((slope (randomUniform (1.0 ~ (PFlength / 40.0) ~ init))))
    118 
    119                         ;; TanhCurve (onset, slope, amplitude)
    120                         (TanhCurve (0.0 freq 1.0))))
    121 
    122                     (const n = 4)
    123 
    124                     (output pc n)
    125                      
    126                     )
    127 |#
     99
     100                    (component (type perturbation)
     101                               
     102                               (defun pf (gid origin init)
     103                                 (let ((period (randomUniform (1.0 ~ (PFlength / 40.0) ~ init)))
     104                                       (phase  (randomUniform (0.0 ~ 0.5 ~ init))))
     105                                   ;; Harmonic (amplitude period phase)
     106                                   (Harmonic (1.0 period phase))))
     107                               
     108                               (const n = 4)
     109                               
     110                               (p (s) = (generator pf) (npts 200))
     111
     112                               (output s n)
     113                               
     114                               )
    128115
    129116                    (defun f (gid origin)
  • release/4/picnic/trunk/picnic-core.scm

    r30692 r30701  
    187187          (PS         (name symbol?)
    188188                      (gfun symbol?)
    189                       (cfun (lambda (x) (or (not x) (symbol? x))))
    190189                      (initial  (lambda (x) (or (not x) (rhs? x))))
    191190                      (npts integer?)
     
    302301
    303302          (define builtin-path-ops
    304                 `(SimpleCurve LineSegment)
     303                `(LineSegment Harmonic)
    305304                )
    306305
     
    331330
    332331                  (path-procs
    333                    (list make-simple-curve make-line-segment)
     332                   (list make-line-segment make-harmonic)
    334333                   )
    335334
    336335                  (path-exprs
    337                    '(make-simple-curve make-line-segment)
     336                   '(make-line-segment make-harmonic)
    338337                   )
    339338
     
    386385                        path-procs
    387386                        path-exprs
    388                         `((,proctype ,proctype  ,proctype  ,inttype)
    389                           (,pointtype ,fptype  ,fptype ,fptype))
     387                        `((,pointtype ,fptype  ,fptype  ,fptype)
     388                          (,fptype ,fptype ,fptype))
    390389                        `(,pathtype ,pathtype)
    391390                        )
     
    714713                                   (alst  (filter identity alst))
    715714                                   (gfun  (lookup-def 'gfun alst))
    716                                    (cfun  (lookup-def 'compose alst))
    717715                                   (npts  (lookup-def 'npts alst))
    718716                                   (initial (lookup-def 'initial alst))
     
    735733                                  ))
    736734
    737                               (if cfun
    738                                   (let ((cfun-proc (hash-table-ref local-env cfun)))
    739                                     (let* ((fd   (procedure-data cfun-proc))
    740                                            (fms  (lookup-def 'formals fd)))
    741                                       (if (not (= (length fms) 2))
    742                                           (picnic:error 'env-extend! "process composition function must take two arguments"))
    743                                       )))
    744 
    745735                              (if (not npts)
    746736                                  (picnic:error 'env-extend! "process definitions require number of points"))
     
    751741                                                          (sprintf "initial value for process ~A" sym)))))
    752742
    753                                 (hash-table-set! picnic-env sym (PS name gfun cfun initial-expr npts)))
     743                                (hash-table-set! picnic-env sym (PS name gfun initial-expr npts)))
    754744                             
    755745                              ))
  • release/4/picnic/trunk/picnic-utils.scm

    r30692 r30701  
    266266        (define (make-simple-curve fx fy fz n)
    267267          (let ((c (pcurve:simple-curve n 1 (list fx fy fz) 0.0 1.0)))
     268            c
     269            ))
     270       
     271
     272        (define (make-harmonic amp period phase)
     273          (let* ((freq (/ (* 2 PI) period))
     274                 (c (pcurve:simple-curve
     275                    10 1 (list (lambda (t) (* amp (cos (+ (* freq t) phase))))
     276                               (lambda (t) t)
     277                               (lambda (t) 0.0))
     278                    0.0 1.0)))
    268279            c
    269280            ))
  • release/4/picnic/trunk/picnic.scm

    r30685 r30701  
    4545
    4646(define-record-type section-descriptor
    47   (make-section-descriptor label processes)
     47  (make-section-descriptor label processes perturbations)
    4848  section-descriptor?
    4949  (label section-descriptor-label)
    5050  (processes section-descriptor-processes)
     51  (perturbations section-descriptor-perturbations)
    5152  )
    5253
     
    375376                               (let (
    376377                                     (label (cn section))
    377                                      (exports (component-exports sys (cid section)))
    378                                      (imports (component-imports sys (cid section)))
     378                                     (exports  (component-exports sys (cid section)))
     379                                     (imports  (component-imports sys (cid section)))
     380                                     (perturbs (filter-map (lambda (x)
     381                                                             (let ((comp (and (eq? (car x) 'perturbation) (second x))))
     382                                                               (component-exports sys comp)
     383                                                               ))
     384                                                           (subcomps sys (cid section))))
    379385                                     )
    380386                                 (d "label of ~A = ~A~%" (cid section) label)
    381387                                 (d "exports in ~A = ~A~%" section exports)
    382388                                 (d "imports in ~A = ~A~%" section imports)
     389                                 (d "perturbations in ~A = ~A~%" section perturbs)
    383390                                 (cons label
    384391                                       (make-section-descriptor
     
    399406                                                   (recur (cons (take exports 2) prs)
    400407                                                          (drop exports 2))))
    401                                              )))
     408                                             )
     409                                        perturbs
     410                                        ))
    402411                                       ))
    403412                             (rest sections)))
     
    624633
    625634                               
    626 (define (invoke-generator/scheme sys section-name section-processes layout-name forest-name forest-type)
     635(define (invoke-generator/scheme sys section-name
     636                                 section-processes section-perturbations
     637                                 layout-name forest-name forest-type)
    627638  (let* ((origin (gensym 'p))
    628639         (make-section (cases picnic:quantity
     
    777788            ,(map
    778789              (lambda (section section-name)
    779                 (let ((section-processes (section-descriptor-processes section))
     790                (let ((section-perturbations (section-descriptor-perturbations section))
     791                      (section-processes (section-descriptor-processes section))
    780792                      (section-label (section-descriptor-label section)))
    781793                  `(,section-name
    782                     ,(invoke-generator/scheme sys section-label section-processes layout-name
    783                                               (cn forest) (forest-type forest)))
     794                    ,(invoke-generator/scheme sys section-label
     795                                              section-processes section-perturbations
     796                                              layout-name (cn forest) (forest-type forest)))
    784797                  ))
    785798              sections
Note: See TracChangeset for help on using the changeset viewer.