make_instrument   xtlang


Defined in:  https://github.com/digego/extempore/tree/v0.8.9/libs/external/instruments_ext.xtm

Implementation

;; make sampler instrument
(bind-func make_instrument
  (lambda (note_kernel:NOTE_KERNEL_SAMPLER effect_kernel:FX_KERNEL)
    (effect_kernel.notekernel:NOTE_KERNEL_SAMPLER note_kernel)
    (let ((poly:i64 36)
          (samples:|20,|128,SAMPLE*||* (zalloc)) ;; 128 samples * 20 'banks'
          (samples_length:|20,|128,i64||* (zalloc)) ;; 128 samples * 20
          (samples_channels:|20,|128,i64||* (zalloc)) ;; 128 samples * 20
          (samples_offsets:|20,|128,i64||* (zalloc)) ;; 128 samples * 20
          (notes:NoteData** (zalloc poly))
          (note:NoteData* null)
          (kernels:[SAMPLE,i64,i64]** (zalloc poly))
          (kernel:[SAMPLE,i64,i64]* null)
          (starttime:i64 0)
          (out:SAMPLE 0.0)
          (k:i64 0) (i:i64 0)
          (new_note (lambda (start:i64 freq:SAMPLE dur:i64 amp:SAMPLE nargs:i64 dargs:SAMPLE*)
                      (let ((free_note (instrument_find_note notes poly))
                            (idx (note_idx free_note))
                            (zone (note_zone (free_note)))
                            (bank:i32 (if (< nargs 1) (i64toi32 0) (convert (pref dargs 0))))
                            (midiidx:i64 (convert (floor (frq2midi freq))))
                            (closest 1000000)
                            (i:i64 0) (iii:i64 0) (idxi:i64 0)
                            (new_idx idx))
                        (dotimes (idxi 128)
                          (let ((v (llabs (- midiidx idxi))))
                            (if (and (<> (aref (aref-ptr samples_length bank) idxi) 0)
                                     (< v closest))
                                (begin (set! new_idx idxi)
                                       (set! closest v) 0))))
                        (if (or (< (- (aref (aref-ptr samples_length bank) new_idx) 10) 1)
                                (null? (aref (aref-ptr samples bank) new_idx)))
                            (begin 
                              (println 'No 'samples 'loaded 'in 'bank bank) 
                              null)
                            (if (null? free_note)
                                null
                                (if (note_active free_note)
                                    (begin
                                      ;; existing kernel is still in use!
                                      ;; simply update note details (i.e. data) and keep on truckin!
                                      (tfill! free_note idx start freq amp dur 1.0 #t 0 (cast zone))
                                      free_note)
                                    (begin ;; new kernel required!
                                      (reset_zone zone)
                                      (push_zone zone)
                                      (tfill! free_note idx start freq amp dur 1.0 #t 0 (cast zone))
                                      (pset! kernels idx (note_kernel free_note
                                                                      (aref-ptr samples bank)
                                                                      (aref-ptr samples_length bank)
                                                                      (aref-ptr samples_offsets bank)
                                                                      (aref-ptr samples_channels bank)
                                                                      new_idx
                                                                      nargs
                                                                      dargs))
                                      (pop_zone)
                                      free_note))))))))
      (dotimes (k 128)
        (dotimes (i 20) ;20 banks
          (aset! (aref-ptr samples_offsets i) k 0)
          (aset! (aref-ptr samples_length i) k 0)))
      ;; init notes
      (dotimes (i poly)
        (pset! kernels i (cast null))
        (pset! notes i (NoteData i 0 0.0 0.0 0 1.0 #f 0 (cast (create_zone (* 10 1024))))))
      (lambda (in:SAMPLE time:i64 chan:i64 dat:SAMPLE*)
        (set! out 0.0)
        (dotimes (k poly) ;; sum all active notes
          (set! note (pref notes k))
          (set! starttime (note_starttime note))
          (if (not (note_active note)) (pset! kernels k (cast null)))
          (set! kernel (pref kernels k))
          (if (and (> time starttime) (not (null? kernel)))
              (set! out (+ out (* 0.3 (kernel time chan))))))
        (* 2.0 (effect_kernel out time chan dat))))))


Back to Index

Similar Entries

  • CV_MAKE_TYPE    xtlang
  • aiProcess_MakeLeftHanded    scheme
  • cl:make-list    scheme
  • cvMakeColour    xtlang
  • glfw_make_context_current    xtlang
  • impc:ir:compile:make-closure    scheme
  • impc:ir:compile:make-closureenv    scheme
  • impc:ir:compile:make-env    scheme
  • impc:ir:compile:make-static    scheme
  • impc:ir:compiler:make-array    scheme
  • impc:ir:compiler:make-tuple    scheme
  • impc:ir:compiler:make-vector    scheme
  • impc:ir:make-arglist-str    scheme
  • impc:ir:make-const-string    scheme
  • impc:ir:make-function-str    scheme
  • impc:ir:make-string    scheme
  • impc:ir:make-struct-str    scheme
  • impc:ir:make-struct-str-env    scheme
  • impc:ti:make-array-check    scheme
  • impc:ti:make-tuple-check    scheme
  • impc:ti:make-vector-check    scheme
  • impc:ti:nativef-generics-make-gtypes-unique    scheme
  • instrument_find_note    xtlang
  • make-bezier    scheme
  • make-envelope    xtlang
  • make-environment    macro
  • make-instrument    macro
  • make-list    scheme
  • make-list-with-proc    scheme
  • make-metre    scheme
  • make-metro    scheme
  • make-rhythm    scheme
  • make-timeline    scheme
  • make-vector-with-proc    scheme
  • make_bodies    xtlang
  • make_instrument    xtlang
  • make_mono    xtlang
  • make_static_scheme_wrapper_ir    scheme
  • make_window_transparent    xtlang
  • match-result:make    scheme
  • matcher:make    scheme
  • my-inc-maker    xtlang
  • my-inc-maker-wrapper    xtlang
  • pc:make-chord    scheme
  • pc:make-chord-fixed    scheme
  • plet-make-bindings    scheme
  • sys_dir_make    xtlang
  • sys_dir_make_recursive    xtlang
  • xtm_make_model    xtlang