October 2005 - fomus-cvs@common-lisp.net - mailman3.common-lisp.net

[fomus-cvs] CVS update: fomus/backend_ly.lisp fomus/backend_mid.lisp fomus/fomus.asd fomus/version.lisp
by dpsenicka＠common-lisp.net 06 Oct '05

06 Oct '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv23599 Modified Files: backend_ly.lisp backend_mid.lisp fomus.asd version.lisp Log Message: bug fixes Date: Thu Oct 6 04:27:16 2005 Author: dpsenicka Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.18 fomus/backend_ly.lisp:1.19 --- fomus/backend_ly.lisp:1.18 Wed Oct 5 16:27:36 2005 +++ fomus/backend_ly.lisp Thu Oct 6 04:27:12 2005 @@ -59,6 +59,20 @@ (er "compiling"))) #-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) +(defparameter *lilypond-version* t) +(defun lilypond-version (options) + (if (truep *lilypond-version*) + (setf *lilypond-version* + (destructuring-bind (&key exe &allow-other-keys) options + (let ((os (make-string-output-stream))) + (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) + (list "-v") :wait t :output os)) + (let* ((out (get-output-stream-string os)) + (p (search "LilyPond " out))) + (when p (multiple-value-bind (n1 np) (parse-integer out :start (+ p 9) :junk-allowed t) + (+ (* n1 100) (parse-integer out :start (1+ np) :junk-allowed t)))))))) + *lilypond-version*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LILYPOND BACKEND @@ -69,13 +83,21 @@ (defparameter +lilypond-defs+ '("octUp = #(set-octavation 1)" "octReset = #(set-octavation 0)" - "octDown = #(set-octavation -1)" - "beamL = #(def-music-function (loc num) (number?) #{\\set stemLeftBeamCount = #$num #})" + "octDown = #(set-octavation -1)")) +(defparameter +lilypond-defs-24+ + '("beamL = #(def-music-function (loc num) (number?) #{\\set stemLeftBeamCount = #$num #})" "beamR = #(def-music-function (loc num) (number?) #{\\set stemRightBeamCount = #$num #})" "beamLR = #(def-music-function (loc numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" "textSpan = #(def-music-function (loc dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" "noteHead = #(def-music-function (loc sty) (symbol?) #{\\once \\override NoteHead #'style = #$sty #})" )) +(defparameter +lilypond-defs-26+ + '("beamL = #(def-music-function (par loc num) (number?) #{\\set stemLeftBeamCount = #$num #})" + "beamR = #(def-music-function (par loc num) (number?) #{\\set stemRightBeamCount = #$num #})" + "beamLR = #(def-music-function (par loc numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" + "textSpan = #(def-music-function (par loc dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" + "noteHead = #(def-music-function (par loc sty) (symbol?) #{\\once \\override NoteHead #'style = #$sty #})" + )) (defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b")) (defparameter +lilypond-num-acc+ (vector "eses" "es" "" "is" "isis")) @@ -140,7 +162,8 @@ (format f "~A" header) (loop for e in +lilypond-head+ do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top (when filehead (loop for e in (force-list 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 + (loop for e in (append +lilypond-defs+ (if (>= (lilypond-version options) 205) +lilypond-defs-26+ +lilypond-defs-24+)) + do (format f "~A~%" e) finally (format f "~%")) ;; definitions (let ((de 0) (nms nil) (twrn nil)) (flet ((lynote (wnum acc1 acc2 caut) (if *quartertones* Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.4 fomus/backend_mid.lisp:1.5 --- fomus/backend_mid.lisp:1.4 Wed Oct 5 16:27:36 2005 +++ fomus/backend_mid.lisp Thu Oct 6 04:27:12 2005 @@ -339,7 +339,7 @@ (if di (>= (event-grace e) 0) (< (event-grace e) 0))) collect (if cd (cons (if di (incf co cd) (decf co cd)) cd) (progn - (setf cd (loop for (x . rr) on r + (setf cd (loop for x in r for su from 1 while (and (event-grace x) (= (event-off x) (event-off e))) @@ -373,9 +373,9 @@ (loop with n0 = (if (chordp ev) (event-notes* ev) (list (event-note* ev))) with ln = (length n0) and cch = (or (when pizz (lookup pizzch aps)) - (loop for v in '(stopped open flageolet harmonic) + (loop for v in '(:stopped :open :flageolet :harmonic) and c in (list stoppedch opench flageoletch harmonicch) - for m = (getmark ev c) + for m = (getmark ev v) when m do (return (lookup c aps))) ch) for n in n0 and x from 1 Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.14 fomus/fomus.asd:1.15 --- fomus/fomus.asd:1.14 Wed Oct 5 16:27:36 2005 +++ fomus/fomus.asd Thu Oct 6 04:27:12 2005 @@ -4,7 +4,7 @@ (asdf:defsystem "fomus" :description "Lisp music notation formatter" - :version "0.1.18" + :version "0.1.19" :author "David Psenicka" :licence "LLGPL" Index: fomus/version.lisp diff -u fomus/version.lisp:1.13 fomus/version.lisp:1.14 --- fomus/version.lisp:1.13 Wed Oct 5 16:27:36 2005 +++ fomus/version.lisp Thu Oct 6 04:27:12 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 18)) +(defparameter +version+ '(0 1 19)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/backend_mid.lisp
by dpsenicka＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv6113 Modified Files: backend_mid.lisp Log Message: bug fix Date: Sat Oct 1 19:37:58 2005 Author: dpsenicka Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.2 fomus/backend_mid.lisp:1.3 --- fomus/backend_mid.lisp:1.2 Sat Oct 1 19:28:29 2005 +++ fomus/backend_mid.lisp Sat Oct 1 19:37:58 2005 @@ -396,5 +396,5 @@ evs)) (setf xta (loop for e in (split-into-groups xta #'type-of) nconc (delete-duplicates e :key #'midi-ch))) (if (typep play 'boolean) - (apply *cm-events* (print (nconc xta evs)) filename :tempo tempo :play play cmargs) + (apply *cm-events* (nconc xta evs) filename :tempo tempo :play play cmargs) (apply *cm-rts* (nconc xta evs) play :tempo tempo cmargs)))))

1 0

[fomus-cvs] CVS update: fomus/TODO fomus/backend_mid.lisp fomus/misc.lisp fomus/test.lisp
by dpsenicka＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv5066 Modified Files: TODO backend_mid.lisp misc.lisp test.lisp Log Message: bug fixes Date: Sat Oct 1 19:28:30 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.22 fomus/TODO:1.23 --- fomus/TODO:1.22 Sat Oct 1 02:49:45 2005 +++ fomus/TODO Sat Oct 1 19:28:29 2005 @@ -4,6 +4,7 @@ Bugs: Quantizing nested tuplets--occasional hangups + Hide accidental internal mark accidentals for trills and related figures (or just a note/step argument for MIDI playback) Doc: list-instr-syms Doc: CM MIDI backend Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.1 fomus/backend_mid.lisp:1.2 --- fomus/backend_mid.lisp:1.1 Sat Oct 1 02:49:45 2005 +++ fomus/backend_mid.lisp Sat Oct 1 19:28:29 2005 @@ -33,7 +33,7 @@ (< (midi-note x) (midi-note y)))) ((midi-note x) t)) (< (midi-dur x) (midi-dur y)))) - ((typep x *cm-midi*) t)) + ((typep y *cm-midi*) t)) (< (midi-ch x) (midi-ch y))) (< (midi-off x) (midi-off y)))) @@ -216,7 +216,7 @@ (gracedur *gracedur*) (minamp *minamp*) (trdursecs *trdursecs*) (tramp *tramp*) (fermatamults *fermatamults*) (breathdur *breathdur*) (tempo *tempo*) (staccatomult *staccatomult*) (staccatissimomult *staccatissimomult*) (tenutoadddur *tenutoadddur*) - (trovlpadddur *trovlpadddur*) (mindursecs *mindursecs*) &allow-other-keys) options + (trovlpadddur *trovlpadddur*) (mindursecs *mindursecs*) delay &allow-other-keys) options (when (typep play 'boolean) (setf nports 1)) (let* ((*gracedur* gracedur) (*minamp* minamp) @@ -327,12 +327,13 @@ (car i)) :test #'equal)) else collect - (let ((i (make-instance *cm-midi* :channel ch :time of :duration du - :keynum (if (and *transpose* (instr-tpose in)) - (+ (instr-tpose in) n) n) - :amplitude midi-vel))) + (let ((i (cons (midi-marks ev bot top ex) + (make-instance *cm-midi* :channel ch :time of :duration du + :keynum (if (and *transpose* (instr-tpose in)) + (+ (instr-tpose in) n) n) + :amplitude midi-vel)))) (when tr (push i ts)) - (cons (midi-marks ev bot top ex) i))) + i)) (list (cons (midi-marks ev t t ex) (make-instance *cm-midi* :channel ch :time of :duration du :keynum nil @@ -378,10 +379,10 @@ (when (list>1p cs) (let ((ll (remove-if (lambda (e) (integerp (midi-note e))) es))) (mapc (lambda (x) (setf (midi-note* x) (floor x) (midi-ch* x) (second cs))) ll) - (push (make-instance *cm-midipbend* :time 0 :channel (second cs) :bend (* pbendwidth 1024)) xta)))) + (push (make-instance *cm-midipbend* :time 0 :channel (second cs) :bend (roundint (/ 2048 pbendwidth))) xta)))) es) finally (loop for e in (nreverse (delete-duplicates el :test #'string=)) do (format t e)))))) - (let ((o (floor (loop for e in evs minimize (midi-off e))))) (when (minusp o) (push (cons o (- o)) adj))) + (let ((o (floor (loop for e in evs do (incf (midi-off* e) delay) minimize (midi-off e))))) (when (minusp o) (push (cons o (- o)) adj))) (loop for (o . a) in (merge-linear (sort adj #'> :key #'car) (lambda (x y) (when (= (car x) (car y)) (cons (car x) (max (cdr x) (cdr y)))))) do (mapc (lambda (x) (when (if (typep x *cm-midi*) (> (midi-endoff x) o) (>= (midi-off x) o)) (if (>= (midi-off x) o) (incf (midi-off* x) a) (incf (midi-dur* x) a)))) @@ -393,6 +394,7 @@ (setf (midi-vel* x) (min (max (coerce (midi-vel x) 'single-float) 0.0) 1.0) (midi-dur* x) (max (midi-dur x) md)))) evs)) + (setf xta (loop for e in (split-into-groups xta #'type-of) nconc (delete-duplicates e :key #'midi-ch))) (if (typep play 'boolean) - (apply *cm-events* (nconc xta evs) filename :tempo tempo :play play cmargs) + (apply *cm-events* (print (nconc xta evs)) filename :tempo tempo :play play cmargs) (apply *cm-rts* (nconc xta evs) play :tempo tempo cmargs))))) Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.10 fomus/misc.lisp:1.11 --- fomus/misc.lisp:1.10 Sat Oct 1 02:49:45 2005 +++ fomus/misc.lisp Sat Oct 1 19:28:29 2005 @@ -32,7 +32,7 @@ (car (last list))) (set-dispatch-macro-character - #\# #\I + #\# #\Z (lambda (s c n) (declare (type stream s) (ignore c n)) (let ((r (read s t nil t))) @@ -41,7 +41,7 @@ (defmacro defprint (class &rest slots) `(defmethod print-object ((x ,class) s) (declare (type stream s)) - (princ "#I" s) + (princ "#Z" s) (prin1 ,(nconc (list 'list (list 'quote class)) (loop for i in slots Index: fomus/test.lisp diff -u fomus/test.lisp:1.16 fomus/test.lisp:1.17 --- fomus/test.lisp:1.16 Sat Oct 1 02:49:45 2005 +++ fomus/test.lisp Sat Oct 1 19:28:29 2005 @@ -5,7 +5,7 @@ ;; Example 1 (fomus - :backend '((:data) (:lilypond :view t)) + :backend '((:data) (:lilypond :view t) (:midi :play t :tempo 120 :delay 10)) :ensemble-type :orchestra :parts (list @@ -24,7 +24,7 @@ ;; Example 2 (fomus - :backend '((:data) (:lilypond :view t)) + :backend '((:data) (:lilypond :view t) (:midi :play t :tempo 120 :delay 10)) :ensemble-type :orchestra :default-beat 1/4 :global (list (make-timesig :off 0 :time '(3 4))

1 0

[fomus-cvs] CVS update: fomus/doc/marks.xml fomus/doc/settings.xml
by dpsenicka＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/fomus/cvsroot/fomus/doc In directory common-lisp.net:/tmp/cvs-serv30128/doc Modified Files: marks.xml settings.xml Log Message: test/bug fixes/CM MIDI backend Date: Sat Oct 1 02:49:52 2005 Author: dpsenicka Index: fomus/doc/marks.xml diff -u fomus/doc/marks.xml:1.10 fomus/doc/marks.xml:1.11 --- fomus/doc/marks.xml:1.10 Sat Aug 27 20:13:30 2005 +++ fomus/doc/marks.xml Sat Oct 1 02:49:52 2005 @@ -35,7 +35,7 @@ and <function><link linkend="mark.slur-">:ENDSLUR-</link></function>). Exceptions that don't have a trailing dash are <function><link linkend="mark.wedge.gt">:STARTWEDGE></link></function> and - <function><link linkend="mark.wedge.lt">:STARTWEDGE<</link></function>. + <function><link linkend="mark.wedge.lt">:STARTWEDGE<</link></function> and related marks. </para></listitem> </itemizedlist> </para> @@ -195,8 +195,8 @@ <member><function><anchor id="mark.sf"/>:SF</function></member> <member><function><anchor id="mark.sp"/>:SP</function></member> <member><function><anchor id="mark.spp"/>:SPP</function></member> - <member><function><anchor id="mark.wedge.gt"/>:STARTWEDGE></function> / <function>:WEDGE-</function> / <function>:ENDWEDGE-</function></member> - <member><function><anchor id="mark.wedge.lt"/>:STARTWEDGE<</function> / <function>:WEDGE-</function> / <function>:ENDWEDGE-</function></member> + <member><function><anchor id="mark.wedge.gt"/>:STARTWEDGE></function> / <function>:WEDGE></function> / <function>:ENDWEDGE></function></member> + <member><function><anchor id="mark.wedge.lt"/>:STARTWEDGE<</function> / <function>:WEDGE<</function> / <function>:ENDWEDGE<</function></member> </simplelist> </section> Index: fomus/doc/settings.xml diff -u fomus/doc/settings.xml:1.11 fomus/doc/settings.xml:1.12 --- fomus/doc/settings.xml:1.11 Wed Aug 31 23:18:05 2005 +++ fomus/doc/settings.xml Sat Oct 1 02:49:52 2005 @@ -1055,9 +1055,8 @@ (:group (:group :violin) (:group :viola) (:group :violoncello) (:group :contrabass))) (:ensemble - :piccolo :flute :oboe :english-horn :bf-clarinet :a-clarinet :bass-clarinet - :bassoon :contra-bassoon - (:grandstaff :piano)))]]> + :piccolo :flute :oboe :english-horn :bf-clarinet :a-clarinet :bassoon + :contra-bassoon (:grandstaff :piano)))]]> </programlisting> </example> @@ -1268,15 +1267,17 @@ <term><varname><anchor id="setting.quality"/>:QUALITY</varname></term> <listitem> <para> - This is a real number greater than <literal>0</literal> and indicates how much <application>FOMUS</application> should trade + This is a real number indicating how much <application>FOMUS</application> should trade speed of computation for quality of output. - The default is <literal>1</literal>, which gives reasonable results for relatively uncomplicated tasks. - Setting it lower increases speed while setting it higher gives better results. - Values of around <literal>3</literal> or <literal>4</literal> should be best--after a certain - point increasing this value only makes the program run slower with no improvements. + The default is <literal>1</literal>, which is reasonable for relatively uncomplicated tasks. + + The most effective values are between approximately <literal>-3</literal> and <literal>3</literal>, though complex + scores might show improvement with values of <literal>5</literal> or more. + + After a certain point increasing this value only makes the program run slower with no noticeable improvement in output. </para> </listitem> </varlistentry>

1 0

[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
by dpsenicka＠common-lisp.net 01 Oct '05

01 Oct '05

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"

1 0