[gsharp-cvs] CVS gsharp
crhodes
crhodes at common-lisp.net
Thu Jul 5 21:13:03 UTC 2007
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv8543
Modified Files:
buffer.lisp cursor.lisp drawing.lisp gui.lisp measure.lisp
Log Message:
Alright, let's try this: more correct key signatures, I hope.
The major change to the protocol is that REMOVE-ELEMENT takes as a
required argument the bar as well as the element; this allows more
symmetric methods to be written for the various stealth mixin bits of
functionality.
Key signatures are elements, as before, within a layer. However, they
are also kept on a list sorted by sequence in a slot of the staff, and
KEYSIG is responsible for checking the relevant staff for other key
signature elements. Editing actions or commands are also responsible
for maintaining this list sorted in the right order. New almost-correct
function for testing the temporal-and-logical ordering of elements.
Drawing code now computes the correct key signature for the each staff;
linebreaking is done with a conservative assumption for how wide the key
signature will be.
Please test.
--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/28 13:56:53 1.48
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/07/05 21:13:03 1.49
@@ -725,7 +725,7 @@
(defgeneric add-element (element bar position))
;;; Delete an element from the bar to which it belongs.
-(defgeneric remove-element (element))
+(defgeneric remove-element (element bar))
(defclass bar (gsharp-object)
((slice :initform nil :initarg :slice :accessor slice)
@@ -768,20 +768,44 @@
(with-slots (elements) b
(setf elements (ninsert-element element elements position)))
(setf bar b)))
-
+
+(defun maybe-update-key-signatures (bar)
+ (let* ((layer (layer (slice bar)))
+ (staves (staves layer)))
+ (dolist (staff staves)
+ (let ((key-signatures (key-signatures staff)))
+ (when (and key-signatures
+ (find (gsharp-numbering:number bar) key-signatures
+ :key (lambda (x) (gsharp-numbering:number (bar x)))))
+ ;; we actually only need to invalidate everything in the
+ ;; current bar using the staff, not the entire staff, but...
+ (gsharp-measure::invalidate-everything-using-staff (buffer staff) staff)
+ ;; there might be more than one key signature in the bar,
+ ;; and they might have changed their relative order as a
+ ;; result of the edit.
+ (setf (key-signatures staff)
+ (sort (key-signatures staff)
+ (lambda (x y) (gsharp::starts-before-p x (bar y) y)))))))))
+
+(defmethod add-element :after ((element element) (bar bar) position)
+ (maybe-update-key-signatures bar))
+
(define-condition element-not-in-bar (gsharp-condition) ()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "Attempt to delete an element not in a bar"))))
-(defmethod remove-element ((element element))
+(defmethod remove-element ((element element) (b bar))
(with-slots (bar) element
- (assert bar () 'element-not-in-bar)
+ (assert (and bar (eq b bar)) () 'element-not-in-bar)
(with-slots (elements) bar
(setf elements (delete element elements :test #'eq)))
(setf bar nil)))
+(defmethod remove-element :before ((element element) (bar bar))
+ (maybe-update-key-signatures bar))
+
(defclass melody-bar (bar)
((print-character :allocation :class :initform #\|)))
--- /project/gsharp/cvsroot/gsharp/cursor.lisp 2006/06/19 17:40:34 1.3
+++ /project/gsharp/cvsroot/gsharp/cursor.lisp 2007/07/05 21:13:03 1.4
@@ -161,20 +161,21 @@
(defcclass cbar bar
())
-(defmethod add-element :after ((element element) (bar bar) position)
+(defmethod add-element :after ((element element) (bar cbar) position)
(loop for cursor in (cursors bar) do
(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)))))
+ (let ((staff (staff keysig)))
+ (setf (gsharp-buffer::key-signatures staff)
+ (merge 'list (list keysig) (gsharp-buffer::key-signatures staff)
+ (lambda (x y) (gsharp::starts-before-p x (bar y) y))))))
-(defmethod remove-element :before ((element element))
+(defmethod remove-element :before ((element element) (bar cbar))
(let ((elemno (number element)))
- (loop for cursor in (cursors (bar element)) do
+ (loop for cursor in (cursors bar) do
(when (> (pos cursor) elemno)
(decf (pos cursor))))))
@@ -195,7 +196,8 @@
(defmethod delete-element ((cursor gsharp-cursor))
(assert (not (end-of-bar-p cursor)) () 'end-of-bar)
- (remove-element (elementno (bar cursor) (pos cursor))))
+ (let ((bar (bar cursor)))
+ (remove-element (elementno bar (pos cursor)) bar)))
(defmethod cursor-bar ((cursor gsharp-cursor))
(bar cursor))
--- /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/06/10 08:10:03 1.76
+++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/07/05 21:13:03 1.77
@@ -32,7 +32,15 @@
(object (type score-pane:lyrics-staff) stream (view textual-view) &key)
(format stream "[lyrics staff ~a]" (name object)))
-(defmethod draw-staff-and-clef (pane (staff fiveline-staff) x1 x2)
+(defun key-signature-for-staff (staff measures)
+ (let ((key-signatures (gsharp-buffer::key-signatures staff))
+ (barno (gsharp-numbering:number (car (measure-bars (car measures))))))
+ (or (and key-signatures
+ (find barno key-signatures :from-end t :test #'>
+ :key (lambda (x) (gsharp-numbering:number (bar x)))))
+ (keysig staff))))
+
+(defmethod draw-staff-and-clef (pane (staff fiveline-staff) measures x1 x2)
(when (clef staff)
(present (clef staff)
`((score-pane:clef)
@@ -40,24 +48,25 @@
:x ,(+ x1 10)
:staff-step ,(lineno (clef staff)))
:stream pane)
- (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 (+ x1 10 (score-pane:staff-step 8)) by (score-pane:staff-step 2)
- while (eq (aref (alterations (keysig staff)) 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 (+ x1 10 (score-pane:staff-step 8)) by (score-pane:staff-step 2.5)
- while (eq (aref (alterations (keysig staff)) pitch) :sharp)
- do (score-pane:draw-accidental pane :sharp x (+ line yoffset)))))
- (present staff
- `((score-pane:fiveline-staff)
- :x1 ,x1 :x2 ,x2)
- :stream pane))
+ (let ((keysig (key-signature-for-staff staff measures)))
+ (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 (+ x1 10 (score-pane:staff-step 8)) 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 (+ x1 10 (score-pane:staff-step 8)) by (score-pane:staff-step 2.5)
+ while (eq (aref (alterations keysig) pitch) :sharp)
+ do (score-pane:draw-accidental pane :sharp x (+ line yoffset)))))
+ (present staff
+ `((score-pane:fiveline-staff)
+ :x1 ,x1 :x2 ,x2)
+ :stream pane)))
-(defmethod draw-staff-and-clef (pane (staff lyrics-staff) x1 x2)
+(defmethod draw-staff-and-clef (pane (staff lyrics-staff) measures x1 x2)
(present staff
`((score-pane:lyrics-staff)
:x1 ,x1 :x2 ,x2)
@@ -389,14 +398,14 @@
(loop for measure in measures do
(draw-measure pane measure))))
-(defun draw-staves (pane staves x y right-edge)
+(defun draw-staves (pane staves measures x y right-edge)
(loop for staff in staves do
(score-pane:with-vertical-score-position
(pane (+ y (staff-yoffset staff)))
(if (member staff (staves (layer (slice (bar *cursor*)))))
- (draw-staff-and-clef pane staff x right-edge)
+ (draw-staff-and-clef pane staff measures x right-edge)
(score-pane:with-light-glyphs pane
- (draw-staff-and-clef pane staff x right-edge))))))
+ (draw-staff-and-clef pane staff measures x right-edge))))))
(defun compute-and-draw-system (pane buffer staves measures method x y timesig-offset right-edge)
@@ -416,20 +425,20 @@
(score-pane:draw-bar-line pane x
(+ y (- (score-pane:staff-step 8)))
(+ y (staff-yoffset (car (last staves)))))
- (draw-staves pane staves x y right-edge))
+ (draw-staves pane staves measures x y right-edge))
-(defun compute-timesig-offset (staves)
+(defun compute-timesig-offset (staves measures)
(max (* (score-pane:staff-step 2)
(loop for staff in staves
maximize
(if (typep staff 'fiveline-staff)
- (count :flat (alterations (keysig staff)))
+ (count :flat (alterations (key-signature-for-staff staff measures)))
0)))
(* (score-pane:staff-step 2.5)
(loop for staff in staves
maximize
(if (typep staff 'fiveline-staff)
- (count :sharp (alterations (keysig staff)))
+ (count :sharp (alterations (key-signature-for-staff staff measures)))
0)))))
(defun split (sequence n method)
@@ -504,11 +513,16 @@
(defmethod draw-buffer (pane (buffer buffer) *cursor* x y)
(score-pane:with-staff-size 6
(let* ((staves (staves buffer))
- (timesig-offset (compute-timesig-offset staves))
+ ;; FIXME: is this the right fudge factor? We have a
+ ;; circular dependency, as we can't know the optimal
+ ;; splitting without knowing the staff key signatures, and
+ ;; we can't know the key signatures until after the
+ ;; splitting.
+ (max-timesig-offset (* (score-pane:staff-step 2.5) 7))
(method (let ((old-method (buffer-cost-method buffer)))
(make-measure-cost-method (min-width old-method)
(spacing-style old-method)
- (- (line-width old-method) timesig-offset)
+ (- (line-width old-method) max-timesig-offset)
(lines-per-page old-method))))
(right-edge (right-edge buffer))
(systems-per-page (max 1 (floor 12 (length staves)))))
@@ -523,9 +537,15 @@
:test #'eq))
all-measures)
(let ((measure-seqs (layout-page all-measures systems-per-page method)))
- (loop for measures in measure-seqs do
+ (loop for measures in measure-seqs
+ for timesig-offset = (compute-timesig-offset staves measures)
+ for new-method = (make-measure-cost-method (min-width method)
+ (spacing-style method)
+ (- (+ (line-width method) max-timesig-offset) timesig-offset)
+ (lines-per-page method))
+ do
(compute-and-draw-system pane buffer staves measures
- method x yy timesig-offset right-edge)
+ new-method x yy timesig-offset right-edge)
(incf yy (+ 20 (* 70 (length staves))))))))
buffer)))))
--- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/28 13:56:53 1.79
+++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/07/05 21:13:03 1.80
@@ -597,12 +597,12 @@
(defparameter *current-cluster* nil)
(defparameter *current-note* nil)
-(defun insert-note (pitch cluster)
+(defun insert-note (pitch cluster accidentals)
(let* ((state (input-state *application-frame*))
(staff (car (staves (layer (slice (bar cluster))))))
(note (make-note pitch staff
:head (notehead state)
- :accidentals (aref (alterations (keysig (current-cursor))) (mod pitch 7))
+ :accidentals accidentals
:dots (dots state))))
(setf *current-cluster* cluster
*current-note* note)
@@ -618,8 +618,9 @@
(t diff)))))
(defun insert-numbered-note-new-cluster (pitch)
- (let ((new-pitch (compute-and-adjust-note pitch)))
- (insert-note new-pitch (insert-cluster))))
+ (let* ((new-pitch (compute-and-adjust-note pitch))
+ (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
+ (insert-note new-pitch (insert-cluster) accidentals)))
(define-gsharp-command (com-insert-note-a :keystroke #\a) ()
(insert-numbered-note-new-cluster 5))
@@ -686,8 +687,9 @@
(setf *current-note* (nth (1- pos) notes)))))
(defun insert-numbered-note-current-cluster (pitch)
- (let ((new-pitch (compute-and-adjust-note pitch)))
- (insert-note new-pitch (cur-cluster))))
+ (let* ((new-pitch (compute-and-adjust-note pitch))
+ (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
+ (insert-note new-pitch (cur-cluster) accidentals)))
(define-gsharp-command com-add-note-a ()
(insert-numbered-note-current-cluster 5))
@@ -710,36 +712,30 @@
(define-gsharp-command com-add-note-g ()
(insert-numbered-note-current-cluster 4))
-(define-gsharp-command com-more-dots ()
- (setf (dots (cur-element))
- (min (1+ (dots (cur-element))) 3)))
-
-(define-gsharp-command com-fewer-dots ()
- (setf (dots (cur-element))
- (max (1- (dots (cur-element))) 0)))
-
-(define-gsharp-command com-more-rbeams ()
- (setf (rbeams (cur-element))
- (min (1+ (rbeams (cur-element))) 3)))
-
-(define-gsharp-command com-fewer-lbeams ()
- (setf (lbeams (cur-element))
- (max (1- (lbeams (cur-element))) 0)))
-
-(define-gsharp-command com-more-lbeams ()
- (setf (lbeams (cur-element))
- (min (1+ (lbeams (cur-element))) 3)))
-
-(define-gsharp-command com-fewer-rbeams ()
- (setf (rbeams (cur-element))
- (max (1- (rbeams (cur-element))) 0)))
-
-(define-gsharp-command com-rotate-notehead ()
- (setf (notehead (cur-element))
- (ecase (notehead (cur-element))
- (:whole :half)
- (:half :filled)
- (:filled :whole))))
+(macrolet ((define-duration-altering-command (name &body body)
+ `(define-gsharp-command ,name ()
+ (let ((element (cur-element)))
+ , at body
+ (gsharp-buffer::maybe-update-key-signatures
+ (bar (current-cursor)))))))
+ (define-duration-altering-command com-more-dots ()
+ (setf (dots element) (min (1+ (dots element)) 3)))
+ (define-duration-altering-command com-fewer-dots ()
+ (setf (dots element) (max (1- (dots element)) 0)))
+ (define-duration-altering-command com-more-rbeams ()
+ (setf (rbeams element) (min (1+ (rbeams element)) 3)))
+ (define-duration-altering-command com-fewer-lbeams ()
+ (setf (lbeams element) (max (1- (lbeams element)) 0)))
+ (define-duration-altering-command com-more-lbeams ()
+ (setf (lbeams element) (min (1+ (lbeams element)) 3)))
+ (define-duration-altering-command com-fewer-rbeams ()
+ (setf (rbeams element) (max (1- (rbeams element)) 0)))
+ (define-duration-altering-command com-rotate-notehead ()
+ (setf (notehead element)
+ (ecase (notehead element)
+ (:whole :half)
+ (:half :filled)
+ (:filled :whole)))))
(define-gsharp-command com-rotate-stem-direction ()
(setf (stem-direction (cur-cluster))
@@ -937,37 +933,43 @@
(define-gsharp-command com-insert-keysig ()
(insert-keysig))
-(defmethod remove-element :before ((keysig gsharp-buffer::key-signature))
+(defmethod remove-element :before ((keysig gsharp-buffer::key-signature) (bar bar))
(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) 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)))))))
+;;; FIXME: this isn't quite right (argh) for the case of two
+;;; temporally coincident zero-duration elements on the same staff in
+;;; different layers: essentially all bets are off.
+(defun starts-before-p (thing bar element-or-nil)
+ ;; does THING start before the temporal position denoted by BAR and
+ ;; ELEMENT-OR-NIL?
+ (assert (or (null element-or-nil) (eq (bar element-or-nil) bar)))
+ (let ((barno (number bar)))
+ (cond
+ ((> (number (bar thing)) barno) nil)
+ ((< (number (bar thing)) barno) t)
+ (t (let ((thing-start-time (loop for e in (elements (bar thing))
+ if (eq e element-or-nil)
+ do (return-from starts-before-p nil)
+ until (eq e thing) sum (duration e)))
+ (element-start-time
+ ;; this is actually the right answer for
+ ;; ELEMENT-OR-NIL = NIL, which means "end of bar"
+ (loop for e in (elements bar)
+ if (eq e thing) do (return-from starts-before-p t)
+ until (eq e element-or-nil) sum (duration e))))
+ (or (> element-start-time thing-start-time)
+ (and (= element-start-time thing-start-time)
+ (or (null element-or-nil)
+ (> (duration element-or-nil) 0)))))))))
+
+(defun %keysig (staff key-signatures bar element-or-nil)
+ (or (and key-signatures
+ (find-if (lambda (x) (starts-before-p x bar element-or-nil))
+ key-signatures :from-end t))
+ (keysig staff)))
(defmethod keysig ((cursor gsharp-cursor))
;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
@@ -978,19 +980,15 @@
(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)))
+ (%keysig staff key-signatures bar 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)))
+ (%keysig staff key-signatures bar element-or-nil)))
(defmethod keysig ((cluster cluster))
(error "Called ~S (a staff-scope operation) on an element with no ~
@@ -1000,10 +998,8 @@
(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)))
+ (bar (bar element)))
+ (%keysig staff key-signatures bar element)))
(define-gsharp-command com-tie-note-left ()
(let ((note (cur-note)))
@@ -1093,7 +1089,7 @@
;; layout for motion will be different from the layout on
;; the screen...
(staves (staves buffer))
- (timesig-offset (gsharp-drawing::compute-timesig-offset staves))
+ (timesig-offset (gsharp-drawing::compute-timesig-offset staves page-measures))
(method (let ((old-method (buffer-cost-method buffer)))
(make-measure-cost-method (min-width old-method)
(spacing-style old-method)
--- /project/gsharp/cvsroot/gsharp/measure.lisp 2007/06/21 11:14:25 1.33
+++ /project/gsharp/cvsroot/gsharp/measure.lisp 2007/07/05 21:13:03 1.34
@@ -397,9 +397,8 @@
(declare (ignore position))
(mark-modified bar))
-(defmethod remove-element :before ((element relement))
- (when (bar element)
- (mark-modified (bar element))))
+(defmethod remove-element :before ((element element) (bar rbar))
+ (mark-modified bar))
(defmethod mark-modified ((bar rbar))
(setf (modified-p bar) t)
@@ -859,7 +858,7 @@
:lines-per-page lines-per-page))
;;; As required by the obseq library, define a sequence cost, i.e., in
-;;; this case the cost of a sequece of measures.
+;;; this case the cost of a sequence of measures.
(defclass measure-seq-cost (seq-cost)
((min-dist :initarg :min-dist :reader min-dist)
(coeff :initarg :coeff :reader coeff)
More information about the Gsharp-cvs
mailing list