- fomus-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[fomus-cvs] CVS update: fomus/marks.lisp
by dpsenicka＠common-lisp.net 15 Aug '05

15 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv2615 Modified Files: marks.lisp Log Message: Testing/bug fixes Date: Tue Aug 16 00:41:55 2005 Author: dpsenicka Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.8 fomus/marks.lisp:1.9 --- fomus/marks.lisp:1.8 Mon Aug 15 21:46:10 2005 +++ fomus/marks.lisp Tue Aug 16 00:41:53 2005 @@ -17,16 +17,19 @@ (defun grace-slurs (pts) (loop - for p in pts do + for p of-type part in pts do (loop - for e in (delete-if (lambda (x) (notany #'event-grace x)) (split-into-groups (part-events p) #'event-off)) + for e of-type cons in (delete-if (lambda (x) (declare (type cons x)) (notany #'event-grace x)) (split-into-groups (part-events p) #'event-off)) for s = (sort e (complement #'sort-offdur)) - do (loop with sl and li - for x in s - when (or (getmark x :endgraceslur-) (getmark x :graceslur-)) - do (if sl (error "Missing :STARTGRACESLUR- mark in offset offset ~S, part ~S" (event-foff e) (part-name p)) (setf sl t)) (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-) (setf li nil)) + do (loop with sl of-type boolean and li of-type list + for x of-type (or noteex restex) in s + when (or (getmark x :endgraceslur-) (getmark x :graceslur-)) do + (when sl (error "Missing :STARTGRACESLUR- mark in offset offset ~S, part ~S" (event-foff x) (part-name p))) + (setf sl t) + (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-) (setf li nil)) unless sl do (push x li) - when (getmark x :startgraceslur-) do (if sl (setf sl nil) (error "Missing :GRACESLUR-/:ENDGRACESLUR- slur mark in offset ~S, part ~S" (event-foff e) (part-name p))) + when (getmark x :startgraceslur-) do + (if sl (setf sl nil) (error "Missing :GRACESLUR-/:ENDGRACESLUR- slur mark in offset ~S, part ~S" (event-foff x) (part-name p))) finally (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-)))) (print-dot)))

1 0

[fomus-cvs] CVS update: fomus/load.lisp
by dpsenicka＠common-lisp.net 05 Aug '05

05 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv19049 Modified Files: load.lisp Log Message: Bug fix Date: Fri Aug 5 19:25:15 2005 Author: dpsenicka Index: fomus/load.lisp diff -u fomus/load.lisp:1.3 fomus/load.lisp:1.4 --- fomus/load.lisp:1.3 Fri Jul 29 10:58:20 2005 +++ fomus/load.lisp Fri Aug 5 19:25:15 2005 @@ -1,15 +1,16 @@ ;; -*-lisp-*- ;; Load file for FOMUS -(let ((fl '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" - "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" - "backends" "main" "interface" "final"))) - (when (some (lambda (na) (let* ((cl (merge-pathnames na *load-pathname*)) - (cn (compile-file-pathname cl)) - (wd (file-write-date cn))) - (or (null wd) (>= (file-write-date cl) (file-write-date cn))))) fl) - (loop for na in fl - for cl = (merge-pathnames na *load-pathname*) - for cn = (compile-file-pathname cl) do - (compile-file cl) - (load cn)))) \ No newline at end of file +(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" + "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" + "backends" "main" "interface" "final") + and nw + for na in fl + for cl = (merge-pathnames na *load-pathname*) + for cn = (compile-file-pathname cl) do + (when (or nw + (not (probe-file cn)) + (>= (file-write-date cl) (file-write-date cn))) + (compile-file cl) + (setf nw t)) + (load cn)) \ No newline at end of file

1 0

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/backend_ly.lisp fomus/data.lisp fomus/postproc.lisp fomus/split.lisp
by dpsenicka＠common-lisp.net 31 Jul '05

31 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20655 Modified Files: CHANGELOG TODO backend_ly.lisp data.lisp postproc.lisp split.lisp Log Message: Testing/bug fixes Date: Sun Jul 31 09:35:07 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.3 fomus/CHANGELOG:1.4 --- fomus/CHANGELOG:1.3 Sun Jul 31 01:48:54 2005 +++ fomus/CHANGELOG Sun Jul 31 09:35:07 2005 @@ -1,8 +1,11 @@ - Testing/bug fixes - Improved quantize algorithm +CHANGELOG -v0.1.6, 7/29/05 + Testing/bug fixes + Support for text, glissandi/portamenti, arpeggios (not all tested yet) + Improved quantize algorithm - Testing/bug fixes - Support for tremolos - Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM +v0.1.6, 7/29/05: + + Testing/bug fixes + Support for tremolos + Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM Index: fomus/TODO diff -u fomus/TODO:1.10 fomus/TODO:1.11 --- fomus/TODO:1.10 Sun Jul 31 01:48:54 2005 +++ fomus/TODO Sun Jul 31 09:35:07 2005 @@ -1,39 +1,38 @@ -TODO LIST: +TODO LIST -IMMEDIATE +Immediate: -Testing and bug fixes -DOC: dynamic marks can take order arguments (backend might not support it) -DOC: LilyPond options: text-markup textdyn-markup texttempo-markup textnote-markup -DOC: remove :texttempo- and :endtexttempo- and related spanner marks -Adjust scores and penalties for decent results -Note heads -Finish fingering mark (no finger number argument) - - - -SHORT TERM - -Number of lines in staff -Global timesig-repl list -MINP and MAXP instrument ranges -MusicXML backend -CMN backend -MIDI backend -Profile and optimize code for speed -Update comments -Reorganize settings -MIDI input interface -Support for polymeters in backends -Integrate user graceslur overrides -Levels for single text marks -Remove redundant dynamic marks -Easier grace note numbering - - - -LONG TERM - -Features for proportional notation (generate hidden rests of constant duration?) -Key signatures (key detection algorithm) -Combine separately notated sections with different settings into one score (concatenate multiple .fms files?) + Testing and bug fixes + DOC: dynamic marks can take order arguments (backend might not support it) + DOC: LilyPond options: text-markup textdyn-markup texttempo-markup textnote-markup + DOC: remove :texttempo- and :endtexttempo- and related spanner marks + DOC: update text markings + Adjust scores and penalties for better/faster results + Note heads + Harmonics + Finish fingering mark (no finger number argument) + +Short Term: + + Number of lines in staff + Global timesig-repl list + MINP and MAXP instrument ranges + MusicXML backend + CMN backend + MIDI backend + Profile and optimize code for speed + Update comments + Reorganize settings + MIDI input interface + Support for polymeters in backends + Integrate user graceslur overrides + Levels for single text marks + Remove redundant dynamic marks + Easier grace note numbering + When deleting unisons, merge marks + +Long Term: + + Features for proportional notation (generate hidden rests?) + Key signatures (key detection algorithm) + Combine separately notated sections with different settings into one score (concatenate multiple .fms files?) Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.8 fomus/backend_ly.lisp:1.9 --- fomus/backend_ly.lisp:1.8 Sun Jul 31 01:48:54 2005 +++ fomus/backend_ly.lisp Sun Jul 31 09:35:07 2005 @@ -78,7 +78,7 @@ "beamL = #(def-music-function (location num) (number?) #{\\set stemLeftBeamCount = #$num #})" "beamR = #(def-music-function (location num) (number?) #{\\set stemRightBeamCount = #$num #})" "beamLR = #(def-music-function (location numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" "" - "textSpan = #(def-music-function (location dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #'($str . \"\") #})" + "textSpan = #(def-music-function (location dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" )) (defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b")) @@ -113,7 +113,7 @@ (:fp . "\\fp") (:sf . "\\sf") (:sff . "\\sff") (:sp . "\\sp") (:spp . "\\spp") (:sfz . "\\sfz") (:rfz . "\\rfz"))) (defparameter +lilypond-text+ "\\markup{\\italic{~A}}") -(defparameter +lilypond-textdyn+ "\\markup{\\italic{\\bold{\\huge{~A}}}}") +(defparameter +lilypond-textdyn+ "\\markup{\\dynamic{\\italic{\\bold{~A}}}}") (defparameter +lilypond-texttempo+ "\\markup{\\bold{\\huge{~A}}}") (defparameter +lilypond-textnote+ "\\markup{\\italic{~A}}") @@ -295,15 +295,15 @@ (or textdyn-markup +lilypond-textdyn+) (or texttempo-markup +lilypond-texttempo+) (or textnote-markup +lilypond-textnote+)) - nconc (loop for (xxx str di) in (getmarks e x) + nconc (loop for (xxx di str) in (getmarks e x) collect (conc-strings (ecase di (:up "^") (:down "_")) (format nil m str)))))) - (xs1 (let ((m (getmark e :starttext-))) ; can't have more than one at once - (if m (format nil "\\textSpan #~A #\"~A \" " (ecase (fourth m) (:up 1) (:down -1)) (third e)) ""))) - (xs2 (let ((m (getmark e :starttext-))) + (xs1 (let ((m (getmark e '(:starttext- 1)))) ; can't have more than one at once + (if m (format nil "\\textSpan #~A #\"~A \" " (ecase (third m) (:up 1) (:down -1)) (fourth m)) ""))) + (xs2 (let ((m (getmark e '(:starttext- 1)))) (if m "\\startTextSpan" ""))) - (xs3 (let ((m (or (getmark e :endtext-)))) + (xs3 (let ((m (getmark e '(:endtext- 1)))) (if m "\\stopTextSpan" ""))) (s1 (conc-stringlist (loop Index: fomus/data.lisp diff -u fomus/data.lisp:1.9 fomus/data.lisp:1.10 --- fomus/data.lisp:1.9 Sun Jul 31 01:48:54 2005 +++ fomus/data.lisp Sun Jul 31 09:35:07 2005 @@ -419,13 +419,13 @@ (let* ((x (find* :slur- :endslur-))) (or* (unique* si 1 x) (unique* si 1 (list* x)) (list* x (unique* si integer)))) (let* ((x (find* :textnote :texttempo :textdyn :text))) - (or* (list* x string) (list* x string (find* :up :down)))) ; text + (or* (list* x string) (list* x string (find* :up :down)) (list* x (find* :up :down) string))) ; text (let* ((x (find* :text- :endtext-))) - (or* x (list* x) (list* x (unique* #|tdn|# tx integer)))) + (or* (unique* tx 1 x) (unique* tx 1 (list* x)) (list* x (unique* tx integer)))) (let* ((x (find* :starttext-))) - (cons* x (or* (unique* tx 1 string) - (unique* tx 1 string (find* :up :down)) - (unique* tx 1 (find* :up :down) string) + (cons* x (or* (unique* tx 1 (list* string)) + (unique* tx 1 (list* string (find* :up :down))) + (unique* tx 1 (list* (find* :up :down) string)) (list* string (unique* tx integer)) (list* (unique* tx integer) string) (list* (find* :up :down) string (unique* tx integer)) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.4 fomus/postproc.lisp:1.5 --- fomus/postproc.lisp:1.4 Sun Jul 31 01:48:55 2005 +++ fomus/postproc.lisp Sun Jul 31 09:35:07 2005 @@ -322,18 +322,18 @@ (addmark e2 (list :endtremolo (/ d 2) w)))) (progn (push re ee) (addmark re (list :tremolo d w))))))))))) (push e ee))) - finally - (loop for g in (split-into-groups (setf (meas-events m) (sort ee #'sort-offdur)) #'event-voice*) do - (loop for (a b) on (sort g #'sort-offdur) - when (and b - (or (getmark a :tremolo) (getmark a :starttremolo) (getmark a :endtremolo)) - (or (getmark b :tremolo) (getmark b :starttremolo) (getmark b :endtremolo))) - do - (setf (event-tiert a) (when (consp (event-tiert a)) (make-list (length (event-tiert a)))) - (event-tielt b) (when (consp (event-tielt b)) (make-list (length (event-tielt b))))) - (when (or (getmark a :starttremolo) (getmark a :endtremolo) - (getmark b :starttremolo) (getmark b :endtremolo)) - (setf (event-beamrt a) 0 (event-beamlt b) 0)))))) + finally (setf (meas-events m) (sort ee #'sort-offdur)))) + (loop for g in (split-into-groups (loop for x in (part-meas p) append (meas-events x)) #'event-voice*) do + (loop for (a b) on (sort g #'sort-offdur) + when (and b + (or (getmark a :tremolo) (getmark a :starttremolo) (getmark a :endtremolo)) + (or (getmark b :tremolo) (getmark b :starttremolo) (getmark b :endtremolo))) + do + (setf (event-tiert a) (when (consp (event-tiert a)) (make-list (length (event-tiert a)))) + (event-tielt b) (when (consp (event-tielt b)) (make-list (length (event-tielt b))))) + (when (or (getmark a :starttremolo) (getmark a :endtremolo) + (getmark b :starttremolo) (getmark b :endtremolo)) + (setf (event-beamrt a) 0 (event-beamlt b) 0)))) (print-dot) finally (when fx (clean-ties pts)))) @@ -355,15 +355,23 @@ (> (event-endoff x) (event-off a)) (< (event-off x) (event-endoff a))) collect (event-voice* x))) - count (< y o) into u - count (> y o) into d + 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) (cons - (if (find (first tx) +marks-defaultup+) :up :down) - (rest tx))))) - ((< d u) (addmark e (cons (first tx) (cons :down (rest tx))))) - ((> d u) (addmark e (cons (first tx) (cons :up (rest tx)))))))))) (print-dot))) + (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))) ;; not included with other postprocs here--in fomus-proc function (defun postpostproc-sortprops (pts) Index: fomus/split.lisp diff -u fomus/split.lisp:1.9 fomus/split.lisp:1.10 --- fomus/split.lisp:1.9 Sun Jul 31 07:39:32 2005 +++ fomus/split.lisp Sun Jul 31 09:35:07 2005 @@ -148,7 +148,10 @@ (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))))) + (setf (meas-events m) e + r (loop for x in n if (chordp x) + nconc (mapcar (lambda (y t1 t2) (copy-event x :note y :tielt t1 :tiert t2)) + (event-note x) (event-tielt x) (event-tiert x)) else collect x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SPLITTER

1 0

[fomus-cvs] CVS update: fomus/split.lisp fomus/util.lisp
by dpsenicka＠common-lisp.net 31 Jul '05

31 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv13174 Modified Files: split.lisp util.lisp Log Message: Testing/bug fixes Date: Sun Jul 31 07:39:32 2005 Author: dpsenicka Index: fomus/split.lisp diff -u fomus/split.lisp:1.8 fomus/split.lisp:1.9 --- fomus/split.lisp:1.8 Sun Jul 31 01:48:55 2005 +++ fomus/split.lisp Sun Jul 31 07:39:32 2005 @@ -477,7 +477,11 @@ (not (find (event-off e2) (event-nomerge e1))) (equal (list (event-dur* e1) (sort-marks (event-marks e1)) (event-tup e1)) (list (event-dur* e2) (sort-marks (event-marks e2)) (event-tup e2)))) - (cons (copy-event e1 :dur (* (event-dur* e1) 2)) + (cons (copy-event e1 :dur (* (event-dur* e1) 2) + :tup (cons (when (car (event-tup e1)) + (cons (* (caar (event-tup e1)) 2) + (cdr (event-tup e1)))) + (cdr (event-tup e1)))) (delete e1 (delete e2 es))) es))) (when (or (initdivp rl) (basesplitp rl)) Index: fomus/util.lisp diff -u fomus/util.lisp:1.7 fomus/util.lisp:1.8 --- fomus/util.lisp:1.7 Sun Jul 31 01:48:55 2005 +++ fomus/util.lisp Sun Jul 31 07:39:32 2005 @@ -1,7 +1,7 @@ ;; -*- lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;************************************************************************************************** -;; FOMUS v0.1.0 +;; FOMUS ;; util.lisp ;;************************************************************************************************** @@ -344,7 +344,8 @@ (let ((du (event-dur* event) ) (u (car (event-tup event)))) (split-event event off - (when u (cons (* (first u) (/ (- off (event-off event)) du)) (rest u))) (cdr (event-tup event)) + (when u (cons (* (first u) (/ (- off (event-off event)) du)) (rest u))) + (cdr (event-tup event)) (when u (cons (* (first u) (/ (- (event-endoff event) off) du)) (rest u)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/data.lisp fomus/split.lisp fomus/voices.lisp
by dpsenicka＠common-lisp.net 29 Jul '05

29 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv8208 Modified Files: CHANGELOG TODO data.lisp split.lisp voices.lisp Log Message: Bug fixes Date: Fri Jul 29 20:55:43 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.1 fomus/CHANGELOG:1.2 --- fomus/CHANGELOG:1.1 Fri Jul 29 10:58:20 2005 +++ fomus/CHANGELOG Fri Jul 29 20:55:43 2005 @@ -2,3 +2,4 @@ Testing/bug fixes Support for tremolos + Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM Index: fomus/TODO diff -u fomus/TODO:1.8 fomus/TODO:1.9 --- fomus/TODO:1.8 Fri Jul 29 10:58:20 2005 +++ fomus/TODO Fri Jul 29 20:55:43 2005 @@ -4,7 +4,7 @@ Testing and bug fixes DOC: dynamic marks can take order arguments (backend might not support it) -DOC: update tremolos +DOC: :beat-division and tuplets Adjust scores and penalties for decent results Breath marks (resolve before/after) Note heads Index: fomus/data.lisp diff -u fomus/data.lisp:1.7 fomus/data.lisp:1.8 --- fomus/data.lisp:1.7 Fri Jul 29 10:58:20 2005 +++ fomus/data.lisp Fri Jul 29 20:55:43 2005 @@ -129,17 +129,17 @@ ;; 8up/down leglines = (cons into-ottava outof-ottava), or I think it can also be just a number ;;(declaim (inline make-instr)) (defstruct (instr (:constructor make-instr-aux) (:copier nil) (:predicate instrp)) - sym clefs (staves 1) minp maxp (voicelim 1) tpose (cleflegls 2) + sym clefs (staves 1) minp maxp (simultlim 1) tpose (cleflegls 2) 8uplegls 8dnlegls percs) -(defparameter +instr-keys+ '(:sym :clefs :staves :minp :maxp :voicelim :tpose :cleflegls :8uplegls :8dnlegls :percs)) +(defparameter +instr-keys+ '(:sym :clefs :staves :minp :maxp :simultlim :tpose :cleflegls :8uplegls :8dnlegls :percs)) (defun make-instr (sym &rest args) (apply #'make-instr-aux :sym sym args)) ;;(declaim (inline copy-instr)) (defun copy-instr (instr &key (sym (instr-sym instr)) (clefs (instr-clefs instr)) (staves (instr-staves instr)) (minp (instr-minp instr)) (maxp (instr-maxp instr)) - (voicelim (instr-voicelim instr)) (tpose (instr-tpose instr)) (cleflegls (instr-cleflegls instr)) (8uplegls (instr-8uplegls instr)) + (simultlim (instr-simultlim instr)) (tpose (instr-tpose instr)) (cleflegls (instr-cleflegls instr)) (8uplegls (instr-8uplegls instr)) (8dnlegls (instr-8dnlegls instr)) (percs (instr-percs instr))) - (make-instr-aux :sym sym :clefs clefs :staves staves :minp minp :maxp maxp :voicelim voicelim :tpose tpose :cleflegls cleflegls + (make-instr-aux :sym sym :clefs clefs :staves staves :minp minp :maxp maxp :simultlim simultlim :tpose tpose :cleflegls cleflegls :8uplegls 8uplegls :8dnlegls 8dnlegls :percs percs)) (defparameter +instr-type+ @@ -150,7 +150,7 @@ (instr-staves (check* (integer 1) "Found ~S, expected (INTEGER 1) in STAVES slot" t)) (instr-minp (check* (or null integer) "Found ~S, expected INTEGER in MINP slot" t)) (instr-maxp (check* (or null integer) "Found ~S, expected INTEGER in MAXP slot" t)) - (instr-voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) + (instr-simultlim (check* (integer 1) "Found ~S, expected (INTEGER 1) in SIMULTLIM slot" t)) (instr-tpose (check* (or null integer) "Found ~S, expected INTEGER in TPOSE slot" t)) (instr-cleflegls (check* (or* (integer 1) (cons-of* (integer 1) @@ -168,7 +168,7 @@ (defparameter *instruments* nil) (eval-when (:load-toplevel :execute) - (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :voicelim 5)) + (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :simultlim 5)) (defparameter +instruments+ (list (make-instr :piccolo :clefs :treble :tpose 12) (make-instr :flute :clefs :treble) @@ -190,10 +190,10 @@ (make-instr :viola :clefs '(:treble :alto) :8uplegls '(5 2)) (make-instr :cello :clefs '(:bass :tenor :treble)) (make-instr :contrabass :clefs '(:bass :tenor) :tpose -12) - (make-instr :harp :clefs '(:treble :bass) :staves 2 :voicelim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) - (make-instr :piano :clefs '(:treble :bass) :staves 2 :voicelim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) - (make-instr :xylophone :clefs '(:treble) :voicelim 2 :tpose 12 :8uplegls '(5 2)) - (make-instr :marimba :clefs '(:treble :bass) :voicelim 2 :8uplegls '(5 2)) + (make-instr :harp :clefs '(:treble :bass) :staves 2 :simultlim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) + (make-instr :piano :clefs '(:treble :bass) :staves 2 :simultlim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) + (make-instr :xylophone :clefs '(:treble) :simultlim 2 :tpose 12 :8uplegls '(5 2)) + (make-instr :marimba :clefs '(:treble :bass) :simultlim 2 :8uplegls '(5 2)) (make-instr :percussion :clefs :percussion) (make-instr :timpani :clefs :bass)))) @@ -327,7 +327,7 @@ (:default-beat (or null (rational (0)))) (:beat-division (or* (integer 1) (and (list* (integer 1) (integer 1)) (length* = 2))) "(INTEGER 1) or ((INTEGER 1) (INTEGER 1))") (:min-tuplet-dur (real (0))) (:max-tuplet-dur (real (0))) (:min-simple-tuplet-dur (real (0))) - (:max-tuplet (or* (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)") + (:max-tuplet (or* null (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)") (:tuplet-dotted-rests boolean) (:double-dotted-notes boolean) (:dotted-note-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") (:shortlongshort-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") Index: fomus/split.lisp diff -u fomus/split.lisp:1.6 fomus/split.lisp:1.7 --- fomus/split.lisp:1.6 Fri Jul 29 10:58:20 2005 +++ fomus/split.lisp Fri Jul 29 20:55:43 2005 @@ -330,7 +330,7 @@ (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation (snd (/ 1/2 num) t nil)) (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)))))))) - (when (and tups (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) (loop with nu = (if (rule-comp rule) (* num 3/2) num) for j in (primes2 (first mt)) ; only primes--number isn't actual tuplet, just division @@ -366,7 +366,7 @@ (list (list 1/8 (un 1/8 :l t t) (und 7/8 nil t)))))) (when (and (al *shortlongshort-notes-level*) (rule-alt rule) (rule-art rule) ex) (list (list '(1/4 3/4) (un 1/4 :l t t) (und 1/2 t t) (un 1/4 :r t t)))) ; longer note in middle - (when (and tups (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) (let ((l (length (force-list (rule-tup rule))))) (when (< l mn) (loop Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.3 fomus/voices.lisp:1.4 --- fomus/voices.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/voices.lisp Fri Jul 29 20:55:43 2005 @@ -104,7 +104,7 @@ (c (cons w (let ((o (- oo (* *voice-full-beat-dist* *max-voice-beat-dist-mul*)))) (remove-if (lambda (e) (<= (event-endoff e) o)) (voicenode-evc no)))))) - (when (let ((i (instr-voicelim instr))) + (when (let ((i (instr-simultlim instr))) (or (null i) (<= (count-if (lambda (x) (and (> (event-endoff x) oo) (= (event-voice x) e))) c) i))) (make-voicenode :sc s :evc c

1 0

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/version.lisp fomus/TODO fomus/backend_ly.lisp fomus/backends.lisp fomus/data.lisp fomus/final.lisp fomus/fomus.asd fomus/load.lisp fomus/main.lisp fomus/marks.lisp fomus/other.lisp fomus/package.lisp fomus/postproc.lisp fomus/split.lisp fomus/util.lisp
by dpsenicka＠common-lisp.net 29 Jul '05

29 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv697 Modified Files: TODO backend_ly.lisp backends.lisp data.lisp final.lisp fomus.asd load.lisp main.lisp marks.lisp other.lisp package.lisp postproc.lisp split.lisp util.lisp Added Files: CHANGELOG version.lisp Log Message: Testing/bug fixes Date: Fri Jul 29 10:58:20 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.7 fomus/TODO:1.8 --- fomus/TODO:1.7 Wed Jul 27 08:57:37 2005 +++ fomus/TODO Fri Jul 29 10:58:20 2005 @@ -4,6 +4,7 @@ Testing and bug fixes DOC: dynamic marks can take order arguments (backend might not support it) +DOC: update tremolos Adjust scores and penalties for decent results Breath marks (resolve before/after) Note heads Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.6 fomus/backend_ly.lisp:1.7 --- fomus/backend_ly.lisp:1.6 Wed Jul 27 22:58:50 2005 +++ fomus/backend_ly.lisp Fri Jul 29 10:58:20 2005 @@ -108,14 +108,15 @@ (:mf . "\\mf") (:f . "\\f") (:ff . "\\ff") (:fff . "\\fff") (:ffff . "\\ffff") (:fffff . "\\fffff") (:fp . "\\fp") (:sf . "\\sf") (:sff . "\\sff") (:sp . "\\sp") (:spp . "\\spp") (:sfz . "\\sfz") (:rfz . "\\rfz"))) -;; TODO: support texts, spanners and tremelos, remove dependency on ACCIDENTALYS +;; TODO: support texts, spanners and tremelos -(defun save-lilypond (parts filename options process view) +(defun save-lilypond (parts header filename options process view) (when (>= *verbose* 1) (out ";; Saving Lilypond file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) (destructuring-bind (xxx &key filehead scorehead &allow-other-keys) options (declare (ignore xxx)) - (format f "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) + (format f "~A" header) + ;;(format f "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) (loop for e in +lilypond-head+ do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top (when filehead (loop for e in filehead do (format f "~A~%" e) finally (format f "~%"))) ;; user header (loop for e in +lilypond-defs+ do (format f "~A~%" e) finally (format f "~%")) ;; definitions @@ -185,108 +186,119 @@ (loop for (ee een) on (meas-events m) ; ee = list of events do (loop for (pre e nxe) on (cons nil ee) while e - for fm = (getmark e :measrest) - for cl = (let ((c (getmark e :clef))) - (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c))) - "")) - and st = (let ((m (getmark e '(:staff :global)))) - (if (and m (null (fourth m))) (lystaff (third m)) "")) - and vo = (if (list>1p (meas-events m)) - (let ((m (getmark e '(:voice :ord1324)))) - (if m - (case (third m) - (1 "\\voiceOne ") (2 "\\voiceTwo ") (3 "\\voiceThree ") (4 "\\voiceFour ") (otherwise "\\oneVoice ")) + do (let ((fm (getmark e :measrest))) + (let ((cl (let ((c (getmark e :clef))) + (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c))) + ""))) + (st (let ((m (getmark e '(:staff :global)))) + (if (and m (null (fourth m))) (lystaff (third m)) ""))) + (vo (if (list>1p (meas-events m)) + (let ((m (getmark e '(:voice :ord1324)))) + (if m + (case (third m) + (1 "\\voiceOne ") (2 "\\voiceTwo ") (3 "\\voiceThree ") (4 "\\voiceFour ") (otherwise "\\oneVoice ")) + "")) "")) - "") - and gr1 = (let ((g (event-grace e))) - (if g - (let ((g1 (getmark e :startgrace))) - (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\\acciaccatura " "\\appoggiatura ")) - (g1 (if (< g 0) "\\acciaccatura {" "\\appoggiatura {")))) - "")) - and gr2 = (if (and (event-grace e) (getmark e :endgrace) (not (getmark e :startgrace))) "}" "") - and ot1 = (cond ((or (getmark e :start8up-) (getmark e :8up)) "\\octUp ") - ((or (getmark e :start8down-) (getmark e :8down)) "\\octDown ")) - and ot2 = (cond ((or (getmark e :end8up-) (getmark e :8up)) " \\octReset") - ((or (getmark e :end8down-) (getmark e :8down)) " \\octReset")) - and ba = (if (notep e) - (if (chordp e) - (format nil "<~A>" (conc-stringlist - (loop - for (n nn) on (event-notes* e) - and w in (event-writtennotes e) - and a in (event-accs e) - and a2 in (event-addaccs e) - collect (lynote w a a2 (getmark e (list :cautacc n)) #|(getmark e (list :showacc n))|#) - when nn collect " "))) - (lynote (event-writtennote e) (event-acc e) (event-addacc e) - (getmark e (list :cautacc (event-note* e))) #|(getmark e (list :showacc n))|#)) - (if fm (if (event-inv e) "\\skip " "R") (if (event-inv e) "s" "r"))) - and du = (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) - (multiple-value-bind (wd ds) (event-writtendur* e ts) - (let ((du (case wd - (2 "\\breve") - (4 "\\longa") - (otherwise (/ wd))))) - (ecase ds - (0 (format nil "~A" du)) - (1 (format nil "~A." du)) - (2 (format nil "~A.." du)))))) - and tu1 = (let ((uu (sort (getmarks e :starttup) #'< :key #'second))) - (conc-stringlist - (loop for u in uu for r = (third u) - collect (format nil "\\times ~A/~A {" (cdr r) (car r))))) ; tup is durmult - and tu2 = (let ((uu (getmarks e :endtup))) - (conc-stringlist - (loop repeat (length uu) collect "}"))) - and ti = (if (and (notep e) (or-list (force-list (event-tiert e)))) "\~" "") - and be1 = (if (and (notep e) (= (event-beamlt e) 0) (> (event-beamrt e) 0)) "[" "") - and be2 = (if (and (notep e) (> (event-beamlt e) 0) (= (event-beamrt e) 0)) "]" "") - and bnu = (let ((l (and (notep e) (notep pre) (> (min (event-nbeams e ts) (event-nbeams pre ts)) (event-beamlt e) 0))) - (r (and (notep e) (notep nxe) (> (min (event-nbeams e ts) (event-nbeams nxe ts)) (event-beamrt e) 0)))) - (cond ((and l r) (format nil "\\beamLR #~A #~A " (event-beamlt e) (event-beamrt e))) - (l (format nil "\\beamL #~A " (event-beamlt e))) - (r (format nil "\\beamR #~A " (event-beamrt e))) - (t ""))) - and ar = (conc-stringlist - (loop for i in - (sort (loop for a in +lilypond-marks+ nconc (mapcar #'force-list (getmarks e (car a)))) - (lambda (x y) (let ((x2 (second x)) (y2 (second y))) - (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) - (x2 t))))) - collect (lookup (first i) +lilypond-marks+))) - ;and txt = ... - and we0 = (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\\< ") - ((and (getmark e :startwedge>) (getmark e :endwedge-)) "\\> ") - (t "")) - and we1 = (cond ((getmark e :endwedge-) "\\!") - ((getmark e :startwedge<) "\\<") - ((getmark e :startwedge>) "\\>") - (t "")) - and we2 = (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge-))) "\\<") - ((and (getmark e :startwedge>) (not (getmark e :endwedge-))) "\\>") - (t "")) - and dyn = (conc-stringlist - (loop for i in - (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) - collect (lookup (first i) +lilypond-dyns+))) - and s1 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-)) - collect "(")) - and s2 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-)) - collect ")")) - and sl1 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-)) - collect "(")) - and sl2 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-)) - collect ")")) - do (format f "~A " (conc-strings st vo cl ot1 tu1 gr1 we0 bnu ba du sl1 s1 s2 sl2 be1 be2 ti ar we1 dyn #|txt|# we2 gr2 tu2 ot2))) + (gr1 (let ((g (event-grace e))) + (if g + (let ((g1 (getmark e :startgrace))) + (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\\acciaccatura " "\\appoggiatura ")) + (g1 (if (< g 0) "\\acciaccatura {" "\\appoggiatura {")))) + ""))) + (gr2 (if (and (event-grace e) (getmark e :endgrace) (not (getmark e :startgrace))) "}" "")) + (ot1 (cond ((or (getmark e :start8up-) (getmark e :8up)) "\\octUp ") + ((or (getmark e :start8down-) (getmark e :8down)) "\\octDown "))) + (ot2 (cond ((or (getmark e :end8up-) (getmark e :8up)) " \\octReset") + ((or (getmark e :end8down-) (getmark e :8down)) " \\octReset"))) + (ba (if (notep e) + (if (chordp e) + (format nil "<~A>" (conc-stringlist + (loop + for (n nn) on (event-notes* e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + collect (lynote w a a2 (getmark e (list :cautacc n))) + when nn collect " "))) + (lynote (event-writtennote e) (event-acc e) (event-addacc e) + (getmark e (list :cautacc (event-note* e))))) + (if fm (if (event-inv e) "\\skip " "R") (if (event-inv e) "s" "r")))) + (du (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) + (multiple-value-bind (wd ds) (let ((m (or (getmark e :tremolo) + (getmark e :starttremolo) + (getmark e :endtremolo)))) + (if m + (values (third m) 0) + (event-writtendur* e ts))) + (let ((du (case wd + (2 "\\breve") + (4 "\\longa") + (otherwise (/ wd))))) + (ecase ds + (0 (format nil "~A" du)) + (1 (format nil "~A." du)) + (2 (format nil "~A.." du))))))) + (tu1 (let ((uu (sort (getmarks e :starttup) #'< :key #'second))) + (conc-stringlist + (loop for u in uu for r = (third u) + collect (format nil "\\times ~A/~A {" (cdr r) (car r)))))) ; tup is durmult + (tu2 (let ((uu (getmarks e :endtup))) + (conc-stringlist + (loop repeat (length uu) collect "}")))) + (ti (if (and (notep e) (or-list (force-list (event-tiert e)))) "\~" "")) + (be1 (if (and (notep e) (= (event-beamlt e) 0) (> (event-beamrt e) 0)) "[" "")) + (be2 (if (and (notep e) (> (event-beamlt e) 0) (= (event-beamrt e) 0)) "]" "")) + (bnu (let ((l (and (notep e) (notep pre) (> (min (event-nbeams e ts) (event-nbeams pre ts)) (event-beamlt e) 0))) + (r (and (notep e) (notep nxe) (> (min (event-nbeams e ts) (event-nbeams nxe ts)) (event-beamrt e) 0)))) + (cond ((and l r) (format nil "\\beamLR #~A #~A " (event-beamlt e) (event-beamrt e))) + (l (format nil "\\beamL #~A " (event-beamlt e))) + (r (format nil "\\beamR #~A " (event-beamrt e))) + (t "")))) + (ar (conc-stringlist + (loop for i in + (sort (loop for a in +lilypond-marks+ nconc (mapcar #'force-list (getmarks e (car a)))) + (lambda (x y) (let ((x2 (second x)) (y2 (second y))) + (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) + (x2 t))))) + collect (lookup (first i) +lilypond-marks+)))) + (we0 (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\\< ") + ((and (getmark e :startwedge>) (getmark e :endwedge-)) "\\> ") + (t ""))) + (we1 (cond ((getmark e :endwedge-) "\\!") + ((getmark e :startwedge<) "\\<") + ((getmark e :startwedge>) "\\>") + (t ""))) + (we2 (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge-))) "\\<") + ((and (getmark e :startwedge>) (not (getmark e :endwedge-))) "\\>") + (t ""))) + (dyn (conc-stringlist + (loop for i in + (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) + collect (lookup (first i) +lilypond-dyns+)))) + (mo1 (let ((m (or (getmark e :tremolo) (getmark e :starttremolo)))) + (if m (format nil "\\repeat \"tremolo\" ~A ~A" (second m) + (if (eq (first m) :tremolo) "" "{")) + ""))) + (mo2 (if (getmark e :endtremolo) "}" "")) + (s1 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-)) + collect "("))) + (s2 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-)) + collect ")"))) + (sl1 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-)) + collect "("))) + (sl2 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-)) + collect ")")))) + (format f "~A " (conc-strings st vo cl ot1 tu1 gr1 we0 bnu mo1 ; stuff before + ba du sl1 s1 s2 sl2 be1 be2 ti ar we1 dyn #|txt|# we2 ; the actual note w/ attachments + mo2 gr2 tu2 ot2))))) ; stuff after (end brackets) when een do (format f s2)) (format f s3 (let ((x (getprop m :barline))) Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.3 fomus/backends.lisp:1.4 --- fomus/backends.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/backends.lisp Fri Jul 29 10:58:20 2005 @@ -24,6 +24,6 @@ (defun backend (backend filename parts options process view) (case backend (:data (save-data filename parts)) - (:lilypond (save-lilypond parts filename options process view)) + (:lilypond (save-lilypond parts (format nil "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (otherwise (error "Unknown backend ~S" backend)))) Index: fomus/data.lisp diff -u fomus/data.lisp:1.6 fomus/data.lisp:1.7 --- fomus/data.lisp:1.6 Tue Jul 26 08:00:57 2005 +++ fomus/data.lisp Fri Jul 29 10:58:20 2005 @@ -150,25 +150,25 @@ (instr-staves (check* (integer 1) "Found ~S, expected (INTEGER 1) in STAVES slot" t)) (instr-minp (check* (or null integer) "Found ~S, expected INTEGER in MINP slot" t)) (instr-maxp (check* (or null integer) "Found ~S, expected INTEGER in MAXP slot" t)) - (voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) - (tpose (check* (or null integer) "Found ~S, expected INTEGER in TPOSE slot" t)) - (cleflegls (check* (or* (integer 1) - (cons-of* (integer 1) - (and* (list-of* (list* (and* symbol (check* (satisfies is-clef) "Found ~S, expected valid clef symbol in list in CLEFLEGLS slot" t)) - (and* symbol (check* (find* :up :dn) "Found ~S, expected :UP or :DN in list in CLEFLEGLS slot" t)) - (integer 1))) - (length* <= 2)))) - "Found ~S, expected (INTEGERS 1) or SYMBOLS in the form I, (I (S S I) ...) in CLEFLEGLS slot" t)) - (8uplegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8UPLEGLS slot" t)) - (8dnlegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8DNLEGLS slot" t)) - (percs (check* (or null (list-of* (type* *perc-type*))) "Found ~S, expected list of PERC objects in PERCS slot" t))))) + (instr-voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) + (instr-tpose (check* (or null integer) "Found ~S, expected INTEGER in TPOSE slot" t)) + (instr-cleflegls (check* (or* (integer 1) + (cons-of* (integer 1) + (and* (list-of* (list* (and* symbol (check* (satisfies is-clef) "Found ~S, expected valid clef symbol in list in CLEFLEGLS slot" t)) + (and* symbol (check* (find* :up :dn) "Found ~S, expected :UP or :DN in list in CLEFLEGLS slot" t)) + (integer 1))) + (length* <= 2)))) + "Found ~S, expected (INTEGERS 1) or SYMBOLS in the form I, (I (S S I) ...) in CLEFLEGLS slot" t)) + (instr-8uplegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8UPLEGLS slot" t)) + (instr-8dnlegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8DNLEGLS slot" t)) + (instr-percs (check* (or null (list-of* (type* *perc-type*))) "Found ~S, expected list of PERC objects in PERCS slot" t))))) ;; tpose = mod. for sounding pitch ;; 8up/8down = (threshold-for-ottava-brackets . threshold-for-back-to-normal) (defparameter *instruments* nil) (eval-when (:load-toplevel :execute) - (defparameter +default-instr+ (make-instr :default :clefs :treble)) + (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :voicelim 5)) (defparameter +instruments+ (list (make-instr :piccolo :clefs :treble :tpose 12) (make-instr :flute :clefs :treble) @@ -407,8 +407,8 @@ (list* x (function* is-clef))) (let* ((x (unique* sy (find* :notehead)))) (list* x (find* ))) ; finish this!!!!!! - (let* ((x (unique* sy :tremolo (find* :righthandtremolo :lefthandtremolo :tremolo))) - (or* x (list* x) (list* x (rational (0)))))) ; tremolos + (let* ((x (unique* sy :tremolo (find* :tremolo :tremolofirst :tremolosecond)))) + (or* x (list* x) (list* x (rational (0))))) ; tremolos (let* ((x (find* :startslur-))) (or* (unique* si 1 x) (unique* si 1 (list* x)) (cons* x (or* (unique* si integer) @@ -492,7 +492,7 @@ '(:endslur- :end8up- :end8down- :endtext- :endtextdyn- :endtexttempo- :endwedge- :fermata :staccatissimo :staccato)) (defparameter +marks-all-ties+ - '(:longtrill :tremolo :lefthandtremolo :righthandtremolo)) + '(:longtrill :tremolo :tremolofirst :tremolosecond)) (defparameter *auto-pizz/arco* t) Index: fomus/final.lisp diff -u fomus/final.lisp:1.3 fomus/final.lisp:1.4 --- fomus/final.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/final.lisp Fri Jul 29 10:58:20 2005 @@ -27,7 +27,7 @@ when (eq y 'eof) do (error "KEYWORD/ARGUMENT-PAIRS expected in initialization file") do (setf nt0 (find-symbol (conc-strings "*" (symbol-name x) "*") :fomus)) if nt0 collect (find-symbol (conc-strings "*" (symbol-name x) "*") :fomus) into nt and collect y into nt - else do (format t ";; WARNING: Unknown setting ~S~%" x) + else do (format t ";; WARNING: Unknown setting ~S in initialization file~%" x) finally (when nt (eval (cons 'setf nt))) (return t))))) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.1.1.1 fomus/fomus.asd:1.2 --- fomus/fomus.asd:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/fomus.asd Fri Jul 29 10:58:20 2005 @@ -10,6 +10,7 @@ :components ((:file "package") + (:file "version" :depends-on ("package")) (:file "misc" :depends-on ("package")) (:file "deps" :depends-on ("package")) (:file "data" :depends-on ("misc" "deps")) @@ -29,10 +30,12 @@ (:file "quantize" :depends-on ("util")) (:file "backend_ly" :depends-on ("util")) - (:file "backends" :depends-on ("backend_ly")) + (:file "backends" :depends-on ("backend_ly" "version")) (:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends")) (:file "interface" :depends-on ("main")) - (:file "final" :depends-on ("util") :in-order-to ((load-op (load-op "interface")))))) \ No newline at end of file + (:file "final" :depends-on ("util" "version") :in-order-to ((load-op (load-op "interface")))) + + )) \ No newline at end of file Index: fomus/load.lisp diff -u fomus/load.lisp:1.2 fomus/load.lisp:1.3 --- fomus/load.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/load.lisp Fri Jul 29 10:58:20 2005 @@ -1,11 +1,15 @@ ;; -*-lisp-*- ;; Load file for FOMUS -(loop for na in - '("package" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" - "backends" "main" "interface" "final") - for cl = (merge-pathnames na *load-pathname*) - for cn = (compile-file-pathname cl) - for wd = (file-write-date cn) - when (or (null wd) (>= (file-write-date cl) (file-write-date cn))) do (compile-file cl) - do (load cn)) \ No newline at end of file +(let ((fl '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" + "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" + "backends" "main" "interface" "final"))) + (when (some (lambda (na) (let* ((cl (merge-pathnames na *load-pathname*)) + (cn (compile-file-pathname cl)) + (wd (file-write-date cn))) + (or (null wd) (>= (file-write-date cl) (file-write-date cn))))) fl) + (loop for na in fl + for cl = (merge-pathnames na *load-pathname*) + for cn = (compile-file-pathname cl) do + (compile-file cl) + (load cn)))) \ No newline at end of file Index: fomus/main.lisp diff -u fomus/main.lisp:1.6 fomus/main.lisp:1.7 --- fomus/main.lisp:1.6 Tue Jul 26 08:00:57 2005 +++ fomus/main.lisp Fri Jul 29 10:58:20 2005 @@ -49,11 +49,11 @@ ;; keysigs not implemented yet ;; returns data structure ready for output via backends (defun fomus-proc () + (find-cm) (when (and (numberp *verbose*) (>= *verbose* 1)) (out ";; Formatting music...")) (when *debug-filename* (save-debug)) (when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types...")) (check-setting-types) - (find-cm) (check-settings) (set-note-precision (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) @@ -135,6 +135,7 @@ (expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks) (clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2) (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) + (preproc-tremolos pts) (preproc-cautaccs pts) (when *auto-grace-slurs* (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.5 fomus/marks.lisp:1.6 --- fomus/marks.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/marks.lisp Fri Jul 29 10:58:20 2005 @@ -76,20 +76,6 @@ do (loop for e in (part-events p) when (popmark e ma) do (addmark e rs) (addmark e re)) (print-dot)))) -;; clean -;; deletes marks at incorrect places in tied notes/chords -;; expects measures and chords -(defun clean-ties (pts) - (loop for p in pts - do (loop for m in (part-meas p) - do (loop - for e in (remove-if-not #'notep (meas-events m)) - when (and (event-tielt e) (and-list (force-list (event-tielt e)))) - do (mapc (lambda (x) (rmmark e x)) +marks-first-tie+) - when (and (event-tiert e) (and-list (force-list (event-tiert e)))) - do (mapc (lambda (x) (rmmark e x)) +marks-last-tie+))) (print-dot))) - -;; (defun distribute-marks (pts mks) (loop with pas = (loop for p in pts collect (cons (mapcan Index: fomus/other.lisp diff -u fomus/other.lisp:1.3 fomus/other.lisp:1.4 --- fomus/other.lisp:1.3 Tue Jul 26 08:00:57 2005 +++ fomus/other.lisp Fri Jul 29 10:58:20 2005 @@ -56,6 +56,13 @@ finally (when so (setf (part-events p) (sort (part-events p) #'sort-offdur)))) (print-dot))) +(defun preproc-tremolos (parts) + (loop for p in parts do + (loop for e in (part-events p) + for m = (or (popmark e :tremolofirst) (popmark e :tremolosecond)) + when m do (let ((x (force-list m))) + (addmark e (list (first x) (second x) (event-note* e))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PERCUSSION Index: fomus/package.lisp diff -u fomus/package.lisp:1.6 fomus/package.lisp:1.7 --- fomus/package.lisp:1.6 Wed Jul 27 08:57:37 2005 +++ fomus/package.lisp Fri Jul 29 10:58:20 2005 @@ -46,15 +46,6 @@ (in-package :fomus) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 5)) -(defparameter +banner+ - `("Lisp music notation formatter" - "Copyright (c) 2005 David Psenicka, All Rights Reserved" - "See file \"COPYING\" for terms of use and distribution.")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; GLOBAL (defparameter *verbose* 2) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.2 fomus/postproc.lisp:1.3 --- fomus/postproc.lisp:1.2 Mon Jul 25 09:56:03 2005 +++ fomus/postproc.lisp Fri Jul 29 10:58:20 2005 @@ -251,6 +251,89 @@ else when o do (addmark e b) (setf o nil)))) (print-dot)))) +;; preproc-tremolos already +;; must be called before preproc-tuplets, actually, should be before any other postprocs +(defun postproc-tremolos (pts) + (loop with fx + for p in pts do + (loop for m in (part-meas p) do + (loop with ee + for e in (meas-events m) do + (let* ((li nil) + (ma (or (force-list (popmark e :tremolo)) + (loop with xf + for x = (popmark e :tremolofirst) + while x + unless xf do (setf xf x) + do (push (third x) li) + finally (when xf (rmmark e :tremolosecond) (return xf))) + (loop with xf + for x = (popmark e :tremolosecond) + while x + unless xf do (setf xf x) + do (push (third x) li) + finally (return xf))))) + (if ma (let* ((d (second ma)) + (w (if d (let ((x (event-writtendur (copy-event e :dur d) (meas-timesig m)))) + (loop-return-lastmin (diff i x) for i = 1/8 then (/ i 2))) + 1/32))) + (let ((wd (event-writtendur e (meas-timesig m)))) + (multiple-value-bind (d o) (floor wd w) + (let ((re (if (> o 0) + (let ((x (split-event* e (- (event-endoff e) (* (event-dur* e) (/ o d)))))) + (let ((bm (min (event-nbeams (car x) (meas-timesig m)) (event-nbeams (cdr x) (meas-timesig m))))) + (setf (event-beamrt (car x)) bm (event-beamlt (cdr x)) bm)) + (push (cdr x) ee) + (setf fx t) + (car x)) + e))) + (let ((sy (first ma))) ; number of divisions, durational value of tremolo marking + (if (or (not (chordp re)) (eq sy :tremolo)) + (progn (push re ee) (addmark re (list :tremolo d w))) + (loop for n0 in (event-notes* re) + and nn in (event-note re) + and lt in (event-tielt re) + and rt in (event-tiert re) + if (if (eq sy :tremolofirst) (find n0 li) (not (find n0 li))) + collect nn into n1 and collect lt into lt1 + else collect nn into n2 and collect rt into rt2 + finally + (if (and n1 n2) + (let ((c1 (list>1p n1)) + (c2 (list>1p n2)) + (d2 (/ (event-dur* re) 2))) + (let ((e1 (copy-event re + :note (if c1 n1 (first n1)) + :tielt (if c1 lt1 (first lt1)) + :tiert (when c1 '(nil)) + :beamrt 0)) + (e2 (copy-event re + :off (+ (event-off e) d2) + :note (if c2 n2 (first n2)) + :tielt (when c2 '(nil)) + :tiert (if c2 rt2 (first rt2)) + :beamlt 0))) + (setf (event-dur* e1) d2 (event-dur* e2) d2) + (push e1 ee) (push e2 ee) (setf fx t) + (addmark e1 (list :starttremolo (/ d 2) w)) + (addmark e2 (list :endtremolo (/ d 2) w)))) + (progn (push re ee) (addmark re (list :tremolo d w))))))))))) + (push e ee))) + finally + (loop for g in (split-into-groups (setf (meas-events m) (sort ee #'sort-offdur)) #'event-voice*) do + (loop for (a b) on (sort g #'sort-offdur) + when (and b + (or (getmark a :tremolo) (getmark a :starttremolo) (getmark a :endtremolo)) + (or (getmark b :tremolo) (getmark b :starttremolo) (getmark b :endtremolo))) + do + (setf (event-tiert a) (when (consp (event-tiert a)) (make-list (length (event-tiert a)))) + (event-tielt b) (when (consp (event-tielt b)) (make-list (length (event-tielt b))))) + (when (or (getmark a :starttremolo) (getmark a :endtremolo) + (getmark b :starttremolo) (getmark b :endtremolo)) + (setf (event-beamrt a) 0 (event-beamlt b) 0)))))) + (print-dot) + finally (when fx (clean-ties pts)))) + (defun postproc-text (pts) (loop for p in pts do (loop for m in (part-meas p) @@ -294,6 +377,7 @@ ;; do lots of nice things for the backend functions (defun postproc (pts) + (postproc-tremolos pts) (postproc-timesigs pts) (postproc-spanners pts) (postproc-voices pts) ;; voices now separated into lists Index: fomus/split.lisp diff -u fomus/split.lisp:1.5 fomus/split.lisp:1.6 --- fomus/split.lisp:1.5 Wed Jul 27 08:57:37 2005 +++ fomus/split.lisp Fri Jul 29 10:58:20 2005 @@ -82,24 +82,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PREPROCESS -;; return cons of two events (either may be nil) -;; copy = insure that returned events are copies -;; tup is inserted into first (left-side) return only -(defun split-event (event off &optional tup dmu) - (cond ((<= (event-endoff event) off) (cons (copy-event event :tup (cons (force-list tup) (force-list dmu))) nil)) - ((<= off (event-off event)) (cons nil (copy-event event))) - (t (etypecase event - (note (cons (copy-event event - :dur (- off (event-off event)) ; shouldn't be dealing with grace note - :tiert (if (chordp event) (make-list (length (event-tiert event)) :initial-element t) t) - :tup (cons (force-list tup) (force-list dmu))) - (copy-event event - :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 (force-list tup) (force-list dmu))) - (copy-event event :off off :dur (- (event-endoff event) off)))))))) - ;; 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 Index: fomus/util.lisp diff -u fomus/util.lisp:1.5 fomus/util.lisp:1.6 --- fomus/util.lisp:1.5 Tue Jul 26 08:00:57 2005 +++ fomus/util.lisp Fri Jul 29 10:58:20 2005 @@ -273,7 +273,7 @@ (sort (copy-list props) (lambda (x y) (string< (prin1-to-string (force-list x)) (prin1-to-string (force-list y)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; CHORDS +;; CHORDS/SPLITTING ;; list = sorted list of events of same offset/duration ;; rests are discarded @@ -296,6 +296,40 @@ :tiert (mapcar #'cddr x))) (copy-event (first r) :marks (combmarks r))))) +;; return cons of two events (either may be nil) +;; copy = insure that returned events are copies +;; tup is inserted into first (left-side) return only unless both is t +(defun split-event (event off &optional tup dmu tup2) + (cond ((<= (event-endoff event) off) (cons (copy-event event :tup (cons (force-list tup) (force-list dmu))) nil)) + ((<= off (event-off event)) (cons nil (if tup2 (copy-event event :tup (cons (force-list tup2) (force-list dmu))) (copy-event event)))) + (t (etypecase event + (note (cons (copy-event event + :dur (- off (event-off event)) ; shouldn't be dealing with grace note + :tiert (if (chordp event) (make-list (length (event-tiert event)) :initial-element t) t) + :tup (cons (force-list tup) (force-list dmu))) + (if tup2 + (copy-event event + :off off + :dur (- (event-endoff event) off) + :tielt (if (chordp event) (make-list (length (event-tielt event)) :initial-element t) t) + :tup (cons (force-list tup2) (force-list dmu))) + (copy-event event + :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 (force-list tup) (force-list dmu))) + (if tup2 + (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons (force-list tup2) (force-list dmu))) + (copy-event event :off off :dur (- (event-endoff event) off))))))))) + +(declaim (inline split-event*)) +(defun split-event* (event off) + (let ((du (event-dur* event) ) + (u (car (event-tup event)))) + (split-event event off + (when u (cons (* (first u) (/ (- off (event-off event)) du)) (rest u))) (cdr (event-tup event)) + (when u (cons (* (first u) (/ (- (event-endoff event) off) du)) (rest u)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; USER MARKS @@ -319,6 +353,19 @@ do (mapc (lambda (x) (funcall fun x (rest me))) (remove-if-not (lambda (e) (and (> (event-endoff e) o1) (or (null o2) (< (event-off e) o2)))) events)))) +;; clean +;; deletes marks at incorrect places in tied notes/chords +;; expects measures and chords +(defun clean-ties (pts) + (loop for p in pts + do (loop for m in (part-meas p) + do (loop + for e in (remove-if-not #'notep (meas-events m)) + when (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo)) + do (mapc (lambda (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) (rmmark e x)) +marks-last-tie+))) (print-dot))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STAVES

1 0

[fomus-cvs] CVS update: fomus/backend_ly.lisp
by dpsenicka＠common-lisp.net 27 Jul '05

27 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20706 Modified Files: backend_ly.lisp Log Message: Fixed title/subtitle/composer header Date: Wed Jul 27 22:58:50 2005 Author: dpsenicka Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.5 fomus/backend_ly.lisp:1.6 --- fomus/backend_ly.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/backend_ly.lisp Wed Jul 27 22:58:50 2005 @@ -305,14 +305,14 @@ collect (format nil "\\skip 1*~A/~A*~A " n d nu) into re and do (setf nu 0) do (incf nu) finally (return (nconc re (list (format nil "\\skip 1*~A/~A*~A" n d nu)))))))))))) + (when (or *title* *subtitle* *composer*) + (format f "\\header {~%") + (when *title* (format f " title = ~S~%" *title*)) + (when *subtitle* (format f " subtitle = ~S~%" *subtitle*)) + (when *composer* (format f " composer = ~S~%" *composer*)) + (format f "}~%~%")) (format f "\\score {~%") ;; score block (loop for e in scorehead do (format f " ~A~%" e)) - (when (or *title* *subtitle* *composer*) - (format f " \\header {~%") - (when *title* (format f " title = ~S~%" *title*)) - (when *subtitle* (format f " subtitle = ~S~%" *subtitle*)) - (when *composer* (format f " composer = ~S~%" *composer*)) - (format f " }~%")) (loop with in = 2 for p in parts and nm in (nreverse nms) do

1 0

[fomus-cvs] CVS update: fomus/test.lisp fomus/TODO fomus/beams.lisp fomus/package.lisp fomus/quantize.lisp fomus/split.lisp fomus/staves.lisp
by dpsenicka＠common-lisp.net 27 Jul '05

27 Jul '05

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

1 0

[fomus-cvs] CVS update: fomus/doc/objects.xml
by dpsenicka＠common-lisp.net 26 Jul '05

26 Jul '05

Update of /project/fomus/cvsroot/fomus/doc In directory common-lisp.net:/tmp/cvs-serv32341/doc Modified Files: objects.xml Log Message: Testing/bug fixes Date: Tue Jul 26 08:01:05 2005 Author: dpsenicka Index: fomus/doc/objects.xml diff -u fomus/doc/objects.xml:1.6 fomus/doc/objects.xml:1.7 --- fomus/doc/objects.xml:1.6 Tue Jul 26 01:16:01 2005 +++ fomus/doc/objects.xml Tue Jul 26 08:01:05 2005 @@ -1401,7 +1401,7 @@ <para> This is an integer or symbol designating where the instrument's notes are to appear on the staff. - The value is interpreted as if notated with a treble clef signature. + The value is interpreted with middle C in the center as if notated with an alto clef signature. See <function>EVENT-NOTE</function> in the <classname><link linkend="class.note">NOTE</link></classname> class for information on specifying notes with symbols.

1 0

[fomus-cvs] CVS update: fomus/README fomus/TODO fomus/accidentals.lisp fomus/data.lisp fomus/main.lisp fomus/other.lisp fomus/util.lisp
by dpsenicka＠common-lisp.net 26 Jul '05

26 Jul '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv32341 Modified Files: README TODO accidentals.lisp data.lisp main.lisp other.lisp util.lisp Log Message: Testing/bug fixes Date: Tue Jul 26 08:00:59 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.3 fomus/README:1.4 --- fomus/README:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/README Tue Jul 26 08:00:57 2005 @@ -20,8 +20,10 @@ (use-package :fm) The program is being developed in SBCL, but should also compile in CMUCL and -OpenMCL. It will eventually run in Allegro Common Lisp and CLISP. +OpenMCL. It will eventually run in Allegro Common Lisp and CLISP. There are +problems compiling it in SBCL v0.9.0 (and probably earlier versions) in Darwin +(errors related to memory management). If you wish to report a bug, make FOMUS generate a debug file (the default -filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the +filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the DEBUG-FILENAME setting in the FOMUS documentation for more information. Index: fomus/TODO diff -u fomus/TODO:1.5 fomus/TODO:1.6 --- fomus/TODO:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/TODO Tue Jul 26 08:00:57 2005 @@ -16,6 +16,7 @@ SHORT TERM +Number of lines in staff Global timesig-repl list MINP and MAXP instrument ranges MusicXML backend Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.4 fomus/accidentals.lisp:1.5 --- fomus/accidentals.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/accidentals.lisp Tue Jul 26 08:00:57 2005 @@ -154,7 +154,7 @@ (list x)))) ; e = lists of accs. if (funcall spellfun o a) collect a) (loop for a in (mapcar conv choices) if (funcall spellfun o a) collect a) ; ignore user's suggestion - (error "No accidentals possible for note ~S, offset ~S, part ~S" (event-note f) (event-foff f) name)) + (error "No accidentals possible for note ~S at offset ~S, part ~S" (event-note f) (event-foff f) name)) collect (let ((w (copy-event f :note (cons (event-note* f) e))) (s (nokeynode-sc no))) (let ((d (cons w Index: fomus/data.lisp diff -u fomus/data.lisp:1.5 fomus/data.lisp:1.6 --- fomus/data.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/data.lisp Tue Jul 26 08:00:57 2005 @@ -42,20 +42,19 @@ (defparameter +notenum+ (vector 9 11 0 2 4 5 7)) (defun note-to-num (note) - (if (keywordp note) note - (roundto - (if (and *cm-exists* *use-cm*) - (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note)) - (if (symbolp note) - (let* ((s (symbol-name note)) - (b (svref +notenum+ (- (char-int (aref s 0)) 65))) - (a (case (aref s 1) - ((#\+ #\S) (incf b) 2) - ((#\- #\F) (decf b) 2) - (otherwise 1)))) - (+ (* (parse-integer (subseq s a)) 12) b 12)) - note)) - *note-precision*))) + (roundto + (if (and *cm-exists* *use-cm*) + (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note)) + (if (symbolp note) + (let* ((s (symbol-name note)) + (b (svref +notenum+ (- (char-int (aref s 0)) 65))) + (a (case (aref s 1) + ((#\+ #\S) (incf b) 2) + ((#\- #\F) (decf b) 2) + (otherwise 1)))) + (+ (* (parse-integer (subseq s a)) 12) b 12)) + note)) + *note-precision*)) (defun is-note (note) (let ((*note-precision* 1)) (numberp (ignore-errors (note-to-num note))))) (defun parse-usernote (no) Index: fomus/main.lisp diff -u fomus/main.lisp:1.5 fomus/main.lisp:1.6 --- fomus/main.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/main.lisp Tue Jul 26 08:00:57 2005 @@ -55,119 +55,119 @@ (check-setting-types) (find-cm) (check-settings) - (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) - #-debug (declare (ignore rm)) - #+debug (when rm (error "Error in FOMUS-PROC")) - (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (or (notep x) (restp x)))) - (let ((pts (progn - (loop for p in *parts* and i from 0 - do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp - (lambda (x) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks - (flet ((gpi () - (or (part-partid p) - (setf (part-partid p) - (loop - for s = (gensym) - while (find s *parts* :key #'part-partid) - finally (return s)))))) - (mapc (lambda (x) - (unless (timesig-partids x) - (setf (timesig-partids x) (gpi)))) - ti) - (mapc (lambda (x) - (unless (event-partid x) - (setf (event-partid x) (gpi)))) - ma)) - (prenconc ti *timesigs*) - (prenconc ke *keysigs*) - (prenconc ma mks) - (multiple-value-bind (eo ep) (split-list evs #'event-partid) - (setf (part-events p) ep) - (prenconc eo *events*)))) - (setf *timesigs* (mapcar #'make-timesigex* *timesigs*)) - (set-note-precision + (set-note-precision + (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) + #-debug (declare (ignore rm)) + #+debug (when rm (error "Error in FOMUS-PROC")) + (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (or (notep x) (restp x)))) + (let ((pts (progn + (loop for p in *parts* and i from 0 + do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp + (lambda (x) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks + (flet ((gpi () + (or (part-partid p) + (setf (part-partid p) + (loop + for s = (gensym) + while (find s *parts* :key #'part-partid) + finally (return s)))))) + (mapc (lambda (x) + (unless (timesig-partids x) + (setf (timesig-partids x) (gpi)))) + ti) + (mapc (lambda (x) + (unless (event-partid x) + (setf (event-partid x) (gpi)))) + ma)) + (prenconc ti *timesigs*) + (prenconc ke *keysigs*) + (prenconc ma mks) + (multiple-value-bind (eo ep) (split-list evs #'event-partid) + (setf (part-events p) ep) + (prenconc eo *events*)))) + (setf *timesigs* (mapcar #'make-timesigex* *timesigs*)) (loop with h = (get-timesigs *timesigs* *parts*) for i from 0 and e in *parts* for (evs rm) on (split-list* *events* (mapcar #'part-partid *parts*) :key #'event-partid) collect (make-partex* e i evs (gethash e h)) - finally (when rm (error "No matching part for event with partid ~S" (first *events*)))))))) ; make copied list of part-exs w/ sorted events - #+debug (fomus-proc-check pts 'start) - (track-progress +progress-int+ - (if *auto-quantize* - (progn (when (>= *verbose* 2) (out "~&; Quantizing...")) - (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize)) - (quantize-generic pts)) - (when *check-ranges* - (when (>= *verbose* 2) (out "~&; Ranges...")) - (check-ranges pts) #+debug (fomus-proc-check pts 'ranges)) - (preproc-harmonics pts) - (when *transpose* - (when (>= *verbose* 2) (out "~&; Transpositions...")) - (transpose pts) #+debug (fomus-proc-check pts 'transpose)) - (if *auto-accidentals* - (progn (when (>= *verbose* 2) (out "~&; Accidentals...")) - (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs)) - (accidentals-generic pts)) - (reset-tempslots pts nil) - (when (and (>= *verbose* 2) (find-if #'is-percussion pts)) - (out "~&; Percussion...") ; before voices & clefs - (percussion pts)) - (if *auto-voicing* - (progn (when (>= *verbose* 2) (out "~&; Voices...")) - (voices pts) #+debug (fomus-proc-check pts 'voices)) - (voices-generic pts)) - (if *auto-staff/clef-changes* - (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided - (clefs pts) #+debug (fomus-proc-check pts 'clefs)) - (clefs-generic pts)) - (reset-tempslots pts 0) - (distribute-marks pts mks) - (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED - ;;(if *auto-quantize* (clean-quantize pts)) - (when *auto-ottavas* ; (before clean-spanners) - (when (>= *verbose* 2) (out "~&; Ottavas...")) - (ottavas pts) #+debug (fomus-proc-check pts 'ottavas)) - (when (>= *verbose* 2) (out "~&; Staff spanners...")) - (clean-spanners pts +marks-spanner-staves+) #+debug (fomus-proc-check pts 'spanners1) - (setf pts (sep-voices (assemble-parts pts))) ; ********** STAVES TOGETHER, VOICES SEPARATED - (when (>= *verbose* 2) (out "~&; Voice spanners...")) - (expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks) - (clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2) - (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) - (preproc-cautaccs pts) - (when *auto-grace-slurs* - (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) - (when (>= *verbose* 2) (out "~&; Measures...")) - (init-parts *timesigs* pts) ; ----- MEASURES - #+debug (fomus-proc-check pts 'measures) - #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x))))) - (when *auto-cautionary-accs* - (when (>= *verbose* 2) (out "~&; Cautionary accidentals...")) - (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs)) - (when (>= *verbose* 2) (out "~&; Chords...")) - (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS - (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1) - (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) - (split pts) #+debug (fomus-proc-check pts 'ties) - (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2) - (when *auto-beams* - (when (>= *verbose* 2) (out "~&; Beams...")) - (beams pts) #+debug (fomus-proc-check pts 'beams)) - (when (>= *verbose* 2) (out "~&; Staff/voice layouts...")) - (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER - (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests) - (when (or *auto-multivoice-rests* *auto-multivoice-notes*) - (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes)) - (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs) - (when (>= *verbose* 2) (out "~&; Post processing...")) - (postaccs pts) #+debug (fomus-proc-check pts 'postaccs) - (postproc pts) #+debug (fomus-proc-check pts 'postproc) - (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts) - (group-parts pts) #+debug (fomus-proc-check pts 'groupparts) - (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops) - (when (>= *verbose* 2) (format t "~&")) - pts))))) + finally (when rm (error "No matching part for event with partid ~S" (first *events*))))))) ; make copied list of part-exs w/ sorted events + #+debug (fomus-proc-check pts 'start) + (track-progress +progress-int+ + (if *auto-quantize* + (progn (when (>= *verbose* 2) (out "~&; Quantizing...")) + (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize)) + (quantize-generic pts)) + (when *check-ranges* + (when (>= *verbose* 2) (out "~&; Ranges...")) + (check-ranges pts) #+debug (fomus-proc-check pts 'ranges)) + (preproc-harmonics pts) + (when *transpose* + (when (>= *verbose* 2) (out "~&; Transpositions...")) + (transpose pts) #+debug (fomus-proc-check pts 'transpose)) + (if *auto-accidentals* + (progn (when (>= *verbose* 2) (out "~&; Accidentals...")) + (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs)) + (accidentals-generic pts)) + (reset-tempslots pts nil) + (when (and (>= *verbose* 2) (find-if #'is-percussion pts)) + (out "~&; Percussion...") ; before voices & clefs + (percussion pts)) + (if *auto-voicing* + (progn (when (>= *verbose* 2) (out "~&; Voices...")) + (voices pts) #+debug (fomus-proc-check pts 'voices)) + (voices-generic pts)) + (if *auto-staff/clef-changes* + (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided + (clefs pts) #+debug (fomus-proc-check pts 'clefs)) + (clefs-generic pts)) + (reset-tempslots pts 0) + (distribute-marks pts mks) + (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED + ;;(if *auto-quantize* (clean-quantize pts)) + (when *auto-ottavas* ; (before clean-spanners) + (when (>= *verbose* 2) (out "~&; Ottavas...")) + (ottavas pts) #+debug (fomus-proc-check pts 'ottavas)) + (when (>= *verbose* 2) (out "~&; Staff spanners...")) + (clean-spanners pts +marks-spanner-staves+) #+debug (fomus-proc-check pts 'spanners1) + (setf pts (sep-voices (assemble-parts pts))) ; ********** STAVES TOGETHER, VOICES SEPARATED + (when (>= *verbose* 2) (out "~&; Voice spanners...")) + (expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks) + (clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2) + (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) + (preproc-cautaccs pts) + (when *auto-grace-slurs* + (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) + (when (>= *verbose* 2) (out "~&; Measures...")) + (init-parts *timesigs* pts) ; ----- MEASURES + #+debug (fomus-proc-check pts 'measures) + #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x))))) + (when *auto-cautionary-accs* + (when (>= *verbose* 2) (out "~&; Cautionary accidentals...")) + (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs)) + (when (>= *verbose* 2) (out "~&; Chords...")) + (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS + (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1) + (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) + (split pts) #+debug (fomus-proc-check pts 'ties) + (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2) + (when *auto-beams* + (when (>= *verbose* 2) (out "~&; Beams...")) + (beams pts) #+debug (fomus-proc-check pts 'beams)) + (when (>= *verbose* 2) (out "~&; Staff/voice layouts...")) + (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER + (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests) + (when (or *auto-multivoice-rests* *auto-multivoice-notes*) + (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes)) + (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs) + (when (>= *verbose* 2) (out "~&; Post processing...")) + (postaccs pts) #+debug (fomus-proc-check pts 'postaccs) + (postproc pts) #+debug (fomus-proc-check pts 'postproc) + (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts) + (group-parts pts) #+debug (fomus-proc-check pts 'groupparts) + (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops) + (when (>= *verbose* 2) (format t "~&")) + pts)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; MAIN Index: fomus/other.lisp diff -u fomus/other.lisp:1.2 fomus/other.lisp:1.3 --- fomus/other.lisp:1.2 Tue Jul 26 01:15:53 2005 +++ fomus/other.lisp Tue Jul 26 08:00:57 2005 @@ -64,13 +64,18 @@ when (is-percussion p) do (loop with pm = (instr-percs (part-instr p)) for ev in (part-events p) do - (let ((n (event-note ev))) + (let ((n (event-note ev))) ; n = value of note slot (unless (numberp n) - (let ((c (etypecase n + (let ((c (etypecase n ; c = percussion struct (symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym)) (perc n)))) - (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1)) - (setf (event-staff* ev) (perc-staff c))) - (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))))))) + (if c + (progn + (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1)) + (setf (event-staff* ev) (perc-staff c))) + (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))) + (setf (event-note ev) (note-to-num (perc-note c)))) + (if (is-note n) (setf (event-note ev) (note-to-num n)) + (error "Unknown percussion specifier ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p)))))))) (print-dot))) Index: fomus/util.lisp diff -u fomus/util.lisp:1.4 fomus/util.lisp:1.5 --- fomus/util.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/util.lisp Tue Jul 26 08:00:57 2005 @@ -501,15 +501,13 @@ :dur (get-dur ev ts) :marks (event-marks ev) :voice (event-voice ev) - :note (let ((n (event-note ev))) - (if (is-percussion pa) - (unless (numberp n) - (perc-note (etypecase n - (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym) - (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa)))) - (perc n))) - n) - (parse-usernote n))))) + :note (if (is-percussion pa) (event-note ev) + ;; (if (numberp n) n + ;; (perc-note (etypecase n + ;; (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym) + ;; (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa)))) + ;; (perc n)))) + (parse-usernote (event-note ev))))) (defmethod make-eventex* ((ev rest) ts pa) (declare (ignore pa)) (make-restex

1 0