[fomus-cvs] CVS update: fomus/backend_cmn.lisp fomus/backend_mid.lisp fomus/TODO fomus/backend_ly.lisp fomus/backend_xml.lisp fomus/backends.lisp fomus/data.lisp fomus/deps.lisp fomus/fomus.asd fomus/load.lisp fomus/main.lisp fomus/misc.lisp fomus/other.lisp fomus/postproc.lisp fomus/test.lisp fomus/version.lisp
David Psenicka
dpsenicka at common-lisp.net
Sat Oct 1 00:49:53 UTC 2005
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*)))))
+ , at 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"
More information about the Fomus-cvs
mailing list