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