/[gsharp]/gsharp/gui.lisp
ViewVC logotype

Contents of /gsharp/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.98 - (show annotations)
Sun May 17 16:11:57 2009 UTC (4 years, 11 months ago) by crhodes
Branch: MAIN
CVS Tags: HEAD
Changes since 1.97: +57 -0 lines
Slightly rudimentary support for view/buffer handling (C-x b and C-x k)

The major thing that needs fixing is being currently unable to name and
refer to views with a sensible (unique) string name.
1 (in-package :gsharp)
2
3 (defun make-initial-cursor (buffer)
4 (let* ((segment (segmentno buffer 0))
5 (layer (layerno segment 0))
6 (slice (body layer))
7 (bar (barno slice 0)))
8 (make-cursor bar 0)))
9
10 (defclass gsharp-minibuffer-pane (minibuffer-pane)
11 ()
12 (:default-initargs
13 :height 20 :max-height 20 :min-height 20))
14
15 (define-command-table total-melody-table
16 :inherit-from (melody-table global-gsharp-table gsharp))
17 (define-command-table total-rhythmic-melody-table
18 :inherit-from (melody-table rhythmic-table global-gsharp-table gsharp))
19 (define-command-table total-cluster-table
20 :inherit-from (cluster-table melody-table global-gsharp-table gsharp))
21 (define-command-table total-lyrics-table
22 :inherit-from (lyrics-table global-gsharp-table gsharp))
23
24 (defclass orchestra-view (score-pane:score-view)
25 ((cursor :initarg :cursor :reader cursor)
26 (buffer :initarg :buffer :reader buffer)))
27
28 ;;; FIXME: we need to sort out Drei's definition of accept methods for
29 ;;; the general VIEW type.
30 ;;;
31 ;;; FIXME: we should name our views so that they can be found by a
32 ;;; string name, rather than the unreadable-object print. There's a
33 ;;; SUBSCRIPTABLE-NAME-MIXIN in ESA-UTILS that is used for this
34 ;;; purpose in the analogous place in Climacs.
35 (define-presentation-method accept
36 ((type orchestra-view) stream (view textual-view)
37 &key (default nil defaultp) (default-type type))
38 (multiple-value-bind (object success string)
39 (complete-input stream
40 (lambda (so-far action)
41 (complete-from-possibilities
42 so-far (views *esa-instance*) '()
43 :action action
44 :name-key #'princ-to-string
45 :value-key #'identity))
46 :partial-completers '(#\Space))
47 (cond
48 (success (values object type))
49 ((and defaultp (= (length string) 0)) (values default default-type))
50 (t (input-not-of-required-type string type)))))
51
52 ;;; exists for the sole purpose of a :before method that updates the
53 ;;; measures of each modified buffer.
54 (defclass gsharp-pane-mixin () ())
55
56 (defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin)
57 ((view :initarg :view :accessor view)))
58
59 (defvar *info-bg-color* +gray85+)
60 (defvar *info-fg-color* +black+)
61
62 (defclass gsharp-info-pane (info-pane gsharp-pane-mixin)
63 ()
64 (:default-initargs
65 :height 20 :max-height 20 :min-height 20
66 :display-function 'display-info
67 :incremental-redisplay t))
68
69 (defun display-info (frame pane)
70 (declare (ignore frame))
71 (let* ((master-pane (master-pane pane))
72 (view (view master-pane))
73 (buffer (buffer view)))
74 (princ " " pane)
75 (princ (cond ((and (needs-saving buffer)
76 (read-only-p buffer)
77 "%*"))
78 ((needs-saving buffer) "**")
79 ((read-only-p buffer) "%%")
80 (t "--"))
81 pane)
82 (princ " " pane)
83 (with-text-face (pane :bold)
84 (format pane "~25A" (name buffer)))
85 (princ " " pane)
86 (format pane "[~a/~a]"
87 (score-pane:current-page-number view)
88 (score-pane:number-of-pages view))
89 (princ " " pane)
90 (with-text-family (pane :sans-serif)
91 (princ (if (recordingp *application-frame*)
92 "Def"
93 "")
94 pane))))
95
96 (define-application-frame gsharp (esa-frame-mixin
97 standard-application-frame)
98 ((views :initarg :views :initform '() :accessor views)
99 (input-state :initarg :input-state :accessor input-state))
100 (:default-initargs :input-state (make-input-state))
101 (:menu-bar menubar-command-table :height 25)
102 (:pointer-documentation t)
103 (:panes
104 (score (let* ((win (make-pane 'gsharp-pane
105 :width 400 :height 500
106 :name "score"
107 ;; :incremental-redisplay t
108 :double-buffering t
109 :display-function 'display-score
110 :command-table 'total-melody-table))
111 (info (make-pane 'gsharp-info-pane
112 :master-pane win
113 :background *info-bg-color*
114 :foreground *info-fg-color*)))
115 (setf (windows *application-frame*) (list win))
116 (setf (view win) (car (views *application-frame*)))
117 (vertically ()
118 (scrolling (:width 750 :height 500
119 :min-height 400 :max-height 20000)
120 win)
121 info)))
122 (state (make-pane 'score-pane:score-pane
123 :width 50 :height 200
124 :name "state"
125 :display-function 'display-state))
126 (element (make-pane 'score-pane:score-pane
127 :width 50 :height 300
128 :min-height 100 :max-height 20000
129 :name "element"
130 :display-function 'display-element))
131 (interactor (make-pane 'gsharp-minibuffer-pane :width 900)))
132 (:layouts
133 (default
134 (vertically ()
135 (horizontally ()
136 score
137 (vertically ()
138 (scrolling (:width 80 :height 200) state)
139 (scrolling (:width 80 :height 300
140 :min-height 300 :max-height 20000)
141 element)))
142 interactor)))
143 (:top-level (esa-top-level)))
144
145 (defmethod buffers ((application-frame gsharp))
146 (let (result)
147 (dolist (window (windows application-frame) (nreverse result))
148 (let ((view (view window)))
149 (when view
150 (pushnew (buffer view) result))))))
151
152 (defmethod esa-current-buffer ((application-frame gsharp))
153 (buffer (view (car (windows application-frame)))))
154
155 (defun current-cursor ()
156 (cursor (view (car (windows *application-frame*)))))
157
158 (defmethod execute-frame-command :around ((frame gsharp) command)
159 (handler-case (call-next-method)
160 (gsharp-condition (condition) (beep) (display-message "~a" condition))))
161
162 (defmethod display-state ((frame gsharp) pane)
163 (let ((state (input-state *application-frame*)))
164 (score-pane:with-score-pane pane
165 (score-pane:with-staff-size 10
166 (score-pane:with-vertical-score-position (pane 100)
167 (let ((xpos 30))
168 (score-pane:draw-notehead pane (notehead state) xpos 4)
169 (when (not (member (notehead state) '(:whole :breve)))
170 (when (or (eq (stem-direction state) :auto)
171 (eq (stem-direction state) :down))
172 (when (eq (notehead state) :filled)
173 (score-pane:with-notehead-left-offsets (left down)
174 (declare (ignore down))
175 (let ((x (+ xpos left)))
176 (loop repeat (rbeams state)
177 for staff-step from -4 by 2 do
178 (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
179 (loop repeat (lbeams state)
180 for staff-step from -4 by 2 do
181 (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
182 (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4))))
183 (when (or (eq (stem-direction state) :auto)
184 (eq (stem-direction state) :up))
185 (when (eq (notehead state) :filled)
186 (score-pane:with-notehead-right-offsets (right up)
187 (declare (ignore up))
188 (let ((x (+ xpos right)))
189 (loop repeat (rbeams state)
190 for staff-step downfrom 12 by 2 do
191 (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
192 (loop repeat (lbeams state)
193 for staff-step downfrom 12 by 2 do
194 (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
195 (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12)))))
196 (score-pane:with-notehead-right-offsets (right up)
197 (declare (ignore up))
198 (loop repeat (dots state)
199 for dx from (+ right 5) by 5 do
200 (score-pane:draw-dot pane (+ xpos dx) 4)))))))))
201
202 (defun update-page-numbers (frame)
203 (loop for window in (windows frame)
204 do (let ((page-number 0)
205 (view (view window)))
206 (gsharp-measure::new-map-over-obseq-subsequences
207 (lambda (all-measures)
208 (incf page-number)
209 (when (member-if (lambda (measure) (member (bar (cursor view))
210 (measure-bars measure)
211 :test #'eq))
212 all-measures)
213 (setf (score-pane:current-page-number view) page-number)))
214 (buffer view))
215 (setf (score-pane:number-of-pages view) page-number))))
216
217 ;;; I tried making this a :before method on redisplay-frame-panes,
218 ;;; but it turns out that McCLIM calls redisplay-frame-pane from
219 ;;; places other than redisplay-frame-panes.
220 (defmethod redisplay-frame-pane :before ((frame gsharp) (pane gsharp-pane-mixin) &key force-p)
221 (declare (ignore pane force-p))
222 (mapc #'recompute-measures (buffers frame))
223 (update-page-numbers frame))
224
225 (defmethod display-score ((frame gsharp) pane)
226 (let* ((buffer (buffer (view pane))))
227 (score-pane:with-score-pane pane
228 (draw-buffer pane buffer (current-cursor)
229 (left-margin buffer) 100)
230 (draw-the-cursor pane (current-cursor) (cursor-element (current-cursor))
231 (last-note (input-state *application-frame*)))
232 (multiple-value-bind (minx miny maxx maxy)
233 (bounding-rectangle* (stream-output-history pane))
234 (declare (ignore minx maxx))
235 (change-space-requirements pane :height (+ maxy miny))))))
236
237 (defmethod window-clear ((pane score-pane:score-pane))
238 (let ((output-history (stream-output-history pane)))
239 (with-bounding-rectangle* (left top right bottom) output-history
240 (medium-clear-area (sheet-medium pane) left top right bottom))
241 (clear-output-record output-history))
242 (window-erase-viewport pane))
243
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 ;;;
246 ;;; Element pane
247
248 (defmethod note-position ((note note))
249 (let ((clef (clef (staff note))))
250 (- (pitch note)
251 (bottom-line clef))))
252
253 (defmethod display-element ((frame gsharp) pane)
254 (when (handler-case (cur-cluster)
255 (gsharp-condition () nil))
256 (score-pane:with-score-pane pane
257 (score-pane:with-staff-size 10
258 (score-pane:with-vertical-score-position (pane 500)
259 (let* ((xpos 30)
260 (cluster (cur-cluster))
261 (notehead (notehead cluster))
262 (rbeams (rbeams cluster))
263 (lbeams (lbeams cluster))
264 (dots (dots cluster))
265 (notes (notes cluster))
266 (stem-direction (stem-direction cluster)))
267 (declare (ignore stem-direction notehead lbeams rbeams dots))
268 (loop for note in notes do
269 (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7)
270 (score-pane:draw-accidental pane (accidentals note)
271 (- xpos (if (oddp (note-position note)) 15 25))
272 (* 3 (note-position note))))
273 (when notes
274 (draw-ellipse* pane xpos (* 15 (note-position (cur-note)))
275 7 0 0 7 :ink +red+))
276 (loop for s from 0 by 30
277 repeat 5 do
278 (draw-line* pane (- xpos 25) s (+ xpos 25) s))))))))
279
280 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
281 ;;;
282 ;;; messages to the user
283
284 ;;; FIXME: do this better
285 (defun message (format-string &rest format-args)
286 (apply #'format *error-output* format-string format-args))
287
288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
289 ;;;
290 ;;; menu bar
291
292 (make-command-table
293 'menubar-command-table
294 :errorp nil
295 :menu '(("File" :menu esa-io-menu-table)
296 ("Macros" :menu keyboard-macro-menu-table)
297 ("Buffer" :menu buffer-command-table)
298 ("Stuff" :menu segment-command-table)
299 ("Segment" :menu segment-command-table)
300 ("Layer" :menu layer-command-table)
301 ("Slice" :menu slice-command-table)
302 ("Measure" :menu measure-command-table)
303 ("Modes" :menu modes-command-table)
304 ("Staves" :menu staves-command-table)
305 ("Play" :menu play-command-table)
306 ("Help" :menu help-menu-table)))
307
308 (define-gsharp-command (com-new-buffer :name t) ()
309 (let* ((buffer (make-instance 'buffer))
310 (cursor (make-initial-cursor buffer))
311 (staff (car (staves buffer)))
312 (input-state (make-input-state))
313 (view (make-instance 'orchestra-view
314 :buffer buffer
315 :cursor cursor)))
316 (push view (views *application-frame*))
317 (setf (view (car (windows *application-frame*))) view)
318 (setf (input-state *application-frame*) input-state
319 (staves (car (layers (car (segments buffer))))) (list staff))))
320
321 (defmethod frame-find-file :around ((application-frame gsharp) filepath)
322 (declare (ignore filepath))
323 (let* ((buffer (call-next-method))
324 (input-state (make-input-state))
325 (cursor (make-initial-cursor buffer))
326 (view (make-instance 'orchestra-view
327 :buffer buffer
328 :cursor cursor)))
329 (push view (views *application-frame*))
330 (setf (view (car (windows *application-frame*))) view
331 (input-state *application-frame*) input-state
332 (filepath buffer) filepath)
333 (select-layer cursor (car (layers (segment (current-cursor)))))))
334
335 (define-gsharp-command (com-quit :name t) ()
336 (frame-exit *application-frame*))
337
338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339 ;;;
340 ;;; buffer menu
341
342 (make-command-table
343 'buffer-command-table
344 :errorp nil
345 :menu '(("Play" :command com-play-buffer)
346 ("Delete Current" :command com-delete-buffer)))
347
348 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;;;
350 ;;; segment menu
351
352 (make-command-table
353 'segment-command-table
354 :errorp nil
355 :menu '(("Forward" :command com-forward-segment)
356 ("Backward" :command com-backward-segment)
357 ("Delete Current" :command com-delete-segment)
358 ("Insert After Current" :command com-insert-segment-after)
359 ("Insert Before Current" :command com-insert-segment-before)))
360
361 (define-gsharp-command (com-forward-segment :name t) ()
362 (forward-segment (current-cursor)))
363
364 (define-gsharp-command (com-backward-segment :name t) ()
365 (backward-segment (current-cursor)))
366
367 (define-gsharp-command (com-delete-segment :name t) ()
368 (delete-segment (current-cursor)))
369
370 (define-gsharp-command (com-insert-segment-before :name t) ()
371 (let ((cursor (current-cursor)))
372 (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer))))
373 cursor)
374 (backward-segment cursor)))
375
376 (define-gsharp-command (com-insert-segment-after :name t) ()
377 (let ((cursor (current-cursor)))
378 (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer))))
379 cursor)
380 (forward-segment cursor)))
381
382 (define-gsharp-command (com-set-segment-tempo :name t) ((tempo 'integer :prompt "Tempo"))
383 (let ((segment (segment (current-cursor))))
384 (setf (tempo segment) tempo)))
385
386 (define-gsharp-command (com-set-segment-tuning-regular-temperament :name t)
387 ((octave-cents 'cl:number :prompt "Octave size in cents")
388 (fifth-cents 'cl:number :prompt "Fifth size in cents")
389 (quartertone-cents 'cl:number :prompt "Quartertone size in cents"))
390 ;; TODO: prompt for sizes of various microtonal accidentals
391 (let ((segment (segment (current-cursor))))
392 (setf (tuning segment) (make-instance 'regular-temperament
393 :octave-cents octave-cents
394 :fifth-cents fifth-cents
395 :quartertone-cents quartertone-cents))))
396
397 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
398 ;;;
399 ;;; layer menu
400
401 (make-command-table
402 'layer-command-table
403 :errorp nil
404 :menu '(("Select" :command com-select-layer)
405 ("Rename" :command com-rename-layer)
406 ("New" :command com-add-layer)
407 ("Delete" :command com-delete-layer)))
408
409 (define-condition layer-name-not-unique (gsharp-condition) ()
410 (:report
411 (lambda (condition stream)
412 (declare (ignore condition))
413 (format stream "Layer name already exists"))))
414
415 (defun acquire-unique-layer-name (prompt)
416 (let ((name (accept 'string :prompt prompt)))
417 (assert (not (member name (layers (segment (current-cursor)))
418 :test #'string= :key #'name))
419 () `layer-name-not-unique)
420 name))
421
422 (define-condition no-such-layer (gsharp-condition) ()
423 (:report
424 (lambda (condition stream)
425 (declare (ignore condition))
426 (format stream "No such layer"))))
427
428 (define-presentation-method accept
429 ((type layer) stream (view textual-view) &key)
430 (multiple-value-bind (layer success string)
431 (handler-case (complete-input stream
432 (lambda (so-far mode)
433 (complete-from-possibilities
434 so-far
435 (layers (segment (current-cursor)))
436 '()
437 :action mode
438 :predicate (constantly t)
439 :name-key #'name
440 :value-key #'identity)))
441 (simple-parse-error () (error 'no-such-layer)))
442 (declare (ignore string))
443 (if success layer (error 'no-such-layer))))
444
445 (defgeneric find-applicable-gsharp-command-table (layer element))
446
447 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) element)
448 (declare (ignore element))
449 (find-command-table 'total-melody-table))
450
451 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) (element rhythmic-element))
452 (find-command-table 'total-rhythmic-melody-table))
453
454 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) (element cluster))
455 (find-command-table 'total-cluster-table))
456
457 (defmethod find-applicable-gsharp-command-table ((layer lyrics-layer) element)
458 (declare (ignore element))
459 (find-command-table 'total-lyrics-table))
460
461 (defmethod find-applicable-command-table ((frame gsharp))
462 (let* ((cursor (current-cursor))
463 (layer (layer cursor))
464 (element (if (beginning-of-bar-p cursor) nil (current-element cursor))))
465 (find-applicable-gsharp-command-table layer element)))
466
467 (define-gsharp-command (com-select-layer :name t) ()
468 (let ((selected-layer (accept 'layer :prompt "Select layer")))
469 (select-layer (current-cursor) selected-layer)))
470
471 (define-gsharp-command (com-rename-layer :name t) ()
472 (setf (name (accept 'layer :prompt "Rename layer"))
473 (acquire-unique-layer-name "New name of layer")))
474
475 (define-gsharp-command (com-add-layer :name t) ()
476 (let* ((name (acquire-unique-layer-name "Name of new layer"))
477 (staff (accept 'score-pane:staff :prompt "Initial staff of new layer"))
478 (new-layer (make-layer (list staff) :name name)))
479 (add-layer new-layer (segment (current-cursor)))
480 (select-layer (current-cursor) new-layer)))
481
482 (define-gsharp-command (com-delete-layer :name t) ()
483 (delete-layer (current-cursor)))
484
485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
486 ;;;
487 ;;; slice menu
488
489 (make-command-table
490 'slice-command-table
491 :errorp nil
492 :menu '(("Head" :command com-head-slice)
493 ("Body" :command com-body-slice)
494 ("Tail" :command com-tail-slisce)))
495
496 (define-gsharp-command (com-head-slice :name t) ()
497 (head-slice (current-cursor)))
498
499 (define-gsharp-command (com-body-slice :name t) ()
500 (body-slice (current-cursor)))
501
502 (define-gsharp-command (com-tail-slice :name t) ()
503 (tail-slice (current-cursor)))
504
505 (define-gsharp-command (com-forward-slice :name t) ()
506 (forward-slice (current-cursor)))
507
508 (define-gsharp-command (com-backward-slice :name t) ()
509 (backward-slice (current-cursor)))
510
511 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
512 ;;;
513 ;;; bar menu
514
515 (make-command-table
516 'measure-command-table
517 :errorp nil
518 :menu '(("Forward" :command (com-forward-measure 1))
519 ("Backward" :command (com-backward-measure 1))))
520
521 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
522 ;;;
523 ;;; modes menu
524
525 (make-command-table
526 'modes-command-table
527 :errorp nil
528 :menu '(("Fundamental" :command com-fundamental)))
529
530 (define-gsharp-command (com-fundamental :name t) ()
531 nil)
532
533 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
534 ;;;
535 ;;; staves menu
536
537 (make-command-table
538 'staves-command-table
539 :errorp nil
540 :menu '(("Rotate" :command com-rotate-staves)))
541
542 (define-gsharp-command (com-rotate-staves :name t) ()
543 (let ((layer (layer (current-cursor))))
544 (setf (staves layer)
545 (append (cdr (staves layer)) (list (car (staves layer)))))))
546
547 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
548 ;;;
549 ;;; play menu
550
551 (make-command-table
552 'play-command-table
553 :errorp nil
554 :menu '(("Buffer" :command com-play-buffer)
555 ("Segment" :command com-play-segment)
556 ("Layer" :command com-play-layer)))
557
558 (define-gsharp-command (com-play-buffer :name t) ()
559 (play-buffer (buffer (current-cursor))))
560
561 (define-gsharp-command (com-play-segment :name t) ()
562 (play-segment (segment (current-cursor))))
563
564 (define-gsharp-command (com-play-layer :name t) ()
565 (play-layer (layer (current-cursor))))
566
567 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
568 ;;;
569 ;;; main entry points
570
571 (defun gsharp (&rest args &key new-process process-name width height)
572 "Start a Gsharp session with a fresh empty buffer"
573 (declare (ignore new-process process-name width height))
574 (apply #'gsharp-common '(com-new-buffer) args))
575
576 (defun edit-file (filename &rest args
577 &key new-process process-name width height)
578 "Start a Gsharp session editing a given file"
579 (declare (ignore new-process process-name width height))
580 (apply #'gsharp-common `(esa-io::com-find-file ,filename) args))
581
582 (defun gsharp-common (command &key new-process (process-name "Gsharp") width height)
583 (let* ((frame (make-application-frame 'gsharp :width width :height height))
584 (*application-frame* frame)
585 (*esa-instance* frame))
586 (adopt-frame (find-frame-manager) *application-frame*)
587 (execute-frame-command *application-frame* command)
588 (flet ((run () (run-frame-top-level frame)))
589 (if new-process
590 (clim-sys:make-process #'run :name process-name)
591 (run)))))
592
593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
594 ;;;
595 ;;; development and debugging aids
596
597 ;;; FIXME: you might expect that this was in an ESA component, but in
598 ;;; fact it's not. Maybe it should be?
599 (define-gsharp-command (com-eval-expression :name t)
600 ((expression 'expression :prompt "Eval"))
601 "Prompt for and evaluate a lisp expression.
602 Prints the results in the minibuffer."
603 (let* ((*package* (find-package :gsharp))
604 (values (multiple-value-list
605 (handler-case (eval expression)
606 (error (condition)
607 (beep)
608 (display-message "~a" condition)
609 (return-from com-eval-expression nil)))))
610 (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values)))
611 (display-message result)))
612
613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
614 ;;;
615 ;;; note insertion commands
616
617 (defun insert-cluster ()
618 (let* ((state (input-state *application-frame*))
619 (cursor (current-cursor))
620 (cluster (make-cluster
621 :notehead (notehead state)
622 :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
623 :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
624 :dots (dots state)
625 :stem-direction (stem-direction state))))
626 (insert-element cluster cursor)
627 (forward-element cursor)
628 cluster))
629
630 (defparameter *current-cluster* nil)
631 (defparameter *current-note* nil)
632
633 (defun insert-note (pitch cluster accidentals)
634 (let* ((state (input-state *application-frame*))
635 (staff (car (staves (layer (slice (bar cluster))))))
636 (note (make-note pitch staff
637 :head (notehead state)
638 :accidentals accidentals
639 :dots (dots state))))
640 (setf *current-cluster* cluster
641 *current-note* note)
642 (add-note cluster note)))
643
644 (defun compute-and-adjust-note (pitch)
645 (let* ((state (input-state *application-frame*))
646 (old-pitch (mod (last-note state) 7))
647 (diff (- pitch old-pitch)))
648 (incf (last-note state)
649 (cond ((> diff 3) (- diff 7))
650 ((< diff -3) (+ diff 7))
651 (t diff)))))
652
653 (defun insert-numbered-note-new-cluster (pitch)
654 (let* ((new-pitch (compute-and-adjust-note pitch))
655 (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
656 (insert-note new-pitch (insert-cluster) accidentals)))
657
658 (define-gsharp-command (com-insert-note-a :keystroke #\a) ()
659 (insert-numbered-note-new-cluster 5))
660
661 (define-gsharp-command (com-insert-note-b :keystroke #\b) ()
662 (insert-numbered-note-new-cluster 6))
663
664 (define-gsharp-command (com-insert-note-c :keystroke #\c) ()
665 (insert-numbered-note-new-cluster 0))
666
667 (define-gsharp-command (com-insert-note-d :keystroke #\d) ()
668 (insert-numbered-note-new-cluster 1))
669
670 (define-gsharp-command (com-insert-note-e :keystroke #\e) ()
671 (insert-numbered-note-new-cluster 2))
672
673 (define-gsharp-command (com-insert-note-f :keystroke #\f) ()
674 (insert-numbered-note-new-cluster 3))
675
676 (define-gsharp-command (com-insert-note-g :keystroke #\g) ()
677 (insert-numbered-note-new-cluster 4))
678
679 (define-gsharp-command com-insert-rest ()
680 (let* ((state (input-state *application-frame*))
681 (cursor (current-cursor))
682 (rest (make-rest (car (staves (layer (current-cursor))))
683 :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
684 :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
685 :dots (dots state)
686 :notehead (notehead state))))
687 (insert-element rest cursor)
688 (forward-element cursor)
689 rest))
690
691 (define-gsharp-command com-insert-empty-cluster ()
692 (insert-cluster))
693
694 (defun cur-cluster ()
695 (current-cluster (current-cursor)))
696
697 (defun cur-element ()
698 (current-element (current-cursor)))
699
700 (defun cur-note ()
701 (let ((cluster (cur-cluster)))
702 (if (eq *current-cluster* cluster) ; it has not moved since last time
703 (or (car (member *current-note* (notes cluster) :test #'eq))
704 (setf *current-note* (car (notes cluster))))
705 (setf *current-cluster* cluster
706 *current-note* (car (notes cluster))))))
707
708 (define-gsharp-command com-current-increment ()
709 (let* ((cluster (cur-cluster))
710 (notes (notes cluster))
711 (rest (member (cur-note) notes :test #'eq)))
712 (unless (null (cdr rest))
713 (setf *current-note* (cadr rest)))))
714
715 (define-gsharp-command com-current-decrement ()
716 (let* ((cluster (cur-cluster))
717 (notes (notes cluster))
718 (pos (position (cur-note) notes :test #'eq)))
719 (unless (zerop pos)
720 (setf *current-note* (nth (1- pos) notes)))))
721
722 (defun insert-numbered-note-current-cluster (pitch)
723 (let* ((new-pitch (compute-and-adjust-note pitch))
724 (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
725 (insert-note new-pitch (cur-cluster) accidentals)))
726
727 (define-gsharp-command com-add-note-a ()
728 (insert-numbered-note-current-cluster 5))
729
730 (define-gsharp-command com-add-note-b ()
731 (insert-numbered-note-current-cluster 6))
732
733 (define-gsharp-command com-add-note-c ()
734 (insert-numbered-note-current-cluster 0))
735
736 (define-gsharp-command com-add-note-d ()
737 (insert-numbered-note-current-cluster 1))
738
739 (define-gsharp-command com-add-note-e ()
740 (insert-numbered-note-current-cluster 2))
741
742 (define-gsharp-command com-add-note-f ()
743 (insert-numbered-note-current-cluster 3))
744
745 (define-gsharp-command com-add-note-g ()
746 (insert-numbered-note-current-cluster 4))
747
748 (macrolet ((define-duration-altering-command (name &body body)
749 `(define-gsharp-command ,name ()
750 (let ((element (cur-element)))
751 ,@body
752 (gsharp-buffer::maybe-update-key-signatures
753 (bar (current-cursor)))))))
754 (define-duration-altering-command com-more-dots ()
755 (setf (dots element) (min (1+ (dots element)) 3)))
756 (define-duration-altering-command com-fewer-dots ()
757 (setf (dots element) (max (1- (dots element)) 0)))
758 (define-duration-altering-command com-more-rbeams ()
759 (setf (rbeams element) (min (1+ (rbeams element)) 3)))
760 (define-duration-altering-command com-fewer-lbeams ()
761 (setf (lbeams element) (max (1- (lbeams element)) 0)))
762 (define-duration-altering-command com-more-lbeams ()
763 (setf (lbeams element) (min (1+ (lbeams element)) 3)))
764 (define-duration-altering-command com-fewer-rbeams ()
765 (setf (rbeams element) (max (1- (rbeams element)) 0)))
766 (define-duration-altering-command com-rotate-notehead ()
767 (setf (notehead element)
768 (ecase (notehead element)
769 (:breve :long)
770 (:whole :breve)
771 (:half :whole)
772 (:filled :half)
773 (:long :filled)))))
774
775 (define-gsharp-command com-rotate-stem-direction ()
776 (setf (stem-direction (cur-cluster))
777 (ecase (stem-direction (cur-cluster))
778 (:auto :up)
779 (:up :down)
780 (:down :auto))))
781
782 (define-gsharp-command com-toggle-staccato ()
783 (let ((cluster (cur-cluster)))
784 (if (member :staccato (annotations cluster))
785 (setf (annotations cluster) (remove :staccato (annotations cluster)))
786 (push :staccato (annotations cluster)))))
787
788 (define-gsharp-command com-toggle-tenuto ()
789 (let ((cluster (cur-cluster)))
790 (if (member :tenuto (annotations cluster))
791 (setf (annotations cluster) (remove :tenuto (annotations cluster)))
792 (push :tenuto (annotations cluster)))))
793
794 (define-gsharp-command com-down ()
795 (let ((element (cur-element)))
796 (if (typep element 'cluster)
797 (let* ((note (cur-note))
798 (new-note (make-note (1- (pitch note)) (staff note)
799 :head (head note)
800 :accidentals (accidentals note)
801 :dots (dots note))))
802 (remove-note note)
803 (add-note element new-note)
804 (setf *current-note* new-note))
805 (let ((rbeams (rbeams element))
806 (lbeams (lbeams element))
807 (dots (dots element))
808 (notehead (notehead element))
809 (staff-pos (staff-pos element))
810 (staff (staff element))
811 (cursor (current-cursor)))
812 (backward-element cursor)
813 (delete-element cursor)
814 (insert-element (make-rest staff
815 :staff-pos (- staff-pos 2)
816 :notehead notehead :dots dots
817 :rbeams rbeams :lbeams lbeams)
818 cursor)
819 (forward-element cursor)))))
820
821 (define-gsharp-command com-up ()
822 (let ((element (cur-element)))
823 (if (typep element 'cluster)
824 (let* ((note (cur-note))
825 (new-note (make-note (1+ (pitch note)) (staff note)
826 :head (head note)
827 :accidentals (accidentals note)
828 :dots (dots note))))
829 (remove-note note)
830 (add-note element new-note)
831 (setf *current-note* new-note))
832 (let ((rbeams (rbeams element))
833 (lbeams (lbeams element))
834 (dots (dots element))
835 (notehead (notehead element))
836 (staff-pos (staff-pos element))
837 (staff (staff element))
838 (cursor (current-cursor)))
839 (backward-element cursor)
840 (delete-element cursor)
841 (insert-element (make-rest staff
842 :staff-pos (+ staff-pos 2)
843 :notehead notehead :dots dots
844 :rbeams rbeams :lbeams lbeams)
845 cursor)
846 (forward-element cursor)))))
847
848 (define-gsharp-command com-octave-down ()
849 (let ((element (cur-element)))
850 (let* ((note (cur-note))
851 (new-note (make-note (- (pitch note) 7) (staff note)
852 :head (head note)
853 :accidentals (accidentals note)
854 :dots (dots note))))
855 (remove-note note)
856 (add-note element new-note)
857 (setf *current-note* new-note))))
858
859 (define-gsharp-command com-octave-up ()
860 (let ((element (cur-element)))
861 (let* ((note (cur-note))
862 (new-note (make-note (+ (pitch note) 7) (staff note)
863 :head (head note)
864 :accidentals (accidentals note)
865 :dots (dots note))))
866 (remove-note note)
867 (add-note element new-note)
868 (setf *current-note* new-note))))
869
870 (defmacro define-microtonal-accidentals (&rest microaccidentals)
871 `(progn
872 (setf (symbol-plist 'microsharpen)
873 ',(loop for (a b) on microaccidentals
874 if b collect a and collect b
875 else collect a and collect a))
876 (setf (symbol-plist 'microflatten)
877 ',(loop for (a b) on (reverse microaccidentals)
878 if b collect a and collect b
879 else collect a and collect a))
880 (deftype accidental () '(member ,@microaccidentals))
881 (defun microsharpen (accidental)
882 (or (getf (symbol-plist 'microsharpen) accidental)
883 (error 'type-error :datum accidental :expected-type 'microaccidental)))
884 (defun microflatten (accidental)
885 (or (getf (symbol-plist 'microflatten) accidental)
886 (error 'type-error :datum accidental :expected-type 'microaccidental)))))
887
888 (defmacro define-accidentals (&rest accidentals)
889 `(progn
890 (deftype accidental () '(member ,@accidentals))
891 (defun sharpen (accidental)
892 (do ((a (microsharpen accidental) (microsharpen a))
893 (olda accidental a))
894 ((or (eq a olda) (member a ',accidentals)) a)))
895 (defun flatten (accidental)
896 (do ((a (microflatten accidental) (microflatten a))
897 (olda accidental a))
898 ((or (eq a olda) (member a ',accidentals)) a)))))
899
900 (define-microtonal-accidentals :double-flat :sesquiflat :flat :semiflat
901 :natural
902 :semisharp :sharp :sesquisharp :double-sharp)
903
904 (define-accidentals :double-flat :flat :natural :sharp :double-sharp)
905
906 (define-gsharp-command com-sharper ()
907 (let* ((cluster (cur-cluster))
908 (note (cur-note))
909 (new-note (make-note (pitch note) (staff note)
910 :head (head note)
911 :accidentals (sharpen (accidentals note))
912 :dots (dots note))))
913 (remove-note note)
914 (add-note cluster new-note)
915 (setf *current-note* new-note)))
916
917 (define-gsharp-command com-microsharper ()
918 ;; FIXME: what are CUR-CLUSTER and CUR-NOTE and how do they relate
919 ;; to CURRENT-CLUSTER &c?
920 (let* ((cluster (cur-cluster))
921 (note (cur-note))
922 (new-note (make-note (pitch note) (staff note)
923 :head (head note)
924 :accidentals (microsharpen (accidentals note))
925 :dots (dots note))))
926 (remove-note note)
927 (add-note cluster new-note)
928 (setf *current-note* new-note)))
929
930 (define-gsharp-command com-flatter ()
931 (let* ((cluster (cur-cluster))
932 (note (cur-note))
933 (new-note (make-note (pitch note) (staff note)
934 :head (head note)
935 :accidentals (flatten (accidentals note))
936 :dots (dots note))))
937 (remove-note note)
938 (add-note cluster new-note)
939 (setf *current-note* new-note)))
940
941 (define-gsharp-command com-microflatter ()
942 (let* ((cluster (cur-cluster))
943 (note (cur-note))
944 (new-note (make-note (pitch note) (staff note)
945 :head (head note)
946 :accidentals (microflatten (accidentals note))
947 :dots (dots note))))
948 (remove-note note)
949 (add-note cluster new-note)
950 (setf *current-note* new-note)))
951
952 (define-gsharp-command com-remove-current-note ()
953 (let ((cluster (cur-cluster))
954 (note (cur-note)))
955 (when note
956 (remove-note note)
957 ;; try to set current-note to the highest note lower than the
958 ;; removed note. If that fails, to the lowest note higher than
959 ;; it.
960 (setf *current-note* (or (cluster-lower-bound cluster note)
961 (cluster-upper-bound cluster note)))
962 (unless *current-note*
963 (com-erase-element 1)))))
964
965 (defun insert-keysig ()
966 (let* ((state (input-state *application-frame*))
967 (cursor (current-cursor))
968 (staff (car (staves (layer cursor))))
969 (keysig (if (keysig cursor)
970 (make-key-signature
971 staff :alterations (copy-seq (alterations (keysig cursor))))
972 (make-key-signature staff))))
973 ;; FIXME: should only invalidate elements temporally after the
974 ;; cursor.
975 (gsharp-measure::invalidate-everything-using-staff (current-buffer) staff)
976 (insert-element keysig cursor)
977 (forward-element cursor)
978 keysig))
979
980 (define-gsharp-command com-insert-keysig ()
981 (insert-keysig))
982
983 (defun insert-timesig (numerator denominator)
984 (let* ((cursor (current-cursor))
985 (staff (car (staves (layer cursor))))
986 (timesig (make-instance 'time-signature
987 :staff staff
988 :components
989 (list (if denominator
990 (cons numerator denominator)
991 numerator)))))
992 (insert-element timesig cursor)
993 (forward-element cursor)
994 timesig))
995
996 (define-gsharp-command (com-insert-timesig :name t)
997 ((numerator '(integer 1 8) :prompt "Numerator")
998 (denominator '(integer 1 8) :prompt "Denominator"))
999 (insert-timesig numerator denominator))
1000
1001 (defmethod remove-element :before ((element staffwise-element) (bar bar))
1002 (let ((staff (staff element)))
1003 (setf (staffwise-elements staff)
1004 (remove element (staffwise-elements staff)))
1005 (gsharp-measure::invalidate-everything-using-staff (current-buffer) staff)))
1006
1007 ;;; FIXME: this isn't quite right (argh) for the case of two
1008 ;;; temporally coincident zero-duration elements on the same staff in
1009 ;;; different layers: essentially all bets are off.
1010 (defun starts-before-p (thing bar element-or-nil)
1011 ;; does THING start before the temporal position denoted by BAR and
1012 ;; ELEMENT-OR-NIL?
1013 (assert (or (null element-or-nil) (eq (bar element-or-nil) bar)))
1014 (when (null (bar thing))
1015 ;; THING is probably the key signature at the start of the piece,
1016 ;; in which case it is definitely before whatever else happens.
1017 (assert (typep thing 'key-signature))
1018 (return-from starts-before-p t))
1019 (let ((barno (number bar)))
1020 (cond
1021 ((> (number (bar thing)) barno) nil)
1022 ((< (number (bar thing)) barno) t)
1023 (t (let ((thing-start-time (loop for e in (elements (bar thing))
1024 if (eq e element-or-nil)
1025 do (return-from starts-before-p nil)
1026 until (eq e thing) sum (duration e)))
1027 (element-start-time
1028 ;; this is actually the right answer for
1029 ;; ELEMENT-OR-NIL = NIL, which means "end of bar"
1030 (loop for e in (elements bar)
1031 if (eq e thing) do (return-from starts-before-p t)
1032 until (eq e element-or-nil) sum (duration e))))
1033 (or (> element-start-time thing-start-time)
1034 (and (= element-start-time thing-start-time)
1035 (or (null element-or-nil)
1036 (> (duration element-or-nil) 0)))))))))
1037
1038 (defun %keysig (staff key-signatures bar element-or-nil)
1039 (or (and key-signatures
1040 (find-if (lambda (x) (starts-before-p x bar element-or-nil))
1041 key-signatures :from-end t))
1042 (keysig staff)))
1043
1044 (defmethod keysig ((cursor gsharp-cursor))
1045 ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
1046 ;; otherwise the operation for getting the staff [(CAR (STAVES
1047 ;; (LAYER CURSOR)))] need not return the staff that we're interested
1048 ;; in.
1049 (assert (eq cursor (current-cursor)))
1050 (let* ((staff (car (staves (layer cursor))))
1051 (key-signatures (key-signatures staff))
1052 (bar (bar cursor))
1053 (element-or-nil (cursor-element cursor)))
1054 (%keysig staff key-signatures bar element-or-nil)))
1055
1056 (defmethod keysig ((note note))
1057 (let* ((staff (staff note))
1058 (key-signatures (key-signatures staff))
1059 (bar (bar (cluster note)))
1060 (element-or-nil (cluster note)))
1061 (%keysig staff key-signatures bar element-or-nil)))
1062
1063 (defmethod keysig ((cluster cluster))
1064 (error "Called ~S (a staff-scope operation) on an element with no ~
1065 associated staff: ~S"
1066 'keysig cluster))
1067
1068 (defmethod keysig ((element element))
1069 (let* ((staff (staff element))
1070 (key-signatures (key-signatures staff))
1071 (bar (bar element)))
1072 (%keysig staff key-signatures bar element)))
1073
1074 (define-gsharp-command com-tie-note-left ()
1075 (let ((note (cur-note)))
1076 (when note
1077 (setf (tie-left note) t))))
1078
1079 (define-gsharp-command com-untie-note-left ()
1080 (let ((note (cur-note)))
1081 (when note
1082 (setf (tie-left note) nil))))
1083
1084 (define-gsharp-command com-tie-note-right ()
1085 (let ((note (cur-note)))
1086 (when note
1087 (setf (tie-right note) t))))
1088
1089 (define-gsharp-command com-untie-note-right ()
1090 (let ((note (cur-note)))
1091 (when note
1092 (setf (tie-right note) nil))))
1093
1094 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1095 ;;;
1096 ;;; motion by element
1097
1098 (define-gsharp-command com-forward-element
1099 ((count 'integer :prompt "Number of Elements" :default 1))
1100 "Move forward by element."
1101 (loop repeat count
1102 do (forward-element (current-cursor))))
1103
1104 (define-gsharp-command com-backward-element
1105 ((count 'integer :prompt "Number of Elements" :default 1))
1106 "Move backward by element."
1107 (loop repeat count
1108 do (backward-element (current-cursor))))
1109
1110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1111 ;;;
1112 ;;; motion by measure
1113
1114 (define-gsharp-command com-forward-measure
1115 ((count 'integer :prompt "Number of Measures" :default 1))
1116 "Move forward by measure."
1117 (loop repeat count do (forward-bar (current-cursor))))
1118
1119 (define-gsharp-command com-backward-measure
1120 ((count 'integer :prompt "Number of Measures" :default 1))
1121 "Move backward by measure."
1122 (loop repeat count do (backward-bar (current-cursor))))
1123
1124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1125 ;;;
1126 ;;; motion by entire score
1127
1128 (define-gsharp-command com-end-of-score ()
1129 (loop until (last-segment-p (current-cursor))
1130 do (forward-segment (current-cursor)))
1131 (loop until (last-bar-p (current-cursor))
1132 do (forward-bar (current-cursor)))
1133 (loop until (end-of-bar-p (current-cursor))
1134 do (forward-element (current-cursor))))
1135
1136 (define-gsharp-command com-beginning-of-score ()
1137 (loop until (first-segment-p (current-cursor))
1138 do (backward-segment (current-cursor)))
1139 (loop until (first-bar-p (current-cursor))
1140 do (backward-bar (current-cursor)))
1141 (loop until (beginning-of-bar-p (current-cursor))
1142 do (backward-element (current-cursor))))
1143
1144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1145 ;;;
1146 ;;; motion by layout (page or line)
1147
1148 ;;; support routines, needed because we're not cacheing the page
1149 ;;; breaks (other than in the buffer Obseq) nor the linebreaks (at
1150 ;;; all)
1151 (defun position-containing-current-bar (sequence)
1152 (let ((bar (bar (current-cursor))))
1153 (position-if (lambda (measure) (member bar (measure-bars measure)))
1154 sequence)))
1155 (defun get-page-lines (buffer page-measures)
1156 (score-pane:with-staff-size 6
1157 (let* (;; all this untimely ripp'd from DRAW-BUFFER in
1158 ;; drawing.lisp. Needs to be kept in sync, otherwise the
1159 ;; layout for motion will be different from the layout on
1160 ;; the screen...
1161 (staves (staves buffer))
1162 (timesig-offset (gsharp-drawing::compute-timesig-offset staves page-measures))
1163 (method (let ((old-method (buffer-cost-method buffer)))
1164 (make-measure-cost-method (min-width old-method)
1165 (spacing-style old-method)
1166 (- (line-width old-method) timesig-offset)
1167 (lines-per-page old-method))))
1168 (systems-per-page (max 1 (floor 12 (length staves)))))
1169 (gsharp-drawing::layout-page page-measures systems-per-page method))))
1170
1171 ;;; FIXME: these routines should implement numeric-argument handling
1172 (define-gsharp-command (com-forward-page :name t)
1173 ()
1174 (let ((cursor (current-cursor)))
1175 (gsharp-measure::new-map-over-obseq-subsequences
1176 (lambda (page-measures)
1177 (let ((position (position-containing-current-bar page-measures)))
1178 (when position
1179 (loop repeat (- (length page-measures) position)
1180 if (last-bar-p cursor)
1181 do (go-to-end-of-bar cursor) (return-from com-forward-page)
1182 else do (forward-bar cursor)
1183 finally (return-from com-forward-page)))))
1184 (current-buffer))))
1185 (define-gsharp-command (com-backward-page :name t)
1186 ()
1187 (let ((cursor (current-cursor)))
1188 (gsharp-measure::new-map-over-obseq-subsequences
1189 (let ((last 0))
1190 (lambda (page-measures)
1191 (let ((position (position-containing-current-bar page-measures)))
1192 (when position
1193 (loop repeat (+ position last)
1194 do (backward-bar cursor)
1195 finally (progn
1196 (go-to-beginning-of-bar cursor)
1197 (return-from com-backward-page)))))
1198 (setf last (length page-measures))))
1199 (current-buffer))))
1200
1201 (define-gsharp-command (com-end-of-line :name t)
1202 ()
1203 (let ((buffer (current-buffer))
1204 (cursor (current-cursor)))
1205 (gsharp-measure::new-map-over-obseq-subsequences
1206 (lambda (page-measures)
1207 (when (position-containing-current-bar page-measures)
1208 (let ((lines (get-page-lines buffer page-measures)))
1209 (dolist (line lines)
1210 (let ((position (position-containing-current-bar line)))
1211 (when position
1212 (loop repeat (- (length line) position 1)
1213 do (forward-bar cursor)
1214 finally (progn
1215 (go-to-end-of-bar cursor)
1216 (return-from com-end-of-line)))))))))
1217 buffer)))
1218 (define-gsharp-command (com-beginning-of-line :name t)
1219 ()
1220 (let ((buffer (current-buffer))
1221 (cursor (current-cursor)))
1222 (gsharp-measure::new-map-over-obseq-subsequences
1223 (lambda (page-measures)
1224 (when (position-containing-current-bar page-measures)
1225 (let ((lines (get-page-lines buffer page-measures)))
1226 (dolist (line lines)
1227 (let ((position (position-containing-current-bar line)))
1228 (when position
1229 (loop repeat position
1230 do (backward-bar cursor)
1231 finally (progn
1232 (go-to-beginning-of-bar cursor)
1233 (return-from com-beginning-of-line)))))))))
1234 buffer)))
1235
1236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1237 ;;;
1238 ;;; selecting layers based on layout (next/previous staff)
1239
1240 ;;; FIXME: numeric argument handling again
1241 (define-gsharp-command (com-previous-staff :name t)
1242 ()
1243 (let ((staff (car (staves (layer (current-cursor))))))
1244 (loop for (prev curr) on (staves (current-buffer))
1245 if (eq curr staff)
1246 do (let ((layers (layers (segment (current-cursor)))))
1247 (dolist (layer layers)
1248 (when (member prev (staves layer))
1249 (select-layer (current-cursor) layer)
1250 (do ()
1251 ((eq prev (car (staves layer))))
1252 (com-rotate-staves))
1253 (return-from com-previous-staff)))))))
1254 (define-gsharp-command (com-next-staff :name t)
1255 ()
1256 (let ((staff (car (staves (layer (current-cursor))))))
1257 (loop for (curr next) on (staves (current-buffer))
1258 if (eq curr staff)
1259 do (let ((layers (layers (segment (current-cursor)))))
1260 (dolist (layer layers)
1261 (when (member next (staves layer))
1262 (select-layer (current-cursor) layer)
1263 (do ()
1264 ((eq next (car (staves layer))))
1265 (com-rotate-staves))
1266 (return-from com-next-staff)))))))
1267
1268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1269 ;;;
1270 ;;; delete commands
1271
1272 (defun go-to-beginning-of-bar (cursor)
1273 (loop until (beginning-of-bar-p cursor)
1274 do (backward-element cursor)))
1275
1276 (defun go-to-end-of-bar (cursor)
1277 (loop until (end-of-bar-p cursor)
1278 do (forward-element cursor)))
1279
1280 ;;; assume cursor is at the end of the bar
1281 (defun fuse-bar-with-next (cursor)
1282 (go-to-beginning-of-bar cursor)
1283 (let ((elements '()))
1284 (loop until (end-of-bar-p cursor) do
1285 (push (cursor-element cursor) elements)
1286 (delete-element cursor))
1287 (delete-bar cursor)
1288 (loop for element in (nreverse elements) do
1289 (insert-element element cursor)
1290 (forward-element cursor))))
1291
1292 (define-gsharp-command com-delete-element
1293 ((count 'integer :prompt "Number of Elements" :default 1))
1294 "Delete element forwards."
1295 (let ((cursor (current-cursor)))
1296 (loop repeat count
1297 do (progn
1298 ;; this will signal a condition if in last bar and
1299 ;; interrupt the execution of the command
1300 (forward-element cursor)
1301 (backward-element cursor)
1302 (if (end-of-bar-p cursor)
1303 (fuse-bar-with-next cursor)
1304 (delete-element cursor))))))
1305
1306 (define-gsharp-command com-erase-element
1307 ((count 'integer :prompt "Number of Elements" :default 1))
1308 "Delete element backwards."
1309 (let ((cursor (current-cursor)))
1310 (loop repeat count
1311 do (progn
1312 (backward-element cursor)
1313 (if (end-of-bar-p cursor)
1314 (fuse-bar-with-next cursor)
1315 (delete-element cursor))))))
1316
1317 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1318 ;;;
1319 ;;; Input State Settings
1320
1321 (define-gsharp-command com-istate-more-dots ()
1322 (setf (dots (input-state *application-frame*))
1323 (min (1+ (dots (input-state *application-frame*))) 3)))
1324
1325 (define-gsharp-command com-istate-fewer-dots ()
1326 (setf (dots (input-state *application-frame*))
1327 (max (1- (dots (input-state *application-frame*))) 0)))
1328
1329 (define-gsharp-command com-istate-more-rbeams ()
1330 (setf (rbeams (input-state *application-frame*))
1331 (min (1+ (rbeams (input-state *application-frame*))) 3)))
1332
1333 (define-gsharp-command com-istate-fewer-lbeams ()
1334 (setf (lbeams (input-state *application-frame*))
1335 (max (1- (lbeams (input-state *application-frame*))) 0)))
1336
1337 (define-gsharp-command com-istate-more-lbeams ()
1338 (setf (lbeams (input-state *application-frame*))
1339 (min (1+ (lbeams (input-state *application-frame*))) 3)))
1340
1341 (define-gsharp-command com-istate-fewer-rbeams ()
1342 (setf (rbeams (input-state *application-frame*))
1343 (max (1- (rbeams (input-state *application-frame*))) 0)))
1344
1345 (define-gsharp-command com-istate-rotate-notehead ()
1346 (setf (notehead (input-state *application-frame*))
1347 (ecase (notehead (input-state *application-frame*))
1348 (:breve :long)
1349 (:whole :breve)
1350 (:half :whole)
1351 (:filled :half)
1352 (:long :filled))))
1353
1354 (define-gsharp-command com-istate-rotate-stem-direction ()
1355 (setf (stem-direction (input-state *application-frame*))
1356 (ecase (stem-direction (input-state *application-frame*))
1357 (:auto :up)
1358 (:up :down)
1359 (:down :auto))))
1360
1361 (define-gsharp-command (com-set-clef :name t) ()
1362 (let ((staff (accept 'score-pane:fiveline-staff :prompt "Set clef of staff"))
1363 (type (accept 'clef-type :prompt "Type of clef"))
1364 (line (accept 'integer :prompt "Line of clef")))
1365 (setf (clef staff) (make-clef type :lineno line))))
1366
1367 (define-gsharp-command com-higher ()
1368 (incf (last-note (input-state *application-frame*)) 7))
1369
1370 (define-gsharp-command com-lower ()
1371 (decf (last-note (input-state *application-frame*)) 7))
1372
1373 (define-gsharp-command com-insert-barline ()
1374 (let ((cursor (current-cursor))
1375 (elements '()))
1376 (loop until (end-of-bar-p cursor)
1377 do (push (cursor-element cursor) elements)
1378 do (delete-element cursor))
1379 (insert-bar-after (make-instance (class-of (bar cursor))) cursor)
1380 (forward-bar cursor)
1381 (loop for element in elements
1382 do (insert-element element cursor))))
1383
1384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1385 ;;;
1386 ;;; Adding, deleting, and modifying staves
1387
1388 (define-condition no-such-staff (gsharp-condition) ()
1389 (:report
1390 (lambda (condition stream)
1391 (declare (ignore condition))
1392 (format stream "No such staff"))))
1393
1394 (define-presentation-method accept
1395 ((type score-pane:staff) stream (view textual-view) &key)
1396 (multiple-value-bind (staff success string)
1397 (handler-case (complete-input stream
1398 (lambda (so-far mode)
1399 (complete-from-possibilities
1400 so-far
1401 (staves (current-buffer))
1402 '()
1403 :action mode
1404 :predicate (constantly t)
1405 :name-key #'name
1406 :value-key #'identity)))
1407 (simple-parse-error () (error 'no-such-staff)))
1408 (declare (ignore string))
1409 (if success staff (error 'no-such-staff))))
1410
1411 (define-presentation-method accept
1412 ((type score-pane:fiveline-staff) stream (view textual-view) &key)
1413 (multiple-value-bind (staff success string)
1414 (handler-case (complete-input stream
1415 (lambda (so-far mode)
1416 (complete-from-possibilities
1417 so-far
1418 (staves (current-buffer))
1419 '()
1420 :action mode
1421 :predicate (lambda (obj) (typep obj 'fiveline-staff))
1422 :name-key #'name
1423 :value-key #'identity)))
1424 (simple-parse-error () (error 'no-such-staff)))
1425 (declare (ignore string))
1426 (if success staff (error 'no-such-staff))))
1427
1428 (defun symbol-name-lowcase (symbol)
1429 (string-downcase (symbol-name symbol)))
1430
1431 (define-presentation-type staff-type ())
1432
1433 (define-condition no-such-staff-type (gsharp-condition) ()
1434 (:report
1435 (lambda (condition stream)
1436 (declare (ignore condition))
1437 (format stream "No such staff type"))))
1438
1439 (define-presentation-method accept
1440 ((type staff-type) stream (view textual-view) &key)
1441 (multiple-value-bind (type success string)
1442 (handler-case (complete-input stream
1443 (lambda (so-far mode)
1444 (complete-from-possibilities
1445 so-far
1446 '(:fiveline :lyrics)
1447 '()
1448 :action mode
1449 :predicate (constantly t)
1450 :name-key #'symbol-name-lowcase
1451 :value-key #'identity)))
1452 (simple-completion-error () (error 'no-such-staff-type)))
1453 (declare (ignore string))
1454 (if success type (error 'no-such-staff-type))))
1455
1456 (define-presentation-type clef-type ())
1457
1458 (define-presentation-method accept
1459 ((type clef-type) stream (view textual-view) &key)
1460 (multiple-value-bind (type success string)
1461 (handler-case (complete-input stream
1462 (lambda (so-far mode)
1463 (complete-from-possibilities
1464 so-far
1465 '(:treble :treble8 :bass :c :percussion)
1466 '()
1467 :action mode
1468 :predicate (constantly t)
1469 :name-key #'symbol-name-lowcase
1470 :value-key #'identity)))
1471 (simple-completion-error () (error 'no-such-staff-type)))
1472 (declare (ignore string))
1473 (if success
1474 type
1475 (error "no such staff type"))))
1476
1477 (define-condition staff-name-not-unique (gsharp-condition) ()
1478 (:report
1479 (lambda (condition stream)
1480 (declare (ignore condition))
1481 (format stream "Staff name already exists"))))
1482
1483 (defun acquire-unique-staff-name (prompt)
1484 (let ((name (accept 'string :prompt prompt)))
1485 (assert (not (member name (staves (current-buffer)) :test #'string= :key #'name))
1486 () `staff-name-not-unique)
1487 name))
1488
1489 (defun acquire-new-staff ()
1490 (let ((name (acquire-unique-staff-name "Name of new staff")))
1491 (ecase (accept 'staff-type :prompt "Type")
1492 (:fiveline (let* ((clef-name (accept 'clef-type :prompt "Clef type of new staff"))
1493 (line (accept 'integer :prompt "Line of clef"))
1494 (clef (make-clef clef-name :lineno line)))
1495 (make-fiveline-staff :name name :clef clef)))
1496 (:lyrics (make-lyrics-staff :name name)))))
1497
1498 (define-gsharp-command (com-insert-staff-above :name t) ()
1499 (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff above staff")
1500 (acquire-new-staff)
1501 (current-buffer)))
1502
1503 (define-gsharp-command (com-insert-staff-below :name t) ()
1504 (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff below staff")
1505 (acquire-new-staff)
1506 (current-buffer)))
1507
1508 (define-gsharp-command (com-delete-staff :name t) ()
1509 (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff")
1510 (current-buffer)))
1511
1512 (define-gsharp-command (com-rename-staff :name t) ()
1513 (let* ((staff (accept 'score-pane:staff :prompt "Rename staff"))
1514 (name (acquire-unique-staff-name "New name of staff"))
1515 (buffer (current-buffer)))
1516 (rename-staff name staff buffer)))
1517
1518 (define-gsharp-command (com-add-staff-to-layer :name t) ()
1519 (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer"))
1520 (layer (layer (current-cursor))))
1521 (add-staff-to-layer staff layer)))
1522
1523 ;;; FIXME restrict to staves that are actually in the layer.
1524 (define-gsharp-command (com-delete-staff-from-layer :name t) ()
1525 (let ((staff (accept 'score-pane:staff :prompt "Delete staff from layer"))
1526 (layer (layer (current-cursor))))
1527 (remove-staff-from-layer staff layer)))
1528
1529 (define-gsharp-command com-more-sharps ()
1530 (more-sharps (keysig (current-cursor))))
1531
1532 (define-gsharp-command com-more-flats ()
1533 (more-flats (keysig (current-cursor))))
1534
1535 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1536 ;;;
1537 ;;; Lyrics
1538
1539 (defun insert-lyrics-element ()
1540 (let* ((state (input-state *application-frame*))
1541 (cursor (current-cursor))
1542 (element (make-lyrics-element (car (staves (layer (current-cursor))))
1543 :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
1544 :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
1545 :dots (dots state)
1546 :notehead (notehead state))))
1547 (insert-element element cursor)
1548 (forward-element cursor)
1549 element))
1550
1551 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1552 ;;;
1553 ;;; I/O
1554
1555 (defmethod frame-make-buffer-from-stream ((frame gsharp) stream)
1556 (read-buffer-from-stream stream))
1557
1558 (defmethod frame-make-new-buffer ((frame gsharp) &key &allow-other-keys)
1559 (make-instance 'buffer))
1560
1561
1562 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1563 ;;;
1564 ;;; Buffer / View handling
1565
1566 ;;; FIXME: these utility functions should live elsewhere.
1567 (defun current-view ()
1568 (view (current-window)))
1569
1570 (defun not-current-view ()
1571 (find (current-view) (views *application-frame*) :test (complement #'eq)))
1572
1573 (defun not-current-view-or-first ()
1574 (or (not-current-view) (car (views *application-frame*))))
1575
1576 (defun next-or-new-buffer-view ()
1577 (or (not-current-view)
1578 (progn (com-new-buffer)
1579 (car (views *application-frame*)))))
1580
1581 (define-gsharp-command (com-switch-to-view :name t)
1582 ((view 'orchestra-view :default (not-current-view-or-first)))
1583 (setf (view (current-window)) view))
1584
1585 (define-gsharp-command (com-kill-view :name t)
1586 ((view 'orchestra-view :default (current-view)))
1587 (let ((views (views *application-frame*)))
1588 (setf (views *application-frame*) (remove view views))
1589 (when (eq view (current-view))
1590 (let ((next-view (next-or-new-buffer-view)))
1591 (setf (view (current-window)) next-view)))))
1592
1593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1594 ;;;
1595 ;;; Printing
1596
1597 (defun print-buffer-filename ()
1598 (let* ((buffer (current-buffer))
1599 (filepath (filepath buffer))
1600 (name (name buffer))
1601 (defaults (or filepath (merge-pathnames (make-pathname :name name)
1602 (user-homedir-pathname)))))
1603 (merge-pathnames (make-pathname :type "ps") defaults)))
1604
1605 (define-gsharp-command (com-print-buffer-to-file :name t)
1606 ((filepath 'pathname
1607 :prompt "Print To: " :prompt-mode :raw
1608 :default (print-buffer-filename) :default-type 'pathname
1609 :insert-default t))
1610 (with-open-file (ps filepath :direction :output :if-exists :supersede)
1611 (let* ((type (pathname-type filepath))
1612 (epsp (string-equal type "EPS")))
1613 (with-output-to-postscript-stream (s ps :device-type (when epsp :eps))
1614 (setf (stream-default-view s)
1615 ;; FIXME: should probably get the class of the view from
1616 ;; the current buffer or window or something.
1617 (make-instance 'orchestra-view :light-glyphs-ink +black+
1618 :buffer (current-buffer)
1619 :cursor (current-cursor)))
1620 (setf (medium-transformation s)
1621 ;; FIXME: This scaling works for me (A4 paper, default
1622 ;; gsharp buffer sizes.
1623 (compose-scaling-with-transformation
1624 (medium-transformation s) 0.8 0.8))
1625 (print-buffer s (current-buffer) (current-cursor)
1626 (left-margin (current-buffer)) 100)))))

  ViewVC Help
Powered by ViewVC 1.1.5