[gsharp-cvs] CVS gsharp
crhodes
crhodes at common-lisp.net
Mon Jun 19 17:40:35 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv11337
Modified Files:
buffer.lisp cursor.lisp drawing.lisp gui.lisp measure.lisp
modes.lisp
Log Message:
Merge keysigN patch, with all its attendant horribleness.
--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/03/02 09:29:44 1.37
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/06/19 17:40:34 1.38
@@ -115,7 +115,8 @@
((print-character :allocation :class :initform #\=)
(clef :accessor clef :initarg :clef :initform (make-clef :treble))
(%keysig :accessor keysig :initarg :keysig
- :initform (make-array 7 :initial-element :natural))))
+ :initform (make-array 7 :initial-element :natural))
+ (key-signatures :accessor key-signatures :initform nil)))
(defmethod initialize-instance :after ((obj fiveline-staff) &rest args)
(declare (ignore args))
--- /project/gsharp/cvsroot/gsharp/cursor.lisp 2004/07/23 16:51:16 1.2
+++ /project/gsharp/cvsroot/gsharp/cursor.lisp 2006/06/19 17:40:34 1.3
@@ -166,6 +166,12 @@
(when (> (pos cursor) position)
(incf (pos cursor)))))
+(defmethod add-element :after
+ ((keysig gsharp-buffer::key-signature) bar position)
+ (setf (gsharp-buffer::key-signatures (staff keysig))
+ ;; FIXME: unordered
+ (cons keysig (gsharp-buffer::key-signatures (staff keysig)))))
+
(defmethod remove-element :before ((element element))
(let ((elemno (number element)))
(loop for cursor in (cursors (bar element)) do
--- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/14 05:03:14 1.70
+++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/19 17:40:34 1.71
@@ -150,6 +150,31 @@
(score-pane:staff-step 5)
(score-pane:staff-step 2)))
+(defmethod right-bulge ((keysig gsharp-buffer::key-signature) pane)
+ ;; FIXME: shares much code with DRAW-ELEMENT (KEY-SIGNATURE).
+ (let ((old-keysig (keysig keysig)))
+ (let ((bulge 0))
+ (loop with advance = 0
+ for pitch in '(6 2 5 1 4 0 3)
+ when (and (eq (aref (alterations old-keysig) pitch) :flat)
+ (not (eq (aref (alterations keysig) pitch)
+ :flat)))
+ do (incf advance (score-pane:staff-step 2))
+ finally (incf bulge (if (= advance 0) 0 (+ advance (score-pane:staff-step 2)))))
+ (loop with advance = 0
+ for pitch in '(3 0 4 1 5 2 6)
+ when (and (eq (aref (alterations old-keysig) pitch) :sharp)
+ (not (eq (aref (alterations keysig) pitch) :sharp)))
+ do (incf advance (score-pane:staff-step 2))
+ finally (incf bulge (if (= advance 0) 0 (+ advance (score-pane:staff-step 2)))))
+ (loop for pitch in '(6 2 5 1 4 0 3)
+ while (eq (aref (alterations keysig) pitch) :flat)
+ do (incf bulge (score-pane:staff-step 2)))
+ (loop for pitch in '(3 0 4 1 5 2 6)
+ while (eq (aref (alterations keysig) pitch) :sharp)
+ do (incf bulge (score-pane:staff-step 2.5)))
+ bulge)))
+
;;; As it turns out, the spacing algorithm would be very complicated
;;; if we were to take into account exactly how elements with
;;; arbitrarily many timelines between them might influence the
@@ -496,6 +521,9 @@
(incf yy (+ 20 (* 70 (length staves))))))))
buffer)))))
+(define-added-mixin xelement () element
+ ((final-absolute-xoffset :accessor final-absolute-element-xoffset)))
+
(define-added-mixin velement () melody-element
(;; the position, in staff steps, of the end of the stem
;; that is not attached to a note, independent of the
@@ -509,11 +537,10 @@
(top-note-staff-yoffset :accessor top-note-staff-yoffset)
;; the yoffset of the staff that contains the bottom note of
;; the element
- (bot-note-staff-yoffset :accessor bot-note-staff-yoffset)
- (final-absolute-xoffset :accessor final-absolute-element-xoffset)))
+ (bot-note-staff-yoffset :accessor bot-note-staff-yoffset)))
(define-added-mixin welement () lyrics-element
- ((final-absolute-xoffset :accessor final-absolute-element-xoffset)))
+ ())
;;; Compute and store several important pieces of information
;;; about an element:
@@ -600,6 +627,11 @@
notes))
(defun draw-beam-group (pane elements)
+ (let ((e (car elements)))
+ (when (typep e 'gsharp-buffer::key-signature)
+ (assert (null (cdr elements)))
+ (return-from draw-beam-group
+ (draw-element pane e (final-absolute-element-xoffset e)))))
(mapc #'compute-top-bot-yoffset elements)
(if (null (cdr elements))
(let ((element (car elements)))
@@ -885,3 +917,46 @@
(with-text-family (pane :serif)
(draw-text* pane (map 'string 'code-char (text element))
x 0 :align-x :center)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Key signature element
+
+(defmethod draw-element (pane (keysig key-signature) &optional flags)
+ (let ((staff (staff keysig))
+ (old-keysig (keysig keysig))
+ (x (final-absolute-element-xoffset keysig)))
+ (score-pane:with-vertical-score-position (pane (staff-yoffset staff))
+ (let ((yoffset (b-position (clef staff))))
+ (loop with advance = 0
+ for pitch in '(6 2 5 1 4 0 3)
+ for line in '(0 3 -1 2 -2 1 -3)
+ when (and (eq (aref (alterations old-keysig) pitch) :flat)
+ (not (eq (aref (alterations keysig) pitch)
+ :flat)))
+ do (score-pane:draw-accidental
+ pane :natural (+ x advance) (+ line yoffset))
+ and do (incf advance (score-pane:staff-step 2))
+ finally (incf x (if (= advance 0) 0 (+ advance (score-pane:staff-step 2))))))
+ (let ((yoffset (f-position (clef staff))))
+ (loop with advance = 0
+ for pitch in '(3 0 4 1 5 2 6)
+ for line in '(0 -3 1 -2 -5 -1 -4)
+ when (and (eq (aref (alterations old-keysig) pitch) :sharp)
+ (not (eq (aref (alterations keysig) pitch) :sharp)))
+ do (score-pane:draw-accidental pane :natural (+ x advance) (+ line yoffset))
+ and do (incf advance (score-pane:staff-step 2))
+ finally (incf x (if (= advance 0) 0 (+ advance (score-pane:staff-step 2))))))
+
+ (let ((yoffset (b-position (clef staff))))
+ (loop for pitch in '(6 2 5 1 4 0 3)
+ for line in '(0 3 -1 2 -2 1 -3)
+ for x from x by (score-pane:staff-step 2)
+ while (eq (aref (alterations keysig) pitch) :flat)
+ do (score-pane:draw-accidental pane :flat x (+ line yoffset))))
+ (let ((yoffset (f-position (clef staff))))
+ (loop for pitch in '(3 0 4 1 5 2 6)
+ for line in '(0 -3 1 -2 -5 -1 -4)
+ for x from x by (score-pane:staff-step 2.5)
+ while (eq (aref (alterations keysig) pitch) :sharp)
+ do (score-pane:draw-accidental pane :sharp x (+ line yoffset)))))))
--- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/17 19:15:02 1.68
+++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/19 17:40:34 1.69
@@ -591,7 +591,7 @@
(staff (car (staves (layer (slice (bar cluster))))))
(note (make-note pitch staff
:head (notehead state)
- :accidentals (aref (alterations (keysig staff)) (mod pitch 7))
+ :accidentals (aref (alterations (keysig (current-cursor))) (mod pitch 7))
:dots (dots state))))
(setf *current-cluster* cluster
*current-note* note)
@@ -858,6 +858,92 @@
(unless *current-note*
(com-erase-element 1)))))
+(defun insert-keysig ()
+ (let* ((state (input-state *application-frame*))
+ (cursor (current-cursor))
+ (staff (car (staves (layer cursor))))
+ (keysig (if (keysig cursor)
+ (gsharp-buffer::make-key-signature
+ staff :alterations (copy-seq (alterations (keysig cursor))))
+ (gsharp-buffer::make-key-signature staff))))
+ ;; FIXME: should only invalidate elements temporally after the
+ ;; cursor.
+ (gsharp-measure::invalidate-everything-using-staff (current-buffer *application-frame*) staff)
+ (insert-element keysig cursor)
+ (forward-element cursor)
+ keysig))
+
+(define-gsharp-command com-insert-keysig ()
+ (insert-keysig))
+
+(defmethod remove-element :before ((keysig gsharp-buffer::key-signature))
+ (let ((staff (staff keysig)))
+ (setf (gsharp-buffer::key-signatures staff)
+ (remove keysig (gsharp-buffer::key-signatures staff)))
+ (gsharp-measure::invalidate-everything-using-staff (current-buffer *application-frame*) staff)))
+
+;;; FIXME: this function does not work for finding a key signature in
+;;; a different layer (but on the same staff). This will bite in
+;;; polyphonic music with key signature changes (e.g. Piano music)
+(defun %keysig (staff key-signatures bar bars element-or-nil)
+ ;; common case
+ (when (null key-signatures)
+ (return-from %keysig (keysig staff)))
+ ;; earlier in the same bar?
+ (let ((k nil))
+ (dolist (e (elements bar) (when k (return-from %keysig k)))
+ (when (eq e element-or-nil)
+ (if k
+ (return-from %keysig k)
+ (return nil)))
+ (when (and (typep e 'gsharp-buffer::key-signature)
+ (eq (staff e) staff))
+ (setq k e))))
+ ;; must be an earlier bar.
+ (let ((bars (nreverse (loop for b in bars until (eq b bar) collect b))))
+ (dolist (b bars (keysig staff))
+ (when (find b key-signatures :key #'bar)
+ (dolist (e (reverse (elements b)) (error "inconsistency"))
+ (when (and (typep e 'key-signature)
+ (eq (staff e) staff))
+ (return-from %keysig e)))))))
+
+(defmethod keysig ((cursor gsharp-cursor))
+ ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
+ ;; otherwise the operation for getting the staff [(CAR (STAVES
+ ;; (LAYER CURSOR)))] need not return the staff that we're interested
+ ;; in.
+ (assert (eq cursor (current-cursor)))
+ (let* ((staff (car (staves (layer cursor))))
+ (key-signatures (gsharp-buffer::key-signatures staff))
+ (bar (bar cursor))
+ (slice (slice bar))
+ (bars (bars slice))
+ (element-or-nil (cursor-element cursor)))
+ (%keysig staff key-signatures bar bars element-or-nil)))
+
+(defmethod keysig ((note note))
+ (let* ((staff (staff note))
+ (key-signatures (gsharp-buffer::key-signatures staff))
+ (bar (bar (cluster note)))
+ (slice (slice bar))
+ (bars (bars slice))
+ (element-or-nil (cluster note)))
+ (%keysig staff key-signatures bar bars element-or-nil)))
+
+(defmethod keysig ((cluster cluster))
+ (error "Called ~S (a staff-scope operation) on an element with no ~
+ associated staff: ~S"
+ 'keysig cluster))
+
+(defmethod keysig ((element element))
+ (let* ((staff (staff element))
+ (key-signatures (gsharp-buffer::key-signatures staff))
+ (bar (bar element))
+ (slice (slice bar))
+ (bars (bars slice)))
+ (%keysig staff key-signatures bar bars element)))
+
(define-gsharp-command com-tie-note-left ()
(let ((note (cur-note)))
(when note
@@ -1188,10 +1274,10 @@
(remove-staff-from-layer staff layer)))
(define-gsharp-command com-more-sharps ()
- (more-sharps (keysig (car (staves (layer (current-cursor)))))))
+ (more-sharps (keysig (current-cursor))))
(define-gsharp-command com-more-flats ()
- (more-flats (keysig (car (staves (layer (current-cursor)))))))
+ (more-flats (keysig (current-cursor))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/13 01:18:10 1.30
+++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/19 17:40:34 1.31
@@ -224,7 +224,7 @@
(loop for note in group do
(setf (final-accidental note)
(if (eq (accidentals note)
- (aref (alterations (keysig (staff note))) (mod (pitch note) 7)))
+ (aref (alterations (keysig note)) (mod (pitch note) 7)))
nil
(accidentals note)))))
--- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/14 19:20:41 1.18
+++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/19 17:40:34 1.19
@@ -44,6 +44,8 @@
(set-key 'com-insert-note-g 'melody-table '(#\g))
(set-key 'com-insert-rest 'melody-table '((#\,)))
(set-key 'com-insert-empty-cluster 'melody-table '((#\Space)))
+(set-key 'com-insert-keysig 'melody-table '(#\K))
+
(set-key 'com-more-sharps 'melody-table '((#\# :meta)))
(set-key 'com-more-sharps 'melody-table '((#\# :meta :shift)))
(set-key 'com-more-flats 'melody-table '((#\@ :meta :shift)))
More information about the Gsharp-cvs
mailing list