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)