Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv14351
Modified Files: CHANGELOG TODO accidentals.lisp classes.lisp data.lisp fomus.asd postproc.lisp quantize.lisp splitrules.lisp staves.lisp test.lisp util.lisp version.lisp voices.lisp Log Message: testing/bug fixes Date: Tue Aug 30 00:28:04 2005 Author: dpsenicka
Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.8 fomus/CHANGELOG:1.9 --- fomus/CHANGELOG:1.8 Sat Aug 27 20:13:21 2005 +++ fomus/CHANGELOG Tue Aug 30 00:28:03 2005 @@ -1,6 +1,17 @@ +v0.1.11 + + Testing/bug fixes: + errors involving 0 durations + parsing user input + user rests and rest marks + switching functionality on/off w/ auto- settings + Support for user rests, pizz/arco markings + v0.1.10
- Testing/bug fixes: quantizing (integrated with splitting/tying now) + Testing/bug fixes: + quantizing (integrated with splitting/tying now) + many other bugs Automatic durations for percussion instruments
v0.1.9
Index: fomus/TODO diff -u fomus/TODO:1.15 fomus/TODO:1.16 --- fomus/TODO:1.15 Sat Aug 27 20:13:21 2005 +++ fomus/TODO Tue Aug 30 00:28:03 2005 @@ -3,13 +3,15 @@ Immediate:
Testing and bug fixes - Nested tuplets - Splitting chords across staves + Nested tuplets not working yet + Automatic multivoice notes not working yet + Splitting chords across staves (LilyPond) :STAFF and other marks for overriding FOMUS's decisions MusicXML backend MIDI output to CM Avoid staff changes when notes move in other direction - Proofread/finish documentation, add many easy examples + Durations that fill to next/previous note + Proofread/finish documentation, add easy examples
Short Term:
Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.9 fomus/accidentals.lisp:1.10 --- fomus/accidentals.lisp:1.9 Sun Aug 21 21:17:40 2005 +++ fomus/accidentals.lisp Tue Aug 30 00:28:03 2005 @@ -18,7 +18,7 @@
(declaim (type boolean *auto-accidentals* *auto-cautionary-accs*)) (defparameter *auto-accidentals* t) -(defparameter *auto-cautionary-accs* t) +(defparameter *auto-cautionary-accs* nil)
;; NOKEY!
@@ -191,7 +191,7 @@ (let ((x (event-useracc f))) (if (and (listp x) (listp (rest x))) x (list x)))) - cho :key #'equal) ; e = lists of accs. + cho :test #'equal) ; e = lists of accs. when (funcall spellfun o a) collect a) (loop for a in cho if (funcall spellfun o a) collect a) ; ignore user's suggestion (error "No accidentals possible for note ~S at offset ~S, part ~S" (event-note f) (event-foff f) name)) @@ -305,13 +305,20 @@ (mapcar #'nokey-convert-qtone +acc-qtones-double+) +acc-double+) for e of-type (or noteex restex) in (part-events p) - for n of-type rational = (event-note* e) and a of-type (integer -2 2) = (event-acc e) and q of-type (rational -1/2 1/2) = (event-addacc e) + for n = (event-note* e) ;;and a of-type (integer -2 2) = (event-acc e) and q of-type (rational -1/2 1/2) = (event-addacc e) + for ua = (let ((u (event-useracc e))) + (if (list1p u) (if (consp (first u)) (first u) (cons (first u) 0)) + (if u (error "Only one accidental allowed when :AUTO-ACCIDENTALS is NIL in note at offset ~S, part ~S" (event-foff e) (part-name p)) + (cons 0 0)))) unless (and (if *quartertones* - (find (cons a q) cho :test #'equal) - (find a cho)) - (nokeyq-spell n (list a q))) - do (error "Invalid note spelling ~S at offset ~S, part ~S" (cond ((/= q 0) (list n a q)) ((/= a 0) (list n a)) (t (list n))) - (event-foff e) (part-name p))))) + (find ua cho :test #'equal) + (find (car ua) cho)) + (nokeyq-spell n ua)) + do (error "Invalid note spelling ~S at offset ~S, part ~S" (cond ((/= (cdr ua) 0) (list n (car ua) (cdr ua))) + ((/= (car ua) 0) (list n (car ua))) + (t (list n))) + (event-foff e) (part-name p)) + do (setf (event-note e) (cons n ua)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CAUTIONARY ACCIDENTALS @@ -325,8 +332,8 @@ (defparameter *caut-acc-ottavas* t) (defparameter *caut-acc-octaves* 1) ; can be a number (for number of octaves above/below) or t for all
-(defparameter *caut-acc-next-meas* nil) -(defparameter *caut-acc-after-one-meas* nil) ; no cautionary accidental after one measure +(defparameter *caut-acc-next-meas* t) +(defparameter *caut-acc-after-one-meas* t) ; no cautionary accidental after one measure
;; rests are removed already, before chords or ties (defun acc-nokey-cautaccs (meas)
Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.10 fomus/classes.lisp:1.11 --- fomus/classes.lisp:1.10 Sun Aug 28 06:32:47 2005 +++ fomus/classes.lisp Tue Aug 30 00:28:03 2005 @@ -143,7 +143,8 @@ (if (consp (event-note ev)) (let ((x (cdr (event-note ev)))) (declare (type (or cons rational) x)) - (if (consp x) (the rational (cdr x)) 0)) 0)) + (if (consp x) (the rational (cdr x)) 0)) + 0)) (defun event-addaccs (ev) (declare (type note ev)) (mapcar (lambda (e)
Index: fomus/data.lisp diff -u fomus/data.lisp:1.16 fomus/data.lisp:1.17 --- fomus/data.lisp:1.16 Sun Aug 28 23:31:27 2005 +++ fomus/data.lisp Tue Aug 30 00:28:03 2005 @@ -82,19 +82,19 @@ (no (note-to-num (if (consp no) (first no) no)))) (if a (cons no (mapcar (lambda (x) (if (and (listp x) (list>1p x)) - (cons (acc-to-num (first x)) (acc-to-num (second x))) - (acc-to-num x))) + (cons (acc-to-num (first x) 1) (acc-to-num (second x) 1/2)) + (acc-to-num x 1))) a)) no)))
(declaim (type cons +accnum+)) (defparameter +accnum+ '(("S" . 1) ("+" . 1) ("F" . -1) ("-" . -1) ("SS" . 2) ("++" . 2) ("FF" . -2) ("--" . -2) ("N" . 0))) ;;(declaim (inline acc-to-num)) -(defun acc-to-num (acc) +(defun acc-to-num (acc prec) (if (symbolp acc) (lookup (symbol-name acc) +accnum+ :test #'string=) - (roundto acc *note-precision*))) + (roundto acc prec))) (defun is-acc (acc) - (or (realp acc) (find (symbol-name acc) +accnum+ :key #'car :test #'string=))) + (typecase acc (real acc) (symbol (find (symbol-name acc) +accnum+ :key #'car :test #'string=))))
(defun dur-to-num (dur bt) (if (and *cm-rhythmfun* *use-cm* (symbolp dur)) @@ -627,8 +627,13 @@
;; include :staff but not :clef (defparameter +marks-rests+ - '(:fermata :breath :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- + '(:fermata :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- :text- :endtext- #|:starttexttempo- :starttextdyn-|# :starttext-)) + +(defparameter +marks-first-rest+ + '(:textnote :texttempo :textdyn :text :text- :starttext-)) +(defparameter +marks-last-rest+ + '(:fermata :endtext-))
(declaim (inline is-restmarksym)) (defun is-restmarksym (sym)
Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.7 fomus/fomus.asd:1.8 --- fomus/fomus.asd:1.7 Sun Aug 28 23:31:27 2005 +++ fomus/fomus.asd Tue Aug 30 00:28:03 2005 @@ -4,7 +4,7 @@ (asdf:defsystem "fomus"
:description "Lisp music notation formatter" - :version "0.1.10" + :version "0.1.11" :author "David Psenicka" :licence "LLGPL"
Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.8 fomus/postproc.lisp:1.9 --- fomus/postproc.lisp:1.8 Sat Aug 27 20:13:21 2005 +++ fomus/postproc.lisp Tue Aug 30 00:28:03 2005 @@ -264,8 +264,9 @@ (loop for g of-type list in (meas-voices m) do (loop for e of-type (or noteex restex) in g + do (rmmark e b) if (getmark e a) do (if o (rmmark e a) (setf o t)) - else when o do (addmark e b) (setf o nil)))) + else when (and o (notep e) (not (or-list (force-list (event-tielt e))))) do (addmark e b) (setf o nil)))) (print-dot))))
;; preproc-tremolos already @@ -359,38 +360,51 @@ (declare (type list pts)) (loop for p of-type partex in pts do (loop for m of-type meas in (part-meas p) - do (loop with a = (loop for v of-type list in (meas-voices m) append (remove-if (lambda (x) (declare (type (or noteex restex) x)) (and (restp x) (event-inv x))) v)) + do (loop with a = (loop for v of-type list in (meas-voices m) + append (remove-if (lambda (x) (declare (type (or noteex restex) x)) (and (restp x) (event-inv x))) v)) for v of-type list in (meas-voices m) - do (loop for e of-type (or noteex restex) in v - for tx = (or (popmark e :starttext-) - (popmark e :startwedge<) (popmark e :startwedge>) (popmark e :startlongtrill-) - (popmark e :text) (popmark e :texttempo) (popmark e :textdyn) (popmark e :textnote)) - while tx do - (loop with o = (event-voice* e) - for y of-type (integer 1 4) in (delete-duplicates - (loop for x of-type (or noteex restex) in a - when (and (= (event-staff x) (event-staff e)) - (/= (event-voice* x) o) - (> (event-endoff x) (event-off a)) - (< (event-off x) (event-endoff a))) - collect (event-voice* x))) - count (< y o) into u ; number of voices above text note - count (> y o) into d ; number of voices below text note - finally - (cond ((= d u) - (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list (or (find :up tx) (find :down tx) (if (find (first tx) +marks-defaultup+) :up :down)) - (find-if #'stringp tx)))))) - ((< d u) (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list :down (find-if #'stringp tx)))))) - ((> d u) (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list :up (find-if #'stringp tx))))))))))) (print-dot))) + do (loop for e of-type (or noteex restex) in v do + (loop + with mks + for tx = (or (popmark e :starttext-) + (popmark e :startwedge<) (popmark e :startwedge>) (popmark e :startlongtrill-) + (popmark e :text) (popmark e :texttempo) (popmark e :textdyn) (popmark e :textnote)) + while tx do + (loop with o = (event-voice* e) + for y of-type (integer 1 4) + in (delete-duplicates + (loop for x of-type (or noteex restex) in a + when (and (= (event-staff x) (event-staff e)) + (/= (event-voice* x) o) + (> (event-endoff x) (event-off a)) + (< (event-off x) (event-endoff a))) + collect (event-voice* x))) + count (< y o) into u ; number of voices above text note + count (> y o) into d ; number of voices below text note + finally + (cond ((= d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list (or (find :up tx) (find :down tx) (if (or (find (first tx) +marks-defaultup+) + (>= (event-staff e) (instr-staves (part-instr p)))) + :up :down)) + (find-if #'stringp tx)))) + mks)) + ((< d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list :down (find-if #'stringp tx)))) + mks)) + ((> d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list :up (find-if #'stringp tx)))) + mks)))) + finally (mapc (lambda (m) (declare (type cons m)) (addmark e m)) mks))))) + (print-dot))) ;; not included with other postprocs here--in fomus-proc function (defun postpostproc-sortprops (pts)
Index: fomus/quantize.lisp diff -u fomus/quantize.lisp:1.10 fomus/quantize.lisp:1.11 --- fomus/quantize.lisp:1.10 Sat Aug 27 20:13:21 2005 +++ fomus/quantize.lisp Tue Aug 30 00:28:03 2005 @@ -162,7 +162,7 @@ (defun quantize-generic (parts) (loop for p in parts do (loop for e in (part-events p) do - (setf (event-dur* e) (rationalize (event-dur* e)) (event-off e) (rationalize (event-off e)))))) + (setf (event-dur* e) (rationalize (or (event-gracedur e) (event-dur* e))) (event-off e) (rationalize (event-off e))))))
#|(cons pts (list o1 o2))|# #|(cons nil nil)|# ;; (uu00 (i)
Index: fomus/splitrules.lisp diff -u fomus/splitrules.lisp:1.2 fomus/splitrules.lisp:1.3 --- fomus/splitrules.lisp:1.2 Sun Aug 28 23:31:27 2005 +++ fomus/splitrules.lisp Tue Aug 30 00:28:03 2005 @@ -182,7 +182,7 @@ (when (and (al *shortlongshort-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) ex (or (not (rule-comp rule)) (>= num 4))) (list (list '(1/4 3/4) (si 1/4 :l t t) (snd 1/2 t t) (si 1/4 :r t t)))) ; longer note in middle - (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3)) + (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) (>= num 3) (not (rule-comp rule))) (cond ((integerp num) (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation
Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.8 fomus/staves.lisp:1.9 --- fomus/staves.lisp:1.8 Sun Aug 28 06:32:47 2005 +++ fomus/staves.lisp Tue Aug 30 00:28:03 2005 @@ -315,7 +315,7 @@ (defun distr-rests-byconfl (parts) (declare (type list parts)) (loop - with rl of-type (cons (cons (rational 0) (rational 0)) list) + with rl of-type list ; (cons (cons (rational 0) (rational 0)) list) and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible for p of-type partex in (remove-if #'is-percussion parts) for sv = (> (instr-staves (part-instr p)) 1) do
Index: fomus/test.lisp diff -u fomus/test.lisp:1.7 fomus/test.lisp:1.8 --- fomus/test.lisp:1.7 Sun Aug 28 23:31:27 2005 +++ fomus/test.lisp Tue Aug 30 00:28:03 2005 @@ -523,8 +523,7 @@ :marks (when (<= (random 3) 0) '(:staccato)))))))
-;; MusicXML -;; (not working yet) +;; MusicXML (not working yet)
(fomus :backend '((:data) (:musicxml)) @@ -571,7 +570,7 @@ :name "Piano" :instr :piano :events - (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata)) + (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata (:text "Here!"))) (loop for off from 0 below 19/2 by 1/2 collect (make-note :off off @@ -580,7 +579,291 @@ :marks (when (<= (random 3) 0) '(:staccato))))))))
+;; Auto Pizz/Arco + +(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :beat-division 8 + :quartertones t + :parts (list + (make-part + :name "Violin" + :instr :violin)) + :events (loop repeat 5 + for off = (random 1.0) then (+ off (1+ (random 1.0))) + and dur = (random 1.0) + collect (make-note :off off + :dur dur + :note (+ 55 (/ (random 25) 2)) + :marks (case (random 2) + (0 '(:pizz)))))) + ;; Auto On/Offs + +(fomus ; :auto-accidentals + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + and note = (+ 48 (random 25)) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note (list note (svref #(0 -1 0 -1 0 0 1 0 -1 0 -1 0) (mod note 12)))))))) + +(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :quartertones t + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note '(60.5 (-1 -0.5))))))) + +(fomus ; :auto-cautionary-accs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :auto-cautionary-accs t + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + and note = (+ 48 (random 25)) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note (list note (svref #(0 -1 0 -1 0 0 1 0 -1 0 -1 0) (mod note 12)))))))) + +(fomus ; :auto-ottavas + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-ottavas nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 20 by 1/2 + and note = (+ 72 (random 37)) + collect (make-note :off off + :dur (if (< off 20) 1/2 1) + :note note))))) + +(fomus ; :auto-voicing + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-voicing nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :voice '(1) ; (1+ (random 2)) + :dur (if (< off 10) 1/2 1) + :note (+ 48 (random 25))))))) + +(fomus ; :auto-grace-slurs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-grace-slurs nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-beams + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-beams nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-quantize + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-quantize nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-staff/clef-changes + :backend '((:data) (:lilypond :view t )) + :ensemble-type :orchestra + :quality 1/2 + :auto-staff/clef-changes nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 100 by 1/2 + collect (make-note :off off + :dur (if (< off 100) 1/2 1) + :note (+ 48 (random 25))))))) + +(fomus ; :auto-multivoice-rests + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-multivoice-rests nil + :parts (list + (make-part + :name "Percussion" + :instr (list :percussion :percs (list (make-perc :woodblock :voice 1 :note 'e4) + (make-perc :snaredrum :voice 2 :note 'a3))) + :events (loop for o from 0 to 50 by 1/2 when (= (random 4) 0) collect + (make-note :off o :dur 1/2 + :note (case (random 2) + (0 :woodblock) + (1 :snaredrum))))))) + +(fomus ; :auto-multivoice-notes (not working yet) + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Violin" + :instr :violin + :events + (loop repeat 2 nconc + (loop + for off from 0 to 40 by 1/2 + collect (make-note :off off + :voice '(1 2) + :dur (if (< off 40) 1/2 1) + :note (+ 55 (random 19)))))))) + +(fomus ; :auto-percussion-durs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-percussion-durs nil + :parts (list + (make-part + :name "Percussion" + :instr (list :percussion :percs (list (make-perc :woodblock :note 'e4 :autodur t) + (make-perc :snaredrum :note 'a3 :autodur t))) + :events (loop for o from 0 to 40 by 1/2 when (= (random 2) 0) collect + (make-note :off o + :note (case (random 2) + (0 :woodblock) + (1 :snaredrum))))))) + +(fomus ; :auto-pizz/arco + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :beat-division 8 + :quartertones t + :auto-pizz/arco nil + :parts (list + (make-part + :name "Violin" + :instr :violin)) + :events (loop repeat 5 + for off = (random 1.0) then (+ off (1+ (random 1.0))) + and dur = (random 1.0) + collect (make-note :off off + :dur dur + :note (+ 55 (/ (random 25) 2)) + :marks (case (random 2) + (0 '(:pizz)) + (1 '(:arco)))))) + +(fomus ; :auto-override-timesigs + :backend '((:data) (:lilypond :view t )) + :ensemble-type :orchestra + :verbose 2 + :quality 1/2 + :auto-override-timesigs nil + :global + (list (make-timesig :off 0 :time '(4 4)) (make-timesig :off 10 :time '(4 4)) (make-timesig :off 11 :time '(4 4))) + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 20 by 1/2 + collect (make-note :off off + :dur (if (< off 20) 1/2 1) + :note (+ 48 (random 25)) + :marks (when (<= (random 3) 0) + '(:staccato))))))) + ;; User Overrides -;; Auto Pizz/Arco +;; Grace note rests ;; Mark Spanners +;; Compound meter +;; Auto Time Signatures \ No newline at end of file
Index: fomus/util.lisp diff -u fomus/util.lisp:1.12 fomus/util.lisp:1.13 --- fomus/util.lisp:1.12 Sun Aug 28 23:31:27 2005 +++ fomus/util.lisp Tue Aug 30 00:28:04 2005 @@ -390,10 +390,13 @@ :off off :dur (- (event-endoff event) off) :tielt (if (chordp event) (make-list (length (event-tielt event)) :initial-element t) t)))))) - (rest (cons (copy-event event :dur (- off (event-off event)) :tup (cons tup dmu)) + (rest (cons (copy-event event :dur (- off (event-off event)) :tup (cons tup dmu) + :marks (if (event-marks event) (cons :splitlt (event-marks event)))) (if tup2 - (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons tup2 dmu)) - (copy-event event :off off :dur (- (event-endoff event) off))))))))) + (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons tup2 dmu) + :marks (if (event-marks event) (cons :splitrt (event-marks event)))) + (copy-event event :off off :dur (- (event-endoff event) off) + :marks (if (event-marks event) (cons :splitrt (event-marks event)))))))))))
;; (declaim (inline split-event*)) (defun split-event* (event off) @@ -439,11 +442,15 @@ (loop for p of-type partex in pts do (loop for m of-type meas in (part-meas p) do (loop - for e of-type noteex in (remove-if-not #'notep (meas-events m)) - when (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo)) + for e of-type (or noteex restex) in (meas-events m) + when (and (notep e) (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo))) do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-first-tie+) - when (or (and (event-tiert e) (and-list (force-list (event-tiert e)))) (getmark e :starttremolo)) - do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-tie+))) (print-dot))) + when (and (notep e) (or (and (event-tiert e) (and-list (force-list (event-tiert e)))) (getmark e :starttremolo))) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-tie+) + when (and (restp e) (popmark e :splitrt)) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-first-rest+) + when (and (restp e) (popmark e :splitlt)) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-rest+))) (print-dot)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STAVES @@ -556,22 +563,25 @@ collect (loop with at for (ts nx) of-type (timesig (or timesig null)) - on (let ((x (merge-linear - (sort (delete-if-not (lambda (x) (or (null (timesig-partids x)) (find (part-partid p) (timesig-partids x)))) - (copy-list timesigs)) ; ts = current time sig, n = next group - #'< :key #'timesig-off) - (lambda (x y) (if (= (timesig-off x) (timesig-off y)) - (cond ((and (null (timesig-partids x)) (timesig-partids y)) y) - ((and (timesig-partids x) (null (timesig-partids y))) x) - (t (error "Conflicting time signature/part IDs assignment at offset ~S, part ~S" - (timesig-foff x) (part-name p))))))))) - (if (or (null x) (> (timesig-off (first x)) 0)) - (cons (copy-timesig dts :off 0) x) - x)) - when (or (null *auto-override-timesigs*) - (= (timesig-off ts) 0) - (null nx) - (>= (- (timesig-off nx) (timesig-off ts)) (or *min-auto-timesig-dur* 0))) + on (let ((z (let ((x (merge-linear + (sort (delete-if-not (lambda (x) (or (null (timesig-partids x)) (find (part-partid p) (timesig-partids x)))) + (copy-list timesigs)) ; ts = current time sig, n = next group + #'< :key #'timesig-off) + (lambda (x y) (if (= (timesig-off x) (timesig-off y)) + (cond ((and (null (timesig-partids x)) (timesig-partids y)) y) + ((and (timesig-partids x) (null (timesig-partids y))) x) + (t (error "Conflicting time signature/part IDs assignment at offset ~S, part ~S" + (timesig-foff x) (part-name p))))))))) + (if (or (null x) (> (timesig-off (first x)) 0)) + (cons (copy-timesig dts :off 0) x) + x)))) + (if *auto-override-timesigs* + (loop for (e1 e2) of-type (timesig (or timesig null)) on z + when (or (<= (timesig-off e1) 0) + (null e2) + (>= (- (timesig-off e2) (timesig-off e1)) (or *min-auto-timesig-dur* 0))) + collect e1) + z)) do (setf at (ut ts p (when nx (timesig-off nx)) (car at))) ; (print-dot) finally (return at))) do (ut at p mx lo) #|(print-dot)|#))))
Index: fomus/version.lisp diff -u fomus/version.lisp:1.5 fomus/version.lisp:1.6 --- fomus/version.lisp:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/version.lisp Tue Aug 30 00:28:04 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 10)) +(defparameter +version+ '(0 1 11)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"
Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.8 fomus/voices.lisp:1.9 --- fomus/voices.lisp:1.8 Sun Aug 21 21:17:41 2005 +++ fomus/voices.lisp Tue Aug 30 00:28:04 2005 @@ -176,17 +176,19 @@ :remscoregreaterfun #'remscoregreaterfun))) (error "Cannot distribute voices within limits of specified instrument in part ~S" name))))))
-(defun voices-setvoice (events) +(defun voices-setvoice (events name) (declare (type list events)) (loop for e of-type (or noteex restex) in events when (listp (event-voice e)) do - (setf (event-voice e) (if (event-voice e) (first (event-voice e)) 1)))) + (setf (event-voice e) (if (event-voice e) (if (list>1p (event-voice e)) + (error "Only one voice allowed when :AUTO-VOICING is NIL in note at offset ~S, part ~S" (event-foff e) name) + (first (event-voice e))) 1))))
;; distribute ambiguous voice assignments (lists) (defun voices (parts) (declare (type list parts)) (loop for e of-type partex in parts - if (is-percussion e) do (voices-setvoice (part-events e)) + if (is-percussion e) do (voices-setvoice (part-events e) (part-name e)) else do (multiple-value-bind (evs rs) (split-list (part-events e) #'notep) (setf (part-events e) (sort (nconc (loop ; copy rests to all voices if voice slot is a list @@ -200,7 +202,7 @@
(defun voices-generic (parts) (declare (type list parts)) - (loop for p of-type partex in parts do (voices-setvoice (part-events p)))) + (loop for p of-type partex in parts do (voices-setvoice (part-events p) (part-name p))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; COMBINE VOICES