/[cl-wav-synth]/cl-wav-synth/cl-wav-synth.lisp
ViewVC logotype

Contents of /cl-wav-synth/cl-wav-synth.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Sat Dec 13 20:53:28 2008 UTC (5 years, 4 months ago) by pbrochard
Branch: MAIN
CVS Tags: HEAD
Changes since 1.22: +0 -1 lines
First libterminatorX commit
1 ;;; CL-Wav-Synth - Manipulate WAV files
2 ;;;
3 ;;; Express noises as you think.
4 ;;;
5 ;;; Copyright (C) 2006 Philippe Brochard (hocwp@free.fr)
6 ;;;
7 ;;; #Date#: Wed Jun 6 14:13:01 2007
8 ;;;
9 ;;; **********************************************
10 ;;; The authors grant you the rights to distribute
11 ;;; and use this software as governed by the terms
12 ;;; of the Lisp Lesser GNU Public License
13 ;;; (http://opensource.franz.com/preamble.html),
14 ;;; known as the LLGPL.
15 ;;; **********************************************
16 ;;;
17 ;;; USAGE:
18 ;;; -----
19 ;;; start your lisp
20 ;;; CL-USER> (load "/where/is/load.lisp")
21 ;;; CL-USER> (in-package :wav)
22 ;;; WAV> (list-all-test)
23 ;;; WAV> (testN)
24 ;;; ... look at each example to see how they works.
25 ;;;
26 ;;; WAV format description: (hmm, in french, sorry :)
27 ;;; ----------------------
28 ;;; * Structure generale: Offset (decimal) offset (hexa) nom longueur (oct.) description
29 ;;;
30 ;;; 0 00h rID 4 contient "RIFF" #52494646
31 ;;;
32 ;;; 4 04h rLen 4 longueur du fichier
33 ;;;
34 ;;; 8 08h wID 4 contient "WAVE" #57415645
35 ;;;
36 ;;; * Le Format Chunk: Offset (decimal) offset (hexa) nom longueur (octet) description
37 ;;;
38 ;;; 12 0Ch fId 4 contient "fmt " ("fmt espace") #666D7420
39 ;;;
40 ;;; 16 10h fLen 4 Longueur du Chunck 16 #10
41 ;;;
42 ;;; 20 14h wFormatTag 2 format (1 = Microsoft Pulse Code Modulation PCM)
43 ;;;
44 ;;; 22 16h nChannels 2 nombre de canaux (1=mono, 2=stereo)
45 ;;;
46 ;;; 24 18h nSamplesPerSec 4 frequence d'echantillonage (en Hz)
47 ;;;
48 ;;; 28 1Ch nAvgBytesPerSec 4 = nChannels * nSamplesPerSec * (nBitsPerSample/8)
49 ;;;
50 ;;; 32 20h nBlockAlign 2 = nChannels * (nBitsPerSample / 8)
51 ;;;
52 ;;; 34 22h nBitsPerSample 2 longueur d'un echantillon en bits (8, 16, 24 ou 32)
53 ;;;
54 ;;; * Le WAVE Data Chunk: Offset (decimal) offset (hexa) nom longueur (octet) description
55 ;;;
56 ;;; 36 24h dId 4 contient "data" #64617461
57 ;;;
58 ;;; 40 28h dLen 4 longueur du chunck dData (en octets)
59 ;;;
60 ;;; 44 et plus 2Ch dData dLen les donnees du son echantillonne
61
62 (in-package :common-lisp)
63
64 (defpackage :cl-wav-synth
65 (:use :common-lisp :uni-shell :bezier)
66 (:nicknames :wav)
67 (:export :time-to-sample
68 :sample-to-time
69 :random-mm
70 :header
71 :sample-p
72 :sample-n-channels
73 :sample-n-samples-per-sec
74 :sample-n-bits-per-sample
75 :sample-time
76 :sample-n-avg-bytes-per-sec
77 :sample-n-block-align
78 :sample-total-byte
79 :sample-last-sample
80 :sample-max-index
81 :sample-max-ampl
82 :sample-name
83 :print-sample
84 :spectrum-rl
85 :spectrum-im
86 :spectrum-time
87 :spectrum-n-samples-per-sec
88 :spectrum-n-bits-per-sample
89 :data
90 :sample
91 :spectrum
92 :t->s
93 :s->t
94 :f->s
95 :find-smin-smax
96 :skip-header
97 :write-fake-header
98 :write-header
99 :read-header
100 :print-header
101 :copy-header
102 :header-equal
103 :make-data
104 :set-data
105 :freq->index
106 :index->freq
107 :get-ampl
108 :set-ampl
109 :write-sample
110 :read-sample
111 :copy-sample
112 :apply-on-sample
113 :cut-sample
114 :insert-sample
115 :mix-sample
116 :extract-channel
117 :add-channel
118 :fft
119 :time<->freq
120 :sample-make-square
121 :sample-make-line
122 :sample-make-lines
123 :sample-make-sin
124 :sample-make-noise
125 :build-from-freq
126 :read-freq-from-file
127 :sample-view
128
129 :song-sample
130 :add-tags :del-tags
131 :s-time
132 :s-form
133 :s-pos
134 :s-tags
135 :s-color
136 :s-length
137
138 :build-song
139 :build-song-in-interval
140 :eval-song-sample-form
141 :list-to-song
142 :with-build-song
143 :with-song
144 :write-song
145 :read-song
146 :*current-song*))
147
148 (in-package :cl-wav-synth)
149
150 ;;; You can edit this variable to your needs
151 ;;; Possibles values are:
152 ;;; A symbol in: dplay, xmms, snd, audacity, cool-player, totem, bmp, macplay
153 ;;; or a command line string
154 (defparameter *default-player* 'dplay
155 "The default command to play a sample")
156
157 (defvar *spi* (float pi 1f0))
158
159 (defvar *current-song* nil)
160
161 ;;; This is in cl-wav-synth for compilation priority
162 (defparameter *wav-test-hash* (make-hash-table))
163
164
165 ;;; Simples converters
166
167 (defun time-to-sample (n-samples-per-sec time)
168 "Convert time in sample according to frequence n-samples-per-sec"
169 (truncate (* n-samples-per-sec time)))
170
171 (defun sample-to-time (n-samples-per-sec n-sample)
172 "Convert sample in time according to frequence n-samples-per-sec"
173 (/ n-sample n-samples-per-sec))
174
175 (defun random-mm (min max)
176 "Return a random number between min and max"
177 (+ (random (- max min)) min))
178
179
180 ;;; Main class
181
182 (defclass header ()
183 ((n-channels :initarg :n-channels
184 :accessor sample-n-channels)
185 (n-samples-per-sec :initarg :n-samples-per-sec
186 :accessor sample-n-samples-per-sec)
187 (n-bits-per-sample :initarg :n-bits-per-sample
188 :accessor sample-n-bits-per-sample)
189 (time :initarg :time :initform nil :accessor sample-time)
190 (n-avg-bytes-per-sec :initform nil :accessor sample-n-avg-bytes-per-sec)
191 (n-block-align :initform nil :accessor sample-n-block-align)
192 (total-byte :initform nil :accessor sample-total-byte)
193 (last-sample :initform nil :accessor sample-last-sample)
194 (max-index :initform nil :accessor sample-max-index)
195 (max-ampl :initform nil :accessor sample-max-ampl)))
196
197 (defclass data ()
198 ((data :initarg :data :initform nil :accessor data)))
199
200 (defclass sample (header data)
201 ((name :initarg :name
202 :initform (format nil "noname-~A.wav" (gensym))
203 :accessor sample-name)))
204
205 (defclass spectrum (data)
206 ( ;;(rl :initarg :rl :initform 0 :accessor spectrum-rl)
207 (im :initarg :im :initform 0 :accessor spectrum-im)
208 (time :initarg :time :initform 0 :accessor spectrum-time)
209 (n-samples-per-sec :initarg :n-samples-per-sec
210 :accessor spectrum-n-samples-per-sec)
211 (n-bits-per-sample :initarg :n-bits-per-sample
212 :accessor spectrum-n-bits-per-sample)))
213
214
215
216 ;;; Object identification methods
217 (defgeneric sample-p (object))
218 (defmethod sample-p ((object sample))
219 (declare (ignore object))
220 t)
221 (defmethod sample-p (object)
222 (declare (ignore object))
223 nil)
224
225
226 ;;; Low level functions helper
227 (defun write-id (stream str)
228 (loop for c across str do
229 (write-byte (char-code c) stream)))
230
231 (defun write-16 (stream n)
232 (write-byte (ldb (byte 8 0) n) stream)
233 (write-byte (ldb (byte 8 8) n) stream))
234
235
236 (defun write-32 (stream n)
237 (write-byte (ldb (byte 8 0) n) stream)
238 (write-byte (ldb (byte 8 8) n) stream)
239 (write-byte (ldb (byte 8 16) n) stream)
240 (write-byte (ldb (byte 8 24) n) stream))
241
242
243 (defun read-id (stream size)
244 (let ((answer (loop for i from 1 to size
245 collect (read-byte stream))))
246 (map 'string #'code-char answer)))
247
248 (defun read-16 (stream)
249 (let ((answer (read-byte stream)))
250 (when answer
251 (setf (ldb (byte 8 8) answer) (read-byte stream)))
252 answer))
253
254 (defun read-32 (stream)
255 (let ((answer (read-byte stream)))
256 (when answer
257 (setf (ldb (byte 8 8) answer) (read-byte stream))
258 (setf (ldb (byte 8 16) answer) (read-byte stream))
259 (setf (ldb (byte 8 24) answer) (read-byte stream)))
260 answer))
261
262
263
264 ;;; Header functions
265
266 (defgeneric t->s (header period))
267 (defmethod t->s ((header header) period)
268 "Convert time period to samples"
269 (with-slots (n-samples-per-sec max-index) header
270 (let ((s (time-to-sample n-samples-per-sec period)))
271 (if (and max-index (>= s max-index))
272 (1- max-index)
273 s))))
274
275 (defgeneric s->t (header period))
276 (defmethod s->t ((header header) index)
277 "Convert samples to time period"
278 (with-slots (n-samples-per-sec) header
279 (sample-to-time n-samples-per-sec index)))
280
281
282
283 (defgeneric f->s (header freq))
284 (defmethod f->s ((header header) freq)
285 "Convert frequence to samples"
286 (truncate (/ (sample-n-samples-per-sec header) freq)))
287
288
289
290
291 (defgeneric find-s (header time))
292 (defmethod find-s ((header header) time)
293 "Find samples index from time in a sample"
294 (with-slots (n-channels) header
295 (if time
296 (* (t->s header time) n-channels)
297 0)))
298
299 (defgeneric find-smin-smax (header start end))
300 (defmethod find-smin-smax ((header header) start end)
301 "Find min and max samples index from min and max time in a sample"
302 (with-slots (last-sample n-channels) header
303 (values (if start
304 (* (t->s header start) n-channels)
305 0)
306 (if end
307 (* (1+ (t->s header end)) n-channels)
308 last-sample))))
309
310
311 (defgeneric skip-header (header))
312 (defmethod skip-header ((header header))
313 (/ 352 (sample-n-bits-per-sample header)))
314
315
316
317
318
319 (defgeneric write-fake-header (filename header))
320 (defmethod write-fake-header (filename (header header))
321 (with-open-file (stream filename :direction :output
322 :if-exists :overwrite :if-does-not-exist :create
323 :element-type '(unsigned-byte 8))
324 (write-sequence (make-array 44 :element-type '(unsigned-byte 8)
325 :initial-element 0)
326 stream))
327 t)
328
329 (defgeneric write-header (filename header &key if-exists))
330 (defmethod write-header (filename (header header) &key (if-exists :overwrite))
331 (with-slots (n-samples-per-sec
332 n-channels n-bits-per-sample
333 n-block-align n-avg-bytes-per-sec
334 total-byte time) header
335 (with-open-file (stream filename :direction :output
336 :if-exists if-exists
337 :if-does-not-exist :create
338 :element-type '(unsigned-byte 8))
339 (write-id stream "RIFF")
340 (write-32 stream (+ 36 total-byte))
341 (write-id stream "WAVE")
342 (write-id stream "fmt ")
343 (write-32 stream 16)
344 (write-16 stream 1)
345 (write-16 stream n-channels)
346 (write-32 stream n-samples-per-sec)
347 (write-32 stream n-avg-bytes-per-sec)
348 (write-16 stream n-block-align)
349 (write-16 stream n-bits-per-sample)
350 (write-id stream "data")
351 (write-32 stream total-byte)))
352 t)
353
354 (defgeneric read-header (filename header))
355 (defmethod read-header (filename (header header))
356 "Read wav header info. See http://www.sonicspot.com/guide/wavefiles.html"
357 (labels ((expected (read-str orig-str)
358 (assert (string= read-str orig-str) ()
359 "error reading header: ~S is not a wav file. Expected ~A Got ~A"
360 filename orig-str read-str)))
361 (with-slots (n-samples-per-sec
362 n-channels n-bits-per-sample
363 n-block-align n-avg-bytes-per-sec
364 total-byte) header
365 (with-open-file (stream filename :direction :input
366 :element-type '(unsigned-byte 8))
367 (expected (read-id stream 4) "RIFF")
368 (read-32 stream)
369 (expected (read-id stream 4) "WAVE")
370 (loop
371 (let* ((next-header (read-id stream 4))
372 (bytes (read-32 stream)))
373 (cond ((string= next-header "fmt ")
374 (read-16 stream) ;; compression code
375 (setf n-channels (read-16 stream))
376 (setf n-samples-per-sec (read-32 stream))
377 (setf n-avg-bytes-per-sec (read-32 stream))
378 (setf n-block-align (read-16 stream))
379 (setf n-bits-per-sample (read-16 stream))
380 ;; possible extra format bytes
381 (dotimes (i (- bytes 16)) (read-byte stream)))
382 ((string= next-header "data")
383 (setf total-byte bytes)
384 (return))
385 (t
386 ;; There're a lot of headers that we don't
387 ;; care. For instance, bext minf elmo, etc
388 (dotimes (i bytes) (read-byte stream)))))))))
389 header)
390
391 (defgeneric print-header (header &optional comment))
392 (defmethod print-header ((header header) &optional (comment ""))
393 (with-slots (n-samples-per-sec
394 n-channels n-bits-per-sample
395 n-block-align n-avg-bytes-per-sec
396 total-byte last-sample max-index
397 time max-ampl) header
398 (format t "~&Header: [~A]
399 n-samples-per-sec = ~A Hz
400 n-channels = ~A chan
401 n-bits-per-sample = ~A bits/sample
402 n-block-align = ~A bytes
403 n-avg-bytes-per-sec = ~A bytes/s
404 total-byte = ~A bytes
405 last-sample = ~A (data sample length)
406 max-index = ~A (one channel length)
407 time = ~,2F s
408 max-ampl = ~A~%"
409 comment
410 n-samples-per-sec
411 n-channels n-bits-per-sample
412 n-block-align n-avg-bytes-per-sec
413 total-byte last-sample max-index
414 time max-ampl)))
415
416
417
418 (defgeneric set-sample-info (arg))
419 (defmethod set-sample-info ((header header))
420 (with-slots (n-samples-per-sec
421 n-channels n-bits-per-sample
422 n-block-align n-avg-bytes-per-sec max-ampl) header
423 (setf n-block-align (* n-channels (/ n-bits-per-sample 8)))
424 (setf n-avg-bytes-per-sec (* n-samples-per-sec n-block-align))
425 (setf max-ampl (1- (expt 2 (1- n-bits-per-sample))))))
426
427 (defgeneric set-total-byte-from-time (arg))
428 (defmethod set-total-byte-from-time ((header header))
429 (with-slots (n-samples-per-sec
430 total-byte n-block-align time) header
431 (when (numberp time)
432 (setf total-byte
433 (* n-block-align (time-to-sample n-samples-per-sec time))))))
434
435 (defgeneric set-total-byte-from-data (arg1 &optional arg2))
436 (defmethod set-total-byte-from-data ((header header) &optional (data-length 1))
437 (with-slots (n-bits-per-sample total-byte) header
438 (setf total-byte
439 (* (/ n-bits-per-sample 8) data-length))))
440
441
442 (defgeneric set-last-sample (arg))
443 (defmethod set-last-sample ((header header))
444 (with-slots (n-bits-per-sample
445 n-samples-per-sec
446 last-sample total-byte max-index n-channels time) header
447 (setf last-sample (if (numberp total-byte)
448 (/ total-byte (/ n-bits-per-sample 8))
449 0)
450 max-index (/ last-sample n-channels)
451 time (float (sample-to-time n-samples-per-sec max-index)))))
452
453 (defgeneric copy-header (header))
454 (defmethod copy-header ((header header))
455 (with-slots (n-channels n-samples-per-sec n-bits-per-sample) header
456 (make-instance 'header :n-channels n-channels
457 :n-samples-per-sec n-samples-per-sec
458 :n-bits-per-sample n-bits-per-sample)))
459
460 (defgeneric header-equal (header1 header2))
461 (defmethod header-equal ((header1 header) (header2 header))
462 "Compare only significant slot from two headers"
463 (and (equal (sample-n-channels header1)
464 (sample-n-channels header2))
465 (equal (sample-n-bits-per-sample header1)
466 (sample-n-bits-per-sample header2))
467 (equal (sample-n-samples-per-sec header1)
468 (sample-n-samples-per-sec header2))))
469
470
471
472 ;;; Data functions
473
474 (defun make-data (size n-bits-per-sample)
475 (make-array size
476 :element-type `(signed-byte ,n-bits-per-sample)
477 :initial-element 0))
478
479 (defgeneric set-data (data &optional last-sample total-byte n-bits-per-sample))
480 (defmethod set-data ((data data)
481 &optional (last-sample 1)
482 (total-byte 1) (n-bits-per-sample 1))
483 (with-slots (data) data
484 (when (numberp total-byte)
485 (setf data (make-data last-sample n-bits-per-sample)))))
486
487
488 ;;; Spectrum functions
489 (defgeneric freq->index (spectrum freq))
490 (defmethod freq->index ((spectrum spectrum) freq)
491 (min (max (floor (* freq (spectrum-time spectrum))) 0)
492 (length (data spectrum))))
493
494
495 (defgeneric index->freq (spectrum index))
496 (defmethod index->freq ((spectrum spectrum) index)
497 (/ index (spectrum-time spectrum)))
498
499
500
501 ;;; Sample functions
502 (defmacro get-ampl (sample chan index)
503 `(aref (data ,sample)
504 (+ (* ,index (sample-n-channels ,sample)) ,chan)))
505
506 (defgeneric set-ampl (sample fun chan index ampl))
507 (defmethod set-ampl ((sample sample) fun chan index ampl)
508 (with-slots (max-ampl) sample
509 (let ((val (truncate (funcall fun
510 (get-ampl sample chan index)
511 ampl))))
512 (setf (get-ampl sample chan index)
513 (cond ((>= val max-ampl) max-ampl)
514 ((<= val (- max-ampl)) (- max-ampl))
515 (t val))))))
516
517
518
519 (defmethod set-total-byte-from-data ((sample sample) &optional ignored)
520 (declare (ignore ignored))
521 (with-slots (n-bits-per-sample data total-byte) sample
522 (setf total-byte
523 (* (/ n-bits-per-sample 8) (length data)))))
524
525
526 (defmethod set-data ((sample sample) &optional ignored1 ignored2 ignored3)
527 (declare (ignore ignored1 ignored2 ignored3))
528 (with-slots (total-byte
529 n-bits-per-sample data last-sample) sample
530 (when (numberp total-byte)
531 (setf data (make-data last-sample n-bits-per-sample)))))
532
533
534
535 (defgeneric initialize (arg))
536 (defmethod initialize ((sample sample))
537 (set-sample-info sample)
538 (set-total-byte-from-time sample)
539 (set-last-sample sample)
540 (set-data sample))
541
542
543 (defmethod initialize-instance :after ((sample sample) &key)
544 (initialize sample))
545
546 (defgeneric print-sample (sample))
547 (defmethod print-sample ((sample sample))
548 (format t "Sample: ~A~%" (sample-name sample))
549 (print-header sample))
550
551 (defun pad-with-zero (stream pos element-type)
552 (let ((len (file-length stream)))
553 (when (> pos len)
554 (let ((padsize (- pos len)))
555 (file-position stream len)
556 (write-sequence (make-array padsize :initial-element 0
557 :element-type element-type) stream)))))
558
559
560
561 (defun swap-indan-8-big->little (data un-data)
562 (let ((v 0))
563 (dotimes (i (length data))
564 (setf v (aref data i))
565 (setf (aref un-data i)
566 (if (>= v 0) v (logxor (1- (- v)) #xFF))))))
567
568 (defun swap-indan-16-big->little (data un-data)
569 (let ((v 0))
570 (dotimes (i (length data))
571 (setf v (aref data i))
572 (rotatef (ldb (byte 8 0) v) (ldb (byte 8 8) v))
573 (setf (aref un-data i)
574 (if (>= v 0) v (logxor (1- (- v)) #xFFFF))))))
575
576 (defun swap-indan-32-big->little (data un-data)
577 (let ((v 0))
578 (dotimes (i (length data))
579 (setf v (aref data i))
580 (rotatef (ldb (byte 8 0) v) (ldb (byte 8 24) v))
581 (rotatef (ldb (byte 8 8) v) (ldb (byte 8 16) v))
582 (setf (aref un-data i)
583 (if (>= v 0) v (logxor (1- (- v)) #xFFFFFFFF))))))
584
585
586
587 (defun swap-indan-8-little->big (un-data data)
588 (let ((v 0))
589 (dotimes (i (length un-data))
590 (setf v (aref un-data i))
591 (setf (aref data i)
592 (if (zerop (logand v #x80))
593 (logand v #x7F)
594 (- (1+ (logxor v #xFF))))))))
595
596
597 (defun swap-indan-16-little->big (un-data data)
598 (let ((v 0))
599 (dotimes (i (length un-data))
600 (setf v (aref un-data i))
601 (rotatef (ldb (byte 8 0) v) (ldb (byte 8 8) v))
602 (setf (aref data i)
603 (if (zerop (logand v #x8000))
604 (logand v #x7FFF)
605 (- (1+ (logxor v #xFFFF))))))))
606
607 (defun swap-indan-32-little->big (un-data data)
608 (let ((v 0))
609 (dotimes (i (length un-data))
610 (setf v (aref un-data i))
611 (rotatef (ldb (byte 8 0) v) (ldb (byte 8 24) v))
612 (rotatef (ldb (byte 8 8) v) (ldb (byte 8 16) v))
613 (setf (aref data i)
614 (if (zerop (logand v #x80000000))
615 (logand v #x7FFFFFFF)
616 (- (1+ (logxor v #xFFFFFFFF))))))))
617
618
619 (defgeneric write-sample (filename sample &key start))
620
621 (defmethod write-sample (filename (sample (eql nil)) &key start)
622 (declare (ignore filename sample start))
623 nil)
624
625 #-PPC
626 (defmethod write-sample (filename (sample sample) &key start)
627 (labels ((l-write ()
628 (with-slots (n-bits-per-sample data) sample
629 (write-header filename sample :if-exists :supersede)
630 (with-open-file (stream filename :direction :output
631 :if-exists :overwrite
632 :if-does-not-exist :create
633 :element-type
634 `(signed-byte ,n-bits-per-sample))
635 (file-position stream (skip-header sample))
636 (write-sequence data stream))))
637 (l-merge ()
638 (let ((header (copy-header sample)))
639 (when (probe-file filename)
640 (read-header filename header)
641 (assert (header-equal sample header) ()
642 "error writing wav: ~S is in a wrong format"
643 filename))
644 (set-sample-info header)
645 (write-fake-header filename header)
646 (with-open-file (stream filename :direction :output
647 :if-exists :overwrite
648 :if-does-not-exist :create
649 :element-type
650 `(signed-byte
651 ,(sample-n-bits-per-sample header)))
652 (let ((pos-start (+ (skip-header header)
653 (* (t->s header start)
654 (sample-n-channels header)))))
655 (pad-with-zero stream pos-start
656 `(signed-byte
657 ,(sample-n-bits-per-sample header)))
658 (file-position stream pos-start)
659 (write-sequence (data sample) stream)
660 (file-position stream 0)
661 (set-total-byte-from-data header (- (file-length stream)
662 (skip-header header)))
663 (set-last-sample header))
664 (write-header filename header)
665 (read-header filename header)))))
666 (if start (l-merge) (l-write))
667 t))
668
669
670
671 #+PPC
672 (defmethod write-sample (filename (sample sample) &key start)
673 (labels ((write-un-data (stream data n-bits-per-sample)
674 (let ((un-data (make-array (length data) :element-type
675 `(unsigned-byte ,n-bits-per-sample))))
676 (case n-bits-per-sample
677 (8 (swap-indan-8-big->little data un-data))
678 (16 (swap-indan-16-big->little data un-data))
679 (32 (swap-indan-32-big->little data un-data)))
680 (write-sequence un-data stream)))
681 (l-write ()
682 (with-slots (n-bits-per-sample data) sample
683 (write-header filename sample :if-exists :supersede)
684 (with-open-file (stream filename :direction :output
685 :if-exists :overwrite
686 :if-does-not-exist :create
687 :element-type
688 `(unsigned-byte ,n-bits-per-sample))
689 (file-position stream (skip-header sample))
690 (write-un-data stream data n-bits-per-sample))))
691 (l-merge ()
692 (let ((header (copy-header sample)))
693 (when (probe-file filename)
694 (read-header filename header)
695 (assert (header-equal sample header) ()
696 "error writing wav: ~S is in a wrong format"
697 filename))
698 (set-sample-info header)
699 (write-fake-header filename header)
700 (with-open-file (stream filename :direction :output
701 :if-exists :overwrite
702 :if-does-not-exist :create
703 :element-type
704 `(unsigned-byte
705 ,(sample-n-bits-per-sample header)))
706 (let ((pos-start (+ (skip-header header)
707 (* (t->s header start)
708 (sample-n-channels header)))))
709 (pad-with-zero stream pos-start
710 `(signed-byte
711 ,(sample-n-bits-per-sample header)))
712 (file-position stream pos-start)
713 (write-un-data stream (data sample)
714 (sample-n-bits-per-sample sample))
715 (file-position stream 0)
716 (set-total-byte-from-data header (- (file-length stream)
717 (skip-header header)))
718 (set-last-sample header))
719 (write-header filename header)
720 (read-header filename header)))))
721 (if start (l-merge) (l-write))
722 t))
723
724
725
726 #-PPC
727 (defun read-sample (filename &key start end name)
728 (let ((sample (make-instance 'sample :n-channels 1
729 :n-samples-per-sec 22050
730 :n-bits-per-sample 16
731 :name (or name (file-namestring filename)))))
732 (with-slots (n-bits-per-sample data) sample
733 (read-header filename sample)
734 (set-sample-info sample)
735 (set-last-sample sample)
736 (multiple-value-bind (smin smax)
737 (find-smin-smax sample start end)
738 (setf data (make-data (- smax smin) n-bits-per-sample))
739 (with-open-file (stream filename :direction :input
740 :element-type
741 `(signed-byte ,n-bits-per-sample))
742 (file-position stream (+ (skip-header sample) smin))
743 (read-sequence data stream)))
744 (set-total-byte-from-data sample)
745 (set-last-sample sample)
746 sample)))
747
748 #+PPC
749 (defun read-sample (filename &key start end name)
750 (let ((sample (make-instance 'sample :n-channels 1
751 :n-samples-per-sec 22050
752 :n-bits-per-sample 16
753 :name (or name (file-namestring filename)))))
754 (with-slots (n-bits-per-sample data) sample
755 (read-header filename sample)
756 (set-sample-info sample)
757 (set-last-sample sample)
758 (multiple-value-bind (smin smax)
759 (find-smin-smax sample start end)
760 (setf data (make-data (- smax smin) n-bits-per-sample))
761 (let ((un-data (make-array (length data) :element-type
762 `(unsigned-byte ,n-bits-per-sample))))
763 (with-open-file (stream filename :direction :input
764 :element-type
765 `(unsigned-byte ,n-bits-per-sample))
766 (file-position stream (+ (skip-header sample) smin))
767 (read-sequence un-data stream))
768 (case n-bits-per-sample
769 (8 (swap-indan-8-little->big un-data data))
770 (16 (swap-indan-16-little->big un-data data))
771 (32 (swap-indan-32-little->big un-data data)))))
772 (set-total-byte-from-data sample)
773 (set-last-sample sample)
774 sample)))
775
776
777 (defgeneric copy-sample (sample &key start end name))
778 (defmethod copy-sample ((sample sample) &key start end name)
779 (with-slots (n-samples-per-sec
780 n-bits-per-sample n-channels data
781 (sample-name name)) sample
782 (let ((new-sample (make-instance 'sample
783 :n-channels n-channels
784 :n-samples-per-sec n-samples-per-sec
785 :n-bits-per-sample n-bits-per-sample
786 :name (or name sample-name))))
787 (set-sample-info new-sample)
788 (multiple-value-bind (smin smax)
789 (find-smin-smax sample start end)
790 (setf (data new-sample) (subseq data smin smax)))
791 (set-total-byte-from-data new-sample)
792 (set-last-sample new-sample)
793 new-sample)))
794
795
796 (defgeneric apply-on-sample (sample fun &key args start end))
797 (defmethod apply-on-sample (sample fun &key args start end)
798 (with-slots (n-samples-per-sec
799 n-bits-per-sample n-channels data
800 (sample-name name)) sample
801 (let ((new-sample (make-instance 'sample
802 :n-channels n-channels
803 :n-samples-per-sec n-samples-per-sec
804 :n-bits-per-sample n-bits-per-sample))
805 val)
806 (set-sample-info new-sample)
807 (multiple-value-bind (smin smax)
808 (find-smin-smax sample start end)
809 (with-slots ((new-data data) max-ampl) new-sample
810 (setf new-data (copy-seq data))
811 (loop for i from smin below smax do
812 (setf val (truncate (apply fun i
813 (aref data i)
814 args)))
815 (setf (aref new-data i)
816 (cond ((>= val max-ampl) max-ampl)
817 ((<= val (- max-ampl)) (- max-ampl))
818 (t val))))))
819 (set-total-byte-from-data new-sample)
820 (set-last-sample new-sample)
821 new-sample)))
822
823
824
825
826
827 (defun cut-sample (sample start end &key name)
828 "Return a new sample without the cutted part"
829 (with-slots (n-samples-per-sec
830 n-bits-per-sample n-channels data
831 (sample-name name)) sample
832 (let ((new-sample (make-instance 'sample
833 :n-channels n-channels
834 :n-samples-per-sec n-samples-per-sec
835 :n-bits-per-sample n-bits-per-sample
836 :name (or name sample-name))))
837 (set-sample-info new-sample)
838 (multiple-value-bind (smin smax)
839 (find-smin-smax sample start end)
840 (setf (data new-sample) (concatenate 'vector
841 (subseq data 0 smin)
842 (subseq data smax))))
843 (set-total-byte-from-data new-sample)
844 (set-last-sample new-sample)
845 new-sample)))
846
847
848 (defun insert-sample (sample sample2 start &key name)
849 "Return a new sample with sample2 inserted at start seconds"
850 (with-slots (n-samples-per-sec
851 n-bits-per-sample n-channels data max-index
852 (sample-name name)) sample
853 (assert (header-equal sample sample2)
854 ()
855 "error samples must have the same format")
856 (let ((new-sample (make-instance 'sample
857 :n-channels n-channels
858 :n-samples-per-sec n-samples-per-sec
859 :n-bits-per-sample n-bits-per-sample
860 :name (or name sample-name)))
861 (ind (time-to-sample n-samples-per-sec start)))
862 (set-sample-info new-sample)
863 (setf (data new-sample)
864 (if (< ind max-index)
865 (concatenate 'vector
866 (subseq data 0 ind)
867 (data sample2)
868 (subseq data ind))
869 (concatenate 'vector
870 data
871 (make-array (- ind max-index) :initial-element 0
872 :element-type `(signed-byte ,n-bits-per-sample))
873 (data sample2))))
874 (set-total-byte-from-data new-sample)
875 (set-last-sample new-sample)
876 new-sample)))
877
878
879
880
881
882
883
884 (defun calc-new-len (len1 len2 start)
885 "Return the new length of a sample with 1 channel
886 <--- len 1 --->
887 <----- len 2 ----->
888 ^ |_start ^
889 |----- new len --------|"
890 (let ((rest (- (+ len2 start) len1)))
891 (+ len1 (if (> rest 0) rest 0))))
892
893 (defgeneric mix-sample (sample1 sample2 fun &key args start))
894 (defmethod mix-sample ((sample1 sample) (sample2 sample) fun
895 &key args (start 0))
896 (with-slots ((n-channels-1 n-channels)
897 (n-bits-per-sample-1 n-bits-per-sample)
898 (n-samples-per-sec-1 n-samples-per-sec)
899 (data-1 data)) sample1
900 (with-slots ((n-channels-2 n-channels)
901 (n-bits-per-sample-2 n-bits-per-sample)
902 (n-samples-per-sec-2 n-samples-per-sec)
903 (data-2 data)) sample2
904 (assert (header-equal sample1 sample2)
905 ()
906 "error sample and new channel must have the same format")
907 (assert (>= start 0) ()
908 "error start must be a null or positive time in seconds")
909 (let* ((len1 (length data-1))
910 (len2 (length data-2))
911 (s-start (* (time-to-sample n-samples-per-sec-2 start) n-channels-2))
912 (new-len (* (calc-new-len (/ len1 n-channels-1)
913 (/ len2 n-channels-2)
914 (/ s-start n-channels-2))
915 n-channels-1))
916 (new-sample (make-instance 'sample :n-channels n-channels-1
917 :n-bits-per-sample n-bits-per-sample-1
918 :n-samples-per-sec n-samples-per-sec-1
919 :data (make-data new-len
920 n-bits-per-sample-1)))
921 val)
922 (set-sample-info new-sample)
923 (set-total-byte-from-data new-sample)
924 (set-last-sample new-sample)
925 (with-slots (data max-ampl) new-sample
926 (dotimes (i new-len)
927 (setf val (truncate (apply fun i
928 (if (< i len1) (aref data-1 i) 0)
929 (if (< s-start i (+ s-start len2))
930 (aref data-2 (- i s-start))
931 0)
932 args)))
933 (setf (aref data i)
934 (cond ((>= val max-ampl) max-ampl)
935 ((<= val (- max-ampl)) (- max-ampl))
936 (t val)))))
937 new-sample))))
938
939
940 (defmethod mix-sample ((filename string) (sample2 sample) fun
941 &key args (start 0))
942 (let ((sample1 (read-sample filename
943 :start start
944 :end (+ start (sample-time sample2)))))
945 (write-sample filename
946 (mix-sample sample1 sample2 fun :args args)
947 :start start)))
948
949
950 (defgeneric extract-channel (sample chan))
951 (defmethod extract-channel ((sample sample) chan)
952 (with-slots (n-channels
953 n-bits-per-sample n-samples-per-sec data) sample
954 (assert (<= 0 chan (1- n-channels)) ()
955 "error new channel can't be ~A (chan=[0..~A])"
956 chan (1- n-channels))
957 (let* ((len (/ (length data) n-channels))
958 (new-sample (make-instance 'sample :n-channels 1
959 :n-bits-per-sample n-bits-per-sample
960 :n-samples-per-sec n-samples-per-sec
961 :data (make-data len
962 n-bits-per-sample))))
963 (set-sample-info new-sample)
964 (set-total-byte-from-data new-sample)
965 (set-last-sample new-sample)
966 (with-slots ((new-data data)) new-sample
967 (dotimes (i len)
968 (setf (aref new-data i)
969 (aref data (+ (* i n-channels) chan)))))
970 new-sample)))
971
972
973 ;;; data: |1 2|1 2|1 2|1 2|1 2| 2 channels
974 ;;; New-chan-data: |3|3|3|
975 ;;; => new-data: |1 2 3|1 2 3|1 2 3|1 2 0|1 2 0| with start=0
976 ;;; => new-data: |1 2 0|1 2 3|1 2 3|1 2 3|1 2 0| with start=1
977 ;;; => new-data: |1 2 0|1 2 0|1 2 0|1 2 3|1 2 3|1 2 3| with start=3
978 (defgeneric add-channel (sample chan new-chan &key start))
979 (defmethod add-channel ((sample sample) chan (new-chan sample) &key (start 0))
980 (with-slots ((n-channels-1 n-channels)
981 (n-bits-per-sample-1 n-bits-per-sample)
982 (n-samples-per-sec-1 n-samples-per-sec)
983 (data-1 data)) sample
984 (with-slots ((n-channels-2 n-channels)
985 (n-bits-per-sample-2 n-bits-per-sample)
986 (n-samples-per-sec-2 n-samples-per-sec)
987 (data-2 data)) new-chan
988 (assert (= n-channels-2 1) ()
989 "error new channel must be a 1 channel sample")
990 (assert (<= 0 chan n-channels-1) ()
991 "error new channel can't be put in channel ~A (chan=[0..~A])"
992 chan n-channels-1)
993 (assert (and (= n-bits-per-sample-1 n-bits-per-sample-2)
994 (= n-samples-per-sec-1 n-samples-per-sec-2))
995 ()
996 "error sample and new channel must have the same format")
997 (assert (>= start 0) ()
998 "error start must be a null or positive time in seconds")
999 (let* ((len1 (/ (length data-1) n-channels-1))
1000 (len2 (length data-2))
1001 (s-start (time-to-sample n-samples-per-sec-2 start))
1002 (new-n-chan (1+ n-channels-1))
1003 (new-sample (make-instance 'sample :n-channels new-n-chan
1004 :n-bits-per-sample n-bits-per-sample-1
1005 :n-samples-per-sec n-samples-per-sec-1
1006 :data
1007 (make-data (* (calc-new-len
1008 len1 len2 s-start)
1009 new-n-chan)
1010 n-bits-per-sample-1))))
1011 (set-sample-info new-sample)
1012 (set-total-byte-from-data new-sample)
1013 (set-last-sample new-sample)
1014 (with-slots (data) new-sample
1015 (dotimes (i len1)
1016 (dotimes (j n-channels-1)
1017 (setf (aref data (+ (* i new-n-chan)
1018 (if (>= j chan) (1+ j) j)))
1019 (aref data-1 (+ (* i n-channels-1) j)))))
1020 (dotimes (i len2)
1021 (setf (aref data (+ (* (+ i s-start) new-n-chan) chan))
1022 (aref data-2 i)))
1023 new-sample)))))
1024
1025
1026 ;;; Time to Freq functions
1027
1028 (defun fft (rl im dir)
1029 (let* ((len (length rl))
1030 (n (if (oddp len) (1- len) len))
1031 (n/2 (/ n 2))
1032 (imh (truncate (/ (log (1+ n)) (log 2.0)))))
1033 ;; bits inversion
1034 (loop for i below n
1035 with j = 0
1036 with m do
1037 (when (> j i)
1038 (rotatef (aref rl j) (aref rl i))
1039 (rotatef (aref im j) (aref im i)))
1040 (setf m n/2)
1041 (loop while (and (>= m 2) (>= j m)) do
1042 (setf j (- j m)
1043 m (truncate (/ m 2))))
1044 (setf j (+ j m)))
1045 ;; FFT calculation
1046 (loop for lg below imh
1047 with m = 2
1048 with ldm = 1
1049 with mh = n/2
1050 with angle = (* pi dir)
1051 with i with j with u
1052 with ur with ui
1053 with vr with vi
1054 with c with s do
1055 (setf c (cos angle)
1056 s (sin angle)
1057 ur 1.0
1058 ui 0.0)
1059 (loop for i2 below ldm do
1060 (setf i i2
1061 j (+ i2 ldm))
1062 (loop for j2 below mh do
1063 (setf vr (- (* ur (aref rl j)) (* ui (aref im j)))
1064 vi (+ (* ur (aref im j)) (* ui (aref rl j)))
1065 (aref rl j) (- (aref rl i) vr)
1066 (aref im j) (- (aref im i) vi))
1067 (incf (aref rl i) vr)
1068 (incf (aref im i) vi)
1069 (incf i m)
1070 (incf j m))
1071 (setf u ur
1072 ur (- (* ur c) (* ui s))
1073 ui (+ (* ui c) (* u s))))
1074 (setf mh (truncate (/ mh 2))
1075 ldm m
1076 angle (* angle 0.5)
1077 m (* m 2)))
1078 (when (= dir 1)
1079 (dotimes (i len)
1080 (setf (aref rl i) (/ (aref rl i) n))
1081 (setf (aref im i) (/ (aref im i) n))))
1082 (values rl im)))
1083
1084 (defgeneric time<->freq (object))
1085 (defmethod time<->freq ((sample sample))
1086 (with-slots (n-samples-per-sec
1087 data n-bits-per-sample n-channels time) sample
1088 (assert (= n-channels 1) ()
1089 "error sample must have exactly one channel and not ~A"
1090 n-channels)
1091 (let ((spectrum (make-instance 'spectrum :time time
1092 :n-samples-per-sec n-samples-per-sec
1093 :n-bits-per-sample n-bits-per-sample
1094 :data (make-array (length data)
1095 :initial-contents
1096 (copy-seq data))
1097 :im (make-array (length data)
1098 :initial-element 0))))
1099 (fft (data spectrum) (spectrum-im spectrum) 1)
1100 spectrum)))
1101
1102 (defmethod time<->freq ((spectrum spectrum))
1103 (with-slots (n-samples-per-sec
1104 n-bits-per-sample data im time) spectrum
1105 (print 'debut)
1106 (let* ((len (length data))
1107 (sample (make-instance 'sample :n-channels 1
1108 :n-samples-per-sec n-samples-per-sec
1109 :n-bits-per-sample n-bits-per-sample
1110 :time time
1111 :data (make-data (length data)
1112 n-bits-per-sample)))
1113 (rl (copy-seq data))
1114 (im (copy-seq im)))
1115 (set-sample-info sample)
1116 (format t "Max spectrum=~A~%"
1117 (loop for i across rl maximize i))
1118 (fft rl im -1)
1119 (print 'ici)
1120 (format t "Max spectrum=~A~%"
1121 (loop for i across rl maximize i))
1122 (with-slots (max-ampl) sample
1123 (let (val)
1124 (dotimes (i (length rl))
1125 (setf val (truncate (* (aref rl i) len)))
1126 (setf (aref (data sample) i)
1127 (cond ((>= val max-ampl) max-ampl)
1128 ((<= val (- max-ampl)) (- max-ampl))
1129 (t val))))))
1130 (format t "Max spectrum=~A~%"
1131 (loop for i across (data sample) maximize i))
1132 (set-total-byte-from-data sample)
1133 (set-last-sample sample)
1134 sample)))
1135
1136
1137 ;;; Generators
1138
1139 (defgeneric sample-make-square (sample fun chan start end freq
1140 minampl maxampl))
1141 (defmethod sample-make-square ((sample sample) fun chan start end freq
1142 minampl maxampl)
1143 "Add a square on sample"
1144 (let* ((smin (t->s sample start))
1145 (smax (min (t->s sample end)
1146 (- (sample-max-index sample) 2)))
1147 (sfreq (f->s sample freq))
1148 (sfreq/2 (/ sfreq 2)))
1149 (loop for i from smin to smax do
1150 (set-ampl sample fun chan i
1151 (if (> sfreq/2 (mod (- i smin) sfreq))
1152 maxampl minampl)))))
1153
1154 (defgeneric sample-make-line (sample fun chan start end freq minampl maxampl))
1155 (defmethod sample-make-line ((sample sample) fun chan start end freq
1156 minampl maxampl)
1157 "Add a line on sample"
1158 (let* ((smin (t->s sample start))
1159 (smax (min (t->s sample end)
1160 (- (sample-max-index sample) 2)))
1161 (sfreq (f->s sample freq))
1162 (dy (/ (- maxampl minampl) sfreq)))
1163 (loop for i from smin to smax do
1164 (set-ampl sample fun chan i
1165 (+ minampl (* (mod (- i smin) sfreq) dy))))))
1166
1167
1168 (defgeneric sample-make-line* (sample fun chan start end freq ampls))
1169 (defmethod sample-make-line* ((sample sample) fun chan start end freq ampls)
1170 "Add lines on sample. Ampls is a list like '((val1 ampl1) (val2 ampl2)...)
1171 where 0 <= val <= 1"
1172 (let* ((smin (t->s sample start))
1173 (smax (t->s sample end))
1174 (sfreq (f->s sample freq))
1175 (points (mapcar #'(lambda (x)
1176 (list (* (first x) sfreq) (second x)))
1177 ampls)))
1178 (labels ((line (mins maxs mina maxa)
1179 (let ((dy (/ (- maxa mina) (- maxs mins))))
1180 (loop for i from smin to smax do
1181 (when (<= mins (mod (- i smin) sfreq) maxs)
1182 (set-ampl sample fun chan i
1183 (+ mina (* (mod (- i smin mins) sfreq)
1184 dy))))))))
1185 (loop for last = (first points) then p
1186 for p in (cdr points) do
1187 (line (first last) (first p) (second last) (second p))))))
1188
1189
1190 (defgeneric sample-make-sin (sample fun chan start end freq ampl sin-fun
1191 &optional phase))
1192 (defmethod sample-make-sin ((sample sample) fun chan start end freq ampl
1193 sin-fun &optional (phase 0))
1194 "Add a sinus on sample"
1195 (let* ((smin (t->s sample start))
1196 (smax (min (t->s sample end)
1197 (- (sample-max-index sample) 2)))
1198 (sfreq (f->s sample freq)))
1199 (loop for i from smin to smax do
1200 (set-ampl sample fun chan i
1201 (* ampl
1202 (funcall sin-fun
1203 (+ (* 2 *spi* (/ (- i smin) sfreq)) phase)))))))
1204
1205 (defgeneric sample-make-noise (sample fun chan start end freq minampl maxampl))
1206 (defmethod sample-make-noise ((sample sample) fun chan start end freq
1207 minampl maxampl)
1208 "Add a noise on sample"
1209 (let* ((smin (t->s sample start))
1210 (smax (min (t->s sample end)
1211 (- (sample-max-index sample) 2)))
1212 (sfreq (f->s sample freq)))
1213 (loop for i from smin to smax
1214 with val = 0 do
1215 (when (zerop (mod (- i smin) sfreq))
1216 (setf val (random-mm minampl maxampl)))
1217 (set-ampl sample fun chan i val))))
1218
1219
1220
1221
1222 (defun build-from-freq (freqs &key (n-samples-per-sec 22050)
1223 (n-bits-per-sample 16) (time 1))
1224 "Build a new sample based on frequences and amplitudes
1225 freqs is a list like this '((freq1 ampl1 phase1) (freq2 ampl2 phase2) ...)"
1226 (labels ((set-fun (data new)
1227 (declare (ignore data))
1228 new))
1229 (let ((sample (make-instance 'sample :n-channels 1
1230 :n-samples-per-sec n-samples-per-sec
1231 :n-bits-per-sample n-bits-per-sample
1232 :time time)))
1233 (with-slots (max-ampl) sample
1234 (sample-make-sin sample #'set-fun 0 0 time (first (first freqs))
1235 (* max-ampl (second (first freqs))) #'sin)
1236 (dolist (freq (rest freqs))
1237 (when (plusp (second freq))
1238 (sample-make-sin sample #'+ 0 0 time (first freq)
1239 (* max-ampl (second freq)) #'sin
1240 (third freq)))))
1241 sample)))
1242
1243
1244 (defun read-freq-from-file (filename base-freq)
1245 "Read frequences and phases from a file :
1246 - first column gain in decibels
1247 - second column phase in radian"
1248 (with-open-file (stream filename :direction :input)
1249 (loop for line = (read-line stream nil :eof)
1250 for i from 1
1251 while (not (eql line :eof))
1252 collect (multiple-value-bind (gain pos)
1253 (read-from-string line)
1254 (list (* base-freq i)
1255 (expt 10 (/ gain 20))
1256 (read-from-string (subseq line pos)))))))
1257
1258
1259
1260 ;;; Viewers (with gnuplot)
1261 (defgeneric sample-view (object &key min max fun))
1262
1263
1264 (defmacro with-view ((stream min max) &body body)
1265 (let ((dataname (gensym))
1266 (filename (gensym)))
1267 `(let ((,dataname (format nil "data-~A.log" (gensym)))
1268 (,filename (format nil "gnuplot-~A.gnuplot" (gensym))))
1269 (with-open-file (,stream ,filename :direction :output
1270 :if-exists :supersede
1271 :if-does-not-exist :create)
1272 (format ,stream "set terminal x11~%")
1273 (format ,stream "set mouse~%")
1274 (format ,stream "plot [~A:~A] ~S with lines~%" ,min ,max ,dataname)
1275 (format ,stream "pause mouse~%"))
1276 (with-open-file (,stream ,dataname :direction :output
1277 :if-exists :supersede
1278 :if-does-not-exist :create)
1279 (progn
1280 ,@body))
1281 (ushell "gnuplot" ,filename)
1282 (delete-file ,dataname)
1283 (delete-file ,filename))))
1284
1285
1286
1287 (defmethod sample-view ((spectrum spectrum) &key (min 0) (max 1000) (fun #'abs))
1288 (with-view (stream min max)
1289 (loop for i from (freq->index spectrum min) to (freq->index spectrum max) do
1290 (format stream "~A ~A~%"
1291 (/ i (spectrum-time spectrum))
1292 (funcall fun (complex (aref (data spectrum) i)
1293 (aref (spectrum-im spectrum) i)))))))
1294
1295 (defmethod sample-view ((sample sample) &key (min 0) (max 1000) (fun 0))
1296 (with-view (stream min max)
1297 (with-slots (max-ampl) sample
1298 (loop for i from (t->s sample min) to (t->s sample max) do
1299 (format stream "~A ~A~%"
1300 (float (s->t sample i))
1301 (get-ampl sample fun i))))))
1302
1303
1304
1305
1306 ;;; Song builder
1307
1308 (defclass song-sample ()
1309 ((time :initarg :time :initform 0 :accessor s-time)
1310 (form :initarg :form :initform nil :accessor s-form)
1311 (pos :initarg :pos :initform 0 :accessor s-pos)
1312 (tags :initarg :tags :initform nil :accessor s-tags)
1313 (color :initarg :color :initform #x00FF00 :accessor s-color)
1314 (length :initarg :length :initform 0.2 :accessor s-length)))
1315
1316
1317 (defun listify (elem)
1318 "Build a list from elem"
1319 (if (or (null elem) (consp elem))
1320 elem
1321 (list elem)))
1322
1323
1324 (defgeneric add-tags (song-sample tag-elem))
1325 (defgeneric del-tags (song-sample tag-elem))
1326
1327 (defmethod add-tags ((song-sample song-sample) tag-elem)
1328 "Add all tags in tag-elem to song-sample
1329 tag-elem can be a tag or a list of tags"
1330 (setf (s-tags song-sample)
1331 (append (listify (s-tags song-sample))
1332 (listify tag-elem))))
1333
1334 (defmethod del-tags ((song-sample song-sample) tag-elem)
1335 "Delete all tags in song-sample from tag-elem
1336 tag-elem can be a tag or a list of tags"
1337 (setf (s-tags song-sample)
1338 (if (consp tag-elem)
1339 (set-difference (s-tags song-sample) tag-elem)
1340 (remove tag-elem (s-tags song-sample)))))
1341
1342
1343 (defun copy-song-sample (song-sample &key time form pos tags color length)
1344 "Copy a song sample"
1345 (make-instance 'song-sample :time (or time (s-time song-sample))
1346 :form (or form (s-form song-sample))
1347 :pos (or pos (s-pos song-sample))
1348 :tags (or tags (s-tags song-sample))
1349 :color (or color (s-color song-sample))
1350 :length (or length (s-length song-sample))))
1351
1352
1353
1354 (defun eval-song-sample-form (song-sample)
1355 "Eval a song sample form, return the produced sample and set
1356 the length to the duration of sample"
1357 (with-slots (form length) song-sample
1358 (let ((sample (typecase form
1359 (string (read-sample form))
1360 (t (ignore-errors (eval form))))))
1361 (when (sample-p sample)
1362 (setf length (sample-time sample)))
1363 sample)))
1364
1365
1366 (defun build-song (filename song)
1367 "A song is a list of song-sample
1368 - Time is the time where to insert the form.
1369 - Form is :
1370 - a string: read the associated file and merge it into filename
1371 - everything else: eval and merge the result if it's a sample.
1372 - Pos is the vertical position for a GUI interface.
1373 - Tags is a symbol or a list of symbol to identify the sample
1374 - Color is the sample color representation
1375 - Length is the sample length in seconds"
1376 (flet ((display-sample (sample)
1377 (with-slots (time form pos tags color length) sample
1378 (format t "Time: ~As pos: ~A tags: ~S color: ~6,'0X length: ~As~%"
1379 time pos tags color length)
1380 (format t " ~S~%" form))
1381 (force-output)))
1382 (let ((song (sort (copy-list song) #'(lambda (x y)
1383 (< (s-time x)
1384 (s-time y)))))
1385 (first-sample-p t))
1386 (when (probe-file filename)
1387 (delete-file filename))
1388 (dolist (sample song)
1389 (display-sample sample)
1390 (let ((ev-sample (eval-song-sample-form sample)))
1391 (when (and (sample-p ev-sample)
1392 (>= (s-time sample) 0))
1393 (if first-sample-p
1394 (progn
1395 (write-sample filename ev-sample
1396 :start (s-time sample))
1397 (setf first-sample-p nil))
1398 (mix-sample filename ev-sample
1399 #'(lambda (index s1 s2)
1400 (declare (ignorable index))
1401 (+ s1 s2))
1402 :start (s-time sample)))))))))
1403
1404 (defun build-song-in-interval (filename song begin end)
1405 (build-song filename
1406 (loop for sample in song
1407 when (or (not (sample-p (eval-song-sample-form sample)))
1408 (<= begin (s-time sample) end))
1409 collect (copy-song-sample sample :time (- (s-time sample) begin)))))
1410
1411
1412
1413 (defun list-to-song (list)
1414 (mapcar #'(lambda (elem)
1415 (destructuring-bind (time form pos tags color length) elem
1416 (make-instance 'song-sample
1417 :time (or time 0)
1418 :form form
1419 :pos (or pos 0)
1420 :tags tags
1421 :color (or color #x00FF00)
1422 :length (or length 0.2))))
1423 list))
1424
1425 (defmacro with-build-song ((filename) &rest body)
1426 `(build-song ,filename (list-to-song ',body)))
1427
1428 (defmacro with-list-song (() &rest body)
1429 `(list-to-song ',body))
1430
1431
1432 (defun write-song (filename song)
1433 (with-open-file (stream filename :direction :output
1434 :if-exists :supersede
1435 :if-does-not-exist :create)
1436 (format stream ";;;; -*- Mode: Lisp -*-")
1437 (format stream "~&~%(setf ~S" '*current-song*)
1438 (format stream "~& (with-list-song ()~%")
1439 (dolist (sample song)
1440 (format stream "~& (~S ~S ~S ~S #x~6,'0X ~S)"
1441 (s-time sample)
1442 (s-form sample)
1443 (s-pos sample)
1444 (s-tags sample)
1445 (s-color sample)
1446 (s-length sample)))
1447 (format stream "))~%")))
1448
1449 (defun read-song (filename)
1450 (with-open-file (stream filename :direction :input)
1451 (load filename))
1452 *current-song*)

  ViewVC Help
Powered by ViewVC 1.1.5