Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv26517
Modified Files: TODO data.lisp main.lisp test.lisp util.lisp Log Message: bug fixes Date: Wed Aug 31 17:56:06 2005 Author: dpsenicka
Index: fomus/TODO diff -u fomus/TODO:1.17 fomus/TODO:1.18 --- fomus/TODO:1.17 Wed Aug 31 16:07:10 2005 +++ fomus/TODO Wed Aug 31 17:56:06 2005 @@ -9,10 +9,13 @@ :STAFF and other marks for overriding FOMUS's decisions MusicXML backend MIDI output to CM - Avoid staff changes when notes move in other direction Durations that fill to next/previous note Proofread/finish documentation, add easy examples Tuplet bracket setting + DOC: :instruments setting update + Aesthetic tweaks: + Avoid staff changes when notes move in other direction + Re-evaluate initial clef decision in measure 1
Short Term:
Index: fomus/data.lisp diff -u fomus/data.lisp:1.19 fomus/data.lisp:1.20 --- fomus/data.lisp:1.19 Wed Aug 31 16:35:15 2005 +++ fomus/data.lisp Wed Aug 31 17:56:06 2005 @@ -463,7 +463,7 @@ ;; exported symbols/arguments to main function (declaim (type cons +settings+)) (defparameter +settings+ - '((:debug-filename (or null string)) (:verbose (integer 0 2)) + `((:debug-filename (or null string)) (:verbose (integer 0 2)) (:use-cm boolean) (:cm-scale t) (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (or* symbol (cons* symbol key-arg-pairs*)))) "(SYMBOL KEYWORD/ARGUMENTS-PAIRS...) or list of (SYMBOL KEYWORD/ARGUMENTS-PAIRS...)") @@ -475,7 +475,7 @@ (:events (or* null (list-of* (or* (type* +note-type+) (type* +rest-type+) (type* +mark-type+)))) "list of NOTE or REST objects")
(:check-ranges boolean) (:transpose boolean) - (:instruments (or* null (list-of* (type* +instr-type+))) "list of INSTR objects") + (:instruments (or* null (list-of* (or* (type* +instr-type+) (cons* symbol (key-arg-pairs* ,@+instr-keys+))))) "list of INSTR objects") (:instr-groups (or* null (type* +instr-group-tree-type+)) "list of nested lists of SYMBOLS") (:default-instr (type* +instr-type+) "INSTR object") (:ensemble-type (or* null symbol (cons* symbol (list-of* +instr-group-tree-type-aux+))) "NIL, SYMBOL or nested lists of SYMBOLS")
Index: fomus/main.lisp diff -u fomus/main.lisp:1.13 fomus/main.lisp:1.14 --- fomus/main.lisp:1.13 Sun Aug 28 23:31:27 2005 +++ fomus/main.lisp Wed Aug 31 17:56:06 2005 @@ -59,127 +59,128 @@ (check-setting-types) (check-settings) (let ((*max-tuplet* (force-list *max-tuplet*))) ; normalize some parameters - (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) (declare (type (or note rest mark) x)) (or (notep x) (restp x)))) - (let ((pts (progn - (loop for p of-type part in *parts* and i from 0 - do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp - (lambda (x) (declare (type (or note rest mark timesig) 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) - (declare (type timesig x)) - (unless (timesig-partids x) - (setf (timesig-partids x) (gpi)))) - ti) - (mapc (lambda (x) - (declare (type mark 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) of-type (list list) 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" (event-partid (first rm)))))))) ; make copied list of part-exs w/ sorted events - #+debug (fomus-proc-check pts 'start) - (track-progress +progress-int+ - (when (find-if #'is-percussion pts) - (when (>= *verbose* 2) (out "~&; Percussion...")) ; before voices & clefs - (percussion pts)) ; was after accs - (autodurs-preproc pts) - (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-noteheads 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)) - (if *auto-voicing* - (progn (when (>= *verbose* 2) (out "~&; Voices...")) - (voices pts) #+debug (fomus-proc-check pts 'voices)) - (voices-generic pts)) - (reset-tempslots pts nil) - (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 nil) - (distribute-marks pts mks) - (reset-tempslots pts nil) - (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED - (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...")) - (when (find-if #'is-percussion pts) (autodurs *timesigs* pts)) ;; uses beamrt until after split function - (preproc-tremolos pts) - (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-preproc-backends pts) - (split pts) #+debug (fomus-proc-check pts 'ties) - (reset-tempslots pts 0) - (reset-resttempslots pts) - (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* 1) (format t "~&")) - pts))))))) + (set-instruments + (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) (declare (type (or note rest mark) x)) (or (notep x) (restp x)))) + (let ((pts (progn + (loop for p of-type part in *parts* and i from 0 + do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp + (lambda (x) (declare (type (or note rest mark timesig) 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) + (declare (type timesig x)) + (unless (timesig-partids x) + (setf (timesig-partids x) (gpi)))) + ti) + (mapc (lambda (x) + (declare (type mark 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) of-type (list list) 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" (event-partid (first rm)))))))) ; make copied list of part-exs w/ sorted events + #+debug (fomus-proc-check pts 'start) + (track-progress +progress-int+ + (when (find-if #'is-percussion pts) + (when (>= *verbose* 2) (out "~&; Percussion...")) ; before voices & clefs + (percussion pts)) ; was after accs + (autodurs-preproc pts) + (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-noteheads 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)) + (if *auto-voicing* + (progn (when (>= *verbose* 2) (out "~&; Voices...")) + (voices pts) #+debug (fomus-proc-check pts 'voices)) + (voices-generic pts)) + (reset-tempslots pts nil) + (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 nil) + (distribute-marks pts mks) + (reset-tempslots pts nil) + (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED + (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...")) + (when (find-if #'is-percussion pts) (autodurs *timesigs* pts)) ;; uses beamrt until after split function + (preproc-tremolos pts) + (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-preproc-backends pts) + (split pts) #+debug (fomus-proc-check pts 'ties) + (reset-tempslots pts 0) + (reset-resttempslots pts) + (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* 1) (format t "~&")) + pts))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; MAIN
Index: fomus/test.lisp diff -u fomus/test.lisp:1.9 fomus/test.lisp:1.10 --- fomus/test.lisp:1.9 Wed Aug 31 16:07:10 2005 +++ fomus/test.lisp Wed Aug 31 17:56:06 2005 @@ -342,12 +342,12 @@ :parts (list (make-part - :name "Violin" - :instr :violin + :name "Cello" + :instr :cello :events (loop for off from 0 to 10 by 1/2 - for note = (+ 55 (random 25)) + for note = (+ 36 (random 25)) collect (make-note :off off :dur (if (< off 10) 1/2 1) :note note
Index: fomus/util.lisp diff -u fomus/util.lisp:1.14 fomus/util.lisp:1.15 --- fomus/util.lisp:1.14 Wed Aug 31 16:07:10 2005 +++ fomus/util.lisp Wed Aug 31 17:56:06 2005 @@ -659,7 +659,14 @@ *min-tuplet-dur* *beat-division* (setf *min-tuplet-dur* (/ *beat-division*)))) (when (< *max-tuplet-dur* *min-tuplet-dur*) (format t "~&;; WARNING: Value ~S of setting :MAX-TUPLET-DUR is smaller than value of setting :MIN-TUPLET-DUR--changing to ~S" - *max-tuplet-dur* (setf *max-tuplet-dur* *min-tuplet-dur*)))) + *max-tuplet-dur* (setf *max-tuplet-dur* *min-tuplet-dur*)))) + +(defmacro set-instruments (&body forms) + `(let ((*instruments* + (loop for e of-type (or instr cons) in *instruments* + if (consp e) collect (apply #'copy-instr (find (first e) +instruments+ :key #'instr-sym) (rest e)) + else collect e))) + ,@forms))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INTERNAL OBJECT CONSTRUCTORS @@ -760,14 +767,15 @@ (format t "; ~A~VT~A~VT~A~%" sy tc (or t2 t1) tl (prin1-to-string (symbol-value (find-symbol (conc-strings "*" (symbol-name sy) "*") :fomus)))))))
(defun list-fomus-instruments () - (loop with li = (remove-duplicates (append *instruments* +instruments+) :key #'instr-sym :from-end t) - with c = (+ (loop for e in li maximize (length (symbol-name (instr-sym e)))) 3) - for e in li - do (format t "; ~A~VT~A~%" - (instr-sym e) c - (conc-stringlist - (loop for (s sn) on (rest +instr-keys+) - collect (format nil (if sn "~A: ~S " "~A: ~S") (string-downcase s) (slot-value e (intern (symbol-name s) :fomus)))))))) + (set-instruments + (loop with li = (remove-duplicates (append *instruments* +instruments+) :key #'instr-sym :from-end t) + with c = (+ (loop for e in li maximize (length (symbol-name (instr-sym e)))) 3) + for e in li + do (format t "; ~A~VT~A~%" + (instr-sym e) c + (conc-stringlist + (loop for (s sn) on (rest +instr-keys+) + collect (format nil (if sn "~A: ~S " "~A: ~S") (string-downcase s) (slot-value e (intern (symbol-name s) :fomus)))))))))
(defun list-fomus-percussion () (loop with li = (remove-duplicates *percussion* :key #'perc-sym :from-end t) @@ -808,6 +816,7 @@ do (format t "; ~A~5T~{ ~A~}~%" s r)))
(defun get-midi-instr (prog &key (default *default-instr*)) - (or (find prog *instruments* :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) - (find prog +instruments+ :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) - default)) \ No newline at end of file + (set-instruments + (or (find prog *instruments* :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) + (find prog +instruments+ :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) + default))) \ No newline at end of file