marks.scm 15.9 KB
Newer Older
1
;;; Examples of mark-related functions
2 3

(provide 'snd-marks.scm)
4
(require snd-selection.scm snd-hooks.scm)
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

;;; Contents:
;;;     mark-name->id is a global version of find-mark
;;;     move-syncd-marks moves all syncd marks together
;;;     describe-mark shows mark history
;;;     click marks between start-sync and stop-sync to sync them together
;;;     synchronize sounds at a given mark
;;;     fit selection between marks, expanding via granulate (this needs some tweaking...)
;;;     pad-marks inserts silence before each in a list of marks
;;;     play-syncd-marks and play-between-marks
;;;     report-mark-names causes mark names to be posted in the minibuffer as a sound is played
;;;     snap-marks places marks at current selection boundaries
;;;     define-selection-via-marks selects the portion between two marks
;;;     snap-mark-to-beat forces dragged mark to end up on a beat
;;;     mark-explode splits a sound into a bunch of sounds based on mark placements
;;;     save-mark-properties sets up an after-save-state-hook function to save any mark-properties
;;;     mark-click-info is a mark-click-hook function that describes a mark and its properties


;;; -------- mark-name->id is a global version of find-mark

26
(define mark-name->id 
27
  (let ((+documentation+ "(mark-name->id name) is like find-mark but searches all currently accessible channels"))
28 29 30 31 32 33 34 35 36 37 38 39
    (lambda (name)
      (call-with-exit
       (lambda (return)
	 (for-each
	  (lambda (snd)
	    (do ((chn 0 (+ 1 chn)))
		((= chn (channels snd)))
	      (let ((mark (find-mark name snd chn)))
		(if (mark? mark) 
		    (return mark)))))
	  (sounds))
	 'no-such-mark)))))
40 41 42 43


;;; -------- move-syncd-marks moves all syncd marks together

44
(define move-syncd-marks 
45
  (let ((+documentation+ "(move-syncd-marks sync diff) moves all marks sharing sync by diff samples"))
46 47 48 49
    (lambda (synch diff)
      (for-each (lambda (m)
		  (set! (mark-sample m) (+ (mark-sample m) diff)))
		(syncd-marks synch)))))
50 51 52 53


;;; -------- describe-mark shows mark history

54
(define describe-mark 
55
  (let ((+documentation+ "(describe-mark mark) returns a description of the movements of mark over the channel's edit history"))
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
    (lambda (id)
      (let ((mark-setting (catch 'no-such-mark (lambda () (mark-home id)) (lambda args #f))))
	(if (not mark-setting)
	    ;; not an active mark, so go scrounging for it
	    ;;   we're looking at every edit of every channel
	    (set! mark-setting (call-with-exit
				(lambda (return)
				  (for-each
				   (lambda (snd)
				     (do ((chn 0 (+ 1 chn)))
					 ((= chn (channels snd)))
				       (let ((max-edits (apply + (edits snd chn))))
					 (do ((ed 0 (+ 1 ed)))
					     ((> ed max-edits))
					   (if (member id (marks snd chn ed))
					       (return (list snd chn)))))))
				   (sounds))
				  #f))))
	(if (pair? mark-setting)
75 76 77 78 79 80 81 82 83
	    (let ((snd (car mark-setting))
		  (chn (cadr mark-setting)))
	      (let ((max-edits (apply + (edits snd chn)))
		    (descr ())
		    (header (list id sound: snd (short-file-name snd) channel: chn)))
		(do ((i max-edits (- i 1)))
		    ((< i 0))
		  (set! descr (cons (and (member id (marks snd chn i)) (mark-sample id i)) descr)))
		(cons header descr)))
84
	    (error 'no-such-mark (list "describe-mark" id)))))))
85 86 87 88 89 90 91 92 93


;;; -------- click marks between start-sync and stop-sync to sync them together
;;;  (easier than calling mark-sync over and over by hand)

(define mark-sync-number 0)
(define (start-sync) (set! mark-sync-number (+ (mark-sync-max) 1)))
(define (stop-sync) (set! mark-sync-number 0))
(define (click-to-sync id) (set! (sync id) mark-sync-number) #f)
94
					;(hook-push mark-click-hook (lambda (hook) (click-to-sync (hook 'id))))
95 96 97 98 99


;;; -------- syncronize sounds at a given mark

(define syncup
100
  (let ((+documentation+ "(syncup marks) pads the channels with zeros so that all the given marks occur at the same time"))
101 102 103
    (lambda ids
      (let* ((samps (map mark-sample ids))
	     (max-samp (apply max samps)))
104 105 106 107 108 109 110
	(do ((lst-ids ids (cdr lst-ids))
	     (lst-samps samps (cdr lst-samps)))
	    ((not (pair? lst-ids)))
	  (if (< (car lst-samps) max-samp)
	      (let ((nsamps (- max-samp (car lst-samps)))
		    (snd-chn (mark-home (car lst-ids))))
		(insert-samples 0 nsamps (make-float-vector nsamps) (car snd-chn) (cadr snd-chn)))))))))
111 112 113 114


;;; -------- fit selection between marks, expanding via granulate (this needs some tweaking...)

115
(define fit-selection-between-marks 
116
  (let ((+documentation+ "(fit-selection-between-marks m1 m2) fits (and mixes) the current selection (via granulate) between the given marks"))
117 118 119 120 121 122 123 124 125 126 127
    (lambda (m1 m2)
      (let ((m1-samp (mark-sample m1))
	    (m2-samp (mark-sample m2))
	    (m1-home (mark-home m1))
	    (m2-home (mark-home m2)))
	(if (not (selection?))
	    (error 'no-active-selection))
	(if (not (equal? m1-home m2-home))
	    (snd-print (format #f "~A is in ~A[~A] but ~A is in ~A[~A]?" 
			       m1 (car m1-home) (cadr m1-home)
			       m2 (car m2-home) (cadr m2-home)))
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
	    (let ((selection-samps (selection-framples)))
	      (let ((mark-samps (- m2-samp m1-samp))
		    (reg-data (let ((data (make-float-vector selection-samps))
				    (rd (make-sampler (selection-position))))
				(do ((i 0 (+ 1 i)))
				    ((= i selection-samps))
				  (set! (data i) (rd)))
				data))
		    (inctr 0))
		(if (= mark-samps selection-samps)
		    (map-channel (lambda (y) 
				   (let ((val (+ y (reg-data inctr))))
				     (set! inctr (+ 1 inctr))
				     val))
				 m1-samp mark-samps (car m1-home) (cadr m1-home))
		    (let ((gr (make-granulate :expansion (/ mark-samps selection-samps)
					      :input (lambda (dir)
						       (if (or (>= inctr selection-samps)
							       (< inctr 0))
							   0.0
							   (let ((val (reg-data inctr)))
							     (set! inctr (+ inctr dir))
							     val))))))
		      (map-channel (lambda (y)
				     (+ y (granulate gr)))
				   m1-samp mark-samps (car m1-home) (cadr m1-home)))))))))))
154 155 156 157


;;; -------- pad-marks inserts silence before each in a list of marks

158
(define pad-marks 
159
  (let ((+documentation+ "(pad-marks marks secs) inserts secs seconds of silence before each mark"))
160 161 162 163 164 165 166 167 168 169 170
    (lambda (ids secs)
      (let* ((silence-length (floor (* secs (srate))))
	     (silence-samps (make-float-vector silence-length)))
	(as-one-edit
	 (lambda ()
	   (for-each 
	    (lambda (n)
	      (let ((samp (max 0 (- (mark-sample n) 1)))
		    (home (mark-home n)))
		(insert-samples samp silence-length silence-samps (car home) (cadr home))))
	    ids)))))))
171 172 173 174


;;; -------- play-syncd-marks

175
(define play-syncd-marks 
176
  (let ((+documentation+ "(play-syncd-marks sync) starts playing from all marks sharing sync"))
177 178 179 180 181 182 183 184 185 186 187 188 189
    (lambda (synch)
      (let ((chans 1)
	    (rate 22050))
	(for-each
	 (lambda (m)
	   (let* ((sound (car (mark-home m)))
		  (channel (cadr (mark-home m)))
		  (new-player (make-player sound channel)))
	     (add-player new-player (mark-sample m))
	     (set! chans (max chans (+ 1 channel)))
	     (set! rate (max rate (srate sound)))))
	 (syncd-marks synch))
	(start-playing chans rate)))))
190 191

(define play-between-marks
192
  (let ((+documentation+ "(play-between-marks ...) plays the portion between the marks (searching for plausible default marks)"))
193 194 195
    (lambda args
      (let* ((snd (or (selected-sound) (car (sounds))))
	     (chn (or (selected-channel) 0))
196
	     (m1 (if (pair? args)
197 198 199 200 201 202 203 204 205 206
		     (car args)
		     (let find-mark ((ms (marks snd chn)))
		       (if (null? ms)
			   (begin
			     (snd-print ";no marks in current window?")
			     #f)
			   (if (>= (mark-sample (car ms)) (left-sample snd chn))
			       (car ms)
			       (find-mark (cdr ms)))))))
	     (m2 (and (mark? m1)
207 208
		      (if (and (pair? args)
			       (pair? (cdr args)))
209 210 211 212 213 214 215 216 217 218 219
			  (cadr args)
			  (let find-another-mark ((ms (marks snd chn)))
			    (if (null? ms)
				(begin
				  (snd-print ";no second mark?")
				  #f)
				(if (> (mark-sample (car ms)) (mark-sample m1))
				    (car ms)
				    (find-another-mark (cdr ms)))))))))
	(if (and (mark? m1)
		 (mark? m2))
220 221 222 223 224 225 226 227
	    (let ((pos1 (mark-sample m1))
		  (pos2 (mark-sample m2)))
	      (let ((beg (min pos1 pos2))
		    (end (max pos1 pos2)))
		(play (car (mark-home m1)) 
		      :channel (cadr (mark-home m1))
		      :start beg 
		      :end end))))))))
228 229 230 231


;;; -------- report-mark-names causes mark names to be posted in the minibuffer as a sound is played

232
(define report-mark-names
233
  (let ((+documentation+ "(report-mark-names) causes mark names to be printed as they are passed while playing"))
234 235 236
    (lambda ()
      (hook-push start-playing-hook 
		 (lambda (snd)
237 238 239 240 241 242 243 244 245 246 247 248
		   (let ((report-mark-names-play-hook
			   (let ((marklist (marks snd 0)))
			     (let ((samplist (map mark-sample marklist))
				   (samp 0))
			       (lambda (hook)
				 (set! samp (+ samp (hook 'size)))
				 (if (and (pair? samplist)
					  (>= samp (car samplist)))
				     (begin
				       (status-report (mark-name (car marklist)) snd)
				       (set! marklist (cdr marklist))
				       (set! samplist (cdr samplist)))))))))
249 250 251 252 253 254 255 256
		     (letrec ((report-mark-names-stop-playing-hook 
			       (lambda (hook)
				 (status-report "" (hook 'snd))
				 (hook-remove play-hook report-mark-names-play-hook)
				 (hook-remove stop-playing-hook report-mark-names-stop-playing-hook))))
		       (hook-push stop-playing-hook report-mark-names-stop-playing-hook)
		       (hook-push play-hook report-mark-names-play-hook)
		       #f)))))))
257 258 259 260


;;; -------- snap-marks

261
(define snap-marks
262
  (let ((+documentation+ "snap-marks places marks at current selection boundaries"))
263
    (lambda ()
264
      (let ((ms ()))
265 266 267 268 269 270 271 272 273
	(if (selection?)
	    (for-each 
	     (lambda (select)
	       (let ((pos (apply selection-position select))
		     (len (apply selection-framples select)))
		 (set! ms (cons (apply add-mark (+ pos len) select) 
				(cons (apply add-mark pos select) ms)))))
	     (selection-members)))
	(reverse ms)))))
274 275 276 277


;;; -------- define-selection-via-marks

278
(define define-selection-via-marks 
279
  (let ((+documentation+ "(define-selection-via-marks m1 m2) defines the current selection to lie between the marks given"))
280 281 282 283 284 285 286 287 288 289 290 291 292
    (lambda (m1 m2)
      (let ((m1sc (mark-home m1))
	    (m2sc (mark-home m2)))
	(if (not (equal? m1sc m2sc))
	    (snd-error "define-selection-via-marks assumes the marks are in the same channel")
	    (let ((beg (min (mark-sample m1) (mark-sample m2)))
		  (end (max (mark-sample m1) (mark-sample m2)))
		  (snd (car m1sc))
		  (chn (cadr m1sc)))
	      (if (selection?)
		  (set! (selection-member? #t) #f)) ; clear entire current selection, if any
	      (set! (selection-member? snd chn) #t)
	      (set! (selection-position snd chn) beg)
293
	      (set! (selection-framples snd chn) (- (+ end 1) beg))))))))
294 295 296 297


;;; -------- snap-mark-to-beat

298
(define snap-mark-to-beat
299
  (let ((+documentation+ "(snap-mark-to-beat) ensures that when a mark is dragged, its released position is always on a beat"))
300
    (lambda ()
301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
      (hook-push mark-hook 
		 (lambda (hook)
		   (let ((mrk (hook 'id))
			 (snd (hook 'snd))
			 (chn (hook 'chn))
			 (reason (hook 'reason))
			 (mark-release 4))			   
		     (if (= reason mark-release)
			 (let* ((samp (mark-sample mrk))
				(bps (/ (beats-per-minute snd chn) 60.0))
				(sr (srate snd))
				(beat (floor (/ (* samp bps) sr))))
			   (let ((lower (floor (/ (* beat sr) bps)))
				 (higher (floor (/ (* (+ 1 beat) sr) bps))))
			     (set! (mark-sample mrk)
				   (if (< (- samp lower) (- higher samp))
				       lower
				       higher)))))))))))
319 320 321 322 323

;;; -------- mark-explode
;;;
;;; write out each section of a file between marks as a separate file

324
(define mark-explode 
325
  (let ((+documentation+ "(mark-explode header-type sample-type) splits a sound into a bunch of sounds based on mark placements"))
326 327 328 329 330 331 332 333
    (lambda* ((htype mus-next) (dformat mus-bfloat))
      (let ((start 0)
	    (file-ctr 0)
	    (snd (or (selected-sound) (car (sounds)))))
	(for-each
	 (lambda (mark)
	   (let ((end (mark-sample mark)))
	     (if (> end start)
334 335
		 (let ((filename (format #f "mark-~D.snd" file-ctr))
		       (dur (- end start)))
336 337 338 339 340
		   (set! file-ctr (+ 1 file-ctr))
		   (do ((i 0 (+ 1 i)))
		       ((= i (channels snd)))
		     (set! (selection-member? snd i) #t)
		     (set! (selection-position snd i) start)
341
		     (set! (selection-framples snd i) dur))
342 343 344 345 346 347 348
		   (save-selection filename :header-type htype :sample-type dformat :srate (srate snd))
		   (do ((i 0 (+ 1 i)))
		       ((= i (channels snd)))
		     (set! (selection-member? snd i) #f))))
	     (set! start end)))
	 (car (marks snd)))
	(update-time-graph snd)))))
349 350


351
;;; -------- save mark property lists
352

353
(define save-mark-properties
354
  (let ((+documentation+ "(save-mark-properties) sets up an after-save-state-hook function to save any mark-properties"))
355 356 357
    (lambda ()
      (hook-push after-save-state-hook 
		 (lambda (hook)
358
		   (let ((fd (open-output-file (hook 'name) "a")))
359 360 361 362 363 364 365 366 367
		     (format fd "~%~%;;; from remember-mark-properties in marks.scm~%")
		     (format fd "(if (not (defined? 'mark-property)) (load \"marks.scm\"))~%")
		     (for-each 
		      (lambda (snd-m)
			(for-each 
			 (lambda (chn-m)
			   (for-each
			    (lambda (m)
			      (let ((mp (mark-properties m)))
368
				(if (pair? mp)
369 370 371 372 373 374 375 376 377 378
				    (let ((mhome (mark-home m))
					  (msamp (mark-sample m)))
				      (format fd "(let ((s (find-sound ~S)))~%" (file-name (car mhome)))
				      (format fd "  (if (sound? s)~%")
				      (format fd "      (let ((m (find-mark ~A s ~A)))~%" msamp (cadr mhome))
				      (format fd "        (if (mark? m)~%")
				      (format fd "            (set! (mark-properties m) '~A)))))~%" mp)))))
			    chn-m))
			 snd-m))
		      (marks))
379
		     (close-output-port fd)))))))
380 381 382


(define mark-click-info 
383
  (let ((+documentation+ "(mark-click-info n) is a mark-click-hook function that describes a mark and its properties"))
384 385 386 387 388 389 390 391 392 393 394
    (lambda (hook)
      (let ((n (hook 'id)))
	(help-dialog "Mark Help"
		     (format #f "Mark ~A~A:~%  sample: ~D = ~,3F secs~A~A"
			     n 
			     (let ((name (mark-name n)))
			       (if (> (length name) 0)
				   (format #f " (~S)" name)
				   ""))
			     (mark-sample n)
			     (* 1.0 (/ (mark-sample n) (srate (car (mark-home n)))))
395 396 397
			     (if (= (sync n) 0)
				 ""
				 (format #f "~%  sync: ~A" (sync n)))
398 399 400 401 402
			     (let ((props (mark-properties n)))
			       (if (pair? props)
				   (format #f "~%  properties: '~A" props)
				   ""))))
	(set! (hook 'result) #t)))))
403 404 405 406 407 408 409 410


#|
;;; this code saves mark info in the sound file header, and reads it back in when the sound is later reopened

(define (eval-header sndf)
  (and (string? (comment sndf))
       (catch #t
411 412 413
	 (lambda ()
	   (eval-string (comment sndf)))
	 (lambda args #f))))
414 415

(define (marks->string sndf)
416
  (let ((str (format #f "(require snd-marks.scm)~%(let ((m #f))~%"))
417 418 419 420 421 422 423 424 425 426 427 428
	(chan 0))
    (for-each
     (lambda (chan-marks)
       (for-each 
	(lambda (m)
	  (set! str 
		(string-append str 
			       (format #f
				       "  (set! m (add-mark ~A #f ~D ~A ~D))~%" 
				       (mark-sample m)
				       chan
				       (if (and (string? (mark-name m))
429
						(> (length (mark-name m)) 0))
430 431 432
					   (format #f "~S" (mark-name m))
					   #f)
				       (sync m))))
433
	  (if (pair? (mark-properties m))
434 435 436 437 438
	      (set! str
		    (string-append str 
				   (format #f
					   "  (set! (mark-properties m) '~A)~%"
					   (mark-properties m))))))
439
	chan-marks)
440 441 442 443
       (set! chan (+ 1 chan)))
     (marks sndf))
    (string-append str (format #f "  m)~%"))))

444 445 446
(hook-push output-comment-hook (lambda (hook) (set! (hook 'result) (marks->string (selected-sound)))))
(hook-push after-open-hook (lambda (hook) (set! (hook 'result) (eval-header (hook 'snd)))))
|#
447

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472
#|
;; from snd11?
(define (delete-between-marks)
  (let ((mx (marks 0 0)))
    (if (and (pair? mx)
	     (pair? (cdr mx))) ; there are at least 2 marks
	(let ((pos (cursor 0 0))
	      (deb #f)
	      (fin #f))
	  (for-each
	   (lambda (m)
	     (if (<= (mark-sample m) pos)
		 (set! deb (mark-sample m)))
	     (if (and (not fin)
		      (> (mark-sample m) pos))
		 (set! fin (mark-sample m))))
	   (sort! mx (lambda (a b) 
		       (< (mark-sample a) (mark-sample b)))))
	  (when (and deb fin)
	    (let ((dur (- fin deb)))
	      (apply for-each
		     (lambda (s c)
		       (delete-samples deb dur s c))
		     (all-chans))))))))
|#