Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv30128
Modified Files: TODO backend_ly.lisp backend_xml.lisp backends.lisp data.lisp deps.lisp fomus.asd load.lisp main.lisp misc.lisp other.lisp postproc.lisp test.lisp version.lisp Added Files: backend_cmn.lisp backend_mid.lisp Log Message: test/bug fixes/CM MIDI backend Date: Sat Oct 1 02:49:46 2005 Author: dpsenicka
Index: fomus/TODO diff -u fomus/TODO:1.21 fomus/TODO:1.22 --- fomus/TODO:1.21 Wed Sep 21 01:23:15 2005 +++ fomus/TODO Sat Oct 1 02:49:45 2005 @@ -4,15 +4,17 @@
Bugs: Quantizing nested tuplets--occasional hangups + accidentals for trills and related figures (or just a note/step argument for MIDI playback) Doc: list-instr-syms + Doc: CM MIDI backend Splitting chords across staves (LilyPond) STAFF, CLEF and other marks for overriding FOMUS's decisions MusicXML backend - MIDI output to CM + CMN backend Durations that fill to next/previous note Proofread/finish documentation: most often used settings - easy, indexed examples of all features + examples of all features Tuplet bracket setting Marks affecting all voices (distinguishing them for purposes of MIDI playback, etc.) Aesthetic tweaks: @@ -22,7 +24,6 @@ Short Term:
Part properties: override settings for individual parts - CMN backend MIDI to percussion Number of lines in staff Percussion enhancements
Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.16 fomus/backend_ly.lisp:1.17 --- fomus/backend_ly.lisp:1.16 Wed Aug 31 23:17:59 2005 +++ fomus/backend_ly.lisp Sat Oct 1 02:49:45 2005 @@ -233,8 +233,8 @@ (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\acciaccatura " "\appoggiatura ")) (g1 (if (< g 0) "\acciaccatura {" "\appoggiatura {")))) "")) - (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\< ") - ((and (getmark e :startwedge>) (getmark e :endwedge-)) "\> ") + (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\< ") + ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\> ") (t "")) (cond ((getmark e '(:arpeggio :up)) "\arpeggioUp ") ((getmark e '(:arpeggio :down)) "\arpeggioDown ") @@ -317,7 +317,7 @@ (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) (x2 t))))) collect (car i))) - (cond ((getmark e :endwedge-) "\!") + (cond ((or (getmark e :endwedge<) (getmark e :endwedge>)) "\!") ((getmark e :startwedge<) "\<") ((getmark e :startwedge>) "\>") (t "")) @@ -325,8 +325,8 @@ (loop for i in (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) collect (lookup (first i) +lilypond-dyns+))) - (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge-))) "\<") - ((and (getmark e :startwedge>) (not (getmark e :endwedge-))) "\>") + (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\<") + ((and (getmark e :startwedge>) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\>") (t "")) (conc-stringlist (loop for x in '(:text :textdyn :texttempo :textnote)
Index: fomus/backend_xml.lisp diff -u fomus/backend_xml.lisp:1.3 fomus/backend_xml.lisp:1.4 --- fomus/backend_xml.lisp:1.3 Sun Aug 28 23:31:27 2005 +++ fomus/backend_xml.lisp Sat Oct 1 02:49:45 2005 @@ -2,7 +2,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;************************************************************************************************** ;; FOMUS -;; backend_ly.lisp +;; backend_xml.lisp ;;**************************************************************************************************
(in-package :fomus)
Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.9 fomus/backends.lisp:1.10 --- fomus/backends.lisp:1.9 Wed Aug 31 16:35:15 2005 +++ fomus/backends.lisp Sat Oct 1 02:49:45 2005 @@ -12,7 +12,7 @@
(declaim (type cons +backendexts+)) (defparameter +backendexts+ - '((:data . "fms") (:lilypond . "ly") (:musicxml . "xml"))) + '((:data . "fms") #|(:cmn . "cmn")|# (:lilypond . "ly") (:musicxml . "xml") (:midi . "mid") #|(:portmidi . "pm") (:midishare . "ms")|#))
(declaim (type (or symbol list) *backend*)) (defparameter *backend* (list (first (first +backendexts+)))) @@ -33,11 +33,15 @@ do (case (first (force-list x)) (:lilypond (split-preproc-lilypond pts)))))
-(defun backend (backend filename parts options process view) +(defun backend (backend filename parts options process play view) (declare (type symbol backend) (type list parts) (type list options) (type boolean process) (type boolean view)) (case backend (:data (save-data filename parts)) +;; (:cmn (save-lilypond parts (format nil +cmn-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (:lilypond (save-lilypond parts (format nil +lilypond-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (:musicxml (save-xml parts (format nil +xml-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options)) + (:midi (save-midi parts filename options play view)) +;; (:portmidi (save-midi parts nil filename options :pm view)) +;; (:midishare (save-midi parts nil filename options :ms view)) (otherwise (error "Unknown backend ~S" backend))))
Index: fomus/data.lisp diff -u fomus/data.lisp:1.22 fomus/data.lisp:1.23 --- fomus/data.lisp:1.22 Fri Sep 2 07:56:45 2005 +++ fomus/data.lisp Sat Oct 1 02:49:45 2005 @@ -27,9 +27,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; QUALITY
-(declaim (type (real (0)) *quality*)) +(declaim (type (real 0) *quality*)) (defparameter *quality* 1)
+(defmacro set-quality (&body forms) + `(let ((*quality* (if (>= *quality* 1) *quality* (/ (- 2 *quality*))))) + ,@forms)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; QUANTIZING
@@ -56,6 +60,9 @@ (declaim (type boolean *quartertones*)) (defparameter *quartertones* nil)
+(declaim (type boolean *transpose*)) +(defparameter *transpose* t) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CONVERSION
@@ -468,7 +475,7 @@ (: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...)") (:filename string) - (:quality (real (0))) + (:quality (real 0))
(:global (or* null (list-of* (type* +timesig-type+))) "list of TIMESIG objects") (:parts (list-of* (type* +part-type+)) "list of PART objects") @@ -540,7 +547,7 @@ '(or* (let* ((x (unique* sy (member :longtrill :arco :pizz :start8down- :8down- :end8down- :8down :start8up- :8up- :end8up- :8up - :startwedge> :startwedge< :wedge- :endwedge- + :startwedge> :startwedge< :wedge< :wedge> :endwedge< :endwedge> :startgraceslur- :graceslur- :endgraceslur- :clef- :endclef- :cautacc :autodur @@ -639,9 +646,9 @@ (defun is-restmarksym (sym) (find sym +marks-rests+))
-(declaim (type cons +marks-unimportant+)) +(declaim (type cons +marks-important+)) (defparameter +marks-important+ - '(:longtrill :arco :pizz :startgraceslur- :graceslur- :endgraceslur- :startwedge> :startwedge< :wedge- :endwedge- + '(:longtrill :arco :pizz :startgraceslur- :graceslur- :endgraceslur- :startwedge> :startwedge< :wedge< :wedge> :endwedge< :endwedge> :rfz :sfz :spp :sp :sff :sf :fp :ffffff :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp :pppppp :fermata :arpeggio :glissando :breath :harmonic :stopped :open :staccato :staccatissimo @@ -667,7 +674,7 @@ :notehead :harmonic :arpeggio :glissando :portamento ; special ones :cautacc :8up :8down :clef)) (defparameter +marks-last-tie+ - '(:endslur- :end8up- :end8down- :endtext- #|:endtextdyn- :endtexttempo-|# :endwedge- + '(:endslur- :end8up- :end8down- :endtext- #|:endtextdyn- :endtexttempo-|# :endwedge< :endwedge> :fermata :staccatissimo :staccato :breath)) ;; (defparameter +marks-all-ties+ ;; '(:longtrill :tremolo :tremolofirst :tremolosecond)) @@ -697,8 +704,8 @@ (:starttext- :text- :endtext- :text) ;; (:starttexttempo- :texttempo- :endtexttempo- :texttempo) ;; (:starttextdyn- :textdyn- :endtextdyn- :textdyn) - (:startwedge< :wedge- :endwedge- t) - (:startwedge> :wedge- :endwedge- t) + (:startwedge< :wedge< :endwedge< t) + (:startwedge> :wedge> :endwedge> t) (:startlongtrill- :longtrill- :endlongtrill- t))) (defparameter +marks-spanner-staves+ '((:start8up- :8up- :end8up- :8up)
Index: fomus/deps.lisp diff -u fomus/deps.lisp:1.4 fomus/deps.lisp:1.5 --- fomus/deps.lisp:1.4 Sun Aug 21 21:17:40 2005 +++ fomus/deps.lisp Sat Oct 1 02:49:45 2005 @@ -20,11 +20,51 @@ (defparameter *cm-notefun* nil) (defparameter *cm-keynumfun* nil) (defparameter *cm-rhythmfun* nil) +(defparameter *cm-midi* nil) +;; (defparameter *cm-seq* nil) +(defparameter *cm-events* nil) +(defparameter *cm-rts* nil) +;; (defparameter *cm-chmap* nil) +(defparameter *cm-midipbend* nil) + +(defparameter *cm-midioff* nil) +(defparameter *cm-midioffslot* nil) +(defparameter *cm-mididur* nil) +(defparameter *cm-mididurslot* nil) +(defparameter *cm-midinote* nil) +(defparameter *cm-midinoteslot* nil) +(defparameter *cm-midich* nil) +(defparameter *cm-midichslot* nil) +(defparameter *cm-midivel* nil) +(defparameter *cm-midivelslot* nil) +(defparameter *cm-progch* nil) +;; (defparameter *cm-skipdrumch* nil)
;; would be nice if can use rhythm symbols (defun find-cm () (when (and (not *cm-exists*) (find-package "CM")) (when (>= *verbose* 2) (format t ";; Common Music package detected~%")) - (setf *cm-exists* t *cm-notefun* (symbol-function (find-symbol "NOTE" :cm)) *cm-keynumfun* (symbol-function (find-symbol "KEYNUM" :cm)) - *cm-rhythmfun* (symbol-function (find-symbol "RHYTHM" :cm))))) + (setf *cm-exists* t + *cm-notefun* (symbol-function (find-symbol "NOTE" :cm)) + *cm-keynumfun* (symbol-function (find-symbol "KEYNUM" :cm)) + *cm-rhythmfun* (symbol-function (find-symbol "RHYTHM" :cm)) + *cm-midi* (find-symbol "MIDI" :cm) + *cm-progch* (find-symbol "MIDI-PROGRAM-CHANGE" :cm) +;; *cm-seq* (find-symbol "SEQ" :cm) +;; *cm-chmap* (find-symbol "*MIDI-CHANNEL-MAP*" :cm) + *cm-midioff* (symbol-function (find-symbol "OBJECT-TIME" :cm)) + *cm-midioffslot* (find-symbol "TIME" :cm) + *cm-mididur* (symbol-function (find-symbol "MIDI-DURATION" :cm)) + *cm-mididurslot* (find-symbol "DURATION" :cm) + *cm-midinote* (symbol-function (find-symbol "MIDI-KEYNUM" :cm)) + *cm-midinoteslot* (find-symbol "KEYNUM" :cm) + *cm-midich* (symbol-function (find-symbol "MIDI-CHANNEL" :cm)) + *cm-midichslot* (find-symbol "CHANNEL" :cm) + *cm-midivel* (symbol-function (find-symbol "MIDI-AMPLITUDE" :cm)) + *cm-midivelslot* (find-symbol "AMPLITUDE" :cm) + *cm-events* (symbol-function (find-symbol "EVENTS" :cm)) +;; *cm-skipdrumch* (find-symbol "*MIDI-SKIP-DRUM-CHANNEL*" :cm) + *cm-midipbend* (find-symbol "MIDI-PITCH-BEND" :cm) + *cm-rts* (ignore-errors (symbol-function (find-symbol "RTS" :cm))) + )))
Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.12 fomus/fomus.asd:1.13 --- fomus/fomus.asd:1.12 Tue Sep 13 23:39:14 2005 +++ fomus/fomus.asd Sat Oct 1 02:49:45 2005 @@ -33,6 +33,7 @@
(:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) + (:file "backend_mid" :depends-on ("util")) (:file "backends" :depends-on ("backend_ly" "backend_xml" "version"))
(:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends"))
Index: fomus/load.lisp diff -u fomus/load.lisp:1.6 fomus/load.lisp:1.7 --- fomus/load.lisp:1.6 Sun Aug 28 06:32:47 2005 +++ fomus/load.lisp Sat Oct 1 02:49:45 2005 @@ -3,7 +3,7 @@
(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "splitrules" "accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" - "backend_xml" "backends" "main" "interface" "final") + "backend_xml" "backend_mid" "backends" "main" "interface" "final") and nw for na in fl for cl = (merge-pathnames na *load-pathname*)
Index: fomus/main.lisp diff -u fomus/main.lisp:1.15 fomus/main.lisp:1.16 --- fomus/main.lisp:1.15 Wed Aug 31 23:17:59 2005 +++ fomus/main.lisp Sat Oct 1 02:49:45 2005 @@ -61,127 +61,128 @@ (let ((*max-tuplet* (force-list *max-tuplet*))) ; normalize some parameters (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...")) - (marks-beforeafter pts) - (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-quality + (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...")) + (marks-beforeafter pts) + (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 @@ -190,7 +191,7 @@ (let ((r (fomus-proc))) (loop for x of-type (or symbol cons) in (force-list2some *backend*) do (let ((xx (force-list x))) - (destructuring-bind (ba &key filename process view &allow-other-keys) xx + (destructuring-bind (ba &key filename process play view &allow-other-keys) xx (declare (type symbol ba) (type boolean process view)) (backend ba (namestring @@ -199,7 +200,7 @@ #+sbcl (sb-unix:posix-getcwd) #+openmcl (ccl:mac-default-directory) #+allegro (excl:current-directory))) - r (rest xx) (or process view) view))))) + r (rest xx) (or process view) play view))))) t)
;; #+allegro (excl:current-directory)
Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.9 fomus/misc.lisp:1.10 --- fomus/misc.lisp:1.9 Wed Aug 31 16:35:15 2005 +++ fomus/misc.lisp Sat Oct 1 02:49:45 2005 @@ -68,7 +68,7 @@ `(mapcar #'cons ,objs ,places))
(defstruct (heap (:constructor make-heap-aux) (:predicate heapp)) - (fun #'identity :type (function (t t) t)) + (fun #'+ :type (function (t t) t)) (arr #() :type (array t)))
(defun percdown (hp n)
Index: fomus/other.lisp diff -u fomus/other.lisp:1.9 fomus/other.lisp:1.10 --- fomus/other.lisp:1.9 Sat Aug 27 20:13:21 2005 +++ fomus/other.lisp Sat Oct 1 02:49:45 2005 @@ -10,9 +10,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(declaim (type boolean *check-ranges* *transpose*)) +(declaim (type boolean *check-ranges*)) (defparameter *check-ranges* t) -(defparameter *transpose* t)
;; must be before notes are transposed! (defun check-ranges (pts)
Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.11 fomus/postproc.lisp:1.12 --- fomus/postproc.lisp:1.11 Wed Aug 31 23:17:59 2005 +++ fomus/postproc.lisp Sat Oct 1 02:49:45 2005 @@ -306,7 +306,7 @@ (setf fx t) (car x)) e))) - (let ((sy (first ma))) ; number of divisions, durational value of tremolo marking + (let ((sy (first ma))) ; number of divisions, written durational value of tremolo marking (declare (type symbol sy)) (if (or (not (chordp re)) (eq sy :tremolo)) (progn (push re ee) (addmark re (list :tremolo d w)))
Index: fomus/test.lisp diff -u fomus/test.lisp:1.15 fomus/test.lisp:1.16 --- fomus/test.lisp:1.15 Wed Sep 21 01:23:15 2005 +++ fomus/test.lisp Sat Oct 1 02:49:45 2005 @@ -352,6 +352,22 @@ :note note :marks (list (list :harmonic :touched (+ note 5))))))))
+(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Cello" + :instr :cello + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note 36 + :marks (list (list :harmonic :sounding 60))))))) + ;; Note Heads
(fomus @@ -858,6 +874,25 @@ for off from 0 to 20 by 1/2 collect (make-note :off off :dur (if (< off 20) 1/2 1) + :note (+ 48 (random 25)) + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +;; MIDI output + +(fomus + :backend '((:data) (:lilypond :view t ) (:midi :tempo 120 :play t)) + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :dur (if (< off 10) 1/2 1) :note (+ 48 (random 25)) :marks (when (<= (random 3) 0) '(:staccato)))))))
Index: fomus/version.lisp diff -u fomus/version.lisp:1.11 fomus/version.lisp:1.12 --- fomus/version.lisp:1.11 Tue Sep 13 23:39:14 2005 +++ fomus/version.lisp Sat Oct 1 02:49:45 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 16)) +(defparameter +version+ '(0 1 17)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"