/[cl-wav-synth]/cl-wav-synth/clim-song-recorder.lisp
ViewVC logotype

Contents of /cl-wav-synth/clim-song-recorder.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (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.3: +0 -1 lines
First libterminatorX commit
1 ;;; CL-Wav-Synth - Manipulate WAV files
2 ;;;
3 ;;; Copyright (C) 2006 Philippe Brochard (hocwp@free.fr)
4 ;;;
5 ;;; #Date#: Mon Feb 5 14:56:54 2007
6 ;;;
7 ;;; **********************************************
8 ;;; The authors grant you the rights to distribute
9 ;;; and use this software as governed by the terms
10 ;;; of the Lisp Lesser GNU Public License
11 ;;; (http://opensource.franz.com/preamble.html),
12 ;;; known as the LLGPL.
13 ;;; **********************************************
14
15 (in-package :cl-wav-synth)
16
17 (defclass song-key ()
18 ((song-sample :initarg :song-sample :initform nil :accessor sk-song-sample)
19 (mikmod-sample :initarg :mikmod-sample :initform nil :accessor sk-mm-sample)))
20
21
22 (defparameter *current-key-song* (make-hash-table))
23
24 (defun ask-song-sample (field message &optional default)
25 (clim:with-application-frame (frame)
26 (clim:accept field :stream (clim:frame-standard-input frame)
27 :prompt message :default default
28 :insert-default t)))
29
30
31 (defun convert-to-char (obj)
32 "Convert obj to a character."
33 (if obj
34 (typecase obj
35 (character obj)
36 (string (aref obj 0))
37 (symbol (convert-to-char (string-downcase (string obj)))))
38 (progn
39 (format t "Please, hit a key to define~%")
40 (force-output)
41 (clim:stream-read-char *standard-input*))))
42
43
44 (define-wav-function add-song-key (&key char form pos tags color)
45 "Define a new key for the song recorder.
46 char is a character or it'll be asked from a keypress.
47 form, pos, tags and color are the attribute of a song-sample"
48 (let ((n-char (convert-to-char char)))
49 (format t "Defining: ~S~%" n-char)
50 (force-output)
51 (let ((song-sample (make-instance 'song-sample :time 0
52 :form (or form (ask-song-sample 'wav-clim::form "Form"))
53 :pos (or pos (ask-song-sample 'number "Position" 0))
54 :tags (or tags (ask-song-sample 'wav-clim::form "Tags"))
55 :color (or color (ask-song-sample 'number "Color" #x00FF00)))))
56 (format t "Defining ~S:~%" n-char)
57 (wav-clim::com-show-song-sample song-sample)
58 (force-output)
59 (setf (gethash n-char *current-key-song*)
60 (make-instance 'song-key :song-sample song-sample)))))
61
62
63 (define-wav-function add-song-key-tone (form &rest def)
64 "Define some new keys for the song recorder.
65 Def is a list like this '(char1 keyword) '(char2 keyword2) ...
66 charN is a key to press in the recorder.
67 keywordN is a tone (:do :re ... or :c :d ...)"
68 (let ((n-form (typecase form
69 (string `(read-sample ,form))
70 (t form))))
71 (dolist (key def)
72 (add-song-key :char (convert-to-char (first key))
73 :form `(tone ,n-form :do ,(second key))))))
74
75 (define-wav-function add-song-key-octave (form def)
76 "Define some new keys for the song recorder.
77 Def is a list of characters to bind. The first char is :do (or :c), the
78 second :re (or :d) and so on..."
79 (apply #'add-song-key-tone form (loop for char in def
80 for tone in *main-tone-list*
81 collect (list char tone))))
82
83
84
85 (define-wav-function edit-song-key (&key char form pos tags color)
86 "Edit a key for the song recorder.
87 char is a character or it'll be asked from a keypress.
88 form, pos, tags and color are the attribute of a song-sample"
89 (let ((n-char (convert-to-char char)))
90 (format t "Editing: ~S~%" n-char)
91 (force-output)
92 (let ((song-key (gethash n-char *current-key-song*)))
93 (if song-key
94 (let ((song-sample (sk-song-sample song-key)))
95 (setf (s-form song-sample) (or form (ask-song-sample 'wav-clim::form
96 "Form" (s-form song-sample)))
97 (s-pos song-sample) (or pos (ask-song-sample 'number
98 "Position" (s-pos song-sample)))
99 (s-tags song-sample) (or tags (ask-song-sample 'wav-clim::form
100 "Tags" (s-tags song-sample)))
101 (s-color song-sample) (or color (ask-song-sample 'number
102 "Color" (s-color song-sample)))))
103 (add-song-key :char n-char :form form :pos pos :tags tags :color color)))))
104
105
106 (define-wav-function remove-song-key (&optional char)
107 "Remove a key for the song recorder"
108 (let ((n-char (convert-to-char char)))
109 (format t "Removing: ~S~%" n-char)
110 (force-output)
111 (let ((song-sample (gethash n-char *current-key-song*)))
112 (when song-sample
113 (remhash n-char *current-key-song*)))))
114
115
116
117 (define-wav-function show-song-recorder-info ()
118 "Show all keys defined for the song recorder"
119 (format t "Recording with the table:~%")
120 (maphash (lambda (key val)
121 (format t " ~S: ~S~%" key (s-form (sk-song-sample val))))
122 *current-key-song*)
123 (format t "~%-*- Press ~S to stop recording -*-~%" #\Newline))
124
125
126
127
128 (defun check-all-song-keys ()
129 (let ((test-sample nil))
130 (maphash (lambda (key val)
131 (format t "Checking ~S -> ~S...~%" key (s-form (sk-song-sample val)))
132 (force-output)
133 (let ((sample (eval-song-sample-form (sk-song-sample val))))
134 (if (sample-p sample)
135 (progn
136 (setf (sk-mm-sample val) sample)
137 (if test-sample
138 (progn
139 (handler-case
140 (mix test-sample sample)
141 (error (err )
142 (format t "Error: ~A~%" err)
143 (force-output)
144 (return-from check-all-song-keys nil))))
145 (setf test-sample sample)))
146 (setf (sk-mm-sample val) nil))))
147 *current-key-song*))
148 t)
149
150
151 #+mikmod
152 (defun register-all-song-keys ()
153 (unless (check-all-song-keys)
154 (return-from register-all-song-keys nil))
155 (setf mikmod:*md-mode* (logior mikmod:*md-mode* #x0004))
156 (unless (zerop (mikmod:mikmod-init ""))
157 (print "Register-all-song-keys: Could not initialize sound")
158 (return-from register-all-song-keys nil))
159 (maphash (lambda (key val)
160 (format t "Compiling ~S -> ~S...~%" key (s-form (sk-song-sample val)))
161 (force-output)
162 (if (sample-p (sk-mm-sample val))
163 (progn
164 (write-sample "tmp-record.wav" (sk-mm-sample val))
165 (setf (sk-mm-sample val) (mikmod:mikmod-load "tmp-record.wav"))
166 (delete-file "tmp-record.wav"))
167 (setf (sk-mm-sample val) nil)))
168 *current-key-song*)
169 (mikmod:mikmod-set-num-voices -1 30)
170 (mikmod:mikmod-enable-output)
171 (format t "Hit a key to start recording...~%")
172 (force-output)
173 (clim:stream-read-char *standard-input*)
174 t)
175
176
177
178 #-mikmod
179 (defun register-all-song-keys ()
180 (check-all-song-keys))
181
182
183
184 #+mikmod
185 (defun play-song-key (song-key)
186 (when (sk-mm-sample song-key)
187 (let ((voice (mikmod:mikmod-play (sk-mm-sample song-key) 0 0)))
188 (mikmod:mikmod-voice-set-panning voice 127)
189 (mikmod:mikmod-update))))
190
191
192 #+mikmod
193 (defun close-all-song-keys ()
194 (maphash (lambda (key val)
195 (declare (ignore key))
196 (when (sk-mm-sample val)
197 (mikmod:mikmod-free (sk-mm-sample val))))
198 *current-key-song*)
199 (mikmod:mikmod-disable-output)
200 (mikmod:mikmod-exit))
201
202
203
204
205
206 (define-wav-function record-song (&optional (delay 0.01))
207 "Record a new song with a virtual keyboard. You can define new
208 keys with add-song-key. Delay is the key granularity."
209 (let ((song nil))
210 (unless (register-all-song-keys)
211 (return-from record-song nil))
212 (show-song-recorder-info)
213 (force-output)
214 (loop with end-loop = nil
215 until end-loop
216 for time from 0 do
217 (loop while (clim:stream-listen *standard-input*) do
218 (let ((char (clim:stream-read-char-no-hang *standard-input*)))
219 (when char
220 (setf end-loop (equal char #\Newline))
221 (let ((song-key (gethash char *current-key-song*)))
222 (when song-key
223 (let ((song-sample (sk-song-sample song-key)))
224 (format t "~A => ~S~%" (* time delay) (s-form song-sample))
225 (force-output)
226 #+mikmod (play-song-key song-key)
227 (push (copy-song-sample song-sample :time (* time delay)) song)))))))
228 #+mikmod (mikmod:mikmod-update)
229 (sleep delay))
230 #+mikmod (close-all-song-keys)
231 song))
232
233
234
235 (define-wav-function save-song-keys (filename)
236 "Save the current keys for the song recorder"
237 (with-open-file (stream filename :direction :output
238 :if-exists :supersede
239 :if-does-not-exist :create)
240 (format stream ";;; Song keys for the recorder -*- lisp -*-~2%")
241 (format stream "~S~2%" '(in-package :wav))
242 (format stream "~S~2%" '(defparameter *current-key-song* (make-hash-table)))
243 (maphash (lambda (key val)
244 (let ((song-sample (sk-song-sample val)))
245 (format stream "~S~%"
246 `(add-song-key :char ,key
247 :form ',(s-form song-sample)
248 :pos ,(s-pos song-sample)
249 :tags ',(s-tags song-sample)
250 :color ,(s-color song-sample)))))
251 *current-key-song*)))
252
253
254 (define-wav-function load-song-keys (filename)
255 "Load keys for the song recorder"
256 (load filename))
257
258
259 ;;; CLIM command table
260
261 (in-package :cl-wav-synth-clim)
262
263
264 (define-command-table song-recorder-command-table)
265
266 (add-menu-item-to-command-table 'song-recorder-command-table "Informations" :divider nil)
267
268 (define-command (com-show-song-key-info :name t :menu t
269 :command-table song-recorder-command-table)
270 ()
271 (cl-wav-synth::show-song-recorder-info))
272
273 (add-menu-item-to-command-table 'song-recorder-command-table "Operations" :divider nil)
274
275 (define-command (com-add-song-key :name t :menu t
276 :command-table song-recorder-command-table)
277 ()
278 (cl-wav-synth::add-song-key))
279
280 (define-command (com-edit-song-key :name t :menu t
281 :command-table song-recorder-command-table)
282 ()
283 (cl-wav-synth::edit-song-key))
284
285 (define-command (com-remove-song-key :name t :menu t
286 :command-table song-recorder-command-table)
287 ()
288 (cl-wav-synth::remove-song-key))
289
290
291 (add-menu-item-to-command-table 'song-recorder-command-table "Files" :divider nil)
292
293 (define-command (com-save-song-keys :name t :menu t
294 :command-table song-recorder-command-table)
295 ((path 'pathname))
296 (cl-wav-synth::save-song-keys path))
297
298 (define-command (com-load-song-keys :name t :menu t
299 :command-table song-recorder-command-table)
300 ((path 'pathname))
301 (cl-wav-synth::load-song-keys path))
302
303
304
305 (add-menu-item-to-command-table 'song-recorder-command-table "Recording" :divider nil)
306
307 (define-command (com-record-song :name t :menu t
308 :command-table song-recorder-command-table)
309 ()
310 (cl-wav-synth::set-song (cl-wav-synth::record-song)))
311
312
313
314 (add-command-table-to-listener 'song-recorder-command-table)
315
316
317
318 ;;; CLIM Listener hack - Adding some mime type
319 (in-package :clim-listener)
320
321 (define-mime-type (text song-keys)
322 (:extensions "keys"))
323
324 (defmethod mime-type-to-command ((mime-type text/song-keys) pathname)
325 (values `(wav-clim::com-load-song-keys ,pathname)
326 (format nil "Load as keys ~A" (file-namestring pathname))
327 (format nil "Load as keys ~A" pathname)))

  ViewVC Help
Powered by ViewVC 1.1.5