Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv24600
Modified Files: beaming.lisp drawing.lisp gsharp.asd measure.lisp score-pane.lisp Added Files: clim-patches.lisp Log Message: Gsharp can now do multiple beams, partial beams and fractional beams. There are still some quirks, however:
* there is an off-by-one-pixel error that sometimes makes the beam not attach to one of its stems;
* I am still using the algorithm for a single beam to compute the beaming, even when there are multiple beams.
Also fixed a bug that did not set the modified-p flag on an element when the stem direction was explicitly altered as a result of a user interaction.
Date: Wed Dec 7 04:38:27 2005 Author: rstrandh
Index: gsharp/beaming.lisp diff -u gsharp/beaming.lisp:1.2 gsharp/beaming.lisp:1.3 --- gsharp/beaming.lisp:1.2 Mon Feb 16 17:08:00 2004 +++ gsharp/beaming.lisp Wed Dec 7 04:38:27 2005 @@ -3,9 +3,9 @@ ;;; The beaming function takes a list of the form: ;;; ((p1 x1) (p2 x2) ... (pn xn)) ;;; where p1 through pn are staff positions (bottom line is 0, -;;; increas upwards by 1 for each half staff step) and x1 through xn +;;; increas upwards by 1 for each staff step) and x1 through xn ;;; are x positions for the clusters given in the same unit as the -;;; positions, i.e., half staff steps +;;; positions, i.e., staff steps
;;; The result of the computation is a VALID BEAMING. Such a beaming ;;; is represented as a list of two elements representing the left and @@ -18,11 +18,13 @@ ;;; representation makes it easy to transform the constellation by ;;; reflection.
-;;; Take two notes and compute the beam slant and beam position for the -;;; beam connecting them. A position of zero means the bottom of the -;;; staff. Positive integers count up 1/2 space so that C on a staff -;;; with a G-clef gets to have number -2. Negative numbers go the other -;;; way. This procedure assumes that pos2 >= pos1. +;;; Take two vertical positions and compute the beam slant and beam +;;; position for the beam connecting them. A position of zero means +;;; the bottom of the staff. Positive integers count up 1/2 space so +;;; that C on a staff with a G-clef gets to have number -2. Negative +;;; numbers go the other way. This function assumes that pos2 >= pos1, +;;; and that the two notes are sufficiently far apart that the slant +;;; is going to be acceptably small. (defun beaming-single-stemsup-rising-twonotes (pos1 pos2) (let ((d (- pos2 pos1)) (s1 (+ pos2 1)) @@ -96,11 +98,19 @@ (t `((,s5 . -1) (,s7 . 0))))))))
(defun reflect-pos (pos) - (list (- 8 (car pos)) (cadr pos))) + (destructuring-bind (p x b) pos + (list (- 8 p) x b)))
(defun reflect-bpos (pos) (cons (- 8 (car pos)) (- (cdr pos))))
+;;; take two points of the form (pos x b), where pos is a vertical +;;; position (in staff-steps), x is a horizontal position (also in +;;; staff-steps), and b is the number of beams at that position and +;;; compute a valid beaming for the two points. To do so, first call +;;; the function passed as an argument on the two vertical positions. +;;; If the slant thus obtained is too high, repeat with a slightly +;;; higher vertical position of the first point. (defun beaming-two-points (p1 p2 fun) (let* ((beaming (funcall fun (car p1) (car p2))) (left (car beaming)) @@ -114,8 +124,18 @@ (progn (incf (car p1)) (beaming-two-points p1 p2 fun)) beaming)))
-;;; main entry +;;; main entry
+;;; Take a list of the form ((p1 x1 b1) (p2 x2 b2) ... (pn xn bn)), +;;; (where pi is a vertical position, xi is a horizontal position +;;; (both measured in staff-steps), and bi is the number of stems at +;;; that position), a stem direction, and a function to compute a +;;; valid slant of two notes sufficiently far apart, compute a valid +;;; beaming. First reflect the positions vertically and horizontally +;;; until the last note is higher than the first and the stems are up. +;;; Then compute a valid beaming using only the first and last +;;; elements of the list. Finally, move the beaming up vertically +;;; until each stem it as least 2.5 staff steps long. (defun beaming-general (positions stem-direction fun) (let* ((first (car positions)) (last (car (last positions))) @@ -130,12 +150,11 @@ (right (cadr beaming)) (y1 (+ (car left) (* 0.5 (cdr left)))) (y2 (+ (car right) (* 0.5 (cdr right)))) + (slope (/ (- y2 y1) (- x2 x1))) (minstem (reduce #'min positions :key (lambda (pos) - (- (+ y1 (* (- (cadr pos) x1) - (/ (- y2 y1) - (- x2 x1)))) - (car pos))))) + (destructuring-bind (p x b) pos + (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b))))))) (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2))))) `((,(+ (car left) increment) . ,(cdr left)) (,(+ (car right) increment) . ,(cdr right))))))))
Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.51 gsharp/drawing.lisp:1.52 --- gsharp/drawing.lisp:1.51 Tue Dec 6 17:36:03 2005 +++ gsharp/drawing.lisp Wed Dec 7 04:38:27 2005 @@ -578,7 +578,12 @@ (x-positions (mapcar (lambda (element) (/ (final-absolute-element-xoffset element) (score-pane:staff-step 1))) elements)) - (beaming (beaming-single (mapcar #'list positions x-positions) stem-direction))) + (nb-beams (mapcar (lambda (element) + (max (lbeams element) (rbeams element))) + elements)) + (beaming (beaming-single (mapcar #'list positions x-positions nb-beams) stem-direction)) + (max-nb-beams (reduce #'max nb-beams)) + (min-nb-beams (reduce #'min nb-beams))) (destructuring-bind ((ss1 . offset1) (ss2 . offset2)) beaming (let* ((y1 (+ ss1 (* 1/2 offset1))) (y2 (+ ss2 (* 1/2 offset2))) @@ -600,14 +605,72 @@ (if (eq stem-direction :up) (score-pane:with-notehead-right-offsets (right up) (declare (ignore up)) - (score-pane:draw-beam pane - (+ (final-absolute-element-xoffset (car elements)) right) ss1 offset1 - (+ (final-absolute-element-xoffset (car (last elements))) right) ss2 offset2)) + (loop repeat min-nb-beams + for ss from 0 by 2 + for offset from 0 + do (score-pane:draw-beam pane + (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset) + (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset))) + (let ((region +nowhere+)) + (loop for beams from (1+ min-nb-beams) to max-nb-beams + for ss from (* 2 min-nb-beams) by 2 + for offset from min-nb-beams + do (loop for (e1 e2) on elements + do (when (not (null e2)) + (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 + (+ (final-absolute-element-xoffset e2) right) 10000)))) + ((>= (rbeams e1) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 + (+ (final-absolute-element-xoffset e1) right (score-pane:staff-step 2)) 10000)))) + ((>= (lbeams e2) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e2) right (score-pane:staff-step -2)) -10000 + (+ (final-absolute-element-xoffset e2) right) 10000)))) + (t nil)))) + (with-drawing-options (pane :clipping-region region) + (score-pane:draw-beam pane + (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset) + (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset)))))) (score-pane:with-notehead-left-offsets (left down) (declare (ignore down)) - (score-pane:draw-beam pane - (+ (final-absolute-element-xoffset (car elements)) left) ss1 offset1 - (+ (final-absolute-element-xoffset (car (last elements))) left) ss2 offset2)))) + (loop repeat min-nb-beams + for ss from 0 by 2 + for offset from 0 + do (score-pane:draw-beam pane + (+ (final-absolute-element-xoffset (car elements)) left) (+ ss1 ss) (- offset1 offset) + (+ (final-absolute-element-xoffset (car (last elements))) left) (+ ss2 ss) (- offset2 offset))) + (let ((region +nowhere+)) + (loop for beams from (1+ min-nb-beams) to max-nb-beams + for ss from (* 2 min-nb-beams) by 2 + for offset from min-nb-beams + do (loop for (e1 e2) on elements + do (when (not (null e2)) + (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 + (+ (final-absolute-element-xoffset e2) left) 10000)))) + ((>= (rbeams e1) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 + (+ (final-absolute-element-xoffset e1) left (score-pane:staff-step 2)) 10000)))) + ((>= (lbeams e2) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e2) left (score-pane:staff-step -2)) -10000 + (+ (final-absolute-element-xoffset e2) left) 10000)))) + (t nil)))) + (with-drawing-options (pane :clipping-region region) + (score-pane:draw-beam pane + (+ (final-absolute-element-xoffset (car elements)) left) (+ ss1 ss) (- offset1 offset) + (+ (final-absolute-element-xoffset (car (last elements))) left) (+ ss2 ss) (- offset2 offset)))))))) (loop for element in elements do (draw-element pane element nil))))))
Index: gsharp/gsharp.asd diff -u gsharp/gsharp.asd:1.4 gsharp/gsharp.asd:1.5 --- gsharp/gsharp.asd:1.4 Tue Nov 29 20:37:39 2005 +++ gsharp/gsharp.asd Wed Dec 7 04:38:27 2005 @@ -22,6 +22,7 @@
(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain)) "packages" + "clim-patches" "esa" "utilities" "gf"
Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.19 gsharp/measure.lisp:1.20 --- gsharp/measure.lisp:1.19 Tue Nov 29 20:37:40 2005 +++ gsharp/measure.lisp Wed Dec 7 04:38:27 2005 @@ -78,6 +78,10 @@ (declare (ignore dots)) (mark-modified element))
+(defmethod (setf stem-direction) :after (direction (element relement)) + (declare (ignore direction)) + (mark-modified element)) + (defmethod note-position ((note note)) (let ((clef (clef (staff note)))) (+ (- (pitch note)
Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.17 gsharp/score-pane.lisp:1.18 --- gsharp/score-pane.lisp:1.17 Tue Nov 8 06:16:12 2005 +++ gsharp/score-pane.lisp Wed Dec 7 04:38:27 2005 @@ -612,8 +612,9 @@ (multiple-value-bind (left right) (stem-offsets *font*) (let* ((xx1 (+ x1 left)) (xx2 (+ x2 right)) - (y1 (- (floor (staff-step (+ staff-step-1 (* 1/2 offset1)))))) - (y2 (- (floor (staff-step (+ staff-step-2 (* 1/2 offset2)))))) + (offset (round (staff-step 1/3))) + (y1 (- (+ (staff-step staff-step-1) (* offset1 offset)))) + (y2 (- (+ (staff-step staff-step-2) (* offset2 offset)))) (slope (abs (/ (- y2 y1) (- xx2 xx1)))) (thickness (/ (staff-line-distance *font*) 2)) (medium (sheet-medium pane)))