draw.scm 10.4 KB
Newer Older
1 2 3 4 5
;;; examples of extensions to Snd's graphics

(provide 'snd-draw.scm)

(define (overlay-rms-env snd chn)
6 7 8 9 10 11 12 13 14 15
  (let ((red (make-color 1 0 0))            ; rms env displayed in red
	(left (left-sample snd chn))
	(right (right-sample snd chn))
	(rms-size 128)                      ; this could be a parameter -- not sure what the "right" size is
	(sr (/ 1.0 (srate snd)))
	(old-color (foreground-color snd chn))
	(axinf (axis-info snd chn))
	(old-axinf (channel-property 'rms-axis-info snd chn))
	(cr (make-cairo (car (channel-widgets snd chn)))))
    
16 17 18 19 20 21 22 23 24 25 26 27 28 29
    ;; these functions are an optimization to speed up calculating the rms env graph.
    ;; ideally we'd use something like:
    ;;
    ;;   (let* ((x1 (x->position (/ i (srate)) snd chn))
    ;;          (y1 (y->position (moving-rms rms (reader)) snd chn)))
    ;;     (draw-line x0 y0 x1 y1)
    ;;
    ;; in the do-loop below that runs through the samples, but I haven't added x|y->position or draw-line
    ;; to the optimizer ("run"), and each would be looking up the graph axis info on each call even if
    ;; available to the optimizer -- this seems wasteful.  So, the grf-it function below is using the
    ;; axis info in axinf to get the pixel location for the envelope line segment break point.
    ;; Also, draw-lines takes a vector for some reason, so we need to tell "run" that it is an
    ;; integer vector (and preload it with 0).  We save the vector in the channel property 'rms-lines,
    ;; and the associated axis info in 'rms-axis-info.  Since redisplay is common in Snd, it reduces
30
    ;; flicker a lot to have this data instantly available.
31
    
32
    (define (pack-x-info axinf)
33 34 35 36 37 38 39
      (float-vector (axinf 2) ;  x0
		    (axinf 4) ;  x1
		    (axinf 10) ; x_axis_x0
		    (axinf 12) ; x_axis_x1
		    (axinf 15) ; scale
		    (- (axinf 10) (* (axinf 2) (axinf 15))))) ; base
    
40
    (define (pack-y-info axinf)
41 42 43 44 45 46 47
      (float-vector (axinf 3) ;  y0
		    (axinf 5) ;  y1
		    (axinf 11) ; y_axis_y0
		    (axinf 13) ; y_axis_y1
		    (axinf 16) ; scale
		    (- (axinf 11) (* (axinf 3) (axinf 16))))) ; base
    
48 49
    (define (grf-it val v)
      (round
50 51 52 53 54
       (if (>= val (v 1))
	   (v 3)
	   (if (<= val (v 0))
	       (v 2)
	       (+ (v 5) (* val (v 4)))))))
55
    
56
    (define* (make-moving-rms (size 128))
57
      (make-moving-average size))
58
    
59 60
    (define (moving-rms gen y)
      (sqrt (moving-average gen (* y y))))
61
    
62 63 64
    (if (equal? axinf old-axinf)                    ; the previously calculated lines can be re-used
	(begin
	  (set! (foreground-color snd chn) red)
65
	  (draw-lines (channel-property 'rms-lines snd chn) snd chn time-graph cr)
66
	  (set! (foreground-color snd chn) old-color))
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
	(let ((start (max 0 (- left rms-size))))
	  (let ((xdata (pack-x-info axinf))
		(ydata (pack-y-info axinf))
		(reader (make-sampler start snd chn))
		(rms (make-moving-rms rms-size))
		(x0 0)
		(y0 0)
		(line-ctr 2)
		(lines (make-vector (* 2 (- (+ (axinf 12) 1) (axinf 10))) 0)))
	    (dynamic-wind
		(lambda ()
		  (set! (foreground-color snd chn) red))
		(lambda ()
		  (if (< start left)                 ; check previous samples to get first rms value
		      (do ((i start (+ 1 i))) 
			  ((= i left))
			(moving-rms rms (reader))))
		  (let ((first-sample (next-sample reader)))
		    (set! x0 (grf-it (* left sr) xdata))
		    (set! y0 (grf-it first-sample ydata)))
		  (set! (lines 0) x0)                ; first graph point
		  (set! (lines 1) y0)
		  (do ((i (+ left 1) (+ 1 i)))       ; loop through all samples calling moving-rms
		      ((= i right))
		    (let ((x1 (grf-it (* i sr) xdata))
			  (y (moving-rms rms (next-sample reader))))
		      (if (> x1 x0)                 ; very often many samples are represented by one pixel
			  (let ((y1 (grf-it y ydata)))
			    (set! (lines line-ctr) x1)
			    (set! (lines (+ 1 line-ctr)) y1)
			    (set! line-ctr (+ line-ctr 2))
			    (set! x0 x1)
			    (set! y0 y1)))))      ; else should we do "max" here? or draw a vertical line from min to max?
		  (if (< line-ctr (length lines))
		      (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)
			  ((>= j (length lines)))
			(set! (lines j) x0)
			(set! (lines (+ j 1)) y0)))
		  (draw-lines lines snd chn time-graph cr)
		  (set! (channel-property 'rms-lines snd chn) lines)  ; save current data for possible redisplay
		  (set! (channel-property 'rms-axis-info snd chn) axinf))
		(lambda ()
		  (set! (foreground-color snd chn) old-color))))))
110
    (free-cairo cr)))
111

112
;; (hook-push after-graph-hook (lambda (hook) (overlay-rms-env (hook 'snd) (hook 'chn))))
113 114


115 116 117 118 119 120 121 122 123
(define display-colored-samples 
  (let ((documentation "(display-colored-samples color beg dur snd chn) displays samples from beg for dur in color 
whenever they're in the current view."))
    (lambda* (color beg dur snd chn)
      (let ((left (left-sample snd chn))
	    (right (right-sample snd chn))
	    (end (+ beg dur))
	    (old-color (foreground-color snd chn))
	    (cr (make-cairo (car (channel-widgets snd chn)))))
124 125 126 127
	(when (and (< left end)
		   (> right beg))
	  (let ((data (make-graph-data snd chn)))
	    (if (float-vector? data)
128 129 130
		(let ((new-data (let ((samps (- (min right end) (max left beg)))
				      (offset (max 0 (- beg left))))
				  (float-vector-subseq data offset (+ offset samps)))))
131 132 133
		  (set! (foreground-color snd chn) color)
		  (graph-data new-data snd chn copy-context (max beg left) (min end right) (time-graph-style snd chn) cr)
		  (set! (foreground-color snd chn) old-color))
134
		(let* ((size (length (car data)))
135
		       (samps (- right left))
136 137
		       (left-bin (floor (/ (* size (max 0 (- beg left))) samps)))
		       (right-bin (floor (/ (* size (- (min end right) left)) samps)))
138 139
		       (new-low-data (float-vector-subseq (car data) left-bin right-bin))
		       (new-high-data (float-vector-subseq (cadr data) left-bin right-bin)))
140 141 142
		  (set! (foreground-color snd chn) color)
		  (graph-data (list new-low-data new-high-data) snd chn copy-context left-bin right-bin (time-graph-style snd chn) cr)
		  (set! (foreground-color snd chn) old-color)))))
143
	(free-cairo cr)))))
144

145

146 147 148 149 150 151
(define (display-samples-in-color hook)
  (let ((snd (hook 'snd))
	(chn (hook 'chn)))
    ;; intended as after-graph-hook member 
    ;; run through 'colored-samples lists passing each to display-colored-samples
    (let ((colors (channel-property 'colored-samples snd chn)))
152
      (if (pair? colors)
153 154 155 156
	  (for-each
	   (lambda (vals)
	     (apply display-colored-samples (append vals (list snd chn))))
	   colors)))))
157

158

159 160 161 162 163
(define color-samples 
  (let ((documentation "(color-samples color beg dur snd chn) causes samples from beg to beg+dur to be displayed in color"))
    (lambda* (color ubeg udur usnd uchn)
      (if (not (member display-samples-in-color (hook-functions after-graph-hook)))
	  (hook-push after-graph-hook display-samples-in-color))
164 165 166 167 168 169 170
      (let ((snd (or usnd (selected-sound) (car (sounds)))))
	(let ((chn (or uchn (selected-channel snd) 0))
	      (beg (or ubeg 0)))
	  (let ((dur (or udur (- (framples snd chn) beg)))
		(old-colors (or (channel-property 'colored-samples snd chn) ())))
	    (set! (channel-property 'colored-samples snd chn) (cons (list color beg dur) old-colors))
	    (update-time-graph snd chn)))))))
171 172


173 174 175
(define uncolor-samples 
  (let ((documentation "(uncolor-samples snd chn) cancels sample coloring in the given channel"))
    (lambda* (usnd uchn)
176 177
      (let* ((snd (or usnd (selected-sound) (car (sounds))))
	     (chn (or uchn (selected-channel snd) 0)))
178 179
	(set! (channel-property 'colored-samples snd chn) ())
	(update-time-graph snd chn)))))
180 181


182 183 184 185
(define display-previous-edits 
  (let ((documentation "(display-previous-edits snd chn) displays all edits of the current sound, with older versions gradually fading away"))
    (lambda (snd chn)
      (let ((edits (edit-position snd chn)))
186 187
	(when (> edits 0)
	  (let* ((old-color (foreground-color snd chn))
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
		 (clist (color->list old-color)))
	    (let ((rinc (/ (- 1.0 (car clist)) (+ edits 1)))
		  (ginc (/ (- 1.0 (cadr clist)) (+ edits 1)))
		  (binc (/ (- 1.0 (caddr clist)) (+ edits 1)))
		  (cr (make-cairo (car (channel-widgets snd chn))))) 
	      (do ((pos 0 (+ 1 pos))
		   (re (- 1.0 rinc) (- re rinc))
		   (ge (- 1.0 ginc) (- ge ginc))
		   (be (- 1.0 binc) (- be binc)))
		  ((> pos edits))
		(let ((data (make-graph-data snd chn pos)))
		  (set! (foreground-color snd chn) (make-color re ge be))
		  (graph-data data snd chn copy-context #f #f (time-graph-style snd chn) cr)))
	      (set! (foreground-color snd chn) old-color)
	      (free-cairo cr))))))))
203

204

205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
(define overlay-sounds
  (let ((documentation "(overlay-sounds . args) overlays onto its first argument all subsequent arguments: (overlay-sounds 1 0 3)"))
    (lambda args
      (let ((base (if (integer? (car args)) 
		      (integer->sound (car args)) 
		      (car args))))
	(hook-push after-graph-hook
		   (lambda (hook)
		     (let ((snd (hook 'snd))
			   (chn (hook 'chn)))
		       (if (equal? snd base)
			   (let ((cr (make-cairo (car (channel-widgets snd chn)))))
			     (for-each 
			      (lambda (nsnd)
				(if (and (sound? nsnd)
					 (> (chans nsnd) chn))
				    (graph-data (make-graph-data nsnd chn) base chn copy-context #f #f graph-dots cr)))
			      (cdr args))
			     (free-cairo cr))))))))))
224 225


226 227 228
(define samples-via-colormap 
  (let ((documentation "(samples-via-colormap snd chn) displays time domain graph using current colormap (just an example of colormap-ref)"))
    (lambda (snd chn)
229
      (let ((data (make-graph-data snd chn))
230 231 232
	    (cr (make-cairo (car (channel-widgets snd chn)))))
	
	(define (samples-1 cur-data)
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
	  (let ((left (left-sample snd chn))
		(right (right-sample snd chn))
		(old-color (foreground-color snd chn))
		(y0 (y->position (cur-data 0)))
		(colors (make-vector *colormap-size* #f))
		(len (length cur-data)))
	    (let ((x0 (x->position (/ left (srate snd))))
		  (incr (/ (- (+ right 1) left) len)))
	      (do ((i (+ left incr) (+ i incr))
		   (j 1 (+ 1 j)))
		  ((or (>= i right)
		       (>= j len)))
		(let ((x1 (x->position (/ i (srate snd))))
		      (y1 (y->position (cur-data j))))
		  (let* ((x (abs (cur-data j)))
			 (ref (floor (* *colormap-size* x))))
		    (set! (foreground-color snd chn) 
			  (or (colors ref)
			      (let ((new-color (apply make-color (colormap-ref (colormap) x))))
				(set! (colors ref) new-color)))))
		  (draw-line x0 y0 x1 y1 snd chn time-graph cr)
		  (set! x0 x1)
		  (set! y0 y1)))
	      (set! (foreground-color snd chn) old-color))))

258 259 260 261 262 263 264
	(if data
	    (if (float-vector? data)
		(samples-1 data)
		(begin
		  (samples-1 (car data))
		  (samples-1 (cadr data)))))
	(free-cairo cr)))))
265 266