#lang racket (require "rsound.rkt" "util.rkt" "paste-util.rkt" data/heap ffi/vector) ;; a simple rsound sequencer (provide/contract [make-unplayed-heap (-> heap?)] [queue-for-playing! (-> heap? rsound? nonnegative-integer? void?)] [heap->signal/block/unsafe (-> heap? (values procedure? procedure?))]) ;; an entry is a vector of an rsound, a start frame, and an end frame. (define-struct entry (sound start finish) #:transparent) ;; a heap of entries, ordered by start time. (define (make-unplayed-heap) (make-heap (lambda (a b) (unless (entry? a) (raise-type-error 'unplayed-heap "entry" 0 a b)) (unless (entry? b) (raise-type-error 'unplayed-heap "entry" 1 a b)) (<= (entry-start a) (entry-start b))))) ;; given a heap and a sound and a start, add the sound to the ;; heap with the given start and a computed end (define (queue-for-playing! heap sound start) (when (heap-has-false? heap) (error 'queue-for-playing "heap has false in it: ~s" (heap->vector heap))) (heap-add! heap (make-entry sound start (+ start (rs-frames sound))))) (define (heap-has-false? heap) (not (for/and ([elt (heap->vector heap)]) elt))) ;; this accepts a heap of input sound entries and produces a "sensitive" ;; signal/block that plays them, and a thunk that can be used to determine the ;; most recent value of t. It's sensitive in the sense that if you don't ;; call it with monotonically non-decreasing time values, it's going to ;; behave badly. It returns a thunk that knows the most recent value of t (define (heap->signal/block/unsafe unplayed) ;; the "playing" heap is ordered by end time, to facilitate removal (define playing (make-heap (lambda (a b) (<= (entry-finish a) (entry-finish b))))) ;; invariant: playing-vec contains the same elements as the "playing" heap. (define playing-vec (vector)) (define last-t 0) (define (get-last-t) last-t) (define (signal/block cpointer frames t) (when (< frames 0) (error 'sequencer "callback called with frames < 0: ~e\n" frames)) (define new-last-t (+ frames t)) (when (< new-last-t last-t) (error 'sequencer "new value of last-t ~e is less than old value ~e." new-last-t last-t)) (set! last-t new-last-t) ;; remove sounds that end before the start: (define sounds-removed? (clear-ended-sounds playing t)) ;; add sounds that start before the end: (define sounds-added? (add-new-sounds unplayed playing t (+ t frames))) (when (or sounds-removed? sounds-added?) (set! playing-vec (heap->vector playing))) (combine-onto! cpointer t frames playing-vec)) (values signal/block get-last-t)) ;; zero the target, and copy the appropriate regions of the ;; source sounds onto them. (define (combine-onto! cpointer t len playing-vec) (zero-buffer! cpointer len) (for ([e (in-vector playing-vec)]) (add-from-buf! cpointer t len e))) ;; given a buffer in which to assemble the sounds, a frame number t, ;; a number of frames len, and a playing entry e, add the appropriate ;; section of the entry to the buffer. ;; required: entries have finish later than start, len > 0. (define (add-from-buf! ptr t len e) (match-define (entry sound start finish) e) ;; in global time: (define copy-start (max t start)) (define copy-finish (min (+ t len) finish)) ;; must have finish later than start: (define copy-len (- copy-finish copy-start)) ;; relative to source buffer: (define src-start (- copy-start start)) ;; relative to target buffer: (define tgt-start (- copy-start t)) (rs-copy-add! ptr tgt-start sound src-start copy-len len)) ;; given a heap (ordered by ending time) and a current time, remove ;; those sounds whose ending times are <= the current time (define (clear-ended-sounds playing-heap current-time) (let loop ([removed? #f]) (cond [(= (heap-count playing-heap) 0) removed?] [else (define earliest-ending (heap-min playing-heap)) (cond [(<= (entry-finish earliest-ending) current-time) (heap-remove-min! playing-heap) (loop #t)] [else removed?])]))) ;; given a heap of queued sounds (ordered by starting time), ;; a heap of playing sounds (ordered by ending time), and ;; a time, add the sounds that begin before or on the given ending ;; time, unless they end before the given starting time. ;; return a boolean indicating whether any sounds were added. (define (add-new-sounds queued-heap playing-heap start-time stop-time) (let loop ([added? #f]) (cond [(= (heap-count queued-heap) 0) added?] [else (define earliest-to-play (heap-min queued-heap)) #;(log-debug (format "earliest: ~s\n" earliest-to-play)) (cond [(<= (entry-finish earliest-to-play) start-time) (log-warning (format "missed a queued sound entirely, because ~e<=~e" (entry-finish earliest-to-play) start-time)) (heap-remove-min! queued-heap) (loop added?)] [(<= (entry-start earliest-to-play) stop-time) (heap-add! playing-heap earliest-to-play) (heap-remove-min! queued-heap) (loop #t)] [else added?])]))) ;; oops; module+ isn't released, yet: ;(module+ test (require rackunit) ;; test of queue (let () (define h (make-unplayed-heap)) (queue-for-playing! h (clip ding 0 10000) 20000) (queue-for-playing! h ding 18000) (check-equal? (heap-count h) 2) (check-equal? (heap-min h) (entry ding 18000 (+ 18000 44100))) (heap-remove-min! h) (check rsound-equal? (entry-sound (heap-min h)) (clip ding 0 10000)) (check-equal? (entry-start (heap-min h)) 20000) (check-equal? (entry-finish (heap-min h)) 30000)) (let () (define playing-heap (make-heap (lambda (a b) (<= (entry-finish a) (entry-finish b))))) (heap-add-all! playing-heap (list (entry 'a 14 29) (entry 'b 16 21) (entry 'c 5 25) (entry 'd 3 25))) (check-equal? (heap-count playing-heap) 4) (check-equal? (heap-min playing-heap) (entry 'b 16 21)) (check-equal? (clear-ended-sounds playing-heap 22) #t) (check-equal? (heap-count playing-heap) 3) (check-equal? (clear-ended-sounds playing-heap 25) #t) (check-equal? (heap-count playing-heap) 1) (check-equal? (clear-ended-sounds playing-heap 30) #t) (check-equal? (heap-count playing-heap) 0) (check-equal? (clear-ended-sounds playing-heap 40) #f)) (let () (define queued-heap (make-unplayed-heap)) (heap-add-all! queued-heap (list (entry 'a 14 29) (entry 'b 16 21) (entry 'e 26 27) (entry 'c 5 25) (entry 'd 3 25))) (define playing-heap (make-heap (lambda (a b) (<= (entry-finish a) (entry-finish b))))) (check-equal? (heap-count queued-heap) 5) (check-equal? (heap-min queued-heap) (entry 'd 3 25)) (check-equal? (add-new-sounds queued-heap playing-heap 0 2) #f) (check-equal? (heap-count queued-heap) 5) (check-equal? (heap-count playing-heap) 0) (check-equal? (add-new-sounds queued-heap playing-heap 2 4) #t) (check-equal? (heap-count queued-heap) 4) (check-equal? (heap-count playing-heap) 1) (check-equal? (add-new-sounds queued-heap playing-heap 4 13) #t) (check-equal? (heap-count queued-heap) 3) (check-equal? (heap-count playing-heap) 2) (check-equal? (add-new-sounds queued-heap playing-heap 13 19) #t) (check-equal? (heap-count queued-heap) 1) (check-equal? (heap-count playing-heap) 4) (check-equal? (add-new-sounds queued-heap playing-heap 19 25) #f) ;; oops, missed e completely: (check-equal? (add-new-sounds queued-heap playing-heap 30 35) #f) (check-equal? (heap-count queued-heap) 0) (check-equal? (heap-count playing-heap) 4)) (let () (define src1 (rsound (make-s16vector (* channels 200) 1) 0 200 44100)) (define entry1 (entry src1 50 250)) (define entry2 (entry src1 65 265)) (define dst1 (make-s16vector (* channels 10) 0)) (check-equal? (s16vector->list dst1) (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (add-from-buf! (s16vector->cpointer dst1) 45 10 entry1) (check-equal? (s16vector->list dst1) (list 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)) (define dst2 (make-s16vector 20 0)) (add-from-buf! (s16vector->cpointer dst2) 60 10 entry1) (add-from-buf! (s16vector->cpointer dst2) 60 10 entry2) (check-equal? (s16vector->list dst2) (list 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2)) (define dst3 (make-s16vector 20 0)) (define src3 (rsound (make-s16vector 10 2) 1 5 44100)) (define entry3 (entry src3 70 74)) (add-from-buf! (s16vector->cpointer dst3) 68 10 entry1) (add-from-buf! (s16vector->cpointer dst3) 68 10 entry3) (check-equal? (s16vector->list dst3) (list 1 1 1 1 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1)) ) (let () (define s1 (rsound (make-s16vector 20 2) 0 10 44100)) (define s2 (rsound (make-s16vector 4 3) 0 2 44100)) (define s3 (rsound (make-s16vector 30 4) 0 15 44100)) (define unplayed-heap (make-unplayed-heap)) (queue-for-playing! unplayed-heap s1 15) (queue-for-playing! unplayed-heap s1 17) (queue-for-playing! unplayed-heap s3 37) (queue-for-playing! unplayed-heap s2 41) (define tgt (make-s16vector 20 123)) (define tgt-ptr (s16vector->cpointer tgt)) (define-values (test-signal/block last-time) (heap->signal/block/unsafe unplayed-heap)) (test-signal/block tgt-ptr 10 0) (check-equal? (s16vector->list tgt) (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (check-equal? (last-time) 10) (test-signal/block tgt-ptr 10 10) (check-equal? (s16vector->list tgt) (list 0 0 0 0 0 0 0 0 0 0 2 2 2 2 4 4 4 4 4 4)) (test-signal/block tgt-ptr 10 20) (check-equal? (s16vector->list tgt) (list 4 4 4 4 4 4 4 4 4 4 2 2 2 2 0 0 0 0 0 0)) (test-signal/block tgt-ptr 10 30) (check-equal? (s16vector->list tgt) (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 4 4 4 4 4)) (test-signal/block tgt-ptr 10 40) (check-equal? (s16vector->list tgt) (list 4 4 7 7 7 7 4 4 4 4 4 4 4 4 4 4 4 4 4 4)) (check-equal? (last-time) 50)) ;)