gsharp-cvs November 2005

gsharp-cvs@common-lisp.net

2 participants
76 discussions

[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain-package.lisp gsharp/Flexichain/flexirank.lisp
by rstrandh＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv31819 Modified Files: flexichain-package.lisp flexirank.lisp Log Message: added flexi-first-p and flexi-last-p to flexirank.lisp Date: Mon Nov 28 22:27:03 2005 Author: rstrandh Index: gsharp/Flexichain/flexichain-package.lisp diff -u gsharp/Flexichain/flexichain-package.lisp:1.5 gsharp/Flexichain/flexichain-package.lisp:1.6 --- gsharp/Flexichain/flexichain-package.lisp:1.5 Mon Nov 28 00:43:50 2005 +++ gsharp/Flexichain/flexichain-package.lisp Mon Nov 28 22:27:02 2005 @@ -38,5 +38,6 @@ #:insert #:insert-sequence #:element< #:element> #:delete< #:delete> #:flexirank-mixin #:element-rank-mixin #:rank + #:flexi-first-p #:flexi-last-p #:flexi-next #:flexi-prev)) Index: gsharp/Flexichain/flexirank.lisp diff -u gsharp/Flexichain/flexirank.lisp:1.3 gsharp/Flexichain/flexirank.lisp:1.4 --- gsharp/Flexichain/flexirank.lisp:1.3 Mon Nov 28 01:25:59 2005 +++ gsharp/Flexichain/flexirank.lisp Mon Nov 28 22:27:02 2005 @@ -28,6 +28,8 @@ ;;; generic function rank. (defgeneric rank (element)) +(defgeneric flexi-first-p (element)) +(defgeneric flexi-last-p (element)) (defgeneric flexi-next (element)) (defgeneric flexi-prev (element)) @@ -38,16 +40,19 @@ (defmethod rank ((element element-rank-mixin)) (index-position (chain element) (index element))) +(defmethod flexi-first-p ((element element-rank-mixin)) + (zerop (rank element))) + +(defmethod flexi-last-p ((element element-rank-mixin)) + (= (rank element) (1- (nb-elements (chain element))))) + (defmethod flexi-next ((element element-rank-mixin)) - (let ((new-rank (1+ (rank element))) - (chain (chain element))) - (assert (< new-rank (nb-elements chain))) - (element* chain new-rank))) + (assert (not (flexi-last-p element))) + (element* (chain element) (1+ (rank element)))) (defmethod flexi-prev ((element element-rank-mixin)) - (let ((new-rank (1- (rank element)))) - (assert (not (minusp new-rank))) - (element* (chain element) new-rank))) + (assert (not (flexi-first-p element))) + (element* (chain element) (1- (rank element)))) ;;; this class must be mixed into a flexichain that contains ranked elements (defclass flexirank-mixin () ())

1 0

[gsharp-cvs] CVS update: gsharp/elasticity.lisp
by rstrandh＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv23128 Added Files: elasticity.lisp Log Message: New file containing code for managing elasticity functions. It is not yet used in Gsharp, but it soon will be. Date: Mon Nov 28 20:34:18 2005 Author: rstrandh

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/measure.lisp gsharp/packages.lisp
by rstrandh＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv20060 Modified Files: drawing.lisp measure.lisp packages.lisp Log Message: More code towards a better spacing algorithm Date: Mon Nov 28 05:25:35 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.34 gsharp/drawing.lisp:1.35 --- gsharp/drawing.lisp:1.34 Mon Nov 21 23:40:48 2005 +++ gsharp/drawing.lisp Mon Nov 28 05:25:34 2005 @@ -96,6 +96,41 @@ collect (/ (nat-width method (measure-coeff measure) min-dist) compress)))) +(defun compute-elasticities (measures method) + (loop for measure in measures + do (loop with timelines = (timelines measure) + for i from 0 below (flexichain:nb-elements timelines) + for timeline = (flexichain:element* timelines i) + do (setf (elasticity timeline) + (expt (duration timeline) (spacing-style method)))))) + +(defgeneric left-bulge (element pane)) +(defgeneric right-bulge (element pane)) + +(defmethod left-bulge ((element element) pane) + 0) + +(defmethod right-bulge ((element element) pane) + 0) + +(defun compute-gaps (measures method pane) + (declare (ignore method)) + (loop for measure in measures + do (loop for bar in (measure-bars measure) + do (loop for (e1 e2) on (elements bar) + for t1 = (timeline e1) + do (cond ((null e2) + (when (flexichain:flexi-last-p t1) + (setf (smallest-gap t1) + (max (smallest-gap t1) + (right-bulge e1 pane))))) + ((eq (flexichain:flexi-next t1) + (timeline e2)) + (setf (smallest-gap t1) + (max (smallest-gap t1) + (+ (right-bulge e1 pane) + (left-bulge e2 pane)))))))))) + (defun draw-measure (pane measure min-dist compress x method draw-cursor) (let* ((width (/ (nat-width method (measure-coeff measure) min-dist) compress)) @@ -154,6 +189,8 @@ (let ((yy y)) (gsharp-measure::new-map-over-obseq-subsequences (lambda (measures) + (compute-elasticities measures method) + (compute-gaps measures method pane) (let ((widths (compute-widths measures method))) (score-pane:with-vertical-score-position (pane yy) (draw-system pane measures (+ x (left-offset buffer) timesig-offset) Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.15 gsharp/measure.lisp:1.16 --- gsharp/measure.lisp:1.15 Mon Nov 28 03:32:06 2005 +++ gsharp/measure.lisp Mon Nov 28 05:25:34 2005 @@ -48,7 +48,7 @@ (defrclass relement element ((duration :initform nil) - (timeline :accessor timeline))) + (timeline :accessor timeline))) (defmethod duration :around ((element relement)) (with-slots (duration) element @@ -393,7 +393,10 @@ ((start-time :initarg :start-time :reader start-time) (elements :initform '() :accessor elements) (duration :initarg :duration :reader duration) - (elasticity :accessor elasticity))) + (elasticity :accessor elasticity) + ;; the minimum x offset from this timeline to the next, or, if this + ;; is the last timeline, from this one to the end of the measure + (smallest-gap :initform 0 :accessor smallest-gap))) (defclass ranked-flexichain (flexichain:standard-flexichain flexichain:flexirank-mixin) ()) @@ -464,7 +467,7 @@ (defmethod measures :before ((segment rsegment)) (when (modified-p segment) (compute-measures segment (spacing-style (buffer-cost-method (buffer segment)))) - (mapc #'compute-timelines (measures segment)) + (mapc #'compute-timelines (slot-value segment 'measures)) (setf (modified-p segment) nil))) (defmethod nb-measures ((segment rsegment)) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.34 gsharp/packages.lisp:1.35 --- gsharp/packages.lisp:1.34 Mon Nov 21 23:40:48 2005 +++ gsharp/packages.lisp Mon Nov 28 05:25:34 2005 @@ -133,7 +133,9 @@ #:top-note #:bot-note #:top-note-pos #:bot-note-pos #:beam-groups #:final-stem-direction #:group-notes-by-staff #:final-relative-note-xoffset - #:final-accidental #:final-relative-accidental-xoffset)) + #:final-accidental #:final-relative-accidental-xoffset + #:timeline #:timelines #:elasticity + #:smallest-gap)) (defpackage :gsharp-postscript (:use :clim :clim-lisp)

1 0

[gsharp-cvs] CVS update: gsharp/gsharp.asd gsharp/measure.lisp
by rstrandh＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv12520 Modified Files: gsharp.asd measure.lisp Log Message: Added explicit timelines which will be used for a better spacing algorithm. Date: Mon Nov 28 03:32:06 2005 Author: rstrandh Index: gsharp/gsharp.asd diff -u gsharp/gsharp.asd:1.2 gsharp/gsharp.asd:1.3 --- gsharp/gsharp.asd:1.2 Mon Nov 21 21:37:45 2005 +++ gsharp/gsharp.asd Mon Nov 28 03:32:06 2005 @@ -20,7 +20,7 @@ :defaults *gsharp-directory*)) collect `(:file ,(pathname-name p) :pathname ,p)))))) -(gsharp-defsystem (:gsharp :depends-on (:mcclim)) +(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain)) "packages" "esa" "utilities" Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.14 gsharp/measure.lisp:1.15 --- gsharp/measure.lisp:1.14 Mon Nov 21 23:40:48 2005 +++ gsharp/measure.lisp Mon Nov 28 03:32:06 2005 @@ -47,7 +47,8 @@ ;;; modification to the element have taken place in the meantime. (defrclass relement element - ((duration :initform nil))) + ((duration :initform nil) + (timeline :accessor timeline))) (defmethod duration :around ((element relement)) (with-slots (duration) element @@ -380,15 +381,28 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Measure +;;; Timeline + +;;; A timeline of a measure is the set of all simultaneous elements of +;;; the bars of the meausure. The duration of a timeline is either +;;; the temporal distance between it and the next closest timeline +;;; following it, or, in case it is the last timeline of the measure, +;;; the duration of the longest element of the timeline. + +(defclass timeline (flexichain:element-rank-mixin) + ((start-time :initarg :start-time :reader start-time) + (elements :initform '() :accessor elements) + (duration :initarg :duration :reader duration) + (elasticity :accessor elasticity))) + +(defclass ranked-flexichain (flexichain:standard-flexichain flexichain:flexirank-mixin) + ()) -;;; A measure represents the set of simultaneous bars. Define a -;;; TIMELINE of a measure to be the set of all simultaneous elements -;;; of the bars of the measure. The DURATION of a timeline is either -;;; the temporal distance to the next closest timeline following it, -;;; or, in case it is the last timeline of the measure, the duration -;;; of the longest element of the timeline. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Measure +;;; A measure represents the set of simultaneous bars. (defclass measure (obseq-elem) (;; the smallest duration of any timeline in the measure (min-dist :initarg :min-dist :reader measure-min-dist) @@ -406,7 +420,9 @@ (seg-pos :initarg :seg-pos :reader measure-seg-pos) (bar-pos :initarg :bar-pos :reader measure-bar-pos) ;; a list of the bars that make up this measure - (bars :initarg :bars :reader measure-bars))) + (bars :initarg :bars :reader measure-bars) + ;; the first timeline of the measure, or NIL of there are not timelines + (timelines :initform (make-instance 'ranked-flexichain) :reader timelines))) (defun make-measure (min-dist coeff start-times seg-pos bar-pos bars) (make-instance 'measure :min-dist min-dist :coeff coeff @@ -448,6 +464,7 @@ (defmethod measures :before ((segment rsegment)) (when (modified-p segment) (compute-measures segment (spacing-style (buffer-cost-method (buffer segment)))) + (mapc #'compute-timelines (measures segment)) (setf (modified-p segment) nil))) (defmethod nb-measures ((segment rsegment)) @@ -630,6 +647,30 @@ (coeff (loop for duration in durations sum (expt duration spacing-style)))) (make-measure min-dist coeff start-times seg-pos bar-pos bars)))) + +(defun compute-timelines (measure) + (let ((timelines (timelines measure)) + (start-times (measure-start-times measure))) + ;; create a timeline for each start time of the measure + (loop for start-time in start-times + for duration in (abs-rel start-times) + for i from 0 + do (let ((timeline (make-instance 'timeline + :start-time start-time + :duration duration))) + (flexichain:insert* timelines i timeline))) + ;; link each timeline to its elements and each element of a + ;; timeline to the timeline + (loop for bar in (measure-bars measure) + do (loop for element in (elements bar) + for start-time = 0 then (+ start-time (duration element)) + for timeline-index from 0 + do (loop while (< (start-time (flexichain:element* timelines timeline-index)) + start-time) + do (incf timeline-index)) + do (let ((timeline (flexichain:element* timelines timeline-index))) + (push element (elements timeline)) + (setf (timeline element) timeline)))))) ;;; Compute all the measures of a segment by stepping through all the ;;; bars in parallel as long as there is at least one simultaneous bar.

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexirank.lisp
by rstrandh＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv2937 Modified Files: flexirank.lisp Log Message: Fixed a bug in the flexirank code. Or, rather, compensated for a quirk in flexichain.lisp that calls move-elements on sentinels. The best way would be to avoid this quirk, but I am not willing to modify the basic flexichain code right now. Date: Mon Nov 28 01:25:59 2005 Author: rstrandh Index: gsharp/Flexichain/flexirank.lisp diff -u gsharp/Flexichain/flexirank.lisp:1.2 gsharp/Flexichain/flexirank.lisp:1.3 --- gsharp/Flexichain/flexirank.lisp:1.2 Mon Nov 28 00:43:50 2005 +++ gsharp/Flexichain/flexirank.lisp Mon Nov 28 01:25:59 2005 @@ -52,10 +52,12 @@ ;;; this class must be mixed into a flexichain that contains ranked elements (defclass flexirank-mixin () ()) -(defmethod move-elements :after ((chain flexirank-mixin) to from start1 start2 end2) +(defmethod move-elements :before ((chain flexirank-mixin) to from start1 start2 end2) (loop for old from start2 below end2 for new from start1 - do (setf (index (aref from old)) new))) + do (let ((element (aref from old))) + (when (typep element 'element-rank-mixin) + (setf (index element) new))))) (defmethod insert* :after ((chain flexirank-mixin) position (object element-rank-mixin)) (setf (index object) (position-index chain position)

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain-package.lisp gsharp/Flexichain/flexichain.asd gsharp/Flexichain/flexirank.lisp
by rstrandh＠common-lisp.net 27 Nov '05

27 Nov '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv32139 Modified Files: flexichain-package.lisp flexichain.asd flexirank.lisp Log Message: Added two more functions (flexi-next and flexi-prev) to flexirank. Date: Mon Nov 28 00:44:00 2005 Author: rstrandh Index: gsharp/Flexichain/flexichain-package.lisp diff -u gsharp/Flexichain/flexichain-package.lisp:1.4 gsharp/Flexichain/flexichain-package.lisp:1.5 --- gsharp/Flexichain/flexichain-package.lisp:1.4 Wed Nov 16 04:06:59 2005 +++ gsharp/Flexichain/flexichain-package.lisp Mon Nov 28 00:43:50 2005 @@ -37,5 +37,6 @@ #:move> #:move< #:insert #:insert-sequence #:element< #:element> #:delete< #:delete> - #:flexirank-mixin #:element-rank-mixin #:rank)) + #:flexirank-mixin #:element-rank-mixin #:rank + #:flexi-next #:flexi-prev)) Index: gsharp/Flexichain/flexichain.asd diff -u gsharp/Flexichain/flexichain.asd:1.4 gsharp/Flexichain/flexichain.asd:1.5 --- gsharp/Flexichain/flexichain.asd:1.4 Wed Nov 16 04:06:59 2005 +++ gsharp/Flexichain/flexichain.asd Mon Nov 28 00:43:50 2005 @@ -27,11 +27,11 @@ ;; The tester is not included, for it depends on clim. The stupid ;; implementation has also been left out, since it seems mostly useful ;; for testing. -(defsystem flexichain +(defsystem :flexichain :name "flexichain" :components ((:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) - (:file "flexichain" :depends-on ("utilities")) + (:file "flexichain" :depends-on ("utilities" "flexichain-package")) (:file "flexicursor" :depends-on ("flexichain")) (:file "flexirank" :depends-on ("flexichain")))) Index: gsharp/Flexichain/flexirank.lisp diff -u gsharp/Flexichain/flexirank.lisp:1.1 gsharp/Flexichain/flexirank.lisp:1.2 --- gsharp/Flexichain/flexirank.lisp:1.1 Wed Nov 16 04:06:59 2005 +++ gsharp/Flexichain/flexirank.lisp Mon Nov 28 00:43:50 2005 @@ -28,6 +28,8 @@ ;;; generic function rank. (defgeneric rank (element)) +(defgeneric flexi-next (element)) +(defgeneric flexi-prev (element)) (defclass element-rank-mixin () ((index :accessor index) @@ -35,6 +37,17 @@ (defmethod rank ((element element-rank-mixin)) (index-position (chain element) (index element))) + +(defmethod flexi-next ((element element-rank-mixin)) + (let ((new-rank (1+ (rank element))) + (chain (chain element))) + (assert (< new-rank (nb-elements chain))) + (element* chain new-rank))) + +(defmethod flexi-prev ((element element-rank-mixin)) + (let ((new-rank (1- (rank element)))) + (assert (not (minusp new-rank))) + (element* (chain element) new-rank))) ;;; this class must be mixed into a flexichain that contains ranked elements (defclass flexirank-mixin () ())

1 0

[gsharp-cvs] CVS update: gsharp/gui.lisp
by rstrandh＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv11943 Modified Files: gui.lisp Log Message: Invalidated elements of layers using a staff that has its key signature altered. Date: Sat Nov 26 22:30:43 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.44 gsharp/gui.lisp:1.45 --- gsharp/gui.lisp:1.44 Sun Nov 20 20:17:22 2005 +++ gsharp/gui.lisp Sat Nov 26 22:30:13 2005 @@ -1089,39 +1089,59 @@ (layer (layer (cursor *application-frame*)))) (remove-staff-from-layer staff layer))) +(defun invalidate-slice-using-staff (slice staff) + (declare (ignore staff)) ; maybe use this later + (loop for bar in (bars slice) + do (loop for element in (elements bar) + do (mark-modified element)))) + (define-gsharp-command com-more-sharps () - (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) - (cond ((eq (aref keysig 3) :flat) (setf (aref keysig 3) :natural)) - ((eq (aref keysig 0) :flat) (setf (aref keysig 0) :natural)) - ((eq (aref keysig 4) :flat) (setf (aref keysig 4) :natural)) - ((eq (aref keysig 1) :flat) (setf (aref keysig 1) :natural)) - ((eq (aref keysig 5) :flat) (setf (aref keysig 5) :natural)) - ((eq (aref keysig 2) :flat) (setf (aref keysig 2) :natural)) - ((eq (aref keysig 6) :flat) (setf (aref keysig 6) :natural)) - ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :sharp)) - ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :sharp)) - ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :sharp)) - ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :sharp)) - ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :sharp)) - ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :sharp)) - ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp))))) + (let ((staff (car (staves (layer (cursor *application-frame*)))))) + (loop for segment in (segments (buffer *application-frame*)) + do (loop for layer in (layers segment) + do (when (member staff (staves layer)) + (invalidate-slice-using-staff (head layer) staff) + (invalidate-slice-using-staff (body layer) staff) + (invalidate-slice-using-staff (tail layer) staff)))) + (let ((keysig (keysig staff))) + (cond ((eq (aref keysig 3) :flat) (setf (aref keysig 3) :natural)) + ((eq (aref keysig 0) :flat) (setf (aref keysig 0) :natural)) + ((eq (aref keysig 4) :flat) (setf (aref keysig 4) :natural)) + ((eq (aref keysig 1) :flat) (setf (aref keysig 1) :natural)) + ((eq (aref keysig 5) :flat) (setf (aref keysig 5) :natural)) + ((eq (aref keysig 2) :flat) (setf (aref keysig 2) :natural)) + ((eq (aref keysig 6) :flat) (setf (aref keysig 6) :natural)) + ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :sharp)) + ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :sharp)) + ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :sharp)) + ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :sharp)) + ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :sharp)) + ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :sharp)) + ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp)))))) (define-gsharp-command com-more-flats () - (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) - (cond ((eq (aref keysig 6) :sharp) (setf (aref keysig 6) :natural)) - ((eq (aref keysig 2) :sharp) (setf (aref keysig 2) :natural)) - ((eq (aref keysig 5) :sharp) (setf (aref keysig 5) :natural)) - ((eq (aref keysig 1) :sharp) (setf (aref keysig 1) :natural)) - ((eq (aref keysig 4) :sharp) (setf (aref keysig 4) :natural)) - ((eq (aref keysig 0) :sharp) (setf (aref keysig 0) :natural)) - ((eq (aref keysig 3) :sharp) (setf (aref keysig 3) :natural)) - ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :flat)) - ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :flat)) - ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :flat)) - ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :flat)) - ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :flat)) - ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :flat)) - ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :flat))))) + (let ((staff (car (staves (layer (cursor *application-frame*)))))) + (loop for segment in (segments (buffer *application-frame*)) + do (loop for layer in (layers segment) + do (when (member staff (staves layer)) + (invalidate-slice-using-staff (head layer) staff) + (invalidate-slice-using-staff (body layer) staff) + (invalidate-slice-using-staff (tail layer) staff)))) + (let ((keysig (keysig staff))) + (cond ((eq (aref keysig 6) :sharp) (setf (aref keysig 6) :natural)) + ((eq (aref keysig 2) :sharp) (setf (aref keysig 2) :natural)) + ((eq (aref keysig 5) :sharp) (setf (aref keysig 5) :natural)) + ((eq (aref keysig 1) :sharp) (setf (aref keysig 1) :natural)) + ((eq (aref keysig 4) :sharp) (setf (aref keysig 4) :natural)) + ((eq (aref keysig 0) :sharp) (setf (aref keysig 0) :natural)) + ((eq (aref keysig 3) :sharp) (setf (aref keysig 3) :natural)) + ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :flat)) + ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :flat)) + ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :flat)) + ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :flat)) + ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :flat)) + ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :flat)) + ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :flat)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/measure.lisp gsharp/packages.lisp
by rstrandh＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv30080 Modified Files: drawing.lisp measure.lisp packages.lisp Log Message: Move the computation of final relative accidental x offsets from drawing.lisp to measure.lisp. Date: Mon Nov 21 23:40:49 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.33 gsharp/drawing.lisp:1.34 --- gsharp/drawing.lisp:1.33 Mon Nov 21 23:18:37 2005 +++ gsharp/drawing.lisp Mon Nov 21 23:40:48 2005 @@ -3,13 +3,6 @@ (define-added-mixin dstaff () staff ((yoffset :initform 0 :accessor staff-yoffset))) -(define-added-mixin dnote () note - (;; The relative x offset of the accidental of the note with respect - ;; to the cluster. A value of nil indicates that accidental has - ;; not been placed yet - (final-relative-accidental-xoffset :initform nil - :accessor final-relative-accidental-xoffset))) - (define-presentation-method present (object (type score-pane:clef) stream (view textual-view) &key) (format stream "[~a clef on staff step ~a]" (name object) (lineno object))) @@ -433,139 +426,6 @@ (defun element-has-suspended-notes (element) (not (apply #'= (mapcar #'final-relative-note-xoffset (notes element))))) -;;; table of x offsets (in staff steps) of accendentals. -;;; The first index represents a notehead or a type of accidental. -;;; The second index represents a type of accidentsl. -;;; The third index is a vertical distance, measured in difference -;;; in staff steps between the two. -;;; The table entry gives how much the accidental represented by -;;; the second parameter must be positioned to the left of the -;;; first one. -;;; Entries in the table are offset by 5 in the last dimension -;;; so that vertical distances between -5 and 5 can be represented -(defparameter *accidental-offset* - ;;; -5 -4 -3 -2 -1 0 1 2 3 4 5 - #3A((( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - dbl flat - ( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - flat - ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - natural - ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - sharp - ( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0)) ; notehead - dbl sharp - (( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - dbl flat - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - flat - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - natural - ( 4 4 4 4 4 4 4 4 4 3.5 0) ; dbl flat - sharp - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0)) ; dbl flat - dbl sharp - (( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - dbl flat - ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - flat - ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - natural - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0) ; flat - sharp - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0)) ; flat - dbl sharp - (( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - dbl flat - ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - flat - ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - natural - ( 2 2 2 2 2 2 2 2 2 2 2) ; natural - sharp - ( 2 2 2 2 2 2 2 2 1 1 1)) ; natural - dbl sharp - (( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - dbl flat - ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - flat - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - natural - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 2.0) ; sharp - sharp - ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0)) ; sharp - dbl sharp - (( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - dbl flat - ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - flat - ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - natural - ( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0) ; dbl sharp - sharp - ( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0)))) ; dbl sharp - dbl sharp - -;;; given 1) a type of accidental 2) its position (in staff steps) 3) -;;; a type of accidental or a type of notehead, and 4) its position, -;;; return the x offset of the first accidental, i.e., how many staff -;;; steps to the left that it must be moved in order to avoid overlap -;;; with the second one. -(defun accidental-distance (acc1 pos1 acc2 pos2) - (let ((dist (- pos2 pos1))) - (if (> (abs dist) 5) - 0 - (aref *accidental-offset* - (ecase acc2 - (:notehead 0) - (:double-flat 1) - (:flat 2) - (:natural 3) - (:sharp 4) - (:double-sharp 5)) - (ecase acc1 - (:double-flat 0) - (:flat 1) - (:natural 2) - (:sharp 3) - (:double-sharp 4)) - (+ dist 5))))) - -;;; given two notes (where the first one has an accidental, and the -;;; second one may or may not have an accidental) and the conversion -;;; factor between staff steps and x positions, compute the x offset -;;; of the accidental of the first note. If the second note has -;;; an accidental, but that has not been given a final x offset, then -;;; use the x offset of the notehead instead. -(defun accidental-relative-xoffset (note1 note2 staff-step) - (let* ((acc1 (final-accidental note1)) - (pos1 (note-position note1)) - (acc2 (if (and (final-accidental note2) - (final-relative-accidental-xoffset note2)) - (final-accidental note2) - :notehead)) - (pos2 (note-position note2)) - (xpos2 (or (final-relative-accidental-xoffset note2) - (final-relative-note-xoffset note2)))) - (- xpos2 (* staff-step (accidental-distance acc1 pos1 acc2 pos2))))) - -;;; given a note and a list of notes, compute x offset of the accidental -;;; of the note as required by each of the notes in the list. In order -;;; for the accidental of the note not to overlap any of the others, -;;; we must use the minimum of all the x offsets thus computed. -(defun accidental-min-xoffset (note1 notes staff-step) - (reduce #'min notes :key (lambda (note) (accidental-relative-xoffset note1 note staff-step)))) - -;;; given a list of notes that have accidentals to place, and a list of -;;; notes that either have no accidentals or with already-placed accidentals, -;;; compute the note in the first list that can be placed as far to the right -;;; as possible. -(defun best-accidental (notes-with-accidentals notes staff-step) - (reduce (lambda (note1 note2) (if (>= (accidental-min-xoffset note1 notes staff-step) - (accidental-min-xoffset note2 notes staff-step)) - note1 - note2)) - notes-with-accidentals)) - -;;; for each note in a list of notes, if it has an accidental, compute -;;; the final relative x offset of that accidental and store it in the note. -(defun compute-final-relative-accidental-xoffset (notes x final-stem-direction) - (let* ((staff-step (score-pane:staff-step 1)) - ;; sort the notes from top to bottom - (notes (sort (copy-list notes) - (lambda (x y) (> (note-position x) (note-position y))))) - (notes-with-accidentals (remove-if-not #'final-accidental notes))) - ;; initially, no accidental has been placed - (loop for note in notes do (setf (final-relative-accidental-xoffset note) nil)) - (when (eq final-stem-direction :up) - ;; when the stem direction is :up and there is a suspended note - ;; i.e., one to the right of the stem, then the accidental of the topmost - ;; suspended note is placed first. - (let ((first-suspended-note - (find x notes-with-accidentals :test #'/= :key #'final-relative-note-xoffset))) - (when first-suspended-note - (setf notes-with-accidentals - (remove first-suspended-note notes-with-accidentals)) - (setf (final-relative-accidental-xoffset first-suspended-note) - (accidental-min-xoffset first-suspended-note notes staff-step))))) - ;; place remaining accidentals - (loop while notes-with-accidentals - do (let ((choice (best-accidental notes-with-accidentals notes staff-step))) - (setf notes-with-accidentals - (remove choice notes-with-accidentals)) - (setf (final-relative-accidental-xoffset choice) - (accidental-min-xoffset choice notes staff-step)))))) - ;;; draw a cluster. The stem direction and the stem position have ;;; already been computed. ;;; 1. Group notes by staff. @@ -586,7 +446,6 @@ (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) (loop for group in groups do - (compute-final-relative-accidental-xoffset group x direction) (draw-notes pane group (dots element) (notehead element)) (draw-ledger-lines pane x group)) (unless (eq (notehead element) :whole) Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.13 gsharp/measure.lisp:1.14 --- gsharp/measure.lisp:1.13 Mon Nov 21 23:18:37 2005 +++ gsharp/measure.lisp Mon Nov 21 23:40:48 2005 @@ -18,7 +18,12 @@ ;;; Note (defrclass rnote note - ((final-accidental :initform nil :accessor final-accidental) + (;; The relative x offset of the accidental of the note with respect + ;; to the cluster. A value of nil indicates that accidental has + ;; not been placed yet + (final-relative-accidental-xoffset :initform nil + :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))) @@ -184,6 +189,139 @@ nil (accidentals note))))) +;;; table of x offsets (in staff steps) of accendentals. +;;; The first index represents a notehead or a type of accidental. +;;; The second index represents a type of accidentsl. +;;; The third index is a vertical distance, measured in difference +;;; in staff steps between the two. +;;; The table entry gives how much the accidental represented by +;;; the second parameter must be positioned to the left of the +;;; first one. +;;; Entries in the table are offset by 5 in the last dimension +;;; so that vertical distances between -5 and 5 can be represented +(defparameter *accidental-offset* + ;;; -5 -4 -3 -2 -1 0 1 2 3 4 5 + #3A((( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - dbl flat + ( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - flat + ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - natural + ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - sharp + ( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0)) ; notehead - dbl sharp + (( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - dbl flat + ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - flat + ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - natural + ( 4 4 4 4 4 4 4 4 4 3.5 0) ; dbl flat - sharp + ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0)) ; dbl flat - dbl sharp + (( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - dbl flat + ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - flat + ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - natural + ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0) ; flat - sharp + ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0)) ; flat - dbl sharp + (( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - dbl flat + ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - flat + ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - natural + ( 2 2 2 2 2 2 2 2 2 2 2) ; natural - sharp + ( 2 2 2 2 2 2 2 2 1 1 1)) ; natural - dbl sharp + (( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - dbl flat + ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - flat + ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - natural + ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 2.0) ; sharp - sharp + ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0)) ; sharp - dbl sharp + (( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - dbl flat + ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - flat + ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - natural + ( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0) ; dbl sharp - sharp + ( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0)))) ; dbl sharp - dbl sharp + +;;; given 1) a type of accidental 2) its position (in staff steps) 3) +;;; a type of accidental or a type of notehead, and 4) its position, +;;; return the x offset of the first accidental, i.e., how many staff +;;; steps to the left that it must be moved in order to avoid overlap +;;; with the second one. +(defun accidental-distance (acc1 pos1 acc2 pos2) + (let ((dist (- pos2 pos1))) + (if (> (abs dist) 5) + 0 + (aref *accidental-offset* + (ecase acc2 + (:notehead 0) + (:double-flat 1) + (:flat 2) + (:natural 3) + (:sharp 4) + (:double-sharp 5)) + (ecase acc1 + (:double-flat 0) + (:flat 1) + (:natural 2) + (:sharp 3) + (:double-sharp 4)) + (+ dist 5))))) + +;;; given two notes (where the first one has an accidental, and the +;;; second one may or may not have an accidental) and the conversion +;;; factor between staff steps and x positions, compute the x offset +;;; of the accidental of the first note. If the second note has +;;; an accidental, but that has not been given a final x offset, then +;;; use the x offset of the notehead instead. +(defun accidental-relative-xoffset (note1 note2 staff-step) + (let* ((acc1 (final-accidental note1)) + (pos1 (note-position note1)) + (acc2 (if (and (final-accidental note2) + (final-relative-accidental-xoffset note2)) + (final-accidental note2) + :notehead)) + (pos2 (note-position note2)) + (xpos2 (or (final-relative-accidental-xoffset note2) + (final-relative-note-xoffset note2)))) + (- xpos2 (* staff-step (accidental-distance acc1 pos1 acc2 pos2))))) + +;;; given a note and a list of notes, compute x offset of the accidental +;;; of the note as required by each of the notes in the list. In order +;;; for the accidental of the note not to overlap any of the others, +;;; we must use the minimum of all the x offsets thus computed. +(defun accidental-min-xoffset (note1 notes staff-step) + (reduce #'min notes :key (lambda (note) (accidental-relative-xoffset note1 note staff-step)))) + +;;; given a list of notes that have accidentals to place, and a list of +;;; notes that either have no accidentals or with already-placed accidentals, +;;; compute the note in the first list that can be placed as far to the right +;;; as possible. +(defun best-accidental (notes-with-accidentals notes staff-step) + (reduce (lambda (note1 note2) (if (>= (accidental-min-xoffset note1 notes staff-step) + (accidental-min-xoffset note2 notes staff-step)) + note1 + note2)) + notes-with-accidentals)) + +;;; for each note in a list of notes, if it has an accidental, compute +;;; the final relative x offset of that accidental and store it in the note. +(defun compute-final-relative-accidental-xoffset (notes final-stem-direction) + (let* ((staff-step (score-pane:staff-step 1)) + ;; sort the notes from top to bottom + (notes (sort (copy-list notes) + (lambda (x y) (> (note-position x) (note-position y))))) + (notes-with-accidentals (remove-if-not #'final-accidental notes))) + ;; initially, no accidental has been placed + (loop for note in notes do (setf (final-relative-accidental-xoffset note) nil)) + (when (eq final-stem-direction :up) + ;; when the stem direction is :up and there is a suspended note + ;; i.e., one to the right of the stem, then the accidental of the topmost + ;; suspended note is placed first. + (let ((first-suspended-note + (find 0 notes-with-accidentals :test #'/= :key #'final-relative-note-xoffset))) + (when first-suspended-note + (setf notes-with-accidentals + (remove first-suspended-note notes-with-accidentals)) + (setf (final-relative-accidental-xoffset first-suspended-note) + (accidental-min-xoffset first-suspended-note notes staff-step))))) + ;; place remaining accidentals + (loop while notes-with-accidentals + do (let ((choice (best-accidental notes-with-accidentals notes staff-step))) + (setf notes-with-accidentals + (remove choice notes-with-accidentals)) + (setf (final-relative-accidental-xoffset choice) + (accidental-min-xoffset choice notes staff-step)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Rest @@ -396,7 +534,8 @@ (defun compute-staff-group-parameters (staff-group stem-direction) (compute-final-relative-note-xoffsets staff-group stem-direction) - (compute-final-accidentals staff-group)) + (compute-final-accidentals staff-group) + (compute-final-relative-accidental-xoffset staff-group stem-direction)) ;;; compute some important parameters of an element (defgeneric compute-element-parameters (element)) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.33 gsharp/packages.lisp:1.34 --- gsharp/packages.lisp:1.33 Mon Nov 21 23:18:37 2005 +++ gsharp/packages.lisp Mon Nov 21 23:40:48 2005 @@ -133,7 +133,7 @@ #:top-note #:bot-note #:top-note-pos #:bot-note-pos #:beam-groups #:final-stem-direction #:group-notes-by-staff #:final-relative-note-xoffset - #:final-accidental)) + #:final-accidental #:final-relative-accidental-xoffset)) (defpackage :gsharp-postscript (:use :clim :clim-lisp)

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/measure.lisp gsharp/packages.lisp
by rstrandh＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv28766 Modified Files: drawing.lisp measure.lisp packages.lisp Log Message: moved the computation of the final accidental (determine whether one should be displayed or not according to the key signature) from drawing.lisp to measure.lisp. Date: Mon Nov 21 23:18:38 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.32 gsharp/drawing.lisp:1.33 --- gsharp/drawing.lisp:1.32 Mon Nov 21 21:37:45 2005 +++ gsharp/drawing.lisp Mon Nov 21 23:18:37 2005 @@ -4,8 +4,7 @@ ((yoffset :initform 0 :accessor staff-yoffset))) (define-added-mixin dnote () note - ((final-accidental :initform nil :accessor final-accidental) - ;; The relative x offset of the accidental of the note with respect + (;; The relative x offset of the accidental of the note with respect ;; to the cluster. A value of nil indicates that accidental has ;; not been placed yet (final-relative-accidental-xoffset :initform nil @@ -431,17 +430,6 @@ (loop for note in notes do (draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note)))) -;;; 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. -(defun compute-final-accidentals (group) - (loop for note in group do - (setf (final-accidental note) - (if (eq (accidentals note) - (aref (keysig (staff note)) (mod (pitch note) 7))) - nil - (accidentals note))))) - (defun element-has-suspended-notes (element) (not (apply #'= (mapcar #'final-relative-note-xoffset (notes element))))) @@ -598,7 +586,6 @@ (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) (loop for group in groups do - (compute-final-accidentals group) (compute-final-relative-accidental-xoffset group x direction) (draw-notes pane group (dots element) (notehead element)) (draw-ledger-lines pane x group)) Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.12 gsharp/measure.lisp:1.13 --- gsharp/measure.lisp:1.12 Mon Nov 21 21:37:45 2005 +++ gsharp/measure.lisp Mon Nov 21 23:18:37 2005 @@ -18,7 +18,8 @@ ;;; Note (defrclass rnote note - (;; the relative x offset of the note with respect to the cluster + ((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))) ;;; given a list of notes, group them so that every note in the group @@ -172,6 +173,17 @@ when (non-empty-cluster-p element) do (setf (final-stem-direction element) stem-direction)))) +;;; 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. +(defun compute-final-accidentals (group) + (loop for note in group do + (setf (final-accidental note) + (if (eq (accidentals note) + (aref (keysig (staff note)) (mod (pitch note) 7))) + nil + (accidentals note))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Rest @@ -383,7 +395,8 @@ (setf note old-note)))))) (defun compute-staff-group-parameters (staff-group stem-direction) - (compute-final-relative-note-xoffsets staff-group stem-direction)) + (compute-final-relative-note-xoffsets staff-group stem-direction) + (compute-final-accidentals staff-group)) ;;; compute some important parameters of an element (defgeneric compute-element-parameters (element)) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.32 gsharp/packages.lisp:1.33 --- gsharp/packages.lisp:1.32 Mon Nov 21 21:37:45 2005 +++ gsharp/packages.lisp Mon Nov 21 23:18:37 2005 @@ -132,7 +132,8 @@ #:note-position #:non-empty-cluster-p #:top-note #:bot-note #:top-note-pos #:bot-note-pos #:beam-groups #:final-stem-direction - #:group-notes-by-staff #:final-relative-note-xoffset)) + #:group-notes-by-staff #:final-relative-note-xoffset + #:final-accidental)) (defpackage :gsharp-postscript (:use :clim :clim-lisp)

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/gsharp.asd gsharp/measure.lisp gsharp/packages.lisp
by rstrandh＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv20469 Modified Files: drawing.lisp gsharp.asd measure.lisp packages.lisp Log Message: moved the computation of relative x offsets of notes from drawing.lisp to measure.lisp. This required some reorganization of packages.lisp and gsharp.asd as well. Date: Mon Nov 21 21:37:45 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.31 gsharp/drawing.lisp:1.32 --- gsharp/drawing.lisp:1.31 Mon Nov 21 03:11:08 2005 +++ gsharp/drawing.lisp Mon Nov 21 21:37:45 2005 @@ -4,9 +4,7 @@ ((yoffset :initform 0 :accessor staff-yoffset))) (define-added-mixin dnote () note - (;; the relative x offset of the note with respect to the cluster - (final-relative-note-xoffset :accessor final-relative-note-xoffset) - (final-accidental :initform nil :accessor final-accidental) + ((final-accidental :initform nil :accessor final-accidental) ;; The relative x offset of the accidental of the note with respect ;; to the cluster. A value of nil indicates that accidental has ;; not been placed yet @@ -433,36 +431,6 @@ (loop for note in notes do (draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note)))) -;;; given a group of notes (i.e. a list of notes, all displayed on the -;;; same staff, compute their final x offsets. This is a question of -;;; determining whether the note goes to the right or to the left of -;;; the stem. The head-note of the stem goes to the left of an -;;; up-stem and to the right of a down-stem. The x offset of a cluster -;;; gives the x position of the head-note. -(defun compute-final-relative-note-xoffsets (group direction) - (setf group (sort (copy-list group) - (if (eq direction :up) - (lambda (x y) (< (note-position x) (note-position y))) - (lambda (x y) (> (note-position x) (note-position y)))))) - (score-pane:with-suspended-note-offset offset - ;; the first element of the group is the head-note - (setf (final-relative-note-xoffset (car group)) 0) - ;; OFFSET is a positive quantity that determines the - ;; absolute difference between the x offset of a suspended - ;; note and that of a normally positioned note. - (when (eq direction :down) (setf offset (- offset))) - (loop for note in (cdr group) - and old-note = (car group) then note - do (let* ((pos (note-position note)) - (old-pos (note-position old-note)) - ;; if adjacent notes are just one staff step apart, - ;; then one must be suspended. - (dx (if (= (abs (- pos old-pos)) 1) offset 0))) - (setf (final-relative-note-xoffset note) dx) - ;; go back to ordinary offset - (when (= (abs (- pos old-pos)) 1) - (setf note old-note)))))) - ;;; 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. @@ -610,15 +578,6 @@ (setf (final-relative-accidental-xoffset choice) (accidental-min-xoffset choice notes staff-step)))))) -;;; 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. -(defun group-notes-by-staff (notes) - (let ((groups '())) - (loop while notes do - (push (remove (staff (car notes)) notes :test-not #'eq :key #'staff) groups) - (setf notes (remove (staff (car notes)) notes :test #'eq :key #'staff))) - groups)) - ;;; draw a cluster. The stem direction and the stem position have ;;; already been computed. ;;; 1. Group notes by staff. @@ -639,7 +598,6 @@ (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) (loop for group in groups do - (compute-final-relative-note-xoffsets group direction) (compute-final-accidentals group) (compute-final-relative-accidental-xoffset group x direction) (draw-notes pane group (dots element) (notehead element)) Index: gsharp/gsharp.asd diff -u gsharp/gsharp.asd:1.1 gsharp/gsharp.asd:1.2 --- gsharp/gsharp.asd:1.1 Tue Nov 1 18:19:51 2005 +++ gsharp/gsharp.asd Mon Nov 21 21:37:45 2005 @@ -27,13 +27,13 @@ "gf" "sdl" "charmap" + "score-pane" "buffer" "numbering" "Obseq/obseq" "measure" "postscript" "glyphs" - "score-pane" "beaming" "drawing" "cursor" Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.11 gsharp/measure.lisp:1.12 --- gsharp/measure.lisp:1.11 Mon Nov 21 03:11:08 2005 +++ gsharp/measure.lisp Mon Nov 21 21:37:45 2005 @@ -18,7 +18,17 @@ ;;; Note (defrclass rnote note - ()) + (;; the relative x offset of the note with respect to the cluster + (final-relative-note-xoffset :accessor final-relative-note-xoffset))) + +;;; 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. +(defun group-notes-by-staff (notes) + (let ((groups '())) + (loop while notes do + (push (remove (staff (car notes)) notes :test-not #'eq :key #'staff) groups) + (setf notes (remove (staff (car notes)) notes :test #'eq :key #'staff))) + groups)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -342,6 +352,39 @@ (append (merge 'list (butlast bar1) (butlast bar2) #'<) (list (max (car (last bar1)) (car (last bar2)))))) +;;; given a group of notes (i.e. a list of notes, all displayed on the +;;; same staff, compute their final x offsets. This is a question of +;;; determining whether the note goes to the right or to the left of +;;; the stem. The head-note of the stem goes to the left of an +;;; up-stem and to the right of a down-stem. The x offset of a cluster +;;; gives the x position of the head-note. +(defun compute-final-relative-note-xoffsets (group direction) + (setf group (sort (copy-list group) + (if (eq direction :up) + (lambda (x y) (< (note-position x) (note-position y))) + (lambda (x y) (> (note-position x) (note-position y)))))) + (score-pane:with-suspended-note-offset offset + ;; the first element of the group is the head-note + (setf (final-relative-note-xoffset (car group)) 0) + ;; OFFSET is a positive quantity that determines the + ;; absolute difference between the x offset of a suspended + ;; note and that of a normally positioned note. + (when (eq direction :down) (setf offset (- offset))) + (loop for note in (cdr group) + and old-note = (car group) then note + do (let* ((pos (note-position note)) + (old-pos (note-position old-note)) + ;; if adjacent notes are just one staff step apart, + ;; then one must be suspended. + (dx (if (= (abs (- pos old-pos)) 1) offset 0))) + (setf (final-relative-note-xoffset note) dx) + ;; go back to ordinary offset + (when (= (abs (- pos old-pos)) 1) + (setf note old-note)))))) + +(defun compute-staff-group-parameters (staff-group stem-direction) + (compute-final-relative-note-xoffsets staff-group stem-direction)) + ;;; compute some important parameters of an element (defgeneric compute-element-parameters (element)) @@ -350,20 +393,26 @@ (defmethod compute-element-parameters ((element cluster)) (when (non-empty-cluster-p element) - (compute-top-bot-pos element))) + (compute-top-bot-pos element) + (loop for staff-group in (group-notes-by-staff (notes element)) + do (compute-staff-group-parameters staff-group (final-stem-direction 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 (non-empty-cluster-p element) + (compute-top-bot-pos element)) + (setf any-element-modified t))) (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))))) + (compute-final-stem-directions elements))) + (loop for element in elements + do (when (modified-p element) + (compute-element-parameters element) + (setf (modified-p element) nil))))) ;;; 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 @@ -416,18 +465,19 @@ ;;; to indicate the position of the measure in the sequence of all ;;; measures of the buffer. (defun compute-measure (bars spacing-style seg-pos bar-pos) - (loop for bar in bars - do (when (modified-p bar) - (compute-bar-parameters bar) - (setf (modified-p bar) nil))) - (let* ((start-times (remove-duplicates - (reduce #'combine-bars - (mapcar #'start-times bars)))) - (durations (abs-rel start-times)) - (min-dist (reduce #'min durations)) - (coeff (loop for duration in durations - sum (expt duration spacing-style)))) - (make-measure min-dist coeff start-times seg-pos bar-pos bars))) + (score-pane:with-staff-size 6 + (loop for bar in bars + do (when (modified-p bar) + (compute-bar-parameters bar) + (setf (modified-p bar) nil))) + (let* ((start-times (remove-duplicates + (reduce #'combine-bars + (mapcar #'start-times bars)))) + (durations (abs-rel start-times)) + (min-dist (reduce #'min durations)) + (coeff (loop for duration in durations + sum (expt duration spacing-style)))) + (make-measure min-dist coeff start-times seg-pos bar-pos bars)))) ;;; Compute all the measures of a segment by stepping through all the ;;; bars in parallel as long as there is at least one simultaneous bar. Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.31 gsharp/packages.lisp:1.32 --- gsharp/packages.lisp:1.31 Mon Nov 21 03:11:08 2005 +++ gsharp/packages.lisp Mon Nov 21 21:37:45 2005 @@ -1,3 +1,16 @@ +(defpackage :esa + (:use :clim-lisp :clim) + (:export #:minibuffer-pane #:display-message + #:esa-pane-mixin #:previous-command + #:info-pane #:master-pane + #:esa-frame-mixin #:windows #:recordingp #:executingp + #:*numeric-argument-p* #:*current-gesture* + #:esa-top-level #:simple-command-loop + #:global-esa-table #:keyboard-macro-table + #:help-table + #:set-key + #:find-applicable-command-table)) + (defpackage :gsharp-utilities (:shadow built-in-class) (:use :clim-lisp :clim-mop) @@ -33,6 +46,20 @@ #:+glyph-flags-up-two+ #:+glyph-flags-up-three+ #:+glyph-flags-up-four+ #:+glyph-flags-up-five+)) +(defpackage :score-pane + (:use :clim :clim-extensions :clim-lisp :sdl :esa) + (:shadow #:rest) + (:export #:draw-fiveline-staff #:draw-lyrics-staff + #:draw-stem #:draw-right-stem #:draw-left-stem + #:draw-ledger-line #:draw-bar-line #:draw-beam #:staff-step + #:draw-notehead #:draw-accidental #:draw-clef #:draw-rest #:draw-dot + #:draw-flags-up #:draw-flags-down + #:with-score-pane #:with-vertical-score-position + #:with-staff-size #:with-notehead-right-offsets + #:with-suspended-note-offset + #:with-notehead-left-offsets #:with-light-glyphs #:score-pane + #:clef #:staff #:fiveline-staff #:lyrics-staff #:notehead)) + (defpackage :gsharp-buffer (:use :common-lisp :gsharp-utilities) (:shadow #:rest) @@ -104,7 +131,8 @@ #:measure-seq-cost #:note-position #:non-empty-cluster-p #:top-note #:bot-note #:top-note-pos #:bot-note-pos - #:beam-groups #:final-stem-direction)) + #:beam-groups #:final-stem-direction + #:group-notes-by-staff #:final-relative-note-xoffset)) (defpackage :gsharp-postscript (:use :clim :clim-lisp) @@ -131,33 +159,6 @@ #:8th-flag-down #:extend-flag-down #:whole-rest #:half-rest #:quarter-rest #:8th-rest #:16th-rest #:32nd-rest #:64th-rest #:128th-rest #:measure-rest #:double-whole-rest)) - -(defpackage :esa - (:use :clim-lisp :clim) - (:export #:minibuffer-pane #:display-message - #:esa-pane-mixin #:previous-command - #:info-pane #:master-pane - #:esa-frame-mixin #:windows #:recordingp #:executingp - #:*numeric-argument-p* #:*current-gesture* - #:esa-top-level #:simple-command-loop - #:global-esa-table #:keyboard-macro-table - #:help-table - #:set-key - #:find-applicable-command-table)) - -(defpackage :score-pane - (:use :clim :clim-extensions :clim-lisp :sdl :esa) - (:shadow #:rest) - (:export #:draw-fiveline-staff #:draw-lyrics-staff - #:draw-stem #:draw-right-stem #:draw-left-stem - #:draw-ledger-line #:draw-bar-line #:draw-beam #:staff-step - #:draw-notehead #:draw-accidental #:draw-clef #:draw-rest #:draw-dot - #:draw-flags-up #:draw-flags-down - #:with-score-pane #:with-vertical-score-position - #:with-staff-size #:with-notehead-right-offsets - #:with-suspended-note-offset - #:with-notehead-left-offsets #:with-light-glyphs #:score-pane - #:clef #:staff #:fiveline-staff #:lyrics-staff #:notehead)) (defpackage :gsharp-beaming (:use :common-lisp)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs November 2005