[gsharp-cvs] CVS gsharp

crhodes crhodes at common-lisp.net
Wed Jun 21 16:31:54 UTC 2006


Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv21067

Modified Files:
	drawing.lisp measure.lisp packages.lisp 
Log Message:
Dots!

Specifically, augmentation dots.  Get their x- and y- positions more 
right, which sometimes entails not drawing a dot at all, sometimes 
adjusting the position for a dot downwards, and (when a flag is drawn or 
there is a suspended note in a flag-up situation) involves shifting the 
entire column of dots rightwards.

Add an example score full of things we got wrong.


--- /project/gsharp/cvsroot/gsharp/drawing.lisp	2006/06/19 17:40:34	1.71
+++ /project/gsharp/cvsroot/gsharp/drawing.lisp	2006/06/21 16:31:54	1.72
@@ -76,6 +76,9 @@
 (defun final-absolute-accidental-xoffset (note)
   (+ (final-absolute-element-xoffset (cluster note)) (final-relative-accidental-xoffset note)))
 
+(defun final-absolute-dot-xoffset (cluster)
+  (+ (final-absolute-element-xoffset cluster) (score-pane:staff-step (final-relative-dot-xoffset cluster))))
+
 (defvar *cursor* nil)
 
 ;;; Compute the elasticity of each timeline in each measure of the
@@ -832,9 +835,13 @@
       (loop for pos from -2 downto bot-note-pos by 2
 	    do (score-pane:draw-ledger-line pane x pos)))))
 
-(defun draw-flags (pane element x direction pos)
+(defun flags-drawn-p (element)
   (let ((nb (max (rbeams element) (lbeams element))))
-    (when (and (> nb 0) (eq (notehead element) :filled))
+    (and (> nb 0) (eq (notehead element) :filled) nb)))
+
+(defun draw-flags (pane element x direction pos)
+  (let ((nb (flags-drawn-p element)))
+    (when nb
       (if (eq direction :up)
 	  (score-pane:with-notehead-right-offsets (right up)
 	    (declare (ignore up))
@@ -843,23 +850,23 @@
 	    (declare (ignore down))
 	    (score-pane:draw-flags-up pane nb (+ x left) pos))))))
   
-(defun draw-dots (pane nb-dots x pos)
-  (let ((staff-step (score-pane:staff-step 1)))
-    (loop with dotpos = (if (evenp pos) (1+ pos) pos)
-	  repeat nb-dots
-	  for xx from (+ x (* 2 staff-step)) by staff-step do
-	  (score-pane:draw-dot pane xx dotpos))))
+(defun draw-dots (pane nb-dots x dot-xoffset dot-pos)
+  (when dot-pos
+    (let ((staff-step (score-pane:staff-step 1)))
+      (loop repeat nb-dots
+            for xx from dot-xoffset by staff-step do
+            (score-pane:draw-dot pane xx dot-pos)))))
 
-(defun draw-note (pane note notehead nb-dots x pos)
+(defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos)
   (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note)))
     (score-pane:draw-notehead pane notehead x pos)
     (when (final-accidental note)
       (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos))
-    (draw-dots pane nb-dots x pos)))
+    (draw-dots pane nb-dots x dot-xoffset dot-pos)))
 
