[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/measure.lisp gsharp/packages.lisp
Robert Strandh
rstrandh at common-lisp.net
Mon Nov 21 02:11:10 UTC 2005
Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv1737
Modified Files:
drawing.lisp measure.lisp packages.lisp
Log Message:
moved computation of final stem direction from drawing.lisp to measure.lisp
Date: Mon Nov 21 03:11:09 2005
Author: rstrandh
Index: gsharp/drawing.lisp
diff -u gsharp/drawing.lisp:1.30 gsharp/drawing.lisp:1.31
--- gsharp/drawing.lisp:1.30 Mon Nov 21 01:45:14 2005
+++ gsharp/drawing.lisp Mon Nov 21 03:11:08 2005
@@ -196,9 +196,6 @@
(bot-note-staff-yoffset :accessor bot-note-staff-yoffset)
(final-absolute-xoffset :accessor final-absolute-element-xoffset)))
-(define-added-mixin vcluster () cluster
- ((final-stem-direction :accessor final-stem-direction)))
-
(define-added-mixin welement () lyrics-element
((final-absolute-xoffset :accessor final-absolute-element-xoffset)))
@@ -216,20 +213,6 @@
(top-note-staff-yoffset element) 0
(bot-note-staff-yoffset element) 0)))
-;;; Given a non-empty cluster that is not beamed together with any
-;;; other clusters, compute and store its final stem direction.
-(defun compute-final-stem-direction (cluster)
- (assert (non-empty-cluster-p cluster))
- (setf (final-stem-direction cluster)
- (if (or (eq (stem-direction cluster) :up) (eq (stem-direction cluster) :down))
- (stem-direction cluster)
- (let ((top-note-pos (top-note-pos cluster))
- (bot-note-pos (bot-note-pos cluster)))
- (if (>= (- top-note-pos 4)
- (- 4 bot-note-pos))
- :down
- :up)))))
-
(defun compute-stem-length (element)
(let* ((top-note-pos (top-note-pos element))
(bot-note-pos (bot-note-pos element))
@@ -290,25 +273,6 @@
(incf start-time (duration element)))
(elements bar))))
-;;; Given a beam group containing at least two nonempty clusters,
-;;; compute and store the final stem directions of all the non-empty
-;;; clusters in the group
-(defun compute-final-stem-directions (elements)
- (let ((stem-direction (if (not (eq (stem-direction (car elements)) :auto))
- (stem-direction (car elements))
- (let ((top-note-pos
- (loop for element in elements
- when (non-empty-cluster-p element)
- maximize (top-note-pos element)))
- (bot-note-pos
- (loop for element in elements
- when (non-empty-cluster-p element)
- minimize (top-note-pos element))))
- (if (>= (- top-note-pos 4) (- 4 bot-note-pos)) :down :up)))))
- (loop for element in elements
- when (non-empty-cluster-p element)
- do (setf (final-stem-direction element) stem-direction))))
-
;;; the dominating note among a bunch of notes is the
;;; one that is closest to the beam, i.e. the one
;;; the one that is closest to the end of the stem that
@@ -330,25 +294,12 @@
(if (< (pitch n1) (pitch n2)) n1 n2))))))
notes))
-;;; Given a beam group, for each nonempty element, compute the top and
-;;; bottom note position, and the final stem direction.
-(defun compute-positions-and-stem-direction (elements)
-;; (loop for element in elements
-;; when (non-empty-cluster-p element)
-;; do (compute-top-bot-pos element))
- (if (null (cdr elements))
- (let ((element (car elements)))
- (when (non-empty-cluster-p element)
- (compute-final-stem-direction element)))
- (compute-final-stem-directions elements)))
-
(defun draw-beam-group (pane elements)
(mapc #'compute-top-bot-yoffset elements)
(if (null (cdr elements))
(let ((element (car elements)))
(when (or (typep element 'rest) (notes element))
(when (non-empty-cluster-p element)
- (compute-final-stem-direction element)
(compute-stem-length element))
(draw-element pane element (final-absolute-element-xoffset element))))
(let* ((stem-direction (final-stem-direction (car elements)))
@@ -402,43 +353,10 @@
(defun draw-cursor (pane x)
(draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+))
-;;; Given a list of the elements of a bar, return a list of beam
-;;; groups. A beam group is defined to be either a singleton list or
-;;; a list with more than one element. In the case of a singleton,
-;;; the element is either a non-cluster, an empty cluster, a cluster
-;;; that does not beam to the right, or a cluster that does beam to
-;;; the right, but either it is the last cluster in the bar, or the
-;;; first following cluster in the bar does not beam to the left. In
-;;; the case of a list with more than one element, the first element
-;;; is a cluster that beams to the right, the last element is a
-;;; cluster that beams to the left, and all other clusters in the list
-;;; beam both to the left and to the right. Notice that in the last
-;;; case, elements other than the first and the last can be
-;;; non-clusters, or empty clusters.
-(defun beam-groups (elements)
- (let ((group '()))
- (loop until (null elements) do
- (setf group (list (car elements))
- elements (cdr elements))
- (when (and (non-empty-cluster-p (car group))
- (plusp (rbeams (car group))))
- (loop while (and (not (null elements))
- (or (not (typep (car elements) 'cluster))
- (null (notes (car elements)))
- (plusp (lbeams (car elements)))))
- do (push (pop elements) group)
- until (and (non-empty-cluster-p (car group))
- (zerop (rbeams (car group)))))
- ;; pop off trailing unbeamable objects
- (loop until (non-empty-cluster-p (car group))
- do (push (pop group) elements)))
- collect (nreverse group))))
-
(defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor)
(compute-element-x-positions bar x time-alist)
(loop for group in (beam-groups (elements bar))
- do (compute-positions-and-stem-direction group)
- (draw-beam-group pane group))
+ do (draw-beam-group pane group))
(when (eq (cursor-bar *cursor*) bar)
(let ((elements (elements bar)))
(if (null (cursor-element *cursor*))
Index: gsharp/measure.lisp
diff -u gsharp/measure.lisp:1.10 gsharp/measure.lisp:1.11
--- gsharp/measure.lisp:1.10 Mon Nov 21 01:45:18 2005
+++ gsharp/measure.lisp Mon Nov 21 03:11:08 2005
@@ -102,7 +102,8 @@
;;; Cluster
(define-added-mixin rcluster () cluster
- (;; the position, in staff steps, of the top not in the element.
+ ((final-stem-direction :accessor final-stem-direction)
+ ;; the position, in staff steps, of the top not 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)))
@@ -128,6 +129,39 @@
(when (cluster note)
(mark-modified (cluster note))))
+;;; Given a non-empty cluster that is not beamed together with any
+;;; other clusters, compute and store its final stem direction.
+(defun compute-final-stem-direction (cluster)
+ (assert (non-empty-cluster-p cluster))
+ (setf (final-stem-direction cluster)
+ (if (or (eq (stem-direction cluster) :up) (eq (stem-direction cluster) :down))
+ (stem-direction cluster)
+ (let ((top-note-pos (top-note-pos cluster))
+ (bot-note-pos (bot-note-pos cluster)))
+ (if (>= (- top-note-pos 4)
+ (- 4 bot-note-pos))
+ :down
+ :up)))))
+
+;;; Given a beam group containing at least two nonempty clusters,
+;;; compute and store the final stem directions of all the non-empty
+;;; clusters in the group
+(defun compute-final-stem-directions (elements)
+ (let ((stem-direction (if (not (eq (stem-direction (car elements)) :auto))
+ (stem-direction (car elements))
+ (let ((top-note-pos
+ (loop for element in elements
+ when (non-empty-cluster-p element)
+ maximize (top-note-pos element)))
+ (bot-note-pos
+ (loop for element in elements
+ when (non-empty-cluster-p element)
+ minimize (top-note-pos element))))
+ (if (>= (- top-note-pos 4) (- 4 bot-note-pos)) :down :up)))))
+ (loop for element in elements
+ when (non-empty-cluster-p element)
+ do (setf (final-stem-direction element) stem-direction))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Rest
@@ -318,12 +352,60 @@
(when (non-empty-cluster-p element)
(compute-top-bot-pos element)))
+(defun compute-beam-group-parameters (elements)
+ (let ((any-element-modified nil))
+ (loop for element in elements
+ do (when (modified-p element)
+ (compute-element-parameters element)
+ (setf any-element-modified t)
+ (setf (modified-p element) nil)))
+ (when any-element-modified
+ (if (null (cdr elements))
+ (when (non-empty-cluster-p (car elements))
+ (compute-final-stem-direction (car elements)))
+ (compute-final-stem-directions elements)))))
+
+;;; Given a list of the elements of a bar, return a list of beam
+;;; groups. A beam group is defined to be either a singleton list or
+;;; a list with more than one element. In the case of a singleton,
+;;; the element is either a non-cluster, an empty cluster, a cluster
+;;; that does not beam to the right, or a cluster that does beam to
+;;; the right, but either it is the last cluster in the bar, or the
+;;; first following cluster in the bar does not beam to the left. In
+;;; the case of a list with more than one element, the first element
+;;; is a cluster that beams to the right, the last element is a
+;;; cluster that beams to the left, and all other clusters in the list
+;;; beam both to the left and to the right. Notice that in the last
+;;; case, elements other than the first and the last can be
+;;; non-clusters, or empty clusters.
+(defun beam-groups (elements)
+ (let ((group '()))
+ (loop until (null elements) do
+ (setf group (list (car elements))
+ elements (cdr elements))
+ (when (and (non-empty-cluster-p (car group))
+ (plusp (rbeams (car group))))
+ (loop while (and (not (null elements))
+ (or (not (typep (car elements) 'cluster))
+ (null (notes (car elements)))
+ (plusp (lbeams (car elements)))))
+ do (push (pop elements) group)
+ until (and (non-empty-cluster-p (car group))
+ (zerop (rbeams (car group)))))
+ ;; pop off trailing unbeamable objects
+ (loop until (non-empty-cluster-p (car group))
+ do (push (pop group) elements)))
+ collect (nreverse group))))
+
;;; compute some important parameters of a bar
-(defun compute-bar-parameters (bar)
- (loop for element in (elements bar)
- do (when (modified-p element)
- (compute-element-parameters element)
- (setf (modified-p element) nil))))
+(defgeneric compute-bar-parameters (bar))
+
+(defmethod compute-bar-parameter (bar)
+ nil)
+
+(defmethod compute-bar-parameters ((bar melody-bar))
+ (loop for group in (beam-groups (elements bar))
+ 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 neded
Index: gsharp/packages.lisp
diff -u gsharp/packages.lisp:1.30 gsharp/packages.lisp:1.31
--- gsharp/packages.lisp:1.30 Mon Nov 21 01:45:18 2005
+++ gsharp/packages.lisp Mon Nov 21 03:11:08 2005
@@ -103,7 +103,8 @@
#:reduced-width #:natural-width #:compress-factor
#:measure-seq-cost
#:note-position #:non-empty-cluster-p
- #:top-note #:bot-note #:top-note-pos #:bot-note-pos))
+ #:top-note #:bot-note #:top-note-pos #:bot-note-pos
+ #:beam-groups #:final-stem-direction))
(defpackage :gsharp-postscript
(:use :clim :clim-lisp)
More information about the Gsharp-cvs
mailing list