1;;; examples of extensions to Snd's graphics 2 3(provide 'snd-draw.scm) 4 5(define overlay-rms-env 6 7 ;; these functions are an optimization to speed up calculating the rms env graph. 8 ;; ideally we'd use something like: 9 ;; 10 ;; (let* ((x1 (x->position (/ i (srate)) snd chn)) 11 ;; (y1 (y->position (moving-rms rms (reader)) snd chn))) 12 ;; (draw-line x0 y0 x1 y1) 13 ;; 14 ;; in the do-loop below that runs through the samples, but I haven't added x|y->position or draw-line 15 ;; to the optimizer ("run"), and each would be looking up the graph axis info on each call even if 16 ;; available to the optimizer -- this seems wasteful. So, the grf-it function below is using the 17 ;; axis info in axinf to get the pixel location for the envelope line segment break point. 18 ;; Also, draw-lines takes a vector for some reason, so we need to tell "run" that it is an 19 ;; integer vector (and preload it with 0). We save the vector in the channel property 'rms-lines, 20 ;; and the associated axis info in 'rms-axis-info. Since redisplay is common in Snd, it reduces 21 ;; flicker a lot to have this data instantly available. 22 23 (let ((pack-x-info (lambda (axinf) 24 (float-vector (axinf 2) ; x0 25 (axinf 4) ; x1 26 (axinf 10) ; x_axis_x0 27 (axinf 12) ; x_axis_x1 28 (axinf 15) ; scale 29 (- (axinf 10) (* (axinf 2) (axinf 15)))))) ; base 30 (pack-y-info (lambda (axinf) 31 (float-vector (axinf 3) ; y0 32 (axinf 5) ; y1 33 (axinf 11) ; y_axis_y0 34 (axinf 13) ; y_axis_y1 35 (axinf 16) ; scale 36 (- (axinf 11) (* (axinf 3) (axinf 16)))))) ; base 37 (grf-it (lambda (val v) 38 (round 39 (if (>= val (v 1)) 40 (v 3) 41 (if (<= val (v 0)) 42 (v 2) 43 (+ (v 5) (* val (v 4)))))))) 44 45 (make-moving-rms (lambda* ((size 128)) 46 (make-moving-average size))) 47 48 (moving-rms (lambda (gen y) 49 (sqrt (moving-average gen (* y y)))))) 50 51 (lambda (snd chn) 52 (let ((red (make-color 1 0 0)) ; rms env displayed in red 53 (left (left-sample snd chn)) 54 (right (right-sample snd chn)) 55 (rms-size 128) ; this could be a parameter -- not sure what the "right" size is 56 (sr (/ 1.0 (srate snd))) 57 (old-color (foreground-color snd chn)) 58 (axinf (axis-info snd chn)) 59 (old-axinf (channel-property 'rms-axis-info snd chn))) 60 61 (if (equal? axinf old-axinf) ; the previously calculated lines can be re-used 62 (begin 63 (set! (foreground-color snd chn) red) 64 (draw-lines (channel-property 'rms-lines snd chn) snd chn time-graph #f) 65 (set! (foreground-color snd chn) old-color)) 66 (let ((start (max 0 (- left rms-size)))) 67 (let ((xdata (pack-x-info axinf)) 68 (ydata (pack-y-info axinf)) 69 (reader (make-sampler start snd chn)) 70 (rms (make-moving-rms rms-size)) 71 (x0 0) 72 (y0 0) 73 (line-ctr 2) 74 (lines (make-vector (* 2 (- (+ (axinf 12) 1) (axinf 10))) 0))) 75 (dynamic-wind 76 (lambda () 77 (set! (foreground-color snd chn) red)) 78 (lambda () 79 (if (< start left) ; check previous samples to get first rms value 80 (do ((i start (+ 1 i))) 81 ((= i left)) 82 (moving-rms rms (reader)))) 83 (let ((first-sample (next-sample reader))) 84 (set! x0 (grf-it (* left sr) xdata)) 85 (set! y0 (grf-it first-sample ydata))) 86 (set! (lines 0) x0) ; first graph point 87 (set! (lines 1) y0) 88 (do ((i (+ left 1) (+ 1 i))) ; loop through all samples calling moving-rms 89 ((= i right)) 90 (let ((x1 (grf-it (* i sr) xdata)) 91 (y (moving-rms rms (next-sample reader)))) 92 (if (> x1 x0) ; very often many samples are represented by one pixel 93 (let ((y1 (grf-it y ydata))) 94 (set! (lines line-ctr) x1) 95 (set! (lines (+ 1 line-ctr)) y1) 96 (set! line-ctr (+ line-ctr 2)) 97 (set! x0 x1) 98 (set! y0 y1))))) ; else should we do "max" here? or draw a vertical line from min to max? 99 (if (< line-ctr (length lines)) 100 (do ((j line-ctr (+ j 2))) ; off-by-one in vector size calc -- need to pad so we don't get a bogus line to (0, 0) 101 ((>= j (length lines))) 102 (set! (lines j) x0) 103 (set! (lines (+ j 1)) y0))) 104 (draw-lines lines snd chn time-graph #f) 105 (set! (channel-property 'rms-lines snd chn) lines) ; save current data for possible redisplay 106 (set! (channel-property 'rms-axis-info snd chn) axinf)) 107 (lambda () 108 (set! (foreground-color snd chn) old-color)))))))))) 109 110;; (hook-push after-graph-hook (lambda (hook) (overlay-rms-env (hook 'snd) (hook 'chn)))) 111 112 113(define display-colored-samples 114 (let ((+documentation+ "(display-colored-samples color beg dur snd chn) displays samples from beg for dur in color 115whenever they're in the current view.")) 116 (lambda* (color beg dur snd chn) 117 (let ((left (left-sample snd chn)) 118 (right (right-sample snd chn)) 119 (end (+ beg dur)) 120 (old-color (foreground-color snd chn))) 121 (when (and (< left end) 122 (> right beg)) 123 (let ((data (make-graph-data snd chn))) 124 (if (float-vector? data) 125 (let ((new-data (let ((samps (- (min right end) (max left beg))) 126 (offset (max 0 (- beg left)))) 127 (float-vector-subseq data offset (+ offset samps))))) 128 (set! (foreground-color snd chn) color) 129 (graph-data new-data snd chn copy-context (max beg left) (min end right) (time-graph-style snd chn) #f) 130 (set! (foreground-color snd chn) old-color)) 131 (let* ((size (length (car data))) 132 (samps (- right left)) 133 (left-bin (floor (/ (* size (max 0 (- beg left))) samps))) 134 (right-bin (floor (/ (* size (- (min end right) left)) samps))) 135 (new-low-data (float-vector-subseq (car data) left-bin right-bin)) 136 (new-high-data (float-vector-subseq (cadr data) left-bin right-bin))) 137 (set! (foreground-color snd chn) color) 138 (graph-data (list new-low-data new-high-data) snd chn copy-context left-bin right-bin (time-graph-style snd chn) #f) 139 (set! (foreground-color snd chn) old-color))))))))) 140 141 142(define (display-samples-in-color hook) 143 (let ((snd (hook 'snd)) 144 (chn (hook 'chn))) 145 ;; intended as after-graph-hook member 146 ;; run through 'colored-samples lists passing each to display-colored-samples 147 (let ((colors (channel-property 'colored-samples snd chn))) 148 (if (pair? colors) 149 (for-each 150 (lambda (vals) 151 (apply display-colored-samples (append vals (list snd chn)))) 152 colors))))) 153 154 155(define color-samples 156 (let ((+documentation+ "(color-samples color beg dur snd chn) causes samples from beg to beg+dur to be displayed in color")) 157 (lambda* (color ubeg udur usnd uchn) 158 (if (not (member display-samples-in-color (hook-functions after-graph-hook))) 159 (hook-push after-graph-hook display-samples-in-color)) 160 (let ((snd (or usnd (selected-sound) (car (sounds))))) 161 (let ((chn (or uchn (selected-channel snd) 0)) 162 (beg (or ubeg 0))) 163 (let ((dur (or udur (- (framples snd chn) beg))) 164 (old-colors (or (channel-property 'colored-samples snd chn) ()))) 165 (set! (channel-property 'colored-samples snd chn) (cons (list color beg dur) old-colors)) 166 (update-time-graph snd chn))))))) 167 168 169(define uncolor-samples 170 (let ((+documentation+ "(uncolor-samples snd chn) cancels sample coloring in the given channel")) 171 (lambda* (usnd uchn) 172 (let* ((snd (or usnd (selected-sound) (car (sounds)))) 173 (chn (or uchn (selected-channel snd) 0))) 174 (set! (channel-property 'colored-samples snd chn) ()) 175 (update-time-graph snd chn))))) 176 177 178(define display-previous-edits 179 (let ((+documentation+ "(display-previous-edits snd chn) displays all edits of the current sound, with older versions gradually fading away")) 180 (lambda (snd chn) 181 (let ((edits (edit-position snd chn))) 182 (when (> edits 0) 183 (let* ((old-color (foreground-color snd chn)) 184 (clist (color->list old-color))) 185 (let ((rinc (/ (- 1.0 (car clist)) (+ edits 1))) 186 (ginc (/ (- 1.0 (cadr clist)) (+ edits 1))) 187 (binc (/ (- 1.0 (caddr clist)) (+ edits 1)))) 188 (do ((pos 0 (+ 1 pos)) 189 (re (- 1.0 rinc) (- re rinc)) 190 (ge (- 1.0 ginc) (- ge ginc)) 191 (be (- 1.0 binc) (- be binc))) 192 ((> pos edits)) 193 (let ((data (make-graph-data snd chn pos))) 194 (set! (foreground-color snd chn) (make-color re ge be)) 195 (graph-data data snd chn copy-context #f #f (time-graph-style snd chn) #f))) 196 (set! (foreground-color snd chn) old-color)))))))) 197 198(define overlay-sounds 199 (let ((+documentation+ "(overlay-sounds . args) overlays onto its first argument all subsequent arguments: (overlay-sounds 1 0 3)")) 200 (lambda args 201 (let ((base (if (integer? (car args)) 202 (integer->sound (car args)) 203 (car args)))) 204 (hook-push after-graph-hook 205 (lambda (hook) 206 (let ((snd (hook 'snd)) 207 (chn (hook 'chn))) 208 (if (equal? snd base) 209 (for-each 210 (lambda (nsnd) 211 (if (and (sound? nsnd) 212 (> (chans nsnd) chn)) 213 (graph-data (make-graph-data nsnd chn) base chn copy-context #f #f graph-dots #f))) 214 (cdr args)))))))))) 215 216 217(define samples-via-colormap 218 (let ((+documentation+ "(samples-via-colormap snd chn) displays time domain graph using current colormap (just an example of colormap-ref)")) 219 (lambda (snd chn) 220 (let ((data (make-graph-data snd chn))) 221 (define (samples-1 cur-data) 222 (let ((left (left-sample snd chn)) 223 (right (right-sample snd chn)) 224 (old-color (foreground-color snd chn)) 225 (y0 (y->position (cur-data 0))) 226 (colors (make-vector *colormap-size* #f)) 227 (len (length cur-data))) 228 (let ((x0 (x->position (/ left (srate snd)))) 229 (incr (/ (- (+ right 1) left) len))) 230 (do ((i (+ left incr) (+ i incr)) 231 (j 1 (+ 1 j))) 232 ((or (>= i right) 233 (>= j len))) 234 (let ((x1 (x->position (/ i (srate snd)))) 235 (y1 (y->position (cur-data j)))) 236 (let* ((x (abs (cur-data j))) 237 (ref (floor (* *colormap-size* x)))) 238 (set! (foreground-color snd chn) 239 (or (colors ref) 240 (let ((new-color (apply make-color (colormap-ref (colormap) x)))) 241 (set! (colors ref) new-color))))) 242 (draw-line x0 y0 x1 y1 snd chn time-graph #f) 243 (set! x0 x1) 244 (set! y0 y1))) 245 (set! (foreground-color snd chn) old-color)))) 246 247 (when data 248 (if (float-vector? data) 249 (samples-1 data) 250 (begin 251 (samples-1 (car data)) 252 (samples-1 (cadr data))))))))) 253 254