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)))
