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