[fomus-cvs] CVS update: fomus/TODO fomus/data.lisp fomus/main.lisp fomus/test.lisp fomus/util.lisp
David Psenicka
dpsenicka at common-lisp.net
Wed Aug 31 15:56:08 UTC 2005
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* , at +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)))
+ , at 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
More information about the Fomus-cvs
mailing list