3 (defparameter *icon-path
*
4 ;; sb-ext:*core-pathname*
5 "/Users/dlewis/lisp/gsharp/Icons/")
6 (defun make-initial-cursor (buffer)
7 (let* ((segment (segmentno buffer
0))
8 (layer (layerno segment
0))
10 (bar (barno slice
0)))
13 (defclass gsharp-minibuffer-pane
(minibuffer-pane)
16 :height
20 :max-height
20 :min-height
20))
18 (define-command-table total-melody-table
19 :inherit-from
(melody-table global-gsharp-table gsharp
))
20 (define-command-table total-rhythmic-melody-table
21 :inherit-from
(melody-table rhythmic-table global-gsharp-table gsharp
))
22 (define-command-table total-cluster-table
23 :inherit-from
(cluster-table melody-table global-gsharp-table gsharp
))
24 (define-command-table total-lyrics-table
25 :inherit-from
(lyrics-table global-gsharp-table gsharp
))
27 (defclass orchestra-view
(score-pane:score-view
)
28 ((cursor :initarg
:cursor
:reader cursor
)
29 (buffer :initarg
:buffer
:reader buffer
)))
31 ;;; FIXME: we need to sort out Drei's definition of accept methods for
32 ;;; the general VIEW type.
34 ;;; FIXME: we should name our views so that they can be found by a
35 ;;; string name, rather than the unreadable-object print. There's a
36 ;;; SUBSCRIPTABLE-NAME-MIXIN in ESA-UTILS that is used for this
37 ;;; purpose in the analogous place in Climacs.
38 (define-presentation-method accept
39 ((type orchestra-view
) stream
(view textual-view
)
40 &key
(default nil defaultp
) (default-type type
))
41 (multiple-value-bind (object success string
)
42 (complete-input stream
43 (lambda (so-far action
)
44 (complete-from-possibilities
45 so-far
(views *esa-instance
*) '()
47 :name-key
#'princ-to-string
48 :value-key
#'identity
))
49 :partial-completers
'(#\Space
))
51 (success (values object type
))
52 ((and defaultp
(= (length string
) 0)) (values default default-type
))
53 (t (input-not-of-required-type string type
)))))
55 ;;; exists for the sole purpose of a :before method that updates the
56 ;;; measures of each modified buffer.
57 (defclass gsharp-pane-mixin
() ())
59 (defclass gsharp-pane
(score-pane:score-pane gsharp-pane-mixin
)
60 ((view :initarg
:view
:accessor view
)))
62 (defvar *info-bg-color
* +gray85
+)
63 (defvar *info-fg-color
* +black
+)
65 (defclass gsharp-info-pane
(info-pane gsharp-pane-mixin
)
68 :height
20 :max-height
20 :min-height
20
69 :display-function
'display-info
70 :incremental-redisplay t
))
72 (defun display-info (frame pane
)
73 (declare (ignore frame
))
74 (let* ((master-pane (master-pane pane
))
75 (view (view master-pane
))
76 (buffer (buffer view
)))
78 (princ (cond ((and (needs-saving buffer
)
81 ((needs-saving buffer
) "**")
82 ((read-only-p buffer
) "%%")
86 (with-text-face (pane :bold
)
87 (format pane
"~25A" (name buffer
)))
89 (format pane
"[~a/~a]"
90 (score-pane:current-page-number view
)
91 (score-pane:number-of-pages view
))
93 (with-text-family (pane :sans-serif
)
94 (princ (if (recordingp *application-frame
*)
99 (defun x-offset-label (frame pane
)
100 (declare (ignore frame
))
101 (when (handler-case (cur-cluster)
102 (gsharp-condition () nil
))
103 (princ (gsharp-buffer::xoffset
(cur-element)) pane
)))
104 (defun x-pad-label (frame pane
)
105 (declare (ignore frame
))
106 (when (handler-case (cur-cluster)
107 (gsharp-condition () nil
))
108 (princ (gsharp-buffer::left-pad
(cur-element)) pane
)))
110 (define-application-frame gsharp
(esa-frame-mixin
111 standard-application-frame
)
112 ((views :initarg
:views
:initform
'() :accessor views
)
113 (input-state :initarg
:input-state
:accessor input-state
))
114 (:default-initargs
:input-state
(make-input-state))
115 (:menu-bar menubar-command-table
:height
25)
116 (:pointer-documentation t
)
118 (score (let* ((win (make-pane 'gsharp-pane
119 :width
400 :height
500
121 ;; :incremental-redisplay t
123 :display-function
'display-score
124 :command-table
'total-melody-table
))
125 (info (make-pane 'gsharp-info-pane
127 :background
*info-bg-color
*
128 :foreground
*info-fg-color
*)))
129 (setf (windows *application-frame
*) (list win
))
130 (setf (view win
) (car (views *application-frame
*)))
132 (scrolling (:width
750 :height
500
133 :min-height
400 :max-height
20000)
136 (state (make-pane 'score-pane
:score-pane
137 :width
50 :height
200
139 :display-function
'display-state
))
140 (element (make-pane 'score-pane
:score-pane
141 :width
50 :height
300
142 :min-height
100 :max-height
20000
144 :display-function
'display-element
))
145 (interactor (make-pane 'gsharp-minibuffer-pane
:width
900)))
152 (scrolling (:width
80 :height
200) state
)
153 (scrolling (:width
80 :height
300
154 :min-height
300 :max-height
20000)
157 (:top-level
(esa-top-level)))
159 (defun simple-button (label function
&key panes
)
160 (make-pane 'push-button
:label label
164 (declare (ignore gadget
))
166 (dolist (pane-keyword panes
)
167 (redisplay-frame-pane
169 (pane-from-keyword *application-frame
* pane-keyword
)
172 (defgeneric pane-from-keyword
(frame pane-keyword
))
173 (defmethod pane-from-keyword (frame (pane-keyword (eql :state
)))
174 (find-pane-named frame
'state
))
175 (defmethod pane-from-keyword (frame (pane-keyword (eql :element
)))
176 (find-pane-named frame
'element
))
177 (defmethod pane-from-keyword (frame (pane-keyword (eql :score
)))
178 (get-main-score-pane))
180 (defun istate-button (label function
)
181 (simple-button label function
:panes
'(:state
)))
182 (defun element-button (label function
)
183 (simple-button label function
:panes
'(:score
:element
)))
185 (defun istate-notehead-button (label value
)
186 (make-pane 'push-button
190 (declare (ignore gadget
))
191 (setf (notehead (input-state *application-frame
*))
193 (when (find-pane-named *application-frame
* 'state
)
194 (redisplay-frame-pane *application-frame
*
195 (find-pane-named *application-frame
* 'state
)
199 (defmethod buffers ((application-frame gsharp
))
201 (dolist (window (windows application-frame
) (nreverse result
))
202 (let ((view (view window
)))
204 (pushnew (buffer view
) result
))))))
206 (defmethod esa-current-buffer ((application-frame gsharp
))
207 (buffer (view (car (windows application-frame
)))))
209 (defun current-cursor ()
210 (cursor (view (car (windows *application-frame
*)))))
212 (defmethod execute-frame-command :around
((frame gsharp
) command
)
214 (let ((buffer (if (views frame
)
215 (list (buffer (car (views frame
)))))))
216 (drei::with-undo
(buffer)
218 (gsharp-condition (condition) (beep) (display-message "~a" condition
))))
220 (defmethod display-state ((frame gsharp
) pane
)
221 (let ((state (input-state *application-frame
*)))
222 (score-pane:with-score-pane pane
223 (score-pane:with-staff-size
10
224 (score-pane:with-vertical-score-position
(pane 100)
226 (score-pane:draw-notehead pane
(notehead state
) xpos
4)
227 (when (not (member (notehead state
) '(:whole
:breve
)))
228 (when (or (eq (stem-direction state
) :auto
)
229 (eq (stem-direction state
) :down
))
230 (when (eq (notehead state
) :filled
)
231 (score-pane:with-notehead-left-offsets
(left down
)
232 (declare (ignore down
))
233 (let ((x (+ xpos left
)))
234 (loop repeat
(rbeams state
)
235 for staff-step from -
4 by
2 do
236 (score-pane:draw-beam pane x staff-step
0 (+ x
10) staff-step
0))
237 (loop repeat
(lbeams state
)
238 for staff-step from -
4 by
2 do
239 (score-pane:draw-beam pane
(- x
10) staff-step
0 x staff-step
0)))))
240 (score-pane:draw-left-stem pane xpos
(- (score-pane:staff-step
4)) (- (score-pane:staff-step -
4))))
241 (when (or (eq (stem-direction state
) :auto
)
242 (eq (stem-direction state
) :up
))
243 (when (eq (notehead state
) :filled
)
244 (score-pane:with-notehead-right-offsets
(right up
)
245 (declare (ignore up
))
246 (let ((x (+ xpos right
)))
247 (loop repeat
(rbeams state
)
248 for staff-step downfrom
12 by
2 do
249 (score-pane:draw-beam pane x staff-step
0 (+ x
10) staff-step
0))
250 (loop repeat
(lbeams state
)
251 for staff-step downfrom
12 by
2 do
252 (score-pane:draw-beam pane
(- x
10) staff-step
0 x staff-step
0)))))
253 (score-pane:draw-right-stem pane xpos
(- (score-pane:staff-step
4)) (- (score-pane:staff-step
12)))))
254 (score-pane:with-notehead-right-offsets
(right up
)
255 (declare (ignore up
))
256 (loop repeat
(dots state
)
257 for dx from
(+ right
5) by
5 do
258 (score-pane:draw-dot pane
(+ xpos dx
) 4)))))))))
260 (defun update-page-numbers (frame)
261 (loop for window in
(windows frame
)
262 do
(let ((page-number 0)
263 (view (view window
)))
264 (gsharp-measure::new-map-over-obseq-subsequences
265 (lambda (all-measures)
267 (when (member-if (lambda (measure) (member (bar (cursor view
))
268 (measure-bars measure
)
271 (setf (score-pane:current-page-number view
) page-number
)))
273 (setf (score-pane:number-of-pages view
) page-number
))))
275 ;;; I tried making this a :before method on redisplay-frame-panes,
276 ;;; but it turns out that McCLIM calls redisplay-frame-pane from
277 ;;; places other than redisplay-frame-panes.
278 (defmethod redisplay-frame-pane :before
((frame gsharp
) (pane gsharp-pane-mixin
) &key force-p
)
279 (declare (ignore pane force-p
))
280 (mapc #'recompute-measures
(buffers frame
))
281 (update-page-numbers frame
))
283 (defmethod display-score ((frame gsharp
) pane
)
284 (let* ((buffer (buffer (view pane
)))
285 (zoom (gsharp-buffer::zoom-level buffer
)))
286 (with-drawing-options (pane :transformation
(make-scaling-transformation zoom zoom
))
287 (score-pane:with-score-pane pane
288 (draw-buffer pane buffer
(current-cursor)
289 (left-margin buffer
) 100)
290 (draw-the-cursor pane
(current-cursor) (cursor-element (current-cursor))
291 (last-note (input-state *application-frame
*)))
292 (multiple-value-bind (minx miny maxx maxy
)
293 (bounding-rectangle* (stream-output-history pane
))
294 (declare (ignore minx maxx
))
295 (change-space-requirements pane
:height
(+ maxy miny
)))))))
297 (defmethod window-clear ((pane score-pane
:score-pane
))
298 (let ((output-history (stream-output-history pane
)))
299 (with-bounding-rectangle* (left top right bottom
) output-history
300 (medium-clear-area (sheet-medium pane
) left top right bottom
))
301 (clear-output-record output-history
))
302 (window-erase-viewport pane
))
304 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
308 (defmethod note-position ((note note
))
309 (let ((clef (clef note
)))
311 (bottom-line clef
))))
313 (defmethod display-element ((frame gsharp
) pane
)
314 (when (handler-case (cur-element)
315 (gsharp-condition () nil
))
316 (draw-current-element pane
(cur-element))))
318 (defgeneric draw-current-element
(pane element
)
319 (:method
(pane element
) nil
))
320 (defmethod draw-current-element (pane (cluster cluster
))
321 (score-pane:with-score-pane pane
322 (score-pane:with-staff-size
10
323 (score-pane:with-vertical-score-position
(pane 10)
325 (notehead (notehead cluster
))
326 (rbeams (rbeams cluster
))
327 (lbeams (lbeams cluster
))
328 (dots (dots cluster
))
329 (notes (notes cluster
))
330 (stem-direction (stem-direction cluster
)))
331 (declare (ignore stem-direction notehead lbeams rbeams dots
))
332 (loop for note in notes do
333 (draw-ellipse* pane xpos
(- 120 (* 15 (note-position note
))) 7 0 0 7)
334 (score-pane:draw-accidental pane
(accidentals note
)
335 (- xpos
(if (oddp (note-position note
)) 15 25))
336 (- (* 3 (note-position note
)) 24)))
338 (draw-ellipse* pane xpos
(- 120 (* 15 (note-position (cur-note))))
340 (loop for s from
0 by
30
342 (draw-line* pane
(- xpos
25) s
(+ xpos
25) s
))
344 (clim::draw-text
* pane
(format nil
"x-offset: ~A"
345 (gsharp-buffer::xoffset cluster
))
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;;; messages to the user
351 ;;; FIXME: do this better
352 (defun message (format-string &rest format-args
)
353 (apply #'format
*error-output
* format-string format-args
))
355 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360 'menubar-command-table
362 :menu
'(("File" :menu esa-io-menu-table
)
363 ("Macros" :menu keyboard-macro-menu-table
)
364 ("Buffer" :menu buffer-command-table
)
365 ("Stuff" :menu segment-command-table
)
366 ("Segment" :menu segment-command-table
)
367 ("Layer" :menu layer-command-table
)
368 ("Slice" :menu slice-command-table
)
369 ("Measure" :menu measure-command-table
)
370 ("Modes" :menu modes-command-table
)
371 ("Staves" :menu staves-command-table
)
372 ("Play" :menu play-command-table
)
373 ("Help" :menu help-menu-table
)))
375 (define-gsharp-command (com-new-buffer :name t
) ()
376 (let* ((buffer (make-instance 'buffer
))
377 (cursor (make-initial-cursor buffer
))
378 (staff (car (staves buffer
)))
379 (input-state (make-input-state))
380 (view (make-instance 'orchestra-view
383 (push view
(views *application-frame
*))
384 (setf (view (car (windows *application-frame
*))) view
)
385 (setf (input-state *application-frame
*) input-state
386 (staves (car (layers (car (segments buffer
))))) (list staff
))))
388 (defmethod frame-find-file :around
((application-frame gsharp
) filepath
)
389 (declare (ignore filepath
))
390 (let* ((buffer (call-next-method))
391 (input-state (make-input-state))
392 (cursor (make-initial-cursor buffer
))
393 (view (make-instance 'orchestra-view
396 (push view
(views *application-frame
*))
397 (setf (view (car (windows *application-frame
*))) view
398 (input-state *application-frame
*) input-state
399 (filepath buffer
) filepath
)
400 (select-layer cursor
(car (layers (segment (current-cursor)))))))
402 (define-gsharp-command (com-quit :name t
) ()
403 (frame-exit *application-frame
*))
405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
410 'buffer-command-table
412 :menu
'(("Play" :command com-play-buffer
)
413 ("Delete Current" :command com-delete-buffer
)))
415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
420 'segment-command-table
422 :menu
'(("Forward" :command com-forward-segment
)
423 ("Backward" :command com-backward-segment
)
424 ("Delete Current" :command com-delete-segment
)
425 ("Insert After Current" :command com-insert-segment-after
)
426 ("Insert Before Current" :command com-insert-segment-before
)))
428 (define-gsharp-command (com-forward-segment :name t
) ()
429 (forward-segment (current-cursor)))
431 (define-gsharp-command (com-backward-segment :name t
) ()
432 (backward-segment (current-cursor)))
434 (define-gsharp-command (com-delete-segment :name t
) ()
435 (delete-segment (current-cursor)))
437 (define-gsharp-command (com-insert-segment-before :name t
) ()
438 (let ((cursor (current-cursor)))
439 (insert-segment-before (make-instance 'segment
:staff
(car (staves (current-buffer))))
441 (backward-segment cursor
)))
443 (define-gsharp-command (com-insert-segment-after :name t
) ()
444 (let ((cursor (current-cursor)))
445 (insert-segment-after (make-instance 'segment
:staff
(car (staves (current-buffer))))
447 (forward-segment cursor
)))
449 (define-gsharp-command (com-set-segment-tempo :name t
) ((tempo 'integer
:prompt
"Tempo"))
450 (let ((segment (segment (current-cursor))))
451 (setf (tempo segment
) tempo
)))
453 (define-gsharp-command (com-set-segment-tuning-regular-temperament :name t
)
454 ((octave-cents 'cl
:number
:prompt
"Octave size in cents")
455 (fifth-cents 'cl
:number
:prompt
"Fifth size in cents")
456 (quartertone-cents 'cl
:number
:prompt
"Quartertone size in cents"))
457 ;; TODO: prompt for sizes of various microtonal accidentals
458 (let ((segment (segment (current-cursor))))
459 (setf (tuning segment
) (make-instance 'regular-temperament
460 :octave-cents octave-cents
461 :fifth-cents fifth-cents
462 :quartertone-cents quartertone-cents
))))
464 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471 :menu
'(("Select" :command com-select-layer
)
472 ("Rename" :command com-rename-layer
)
473 ("New" :command com-add-layer
)
474 ("Delete" :command com-delete-layer
)))
476 (define-condition layer-name-not-unique
(gsharp-condition) ()
478 (lambda (condition stream
)
479 (declare (ignore condition
))
480 (format stream
"Layer name already exists"))))
482 (defun acquire-unique-layer-name (prompt)
483 (let ((name (accept 'string
:prompt prompt
)))
484 (assert (not (member name
(layers (segment (current-cursor)))
485 :test
#'string
= :key
#'name
))
486 () `layer-name-not-unique
)
489 (define-condition no-such-layer
(gsharp-condition) ()
491 (lambda (condition stream
)
492 (declare (ignore condition
))
493 (format stream
"No such layer"))))
495 (define-presentation-method accept
496 ((type layer
) stream
(view textual-view
) &key
)
497 (multiple-value-bind (layer success string
)
498 (handler-case (complete-input stream
499 (lambda (so-far mode
)
500 (complete-from-possibilities
502 (layers (segment (current-cursor)))
505 :predicate
(constantly t
)
507 :value-key
#'identity
)))
508 (simple-parse-error () (error 'no-such-layer
)))
509 (declare (ignore string
))
510 (if success layer
(error 'no-such-layer
))))
512 (defgeneric find-applicable-gsharp-command-table
(layer element
))
514 (defmethod find-applicable-gsharp-command-table ((layer melody-layer
) element
)
515 (declare (ignore element
))
516 (find-command-table 'total-melody-table
))
518 (defmethod find-applicable-gsharp-command-table ((layer melody-layer
) (element rhythmic-element
))
519 (find-command-table 'total-rhythmic-melody-table
))
521 (defmethod find-applicable-gsharp-command-table ((layer melody-layer
) (element cluster
))
522 (find-command-table 'total-cluster-table
))
524 (defmethod find-applicable-gsharp-command-table ((layer lyrics-layer
) element
)
525 (declare (ignore element
))
526 (find-command-table 'total-lyrics-table
))
528 (defmethod find-applicable-command-table ((frame gsharp
))
529 (let* ((cursor (current-cursor))
530 (layer (layer cursor
))
531 (element (if (beginning-of-bar-p cursor
) nil
(current-element cursor
))))
532 (find-applicable-gsharp-command-table layer element
)))
534 (define-gsharp-command (com-select-layer :name t
) ()
535 (let ((selected-layer (accept 'layer
:prompt
"Select layer")))
536 (select-layer (current-cursor) selected-layer
)))
538 (define-gsharp-command (com-rename-layer :name t
) ()
539 (setf (name (accept 'layer
:prompt
"Rename layer"))
540 (acquire-unique-layer-name "New name of layer")))
542 (define-gsharp-command (com-add-layer :name t
) ()
543 (let* ((name (acquire-unique-layer-name "Name of new layer"))
544 (staff (accept 'score-pane
:staff
:prompt
"Initial staff of new layer"))
545 (new-layer (make-layer (list staff
) :name name
)))
546 (add-layer new-layer
(segment (current-cursor)))
547 (select-layer (current-cursor) new-layer
)))
549 (define-gsharp-command (com-delete-layer :name t
) ()
550 (delete-layer (current-cursor)))
552 (define-gsharp-command (com-jump-to-here :name t
)
554 (let ((cursor (current-cursor)))
555 (setf (gsharp-cursor::bar cursor
) (bar element
)
556 (gsharp-cursor::pos cursor
) (1+ (position element
557 (elements (bar element
)))))))
559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
566 :menu
'(("Head" :command com-head-slice
)
567 ("Body" :command com-body-slice
)
568 ("Tail" :command com-tail-slisce
)))
570 (define-gsharp-command (com-head-slice :name t
) ()
571 (head-slice (current-cursor)))
573 (define-gsharp-command (com-body-slice :name t
) ()
574 (body-slice (current-cursor)))
576 (define-gsharp-command (com-tail-slice :name t
) ()
577 (tail-slice (current-cursor)))
579 (define-gsharp-command (com-forward-slice :name t
) ()
580 (forward-slice (current-cursor)))
582 (define-gsharp-command (com-backward-slice :name t
) ()
583 (backward-slice (current-cursor)))
585 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
590 'measure-command-table
592 :menu
'(("Forward" :command
(com-forward-measure 1))
593 ("Backward" :command
(com-backward-measure 1))))
595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
602 :menu
'(("Fundamental" :command com-fundamental
)))
604 (define-gsharp-command (com-fundamental :name t
) ()
607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
612 'staves-command-table
614 :menu
'(("Rotate" :command com-rotate-staves
)))
616 (define-gsharp-command (com-rotate-staves :name t
) ()
617 (let ((layer (layer (current-cursor))))
619 (append (cdr (staves layer
)) (list (car (staves layer
)))))))
621 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
628 :menu
'(("Buffer" :command com-play-buffer
)
629 ("Segment" :command com-play-segment
)
630 ("Layer" :command com-play-layer
)))
632 (define-gsharp-command (com-play-buffer :name t
) ()
633 (play-buffer (buffer (current-cursor))))
635 (define-gsharp-command (com-play-segment :name t
) ()
636 (play-segment (segment (current-cursor))))
638 (define-gsharp-command (com-play-layer :name t
) ()
639 (play-layer (layer (current-cursor))))
641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
643 ;;; main entry points
645 (defun gsharp (&rest args
&key new-process process-name width height
)
646 "Start a Gsharp session with a fresh empty buffer"
647 (declare (ignore new-process process-name width height
))
648 (apply #'gsharp-common
'(com-new-buffer) args
))
650 (defun edit-file (filename &rest args
651 &key new-process process-name width height
)
652 "Start a Gsharp session editing a given file"
653 (declare (ignore new-process process-name width height
))
654 (apply #'gsharp-common
`(esa-io::com-find-file
,filename
) args
))
656 (defun gsharp-common (command &key new-process
(process-name "Gsharp") width height
)
657 (let* ((frame (make-application-frame 'gsharp
:width width
:height height
))
658 (*application-frame
* frame
)
659 (*esa-instance
* frame
))
660 (adopt-frame (find-frame-manager) *application-frame
*)
661 (execute-frame-command *application-frame
* command
)
662 (flet ((run () (run-frame-top-level frame
)))
664 (clim-sys:make-process
#'run
:name process-name
)
667 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
669 ;;; development and debugging aids
671 ;;; FIXME: you might expect that this was in an ESA component, but in
672 ;;; fact it's not. Maybe it should be?
673 (define-gsharp-command (com-eval-expression :name t
)
674 ((expression 'expression
:prompt
"Eval"))
675 "Prompt for and evaluate a lisp expression.
676 Prints the results in the minibuffer."
677 (let* ((*package
* (find-package :gsharp
))
678 (values (multiple-value-list
679 (handler-case (eval expression
)
682 (display-message "~a" condition
)
683 (return-from com-eval-expression nil
)))))
684 (result (format nil
"~:[; No values~;~:*~{~S~^,~}~]" values
)))
685 (display-message result
)))
687 (define-gsharp-command (com-raster+ :name t
) ()
688 (let ((score-pane (get-main-score-pane)))
689 (incf (gsharp-buffer::rastral-size
(buffer (current-cursor))))
690 (redisplay-frame-pane *application-frame
* score-pane
:force-p t
)))
691 (define-gsharp-command (com-raster- :name t
) ()
692 (let ((score-pane (get-main-score-pane)))
693 (unless (<= (gsharp-buffer::rastral-size
(buffer (current-cursor))) 6)
694 (decf (gsharp-buffer::rastral-size
(buffer (current-cursor))))
695 (redisplay-frame-pane *application-frame
* score-pane
:force-p t
))))
697 (defun get-main-score-pane ()
699 (frame-current-panes *application-frame
*)
703 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
705 ;;; note insertion commands
707 (defun insert-cluster ()
708 (let* ((state (input-state *application-frame
*))
709 (cursor (current-cursor))
710 (cluster (make-cluster
711 :notehead
(notehead state
)
712 :lbeams
(if (eq (notehead state
) :filled
) (lbeams state
) 0)
713 :rbeams
(if (eq (notehead state
) :filled
) (rbeams state
) 0)
715 :stem-direction
(stem-direction state
))))
716 (insert-element cluster cursor
)
717 (forward-element cursor
)
720 (defparameter *current-cluster
* nil
)
721 (defparameter *current-note
* nil
)
723 (defun insert-note (pitch cluster accidentals
)
724 (let* ((state (input-state *application-frame
*))
725 (staff (car (staves (layer (slice (bar cluster
))))))
726 (note (make-note pitch staff
727 :head
(notehead state
)
728 :accidentals accidentals
729 :dots
(dots state
))))
730 (setf *current-cluster
* cluster
732 (add-note cluster note
)))
734 (defun compute-and-adjust-note (pitch)
735 (let* ((state (input-state *application-frame
*))
736 (old-pitch (mod (last-note state
) 7))
737 (diff (- pitch old-pitch
)))
738 (incf (last-note state
)
739 (cond ((> diff
3) (- diff
7))
740 ((< diff -
3) (+ diff
7))
743 (defun insert-numbered-note-new-cluster (pitch)
744 (let* ((new-pitch (compute-and-adjust-note pitch
))
745 (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch
7))))
746 (insert-note new-pitch
(insert-cluster) accidentals
)))
748 (define-gsharp-command (com-insert-note-a :keystroke
#\a) ()
749 (insert-numbered-note-new-cluster 5))
751 (define-gsharp-command (com-insert-note-b :keystroke
#\b) ()
752 (insert-numbered-note-new-cluster 6))
754 (define-gsharp-command (com-insert-note-c :keystroke
#\c
) ()
755 (insert-numbered-note-new-cluster 0))
757 (define-gsharp-command (com-insert-note-d :keystroke
#\d
) ()
758 (insert-numbered-note-new-cluster 1))
760 (define-gsharp-command (com-insert-note-e :keystroke
#\e
) ()
761 (insert-numbered-note-new-cluster 2))
763 (define-gsharp-command (com-insert-note-f :keystroke
#\f) ()
764 (insert-numbered-note-new-cluster 3))
766 (define-gsharp-command (com-insert-note-g :keystroke
#\g
) ()
767 (insert-numbered-note-new-cluster 4))
769 (define-gsharp-command com-insert-rest
()
770 (let* ((state (input-state *application-frame
*))
771 (cursor (current-cursor))
772 (rest (make-rest (car (staves (layer (current-cursor))))
773 :rbeams
(if (eq (notehead state
) :filled
) (rbeams state
) 0)
774 :lbeams
(if (eq (notehead state
) :filled
) (lbeams state
) 0)
776 :notehead
(notehead state
))))
777 (insert-element rest cursor
)
778 (forward-element cursor
)
781 (define-gsharp-command com-insert-empty-cluster
()
784 (defun cur-elementp ()
787 (not-on-an-element () nil
)))
788 (defun cur-clusterp ()
791 (not-on-a-cluster () nil
)))
795 (not-on-a-cluster () nil
)
796 (not-on-an-element () nil
)))
798 (defun cur-cluster ()
799 (current-cluster (current-cursor)))
801 (defun cur-element ()
802 (current-element (current-cursor)))
805 (let ((cluster (cur-cluster)))
806 (if (eq *current-cluster
* cluster
) ; it has not moved since last time
807 (or (car (member *current-note
* (notes cluster
) :test
#'eq
))
808 (setf *current-note
* (car (notes cluster
))))
809 (setf *current-cluster
* cluster
810 *current-note
* (car (notes cluster
))))))
812 (define-gsharp-command com-current-increment
()
813 (let* ((cluster (cur-cluster))
814 (notes (notes cluster
))
815 (rest (member (cur-note) notes
:test
#'eq
)))
816 (unless (null (cdr rest
))
817 (setf *current-note
* (cadr rest
)))))
819 (define-gsharp-command com-current-decrement
()
820 (let* ((cluster (cur-cluster))
821 (notes (notes cluster
))
822 (pos (position (cur-note) notes
:test
#'eq
)))
824 (setf *current-note
* (nth (1- pos
) notes
)))))
826 (defun insert-numbered-note-current-cluster (pitch)
827 (let* ((new-pitch (compute-and-adjust-note pitch
))
828 (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch
7))))
829 (insert-note new-pitch
(cur-cluster) accidentals
)))
831 (define-gsharp-command com-add-note-a
()
832 (insert-numbered-note-current-cluster 5))
834 (define-gsharp-command com-add-note-b
()
835 (insert-numbered-note-current-cluster 6))
837 (define-gsharp-command com-add-note-c
()
838 (insert-numbered-note-current-cluster 0))
840 (define-gsharp-command com-add-note-d
()
841 (insert-numbered-note-current-cluster 1))
843 (define-gsharp-command com-add-note-e
()
844 (insert-numbered-note-current-cluster 2))
846 (define-gsharp-command com-add-note-f
()
847 (insert-numbered-note-current-cluster 3))
849 (define-gsharp-command com-add-note-g
()
850 (insert-numbered-note-current-cluster 4))
852 (macrolet ((define-duration-altering-command (name &body body
)
853 `(define-gsharp-command ,name
()
854 (let ((element (cur-element)))
856 (gsharp-buffer::maybe-update-key-signatures
857 (bar (current-cursor)))))))
858 (define-duration-altering-command com-more-dots
()
859 (setf (dots element
) (min (1+ (dots element
)) 3)))
860 (define-duration-altering-command com-fewer-dots
()
861 (setf (dots element
) (max (1- (dots element
)) 0)))
862 (define-duration-altering-command com-more-rbeams
()
863 (setf (rbeams element
) (min (1+ (rbeams element
)) 3)))
864 (define-duration-altering-command com-fewer-lbeams
()
865 (setf (lbeams element
) (max (1- (lbeams element
)) 0)))
866 (define-duration-altering-command com-more-lbeams
()
867 (setf (lbeams element
) (min (1+ (lbeams element
)) 3)))
868 (define-duration-altering-command com-fewer-rbeams
()
869 (setf (rbeams element
) (max (1- (rbeams element
)) 0)))
870 (define-duration-altering-command com-rotate-notehead
()
871 (setf (notehead element
)
872 (ecase (notehead element
)
879 (define-gsharp-command com-rotate-stem-direction
()
880 (setf (stem-direction (cur-cluster))
881 (ecase (stem-direction (cur-cluster))
886 (define-gsharp-command com-toggle-staccato
()
887 (let ((cluster (cur-cluster)))
888 (if (member :staccato
(annotations cluster
))
889 (setf (annotations cluster
) (remove :staccato
(annotations cluster
)))
890 (push :staccato
(annotations cluster
)))))
892 (define-gsharp-command com-toggle-tenuto
()
893 (let ((cluster (cur-cluster)))
894 (if (member :tenuto
(annotations cluster
))
895 (setf (annotations cluster
) (remove :tenuto
(annotations cluster
)))
896 (push :tenuto
(annotations cluster
)))))
898 (define-gsharp-command com-down
()
899 (let ((element (cur-element)))
900 (if (typep element
'cluster
)
901 (let* ((note (cur-note))
902 (new-note (make-note (1- (pitch note
)) (staff note
)
904 :accidentals
(accidentals note
)
907 (add-note element new-note
)
908 (setf *current-note
* new-note
))
909 (let ((rbeams (rbeams element
))
910 (lbeams (lbeams element
))
911 (dots (dots element
))
912 (notehead (notehead element
))
913 (staff-pos (staff-pos element
))
914 (staff (staff element
))
915 (cursor (current-cursor)))
916 (backward-element cursor
)
917 (delete-element cursor
)
918 (insert-element (make-rest staff
919 :staff-pos
(- staff-pos
2)
920 :notehead notehead
:dots dots
921 :rbeams rbeams
:lbeams lbeams
)
923 (forward-element cursor
)))))
925 (define-gsharp-command com-up
()
926 (let ((element (cur-element)))
927 (if (typep element
'cluster
)
928 (let* ((note (cur-note))
929 (new-note (make-note (1+ (pitch note
)) (staff note
)
931 :accidentals
(accidentals note
)
934 (add-note element new-note
)
935 (setf *current-note
* new-note
))
936 (let ((rbeams (rbeams element
))
937 (lbeams (lbeams element
))
938 (dots (dots element
))
939 (notehead (notehead element
))
940 (staff-pos (staff-pos element
))
941 (staff (staff element
))
942 (cursor (current-cursor)))
943 (backward-element cursor
)
944 (delete-element cursor
)
945 (insert-element (make-rest staff
946 :staff-pos
(+ staff-pos
2)
947 :notehead notehead
:dots dots
948 :rbeams rbeams
:lbeams lbeams
)
950 (forward-element cursor
)))))
952 (define-gsharp-command com-octave-down
()
953 (let ((element (cur-element)))
954 (let* ((note (cur-note))
955 (new-note (make-note (- (pitch note
) 7) (staff note
)
957 :accidentals
(accidentals note
)
960 (add-note element new-note
)
961 (setf *current-note
* new-note
))))
963 (define-gsharp-command com-octave-up
()
964 (let ((element (cur-element)))
965 (let* ((note (cur-note))
966 (new-note (make-note (+ (pitch note
) 7) (staff note
)
968 :accidentals
(accidentals note
)
971 (add-note element new-note
)
972 (setf *current-note
* new-note
))))
974 (defmacro define-microtonal-accidentals
(&rest microaccidentals
)
976 (setf (symbol-plist 'microsharpen
)
977 ',(loop for
(a b
) on microaccidentals
978 if b collect a and collect b
979 else collect a and collect a
))
980 (setf (symbol-plist 'microflatten
)
981 ',(loop for
(a b
) on
(reverse microaccidentals
)
982 if b collect a and collect b
983 else collect a and collect a
))
984 (deftype accidental
() '(member ,@microaccidentals
))
985 (defun microsharpen (accidental)
986 (or (getf (symbol-plist 'microsharpen
) accidental
)
987 (error 'type-error
:datum accidental
:expected-type
'microaccidental
)))
988 (defun microflatten (accidental)
989 (or (getf (symbol-plist 'microflatten
) accidental
)
990 (error 'type-error
:datum accidental
:expected-type
'microaccidental
)))))
992 (defmacro define-accidentals
(&rest accidentals
)
994 (deftype accidental
() '(member ,@accidentals
))
995 (defun sharpen (accidental)
996 (do ((a (microsharpen accidental
) (microsharpen a
))
998 ((or (eq a olda
) (member a
',accidentals
)) a
)))
999 (defun flatten (accidental)
1000 (do ((a (microflatten accidental
) (microflatten a
))
1001 (olda accidental a
))
1002 ((or (eq a olda
) (member a
',accidentals
)) a
)))))
1004 (define-microtonal-accidentals :double-flat
:sesquiflat
:flat
:semiflat
1006 :semisharp
:sharp
:sesquisharp
:double-sharp
)
1008 (define-accidentals :double-flat
:flat
:natural
:sharp
:double-sharp
)
1010 (define-gsharp-command com-sharper
()
1011 (let* ((cluster (cur-cluster))
1013 (new-note (make-note (pitch note
) (staff note
)
1015 :accidentals
(sharpen (accidentals note
))
1016 :dots
(dots note
))))
1018 (add-note cluster new-note
)
1019 (setf *current-note
* new-note
)))
1021 (define-gsharp-command com-microsharper
()
1022 ;; FIXME: what are CUR-CLUSTER and CUR-NOTE and how do they relate
1023 ;; to CURRENT-CLUSTER &c?
1024 (let* ((cluster (cur-cluster))
1026 (new-note (make-note (pitch note
) (staff note
)
1028 :accidentals
(microsharpen (accidentals note
))
1029 :dots
(dots note
))))
1031 (add-note cluster new-note
)
1032 (setf *current-note
* new-note
)))
1034 (define-gsharp-command com-flatter
()
1035 (let* ((cluster (cur-cluster))
1037 (new-note (make-note (pitch note
) (staff note
)
1039 :accidentals
(flatten (accidentals note
))
1040 :dots
(dots note
))))
1042 (add-note cluster new-note
)
1043 (setf *current-note
* new-note
)))
1045 (define-gsharp-command com-microflatter
()
1046 (let* ((cluster (cur-cluster))
1048 (new-note (make-note (pitch note
) (staff note
)
1050 :accidentals
(microflatten (accidentals note
))
1051 :dots
(dots note
))))
1053 (add-note cluster new-note
)
1054 (setf *current-note
* new-note
)))
1056 (define-gsharp-command com-remove-current-note
()
1057 (let ((cluster (cur-cluster))
1061 ;; try to set current-note to the highest note lower than the
1062 ;; removed note. If that fails, to the lowest note higher than
1064 (setf *current-note
* (or (cluster-lower-bound cluster note
)
1065 (cluster-upper-bound cluster note
)))
1066 (unless *current-note
*
1067 (com-erase-element 1)))))
1069 (defun insert-keysig ()
1070 (let* ((state (input-state *application-frame
*))
1071 (cursor (current-cursor))
1072 (staff (car (staves (layer cursor
))))
1073 (keysig (if (keysig cursor
)
1075 staff
:alterations
(copy-seq (alterations (keysig cursor
))))
1076 (make-key-signature staff
))))
1077 ;; FIXME: should only invalidate elements temporally after the
1079 (gsharp-measure::invalidate-everything-using-staff
(current-buffer) staff
)
1080 (insert-element keysig cursor
)
1081 (forward-element cursor
)
1084 (define-gsharp-command com-insert-keysig
()
1087 (defun insert-clef (clef)
1088 (let ((cursor (current-cursor)))
1089 (gsharp-measure::invalidate-everything-using-staff
(current-buffer) (staff clef
))
1090 (insert-element clef cursor
)
1091 (forward-element cursor
)
1094 (defun insert-timesig (numerator denominator
)
1095 (let* ((cursor (current-cursor))
1096 (staff (car (staves (layer cursor
))))
1097 (timesig (make-time-signature :staff staff
1099 (list (if denominator
1100 (cons numerator denominator
)
1102 (insert-element timesig cursor
)
1103 (forward-element cursor
)
1106 (define-gsharp-command (com-insert-timesig :name t
)
1107 ((numerator '(integer 1 8) :prompt
"Numerator")
1108 (denominator '(integer 1 8) :prompt
"Denominator"))
1109 (insert-timesig numerator denominator
))
1111 (define-gsharp-command (com-insert-clef :name t
) ()
1112 (let* ((type (accept 'clef-type
:prompt
"Type of clef"))
1113 (line (accept 'integer
:prompt
"Line of clef"))
1114 (clef (make-clef type
:lineno line
)))
1115 (setf (slot-value clef
'gsharp-buffer
::%staff
) (car (staves (layer (current-cursor)))))
1116 (insert-clef clef
)))
1118 (defmethod remove-element :before
((element staffwise-element
) (bar bar
))
1119 (let ((staff (staff element
)))
1120 (setf (staffwise-elements staff
)
1121 (remove element
(staffwise-elements staff
)))
1122 (gsharp-measure::invalidate-everything-using-staff
(current-buffer) staff
)))
1124 ;;; FIXME: this isn't quite right (argh) for the case of two
1125 ;;; temporally coincident zero-duration elements on the same staff in
1126 ;;; different layers: essentially all bets are off.
1127 (defun starts-before-p (thing bar element-or-nil
)
1128 ;; does THING start before the temporal position denoted by BAR and
1130 (assert (or (null element-or-nil
) (eq (bar element-or-nil
) bar
)))
1131 (when (null (bar thing
))
1132 ;; THING is probably the key signature at the start of the piece,
1133 ;; in which case it is definitely before whatever else happens.
1134 (assert (typep thing
'key-signature
))
1135 (return-from starts-before-p t
))
1136 (let ((barno (number bar
)))
1138 ((> (number (bar thing
)) barno
) nil
)
1139 ((< (number (bar thing
)) barno
) t
)
1140 (t (let ((thing-start-time (loop for e in
(elements (bar thing
))
1141 if
(eq e element-or-nil
)
1142 do
(return-from starts-before-p nil
)
1143 until
(eq e thing
) sum
(duration e
)))
1145 ;; this is actually the right answer for
1146 ;; ELEMENT-OR-NIL = NIL, which means "end of bar"
1147 (loop for e in
(elements bar
)
1148 if
(eq e thing
) do
(return-from starts-before-p t
)
1149 until
(eq e element-or-nil
) sum
(duration e
))))
1150 (or (> element-start-time thing-start-time
)
1151 (and (= element-start-time thing-start-time
)
1152 (or (null element-or-nil
)
1153 (> (duration element-or-nil
) 0)))))))))
1155 (defun %keysig
(staff key-signatures bar element-or-nil
)
1156 (or (and key-signatures
1157 (find-if (lambda (x) (starts-before-p x bar element-or-nil
))
1158 key-signatures
:from-end t
))
1161 (defmethod keysig ((cursor gsharp-cursor
))
1162 ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
1163 ;; otherwise the operation for getting the staff [(CAR (STAVES
1164 ;; (LAYER CURSOR)))] need not return the staff that we're interested
1166 (assert (eq cursor
(current-cursor)))
1167 (let* ((staff (car (staves (layer cursor
))))
1168 (key-signatures (key-signatures staff
))
1170 (element-or-nil (cursor-element cursor
)))
1171 (%keysig staff key-signatures bar element-or-nil
)))
1173 (defmethod keysig ((note note
))
1174 (let* ((staff (staff note
))
1175 (key-signatures (key-signatures staff
))
1176 (bar (bar (cluster note
)))
1177 (element-or-nil (cluster note
)))
1178 (%keysig staff key-signatures bar element-or-nil
)))
1180 (defmethod keysig ((cluster cluster
))
1181 (error "Called ~S (a staff-scope operation) on an element with no ~
1182 associated staff: ~S"
1185 (defmethod keysig ((element element
))
1186 (let* ((staff (staff element
))
1187 (key-signatures (key-signatures staff
))
1188 (bar (bar element
)))
1189 (%keysig staff key-signatures bar element
)))
1191 ;; These are copied from the keysig equivalents, which seem to work...
1192 (defun %clef
(staff clefs bar element-or-nil
)
1194 (find-if (lambda (x) (starts-before-p x bar element-or-nil
))
1198 (defmethod clef ((cursor gsharp-cursor
))
1199 (assert (eq cursor
(current-cursor)))
1200 (let* ((staff (car (staves (layer cursor
))))
1201 (clefs (clefs staff
))
1203 (element-or-nil (cursor-element cursor
)))
1204 (%clef staff clefs bar element-or-nil
)))
1206 (defmethod clef ((note note
))
1207 (let* ((staff (staff note
))
1208 (clefs (clefs staff
))
1209 (bar (bar (cluster note
)))
1210 (element-or-nil (cluster note
)))
1211 (%clef staff clefs bar element-or-nil
)))
1213 (defmethod clef ((cluster cluster
))
1214 (error "Called ~S (a staff-scope operation) on an element with no ~
1215 associated staff: ~S"
1218 (defmethod clef ((element element
))
1219 ;; Obviously, only works for elemnts with a staff (i.e. not a
1221 (let* ((staff (staff element
))
1222 (clefs (clefs staff
))
1223 (bar (bar element
)))
1224 (%clef staff clefs bar element
)))
1226 (define-gsharp-command com-tie-note-left
()
1227 (let ((note (cur-note)))
1229 (setf (tie-left note
) t
))))
1231 (define-gsharp-command com-untie-note-left
()
1232 (let ((note (cur-note)))
1234 (setf (tie-left note
) nil
))))
1236 (define-gsharp-command com-tie-note-right
()
1237 (let ((note (cur-note)))
1239 (setf (tie-right note
) t
))))
1241 (define-gsharp-command com-untie-note-right
()
1242 (let ((note (cur-note)))
1244 (setf (tie-right note
) nil
))))
1246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1248 ;;; motion by element
1250 (define-gsharp-command com-forward-element
1251 ((count 'integer
:prompt
"Number of Elements" :default
1))
1252 "Move forward by element."
1254 do
(forward-element (current-cursor))))
1256 (define-gsharp-command com-backward-element
1257 ((count 'integer
:prompt
"Number of Elements" :default
1))
1258 "Move backward by element."
1260 do
(backward-element (current-cursor))))
1262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1264 ;;; motion by measure
1266 (define-gsharp-command com-forward-measure
1267 ((count 'integer
:prompt
"Number of Measures" :default
1))
1268 "Move forward by measure."
1269 (loop repeat count do
(forward-bar (current-cursor))))
1271 (define-gsharp-command com-backward-measure
1272 ((count 'integer
:prompt
"Number of Measures" :default
1))
1273 "Move backward by measure."
1274 (loop repeat count do
(backward-bar (current-cursor))))
1276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1278 ;;; motion by entire score
1280 (define-gsharp-command com-end-of-score
()
1281 (loop until
(last-segment-p (current-cursor))
1282 do
(forward-segment (current-cursor)))
1283 (loop until
(last-bar-p (current-cursor))
1284 do
(forward-bar (current-cursor)))
1285 (loop until
(end-of-bar-p (current-cursor))
1286 do
(forward-element (current-cursor))))
1288 (define-gsharp-command com-beginning-of-score
()
1289 (loop until
(first-segment-p (current-cursor))
1290 do
(backward-segment (current-cursor)))
1291 (loop until
(first-bar-p (current-cursor))
1292 do
(backward-bar (current-cursor)))
1293 (loop until
(beginning-of-bar-p (current-cursor))
1294 do
(backward-element (current-cursor))))
1296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1298 ;;; motion by layout (page or line)
1300 ;;; support routines, needed because we're not cacheing the page
1301 ;;; breaks (other than in the buffer Obseq) nor the linebreaks (at
1303 (defun position-containing-current-bar (sequence)
1304 (let ((bar (bar (current-cursor))))
1305 (position-if (lambda (measure) (member bar
(measure-bars measure
)))
1307 (defun get-page-lines (buffer page-measures
)
1308 (score-pane:with-staff-size
(gsharp-buffer::rastral-size buffer
)
1309 (let* (;; all this untimely ripp'd from DRAW-BUFFER in
1310 ;; drawing.lisp. Needs to be kept in sync, otherwise the
1311 ;; layout for motion will be different from the layout on
1313 (staves (staves buffer
))
1314 (timesig-offset (gsharp-drawing::compute-timesig-offset staves page-measures
))
1315 (method (let ((old-method (buffer-cost-method buffer
)))
1316 (make-measure-cost-method (min-width old-method
)
1317 (spacing-style old-method
)
1318 (- (line-width old-method
) timesig-offset
)
1319 (lines-per-page old-method
))))
1320 (systems-per-page (gsharp-measure::systems-per-page buffer
)))
1321 (gsharp-drawing::layout-page page-measures systems-per-page method
))))
1323 ;;; FIXME: these routines should implement numeric-argument handling
1324 (define-gsharp-command (com-forward-page :name t
)
1326 (let ((cursor (current-cursor)))
1327 (gsharp-measure::new-map-over-obseq-subsequences
1328 (lambda (page-measures)
1329 (let ((position (position-containing-current-bar page-measures
)))
1331 (loop repeat
(- (length page-measures
) position
)
1332 if
(last-bar-p cursor
)
1333 do
(go-to-end-of-bar cursor
) (return-from com-forward-page
)
1334 else do
(forward-bar cursor
)
1335 finally
(return-from com-forward-page
)))))
1337 (define-gsharp-command (com-backward-page :name t
)
1339 (let ((cursor (current-cursor)))
1340 (gsharp-measure::new-map-over-obseq-subsequences
1342 (lambda (page-measures)
1343 (let ((position (position-containing-current-bar page-measures
)))
1345 (loop repeat
(+ position last
)
1346 do
(backward-bar cursor
)
1348 (go-to-beginning-of-bar cursor
)
1349 (return-from com-backward-page
)))))
1350 (setf last
(length page-measures
))))
1353 (define-gsharp-command (com-end-of-line :name t
)
1355 (let ((buffer (current-buffer))
1356 (cursor (current-cursor)))
1357 (gsharp-measure::new-map-over-obseq-subsequences
1358 (lambda (page-measures)
1359 (when (position-containing-current-bar page-measures
)
1360 (let ((lines (get-page-lines buffer page-measures
)))
1361 (dolist (line lines
)
1362 (let ((position (position-containing-current-bar line
)))
1364 (loop repeat
(- (length line
) position
1)
1365 do
(forward-bar cursor
)
1367 (go-to-end-of-bar cursor
)
1368 (return-from com-end-of-line
)))))))))
1370 (define-gsharp-command (com-beginning-of-line :name t
)
1372 (let ((buffer (current-buffer))
1373 (cursor (current-cursor)))
1374 (gsharp-measure::new-map-over-obseq-subsequences
1375 (lambda (page-measures)
1376 (when (position-containing-current-bar page-measures
)
1377 (let ((lines (get-page-lines buffer page-measures
)))
1378 (dolist (line lines
)
1379 (let ((position (position-containing-current-bar line
)))
1381 (loop repeat position
1382 do
(backward-bar cursor
)
1384 (go-to-beginning-of-bar cursor
)
1385 (return-from com-beginning-of-line
)))))))))
1388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1390 ;;; selecting layers based on layout (next/previous staff)
1392 ;;; FIXME: numeric argument handling again
1393 (define-gsharp-command (com-previous-staff :name t
)
1395 (let ((staff (car (staves (layer (current-cursor))))))
1396 (loop for
(prev curr
) on
(staves (current-buffer))
1398 do
(let ((layers (layers (segment (current-cursor)))))
1399 (dolist (layer layers
)
1400 (when (member prev
(staves layer
))
1401 (select-layer (current-cursor) layer
)
1403 ((eq prev
(car (staves layer
))))
1404 (com-rotate-staves))
1405 (return-from com-previous-staff
)))))))
1406 (define-gsharp-command (com-next-staff :name t
)
1408 (let ((staff (car (staves (layer (current-cursor))))))
1409 (loop for
(curr next
) on
(staves (current-buffer))
1411 do
(let ((layers (layers (segment (current-cursor)))))
1412 (dolist (layer layers
)
1413 (when (member next
(staves layer
))
1414 (select-layer (current-cursor) layer
)
1416 ((eq next
(car (staves layer
))))
1417 (com-rotate-staves))
1418 (return-from com-next-staff
)))))))
1420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1424 (defun go-to-beginning-of-bar (cursor)
1425 (loop until
(beginning-of-bar-p cursor
)
1426 do
(backward-element cursor
)))
1428 (defun go-to-end-of-bar (cursor)
1429 (loop until
(end-of-bar-p cursor
)
1430 do
(forward-element cursor
)))
1432 ;;; assume cursor is at the end of the bar
1433 (defun fuse-bar-with-next (cursor)
1434 (go-to-beginning-of-bar cursor
)
1435 (let ((elements '()))
1436 (loop until
(end-of-bar-p cursor
) do
1437 (push (cursor-element cursor
) elements
)
1438 (delete-element cursor
))
1440 (loop for element in
(nreverse elements
) do
1441 (insert-element element cursor
)
1442 (forward-element cursor
))))
1444 (define-gsharp-command com-delete-element
1445 ((count 'integer
:prompt
"Number of Elements" :default
1))
1446 "Delete element forwards."
1447 (let ((cursor (current-cursor)))
1450 ;; this will signal a condition if in last bar and
1451 ;; interrupt the execution of the command
1452 (forward-element cursor
)
1453 (backward-element cursor
)
1454 (if (end-of-bar-p cursor
)
1455 (fuse-bar-with-next cursor
)
1456 (delete-element cursor
))))))
1458 (define-gsharp-command com-erase-element
1459 ((count 'integer
:prompt
"Number of Elements" :default
1))
1460 "Delete element backwards."
1461 (let ((cursor (current-cursor)))
1464 (backward-element cursor
)
1465 (if (end-of-bar-p cursor
)
1466 (fuse-bar-with-next cursor
)
1467 (delete-element cursor
))))))
1469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1471 ;;; Input State Settings
1473 (define-gsharp-command com-istate-more-dots
()
1474 (setf (dots (input-state *application-frame
*))
1475 (min (1+ (dots (input-state *application-frame
*))) 3)))
1477 (define-gsharp-command com-istate-fewer-dots
()
1478 (setf (dots (input-state *application-frame
*))
1479 (max (1- (dots (input-state *application-frame
*))) 0)))
1481 (define-gsharp-command com-istate-more-rbeams
()
1482 (setf (rbeams (input-state *application-frame
*))
1483 (min (1+ (rbeams (input-state *application-frame
*))) 3)))
1485 (define-gsharp-command com-istate-fewer-lbeams
()
1486 (setf (lbeams (input-state *application-frame
*))
1487 (max (1- (lbeams (input-state *application-frame
*))) 0)))
1489 (define-gsharp-command com-istate-more-lbeams
()
1490 (setf (lbeams (input-state *application-frame
*))
1491 (min (1+ (lbeams (input-state *application-frame
*))) 3)))
1493 (define-gsharp-command com-istate-fewer-rbeams
()
1494 (setf (rbeams (input-state *application-frame
*))
1495 (max (1- (rbeams (input-state *application-frame
*))) 0)))
1497 (define-gsharp-command com-istate-rotate-notehead
()
1498 (setf (notehead (input-state *application-frame
*))
1499 (ecase (notehead (input-state *application-frame
*))
1506 (define-gsharp-command com-istate-rotate-notehead-downwards
()
1507 (setf (notehead (input-state *application-frame
*))
1508 (ecase (notehead (input-state *application-frame
*))
1515 (define-gsharp-command com-istate-rotate-stem-direction
()
1516 (setf (stem-direction (input-state *application-frame
*))
1517 (ecase (stem-direction (input-state *application-frame
*))
1522 (define-gsharp-command (com-set-clef :name t
) ()
1523 (let ((staff (accept 'score-pane
:fiveline-staff
:prompt
"Set clef of staff"))
1524 (type (accept 'clef-type
:prompt
"Type of clef"))
1525 (line (accept 'integer
:prompt
"Line of clef")))
1526 (setf (clef staff
) (make-clef type
:lineno line
))))
1528 (define-gsharp-command com-higher
()
1529 (incf (last-note (input-state *application-frame
*)) 7))
1531 (define-gsharp-command com-lower
()
1532 (decf (last-note (input-state *application-frame
*)) 7))
1534 (define-gsharp-command com-insert-barline
()
1535 (let ((cursor (current-cursor))
1537 (loop until
(end-of-bar-p cursor
)
1538 do
(push (cursor-element cursor
) elements
)
1539 do
(delete-element cursor
))
1540 (insert-bar-after (make-instance (class-of (bar cursor
))) cursor
)
1541 (forward-bar cursor
)
1542 (loop for element in elements
1543 do
(insert-element element cursor
))))
1545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1547 ;;; Adding, deleting, and modifying staves
1549 (define-condition no-such-staff
(gsharp-condition) ()
1551 (lambda (condition stream
)
1552 (declare (ignore condition
))
1553 (format stream
"No such staff"))))
1555 (define-presentation-method accept
1556 ((type score-pane
:staff
) stream
(view textual-view
) &key
)
1557 (multiple-value-bind (staff success string
)
1558 (handler-case (complete-input stream
1559 (lambda (so-far mode
)
1560 (complete-from-possibilities
1562 (staves (current-buffer))
1565 :predicate
(constantly t
)
1567 :value-key
#'identity
)))
1568 (simple-parse-error () (error 'no-such-staff
)))
1569 (declare (ignore string
))
1570 (if success staff
(error 'no-such-staff
))))
1572 (define-presentation-method accept
1573 ((type score-pane
:fiveline-staff
) stream
(view textual-view
) &key
)
1574 (multiple-value-bind (staff success string
)
1575 (handler-case (complete-input stream
1576 (lambda (so-far mode
)
1577 (complete-from-possibilities
1579 (staves (current-buffer))
1582 :predicate
(lambda (obj) (typep obj
'fiveline-staff
))
1584 :value-key
#'identity
)))
1585 (simple-parse-error () (error 'no-such-staff
)))
1586 (declare (ignore string
))
1587 (if success staff
(error 'no-such-staff
))))
1589 (defun symbol-name-lowcase (symbol)
1590 (string-downcase (symbol-name symbol
)))
1592 (define-presentation-type staff-type
())
1594 (define-condition no-such-staff-type
(gsharp-condition) ()
1596 (lambda (condition stream
)
1597 (declare (ignore condition
))
1598 (format stream
"No such staff type"))))
1600 (define-presentation-method accept
1601 ((type staff-type
) stream
(view textual-view
) &key
)
1602 (multiple-value-bind (type success string
)
1603 (handler-case (complete-input stream
1604 (lambda (so-far mode
)
1605 (complete-from-possibilities
1607 '(:fiveline
:lyrics
)
1610 :predicate
(constantly t
)
1611 :name-key
#'symbol-name-lowcase
1612 :value-key
#'identity
)))
1613 (simple-completion-error () (error 'no-such-staff-type
)))
1614 (declare (ignore string
))
1615 (if success type
(error 'no-such-staff-type
))))
1617 (define-presentation-type clef-type
())
1619 (define-presentation-method accept
1620 ((type clef-type
) stream
(view textual-view
) &key
)
1621 (multiple-value-bind (type success string
)
1622 (handler-case (complete-input stream
1623 (lambda (so-far mode
)
1624 (complete-from-possibilities
1626 '(:treble
:treble8
:bass
:c
:percussion
)
1629 :predicate
(constantly t
)
1630 :name-key
#'symbol-name-lowcase
1631 :value-key
#'identity
)))
1632 (simple-completion-error () (error 'no-such-staff-type
)))
1633 (declare (ignore string
))
1636 (error "no such staff type"))))
1638 (define-condition staff-name-not-unique
(gsharp-condition) ()
1640 (lambda (condition stream
)
1641 (declare (ignore condition
))
1642 (format stream
"Staff name already exists"))))
1644 (defun acquire-unique-staff-name (prompt)
1645 (let ((name (accept 'string
:prompt prompt
)))
1646 (assert (not (member name
(staves (current-buffer)) :test
#'string
= :key
#'name
))
1647 () `staff-name-not-unique
)
1650 (defun acquire-new-staff ()
1651 (let ((name (acquire-unique-staff-name "Name of new staff")))
1652 (ecase (accept 'staff-type
:prompt
"Type")
1653 (:fiveline
(let* ((clef-name (accept 'clef-type
:prompt
"Clef type of new staff"))
1654 (line (accept 'integer
:prompt
"Line of clef"))
1655 (clef (make-clef clef-name
:lineno line
)))
1656 (make-fiveline-staff :name name
:clef clef
)))
1657 (:lyrics
(make-lyrics-staff :name name
)))))
1659 (define-gsharp-command (com-insert-staff-above :name t
) ()
1660 (add-staff-before-staff (accept 'score-pane
:staff
:prompt
"Insert staff above staff")
1664 (define-gsharp-command (com-insert-staff-below :name t
) ()
1665 (add-staff-after-staff (accept 'score-pane
:staff
:prompt
"Insert staff below staff")
1669 (define-gsharp-command (com-delete-staff :name t
) ()
1670 (remove-staff-from-buffer (accept 'score-pane
:staff
:prompt
"Staff")
1673 (define-gsharp-command (com-rename-staff :name t
) ()
1674 (let* ((staff (accept 'score-pane
:staff
:prompt
"Rename staff"))
1675 (name (acquire-unique-staff-name "New name of staff"))
1676 (buffer (current-buffer)))
1677 (rename-staff name staff buffer
)))
1679 (define-gsharp-command (com-add-staff-to-layer :name t
) ()
1680 (let ((staff (accept 'score-pane
:staff
:prompt
"Add staff to layer"))
1681 (layer (layer (current-cursor))))
1682 (add-staff-to-layer staff layer
)))
1684 ;;; FIXME restrict to staves that are actually in the layer.
1685 (define-gsharp-command (com-delete-staff-from-layer :name t
) ()
1686 (let ((staff (accept 'score-pane
:staff
:prompt
"Delete staff from layer"))
1687 (layer (layer (current-cursor))))
1688 (remove-staff-from-layer staff layer
)))
1690 (define-gsharp-command com-more-sharps
()
1691 (more-sharps (keysig (current-cursor))))
1693 (define-gsharp-command com-more-flats
()
1694 (more-flats (keysig (current-cursor))))
1696 (define-presentation-to-command-translator jump-to-here
1697 (element gsharp
::com-jump-to-here gsharp
1699 :documentation
"Move cursor here")
1700 (presentation) (list (presentation-object presentation
)))
1702 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1706 (defun insert-lyrics-element ()
1707 (let* ((state (input-state *application-frame
*))
1708 (cursor (current-cursor))
1709 (element (make-lyrics-element (car (staves (layer (current-cursor))))
1710 :rbeams
(if (eq (notehead state
) :filled
) (rbeams state
) 0)
1711 :lbeams
(if (eq (notehead state
) :filled
) (lbeams state
) 0)
1713 :notehead
(notehead state
))))
1714 (insert-element element cursor
)
1715 (forward-element cursor
)
1718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1722 (defmethod frame-make-buffer-from-stream ((frame gsharp
) stream
)
1723 (read-buffer-from-stream stream
))
1725 (defmethod frame-make-new-buffer ((frame gsharp
) &key
&allow-other-keys
)
1726 (make-instance 'buffer
))
1729 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1731 ;;; Buffer / View handling
1733 ;;; FIXME: these utility functions should live elsewhere.
1734 (defun current-view ()
1735 (view (current-window)))
1737 (defun not-current-view ()
1738 (find (current-view) (views *application-frame
*) :test
(complement #'eq
)))
1740 (defun not-current-view-or-first ()
1741 (or (not-current-view) (car (views *application-frame
*))))
1743 (defun next-or-new-buffer-view ()
1744 (or (not-current-view)
1745 (progn (com-new-buffer)
1746 (car (views *application-frame
*)))))
1748 (define-gsharp-command (com-switch-to-view :name t
)
1749 ((view 'orchestra-view
:default
(not-current-view-or-first)))
1750 (setf (view (current-window)) view
))
1752 (define-gsharp-command (com-kill-view :name t
)
1753 ((view 'orchestra-view
:default
(current-view)))
1754 (let ((views (views *application-frame
*)))
1755 (setf (views *application-frame
*) (remove view views
))
1756 (when (eq view
(current-view))
1757 (let ((next-view (next-or-new-buffer-view)))
1758 (setf (view (current-window)) next-view
)))))
1760 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1764 (defun print-buffer-filename ()
1765 (let* ((buffer (current-buffer))
1766 (filepath (filepath buffer
))
1767 (name (name buffer
))
1768 (defaults (or filepath
(merge-pathnames (make-pathname :name name
)
1769 (user-homedir-pathname)))))
1770 (merge-pathnames (make-pathname :type
"ps") defaults
)))
1772 (defparameter *scale
* 0.8)
1773 (defparameter *top-margin
* 100)
1775 (define-gsharp-command (com-print-buffer-to-file :name t
)
1776 ((filepath 'pathname
1777 :prompt
"Print To: " :prompt-mode
:raw
1778 :default
(print-buffer-filename) :default-type
'pathname
1780 (with-open-file (ps filepath
:direction
:output
:if-exists
:supersede
)
1781 (let* ((type (pathname-type filepath
))
1782 (epsp (string-equal type
"EPS")))
1783 (with-output-to-postscript-stream (s ps
:device-type
(when epsp
:eps
))
1784 (setf (stream-default-view s
)
1785 ;; FIXME: should probably get the class of the view from
1786 ;; the current buffer or window or something.
1787 (make-instance 'orchestra-view
:light-glyphs-ink
+black
+
1788 :buffer
(current-buffer)
1789 :cursor
(current-cursor)))
1790 (setf (medium-transformation s
)
1791 ;; FIXME: not a very flexible or intelligent scaling system
1792 (compose-scaling-with-transformation
1793 (medium-transformation s
) *scale
* *scale
*))
1794 (print-buffer s
(current-buffer) (current-cursor)
1795 (left-margin (current-buffer)) *top-margin
*)))))
1797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1799 ;; File dialogue box
1802 (define-gsharp-command (com-load-score-file :name
"Load file" :menu t
)
1804 (let ((file (gui-get-pathname :extensions
'("gsh" "mxml" "xml"))))
1805 (when (pathnamep file
)
1806 (com-find-file file
))))
1808 (define-gsharp-command (com-save-score-file-as :name
"Save file as" :menu t
)
1810 (com-write-buffer (gui-get-pathname :extensions
'("gsh" "mxml" "xml"))))
1812 (define-gsharp-command (com-zoom-in :name t
:menu t
)
1814 (unless (<= (gsharp-buffer::zoom-level
(buffer (current-cursor))) 64)
1815 (incf (gsharp-buffer::zoom-level
(buffer (current-cursor))) 1/4)))
1816 (define-gsharp-command (com-zoom-out :name t
:menu t
)
1818 (unless (<= (gsharp-buffer::zoom-level
(buffer (current-cursor))) 1/4)
1819 (decf (gsharp-buffer::zoom-level
(buffer (current-cursor))) 1/4)))
1821 (define-command (com-undo :name t
:command-table gsharp
) ()
1822 (handler-case (drei::undo
(drei::undo-tree
(current-buffer)))
1823 (drei-undo:no-more-undo
() (beep) (display-message "No more undo"))))
1824 (define-command (com-redo :name t
:command-table gsharp
) ()
1825 (handler-case (drei::redo
(drei::undo-tree
(current-buffer)))
1826 (drei-undo:no-more-undo
() (beep) (display-message "No more redo"))))