[fomus-cvs] CVS update: fomus/test.lisp fomus/TODO fomus/beams.lisp fomus/package.lisp fomus/quantize.lisp fomus/split.lisp fomus/staves.lisp
David Psenicka
dpsenicka at common-lisp.net
Wed Jul 27 06:57:40 UTC 2005
Update of /project/fomus/cvsroot/fomus
In directory common-lisp.net:/tmp/cvs-serv31290
Modified Files:
TODO beams.lisp package.lisp quantize.lisp split.lisp
staves.lisp
Added Files:
test.lisp
Log Message:
Testing/bug fixes
Date: Wed Jul 27 08:57:38 2005
Author: dpsenicka
Index: fomus/TODO
diff -u fomus/TODO:1.6 fomus/TODO:1.7
--- fomus/TODO:1.6 Tue Jul 26 08:00:57 2005
+++ fomus/TODO Wed Jul 27 08:57:37 2005
@@ -3,13 +3,10 @@
IMMEDIATE
Testing and bug fixes
-DOC: Information on anonymous CVS downloading
DOC: dynamic marks can take order arguments (backend might not support it)
-DOC: other interface functions
-DOC: part properties
Adjust scores and penalties for decent results
Breath marks (resolve before/after)
-Noteheads
+Note heads
Finish fingering mark (no finger number argument)
@@ -30,6 +27,7 @@
Integrate user graceslur overrides
Levels for single text marks
Remove redundant dynamic marks
+Easier grace note numbering
Index: fomus/beams.lisp
diff -u fomus/beams.lisp:1.2 fomus/beams.lisp:1.3
--- fomus/beams.lisp:1.2 Tue Jul 26 01:15:53 2005
+++ fomus/beams.lisp Wed Jul 27 08:57:37 2005
@@ -93,7 +93,7 @@
collect e0
do (incf o (event-writtendur e0 ts dmu))
finally (setf ee ee0)))) ; x is in forward order
- (when re (push re rr) (setf re nil)) ; first of re is the largest offset
+ (when re (push re rr) (setf re nil)) ; first of re is the largest offset
(let ((xr (spt x nil nil (event-tupdurmult e) (1+ tf))))
(when xa (nconc (last-element xr) (list xa))) ; "prepend" for continuous beaming
xr))
@@ -129,19 +129,20 @@
when (and (notep e0) (notep e1))
do (setf (event-beamrt e1) (min dv (event-nbeams e0 ts) (event-nbeams e1 ts)))))
(cons spf spb))))
- (fb (spf spb)
+ (fb (spf spb)
(let ((ll nil) (lr nil)) ; fix beams that don't have enough
+ ;;(debugn-if (= (meas-off m) 8) "~A" spf)
(loop for ee in spf
do (loop
for (e0 e1) on ee while e1
- for nb = (event-nbeams e1 ts) ;(min dv (event-nbeams e1 ts))
- when (and (notep e0) (notep e1) (> (event-nbeams e0 ts) 0)
+ for nb = (event-nbeams e1 ts)
+ when (and (notep e0) (notep e1) (> (event-beamrt e0) 0) ; (event-nbeams e0 ts)
(and (< (event-beamlt e1) nb) (< (event-beamrt e1) nb)))
do (push (cons (event-nbeams e1 ts) e1) ll)))
(loop for ee in spb
do (loop for (e0 e1) on ee while e1
- for nb = (event-nbeams e1 ts) ;(min dv (event-nbeams e1 ts))
- when (and (notep e0) (notep e1) (> (event-nbeams e0 ts) 0)
+ for nb = (event-nbeams e1 ts)
+ when (and (notep e0) (notep e1) (> (event-beamlt e0) 0) ; (event-nbeams e0 ts)
(and (< (event-beamlt e1) nb) (< (event-beamrt e1) nb)))
do (push (cons (event-nbeams e1 ts) e1) lr)))
(loop for (nb . e) in ll do (setf (event-beamlt e) nb))
@@ -163,12 +164,11 @@
finally
(loop for (f . b) in (nreverse ag) do (fb f b))
(fb (list evs) (list (reverse evs))))))
- (let ((gg (split-into-groups grs #'event-off)))
+ (let ((gg (mapcar (lambda (x) (sort x #'sort-offdur)) (split-into-groups grs #'event-off))))
(loop for gr in gg
- do (loop for (e0 e1 e2) on gr while e2
+ do (loop for (e1 e2) on gr while e2
for nb = (event-nbeams e1 ts)
- when (and (notep e0) (notep e1)) do (setf (event-beamlt e1) (min (event-nbeams e0 ts) nb))
- when (and (notep e1) (notep e2)) do (setf (event-beamrt e1) (min (event-nbeams e2 ts) nb))))
+ when (and (notep e1) (notep e2)) do (let ((x (min (event-nbeams e2 ts) nb))) (setf (event-beamrt e1) x (event-beamlt e2) x))))
(let ((ll nil) (lr nil)) ; fix beams that don't have enough
(loop for ee in gg
do (loop for (e0 e1) on ee while e1
Index: fomus/package.lisp
diff -u fomus/package.lisp:1.5 fomus/package.lisp:1.6
--- fomus/package.lisp:1.5 Tue Jul 26 01:15:53 2005
+++ fomus/package.lisp Wed Jul 27 08:57:37 2005
@@ -48,7 +48,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 4))
+(defparameter +version+ '(0 1 5))
(defparameter +banner+
`("Lisp music notation formatter"
"Copyright (c) 2005 David Psenicka, All Rights Reserved"
Index: fomus/quantize.lisp
diff -u fomus/quantize.lisp:1.4 fomus/quantize.lisp:1.5
--- fomus/quantize.lisp:1.4 Tue Jul 26 01:15:53 2005
+++ fomus/quantize.lisp Wed Jul 27 08:57:37 2005
@@ -18,7 +18,7 @@
(defun auto-quantize-fun () (if (eq *auto-quantize-fun* :default) :quantize1 *auto-quantize-fun*))
(defparameter *auto-quantize* t)
-(defparameter *default-grace-dur* 1/2) ; dur, grace#
+(defparameter *default-grace-dur* 1/4) ; dur, grace#
(defparameter *default-grace-num* 0)
(defun byfit-score (evpts qpts)
@@ -114,8 +114,7 @@
((> (event-off e) e1) (push (cons (cons #'<= (event-off e)) e1) ad))) ; <--
(setf (event-off e) e1
(event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s))))))
- (let ((x (roundto (event-gracedur e) bd)))
- (when (<= x 0) bd x)))))
+ (max bd (roundto (event-gracedur e) bd)))))
(let ((e2 (let ((o (event-endoff e))) (loop-return-lastmin (diff x o) for x in qs))))
(aa (event-off e) e1)
(setf (event-off e) e1)
Index: fomus/split.lisp
diff -u fomus/split.lisp:1.4 fomus/split.lisp:1.5
--- fomus/split.lisp:1.4 Tue Jul 26 01:15:53 2005
+++ fomus/split.lisp Wed Jul 27 08:57:37 2005
@@ -103,7 +103,7 @@
;; adds rests, ties overlapping notes of different durs
;; returns values: notes in measure, notes outside measure
;; expects voices separated into parts, input is sorted, output is sorted
-(defun split-preproc (evs off endoff)
+(defun split-preproc (evs off endoff voc)
(multiple-value-bind (gs ns) (split-list evs #'event-grace)
(loop ; get rid of unison overlaps
for el on ns
@@ -120,12 +120,11 @@
(lambda (x y) (and (= (event-note* x) (event-note* y))
(= (event-off x) (event-off y))
(= (event-grace x) (event-grace y))))))
- (setf ns (let ((vc (if ns (event-voice* (first ns)) 1))) ; fill holes w/ rests
- (nconc (mapcar (lambda (x) (make-restex :off (car x) :dur (- (cdr x) (car x)) :voice vc))
- (get-holes (merge-linear (mapcar (lambda (x) (cons (event-off x) (event-endoff x))) ns)
- (lambda (x y) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
- off endoff))
- ns)))
+ (setf ns (nconc (mapcar (lambda (x) (make-restex :off (car x) :dur (- (cdr x) (car x)) :voice voc))
+ (get-holes (merge-linear (mapcar (lambda (x) (cons (event-off x) (event-endoff x))) ns)
+ (lambda (x y) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
+ off endoff))
+ ns))
(loop
for x in ns ; split overlapping events
collect (event-off x) into s
@@ -144,7 +143,7 @@
(setf gs (loop
for e in (split-into-groups gs (lambda (x) (cons (event-off x) (event-grace x))) :test 'equal) ; put vertical notes into chords (note = list of notes, combine all attributes)
if (list>1p e) collect (make-chord e) else collect (first e)))
- (loop ; split places at grace note offsets
+ (loop ; split places at grace note offsets
for g in gs
for i = (event-off g)
do (setf ns (loop
@@ -163,7 +162,9 @@
(loop
with r ; leftover tied notes
for m in (part-meas p) do
- (multiple-value-bind (e n) (split-preproc (nconc r (meas-events m)) (meas-off m) (meas-endoff m))
+ (multiple-value-bind (e n) (split-preproc (nconc r (meas-events m)) (meas-off m) (meas-endoff m)
+ (let ((i (find-if #'meas-events (part-meas p))))
+ (if i (event-voice* (first (meas-events i))) 1)))
(setf (meas-events m) e r n)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Index: fomus/staves.lisp
diff -u fomus/staves.lisp:1.2 fomus/staves.lisp:1.3
--- fomus/staves.lisp:1.2 Tue Jul 26 01:15:53 2005
+++ fomus/staves.lisp Wed Jul 27 08:57:37 2005
@@ -275,7 +275,7 @@
(defun distr-rests-byconfl (parts)
(loop
with rl and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible
- for p in parts
+ for p in (remove-if #'is-percussion parts)
for sv = (> (instr-staves (part-instr p)) 1) do
(loop
for v in (loop with v for m in (part-meas p) do (loop for e in (meas-events m) do (pushnew (event-voice* e) v)) finally (return v)) do
More information about the Fomus-cvs
mailing list