-(defun draw-notes (pane notes dots notehead)
+(defun draw-notes (pane notes dots notehead dot-xoffset)
   (loop for note in notes do
-	(draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note))))
+	(draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note) dot-xoffset (final-absolute-dot-ypos note))))
 
 (defun element-has-suspended-notes (element)
   (not (apply #'= (mapcar #'final-relative-note-xoffset (notes element)))))
@@ -873,17 +880,23 @@
 (defmethod draw-element (pane (element cluster) &optional (flags t))
   (with-new-output-record (pane)
     (unless (null (notes element))
-      (let ((direction (final-stem-direction element))
-	    (stem-pos (final-stem-position element))
-	    (stem-yoffset (final-stem-yoffset element))
-	    (groups (group-notes-by-staff (notes element)))
-	    (x (final-absolute-element-xoffset element)))
+      (let* ((direction (final-stem-direction element))
+             (stem-pos (final-stem-position element))
+             (stem-yoffset (final-stem-yoffset element))
+             (groups (group-notes-by-staff (notes element)))
+             (x (final-absolute-element-xoffset element))
+             (dot-xoffset 
+              (let ((basic-xoffset (+ (score-pane:staff-step 2)
+                                      (reduce #'max (mapcar #'final-absolute-note-xoffset (notes element))))))
+                (if (and flags (eq direction :up) (flags-drawn-p element))
+                    (max basic-xoffset (+ (score-pane:staff-step 4) x))
+                    basic-xoffset))))
 	(when flags
 	  (score-pane:with-vertical-score-position (pane stem-yoffset)
 	    (draw-flags pane element x direction stem-pos)))
-	(loop for group in groups do 
-	      (draw-notes pane group (dots element) (notehead element))
-	      (draw-ledger-lines pane x group))
+        (loop for group in groups do 
+              (draw-notes pane group (dots element) (notehead element) dot-xoffset)
+              (draw-ledger-lines pane x group))
 	(unless (eq (notehead element) :whole)
 	  (if (eq direction :up)
 	      (score-pane:draw-right-stem
--- /project/gsharp/cvsroot/gsharp/measure.lisp	2006/06/19 17:40:34	1.31
+++ /project/gsharp/cvsroot/gsharp/measure.lisp	2006/06/21 16:31:54	1.32
@@ -56,7 +56,11 @@
 				      :accessor final-relative-accidental-xoffset)
    (final-accidental :initform nil :accessor final-accidental)
    ;; the relative x offset of the note with respect to the cluster
-   (final-relative-note-xoffset :accessor final-relative-note-xoffset)))
+   (final-relative-note-xoffset :accessor final-relative-note-xoffset)
+   ;; the absolute y position of any dot, or NIL if dots should not be
+   ;; drawn
+   (final-absolute-dot-ypos :accessor final-absolute-dot-ypos :initform nil)
+))
 
 ;;; given a list of notes, group them so that every note in the group
 ;;; is displayed on the same staff.  Return the list of groups. 
@@ -158,7 +162,7 @@
 
 (define-added-mixin rcluster () cluster
   ((final-stem-direction :accessor final-stem-direction)
-   ;; the position, in staff steps, of the top not in the element.
+   ;; the position, in staff steps, of the top note in the element.
    (top-note-pos :accessor top-note-pos)
    ;; the position, in staff steps, of the bottom note in the element.
    (bot-note-pos :accessor bot-note-pos)))
@@ -217,6 +221,22 @@
 	  when (non-empty-cluster-p element)
 	  do (setf (final-stem-direction element) stem-direction))))
 
+(defun compute-final-dot-positions (group)
+  (setf group (sort (copy-list group) #'> :key #'note-position))
+  (let ((so-far nil))
+    (dolist (note group)
+      (let* ((position (note-position note))
+             (ideal (if (oddp position) position (1+ position))))
+        (cond
+          ;; if there's no dot at our ideal position, use that
+          ((not (member ideal so-far)) (push (setf (final-absolute-dot-ypos note) ideal) so-far))
+          ;; if the note in question is on a line and we haven't
+          ;; got a dot in the space underneath, use that
+          ((and (evenp position) (not (member (- ideal 2) so-far)))
+           (push (setf (final-absolute-dot-ypos note) (- ideal 2)) so-far))
+          ;; otherwise, give up for this note
+          (t (setf (final-absolute-dot-ypos note) nil)))))))
+
 ;;; Given a list of notes to be displayed on the same staff line, for
 ;;; each note, compute the accidental to be displayed as a function of
 ;;; the accidentals of the note and the key signature of the staff.
@@ -550,6 +570,7 @@
 
 (defun compute-staff-group-parameters (staff-group stem-direction)
   (compute-final-relative-note-xoffsets staff-group stem-direction)
+  (compute-final-dot-positions staff-group)
   (compute-final-accidentals staff-group)
   (compute-final-relative-accidental-xoffset staff-group stem-direction))
 
@@ -622,7 +643,7 @@
 
 (defmethod compute-bar-parameters ((bar melody-bar))
   (loop for group in (beam-groups (elements bar))
-	do (compute-beam-group-parameters group)))	
+	do (compute-beam-group-parameters group)))
 
 ;;; From a list of simultaneous bars (and some other stuff), create a
 ;;; measure.  The `other stuff' is the spacing style, which is needed
--- /project/gsharp/cvsroot/gsharp/packages.lisp	2006/06/14 03:38:56	1.57
+++ /project/gsharp/cvsroot/gsharp/packages.lisp	2006/06/21 16:31:54	1.58
@@ -128,6 +128,7 @@
 	   #:beam-groups #:final-stem-direction
 	   #:group-notes-by-staff #:final-relative-note-xoffset
 	   #:final-accidental #:final-relative-accidental-xoffset
+           #:final-relative-dot-xoffset #:final-absolute-dot-ypos
 	   #:timeline #:timelines #:elasticity
 	   #:smallest-gap #:elasticity-function))
 




More information about the Gsharp-cvs mailing list