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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Aug 25 12:24:02 2006 UTC (7 years, 8 months ago) by pbrochard
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +8 -5 lines
Move song/file menu to global file menu
1 ;;; CL-Wav-Synth - Manipulate WAV files
2 ;;;
3 ;;; Copyright (C) 2006 Philippe Brochard (hocwp@free.fr)
4 ;;;
5 ;;; #Date#: Fri Aug 25 14:07:19 2006
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-clim)
16
17
18 (define-command-table build-song-selection-command-table)
19
20 (defun selection-find-first-point (map-song)
21 (when *pointer-documentation-output*
22 (window-clear *pointer-documentation-output*)
23 (format *pointer-documentation-output* "~&Please, select the first selection point."))
24 (block processor
25 (tracking-pointer (map-song)
26 (:pointer-motion (&key window x y)
27 (declare (ignore window))
28 (display-text-info-on-position x y map-song))
29 (:pointer-button-press (&key event x y)
30 (declare (ignore event))
31 (when *pointer-documentation-output*
32 (window-clear *pointer-documentation-output*))
33 (return-from processor
34 (convert-point-to-pane x y map-song))))))
35
36 (defun selection-find-second-point (time1 pos1 map-song)
37 (multiple-value-bind (x1 y1)
38 (convert-pane-to-point time1 pos1 map-song)
39 (let ((lx x1) (ly y1))
40 (when *pointer-documentation-output*
41 (window-clear *pointer-documentation-output*)
42 (format *pointer-documentation-output* "~&Please, select the second selection point."))
43 (block processor
44 (tracking-pointer (map-song)
45 (:pointer-motion (&key window x y)
46 (declare (ignore window))
47 (draw-rectangle* map-song x1 y1 lx ly :filled nil :ink +flipping-ink+)
48 (draw-rectangle* map-song x1 y1 x y :filled nil :ink +flipping-ink+)
49 (setf lx x ly y)
50 (display-text-info-on-position x y map-song))
51 (:pointer-button-release (&key event x y)
52 (declare (ignore event))
53 (when *pointer-documentation-output*
54 (window-clear *pointer-documentation-output*))
55 (return-from processor
56 (convert-point-to-pane x y map-song))))))))
57
58 (defun selection-rectangular (map-song)
59 (multiple-value-bind (time1 pos1)
60 (selection-find-first-point map-song)
61 (multiple-value-bind (time2 pos2)
62 (selection-find-second-point time1 pos1 map-song)
63 (values time1 pos1 time2 pos2))))
64
65 (defun selection-move-rectangular (map-song time1 pos1 time2 pos2 &optional song-sample-selected)
66 (multiple-value-bind (x1 y1)
67 (convert-pane-to-point time1 pos1 map-song)
68 (multiple-value-bind (x2 y2)
69 (convert-pane-to-point time2 pos2 map-song)
70 (let* ((startx (min x1 x2))
71 (starty (min y1 y2))
72 (lx startx)
73 (ly starty)
74 (width (abs (- x2 x1)))
75 (height (abs (- y2 y1))))
76 (labels ((draw-song-selected (dx dy color)
77 (dolist (song-sample song-sample-selected)
78 (multiple-value-bind (time-x pos-y)
79 (convert-pane-to-point (s-time song-sample) (s-pos song-sample) map-song)
80 (let ((length-x (* (s-length song-sample) (song-scaling map-song)))
81 (radius-y (* (song-sample-radius map-song) (song-scaling map-song))))
82 (draw-rectangle* map-song (+ time-x dx) (+ (- pos-y radius-y) dy)
83 (+ (+ time-x length-x) dx) (+ (+ pos-y radius-y) dy)
84 :ink color :filled nil))))))
85 (draw-song-selected 0 0 +red+)
86 (draw-rectangle* map-song lx ly (+ lx width) (+ ly height)
87 :filled nil :ink +red+)
88 (draw-song-selected (- lx startx) (- ly starty) +flipping-ink+)
89 (draw-rectangle* map-song lx ly (+ lx width) (+ ly height)
90 :filled nil :ink +flipping-ink+)
91 (block processor
92 (tracking-pointer (map-song)
93 (:pointer-motion (&key window x y)
94 (declare (ignore window))
95 (draw-rectangle* map-song lx ly (+ lx width) (+ ly height)
96 :filled nil :ink +flipping-ink+)
97 (draw-song-selected (- lx startx) (- ly starty) +flipping-ink+)
98 (draw-rectangle* map-song x y (+ x width) (+ y height)
99 :filled nil :ink +flipping-ink+)
100 (draw-song-selected (- x startx) (- y starty) +flipping-ink+)
101 (setf lx x ly y)
102 (display-text-info-on-position x y map-song))
103 (:pointer-button-release
104 (&key event x y)
105 (declare (ignore event))
106 (return-from processor
107 (multiple-value-bind (time3 pos3)
108 (convert-point-to-pane x y map-song)
109 (multiple-value-bind (time4 pos4)
110 (convert-point-to-pane (+ x width) (+ y height) map-song)
111 (values time3 pos3 time4 pos4))))))))))))
112
113
114 (add-menu-item-to-command-table 'build-song-selection-command-table "Samples operations" :divider nil)
115
116
117
118 (define-command (com-song-selection-move-click :name t :menu nil
119 :command-table build-song-selection-command-table)
120 ((x 'real) (y 'real))
121 (with-application-frame (frame)
122 (let ((map-song (find-pane-named frame 'map-song)))
123 (multiple-value-bind (time1 pos1)
124 (convert-point-to-pane x y map-song)
125 (multiple-value-bind (time2 pos2)
126 (selection-find-second-point time1 pos1 map-song)
127 (multiple-value-bind (time3 pos3 time4 pos4)
128 (selection-move-rectangular map-song time1 pos1 time2 pos2
129 (wav::s-find :time (<= (min time1 time2) wav::time (max time1 time2))
130 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2))))
131 (let ((dtime (- (min time3 time4) (min time1 time2)))
132 (dpos (- (min pos3 pos4) (min pos1 pos2))))
133 (wav::s-map (:time (<= (min time1 time2) wav::time (max time1 time2))
134 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2)))
135 (incf wav::time dtime)
136 (incf wav::pos dpos)))))))))
137
138 (defmacro selection-call-com-click (&body body)
139 `(with-application-frame (frame)
140 (let ((map-song (find-pane-named frame 'map-song)))
141 (multiple-value-bind (time1 pos1)
142 (selection-find-first-point map-song)
143 (multiple-value-bind (x1 y1)
144 (convert-pane-to-point time1 pos1 map-song)
145 ,@body)))))
146
147 (define-command (com-song-selection-move :name t :menu "Move samples in selection"
148 :command-table build-song-selection-command-table)
149 ()
150 (selection-call-com-click (com-song-selection-move-click x1 y1)))
151
152
153
154 (define-command (com-song-selection-copy-click :name t :menu nil
155 :command-table build-song-selection-command-table)
156 ((x 'real) (y 'real))
157 (with-application-frame (frame)
158 (let ((map-song (find-pane-named frame 'map-song)))
159 (multiple-value-bind (time1 pos1)
160 (convert-point-to-pane x y map-song)
161 (multiple-value-bind (time2 pos2)
162 (selection-find-second-point time1 pos1 map-song)
163 (multiple-value-bind (time3 pos3 time4 pos4)
164 (selection-move-rectangular map-song time1 pos1 time2 pos2
165 (wav::s-find :time (<= (min time1 time2) wav::time (max time1 time2))
166 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2))))
167 (let ((dtime (- (min time3 time4) (min time1 time2)))
168 (dpos (- (min pos3 pos4) (min pos1 pos2))))
169 (s-map (:time (<= (min time1 time2) wav::time (max time1 time2))
170 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2)))
171 (s-copy wav::it :time (+ wav::time dtime)
172 :pos (+ wav::pos dpos))))))))))
173
174 (define-command (com-song-selection-copy :name t :menu "Copy samples in selection"
175 :command-table build-song-selection-command-table)
176 ()
177 (selection-call-com-click (com-song-selection-copy-click x1 y1)))
178
179
180 (define-command (com-song-selection-delete-click :name t :menu nil
181 :command-table build-song-selection-command-table)
182 ((x 'real) (y 'real))
183 (with-application-frame (frame)
184 (let ((map-song (find-pane-named frame 'map-song)))
185 (multiple-value-bind (time1 pos1)
186 (convert-point-to-pane x y map-song)
187 (multiple-value-bind (time2 pos2)
188 (selection-find-second-point time1 pos1 map-song)
189 (s-delete :time (<= (min time1 time2) wav::time (max time1 time2))
190 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2))))))))
191
192 (define-command (com-song-selection-delete :name t :menu "Delete samples in selection"
193 :command-table build-song-selection-command-table)
194 ()
195 (selection-call-com-click (com-song-selection-delete-click x1 y1)))
196
197
198
199 (add-menu-item-to-command-table 'build-song-selection-command-table "Tags operations" :divider nil)
200
201 (define-command (com-song-selection-add-tags :name t :menu "Add tags in selection"
202 :command-table build-song-selection-command-table)
203 ()
204 (with-application-frame (frame)
205 (let ((map-song (find-pane-named frame 'map-song)))
206 (multiple-value-bind (time1 pos1 time2 pos2)
207 (selection-rectangular map-song)
208 (let ((new-tags (accept 'form :stream (frame-standard-input frame)
209 :prompt "Tags to add")))
210 (s-map (:time (<= (min time1 time2) wav::time (max time1 time2))
211 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2)))
212 (add-tags wav::it new-tags)))))))
213
214 (define-command (com-song-selection-del-tags :name t :menu "Delete tags in selection"
215 :command-table build-song-selection-command-table)
216 ()
217 (with-application-frame (frame)
218 (let ((map-song (find-pane-named frame 'map-song)))
219 (multiple-value-bind (time1 pos1 time2 pos2)
220 (selection-rectangular map-song)
221 (let ((new-tags (accept 'form :stream (frame-standard-input frame)
222 :prompt "Tags to delete")))
223 (s-map (:time (<= (min time1 time2) wav::time (max time1 time2))
224 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2)))
225 (del-tags wav::it new-tags)))))))
226
227 (add-menu-item-to-command-table 'build-song-selection-command-table "Build and play operations" :divider nil)
228
229
230
231 (define-command (com-song-selection-build-and-play :name t :menu "Build and play the selection"
232 :command-table build-song-selection-command-table)
233 ()
234 (with-application-frame (frame)
235 (let* ((map-song (find-pane-named frame 'map-song))
236 (filename (filename-song->wav (song-sample-filename map-song))))
237 (multiple-value-bind (time1 pos1 time2 pos2)
238 (selection-rectangular map-song)
239 (format t "Building to ~A~%" filename)
240 (build-song-in-interval (namestring filename)
241 (s-find :time (<= (min time1 time2) wav::time (max time1 time2))
242 :pos (<= (min pos1 pos2) wav::pos (max pos1 pos2)))
243 (min time1 time2) (max time1 time2))
244 (format t "Playing ~A~%" filename)
245 (play (namestring filename))))))
246
247
248
249
250 (define-presentation-to-command-translator song-selection-move
251 (blank-area com-song-selection-move-click wav-clim
252 :gesture :move-selection :echo t
253 :documentation "Move samples in selection"
254 :pointer-documentation "Move samples in selection"
255 :tester ((window) (typep window 'song-pane)))
256 (x y)
257 (list x y))
258
259
260 (define-presentation-to-command-translator song-selection-copy
261 (blank-area com-song-selection-copy-click wav-clim
262 :gesture :copy-selection :echo t
263 :documentation "Copy samples in selection"
264 :pointer-documentation "Copy samples in selection"
265 :tester ((window) (typep window 'song-pane)))
266 (x y)
267 (list x y))
268
269
270 (define-presentation-to-command-translator song-selection-delete
271 (blank-area com-song-selection-delete-click wav-clim
272 :gesture :delete-selection :echo t
273 :documentation "Delete samples in selection"
274 :pointer-documentation "Delete samples in selection"
275 :tester ((window) (typep window 'song-pane)))
276 (x y)
277 (list x y))
278
279
280 (define-presentation-to-command-translator song-selection-add-tags
281 (blank-area com-song-selection-add-tags wav-clim
282 :gesture nil :echo t
283 :documentation "Add tags in selection"
284 :tester ((window) (typep window 'song-pane)))
285 ()
286 ())
287
288
289 (define-presentation-to-command-translator song-selection-del-tags
290 (blank-area com-song-selection-del-tags wav-clim
291 :gesture nil :echo t
292 :documentation "Delete tags in selection"
293 :tester ((window) (typep window 'song-pane)))
294 ()
295 ())
296
297 (define-presentation-to-command-translator song-selection-build-and-play
298 (blank-area com-song-selection-build-and-play wav-clim
299 :gesture nil :echo t
300 :documentation "Build and play the selection"
301 :tester ((window) (typep window 'song-pane)))
302 ()
303 ())
304
305
306 (add-command-table-to-listener 'build-song-selection-command-table)

  ViewVC Help
Powered by ViewVC 1.1.5