Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv21316 Modified Files: TODO backend_mid.lisp postproc.lisp version.lisp Log Message: bug fix Date: Sun Jan 8 03:58:43 2006 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.26 fomus/TODO:1.27 --- fomus/TODO:1.26 Thu Dec 1 00:51:37 2005 +++ fomus/TODO Sun Jan 8 03:58:43 2006 @@ -6,6 +6,7 @@ Quantizing nested tuplets--occasional hangups Many more... Doc: list-instr-syms, list-perc-syms + Doc: separate MIDI files for different parts Specifying percussion from MIDI info Automatic percussion instrument changes Splitting chords across staves (LilyPond) Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.9 fomus/backend_mid.lisp:1.10 --- fomus/backend_mid.lisp:1.9 Thu Dec 1 00:51:37 2005 +++ fomus/backend_mid.lisp Sun Jan 8 03:58:43 2006 @@ -121,7 +121,7 @@ (defparameter *grace-dur-secs* 1/12) (declaim (special *gracedur*)) (defparameter *min-amp* 1/10) -(defparameter *trdur-secs* 1/12) ; trill notes per sec. (and unmeasured tremolos) +(defparameter *trdur-secs* 1/16) ; trill notes per sec. (and unmeasured tremolos) (declaim (special *trdur*)) (defparameter *tramp* 3/4) (defparameter *fermata-mults* '(3/2 2 3)) @@ -248,10 +248,10 @@ do (setf (midi-dur* e) (min (+ (midi-dur e) *slur-adddur*) (* (midi-dur n) 3/2)))) ev)))) -(defun save-midi (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename) +(defun save-midi-aux (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename) (unless *cm-exists* (format t ";; ERROR: Common Music required for MIDI output~%") - (return-from save-midi)) + (return-from save-midi-aux)) (when (>= *verbose* 1) (if (typep play 'boolean) (out ";; Saving MIDI file ~S...~%" filename) (out ";; Scheduling MIDI playback...~%" filename))) (destructuring-bind (&key (nports 1) instr-per-ch events-fun (pbend-width 2) cm-args @@ -314,7 +314,7 @@ (progn (format t ";; ERROR: Too many parts/instruments for ~S port(s)/~S channels (use NPORTS option, MIDI-CH option in parts or MIDIPRGCH-EX slot in instruments to fix)~%" nports (* nports 16)) - (return-from save-midi))))) + (return-from save-midi-aux))))) (unless (is-percussion p) (loop for i in (chs (cdr c)) do (setf (svref (nth (car c) ps) i) @@ -514,4 +514,18 @@ (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* (sort (nconc xta evs) #'midi-sort) filename :tempo tempo :play play cm-args) - (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args))))) \ No newline at end of file + (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args))))) + +(defun save-midi (parts filename options play) + (flet ((ms (x y) (< (position x parts) (position y parts))) + (me (p) (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p) + (namestring (merge-pathnames midi-filename filename))))) + (loop for ps in (sort (mapcar (lambda (x) (sort x #'ms)) + (split-into-groups (remove-if-not (lambda (p) + (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p) + midi-filename)) + parts) + #'me :test 'equal)) + #'ms :key #'first) + do (save-midi-aux ps (me (first ps)) options nil))) + (save-midi-aux parts filename options play)) \ No newline at end of file Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.15 fomus/postproc.lisp:1.16 --- fomus/postproc.lisp:1.15 Fri Nov 11 23:03:16 2005 +++ fomus/postproc.lisp Sun Jan 8 03:58:43 2006 @@ -321,10 +321,10 @@ unless xf do (setf xf x) do (push (third x) li) finally (return xf))))) - (if ma (let* ((d (second ma)) + (if ma (let* ((d (second ma)) ; dur. of unit (w (if d (let ((x (event-writtendur (copy-event e :dur d) (meas-timesig m)))) (loop-return-lastmin (diff i x) for i = 1/8 then (/ i 2))) - 1/32))) + 1/32))) ; writ. trem. unit dur. (let ((wd (event-writtendur e (meas-timesig m)))) (multiple-value-bind (d o) (floor wd w) (let ((re (if (> o 0) @@ -351,6 +351,8 @@ (let ((c1 (list>1p n1)) (c2 (list>1p n2)) (d2 (/ (event-dur* re) 2))) + (let ((x (event-tupfrac re))) + (when x (setf (car x) (/ (the rational (car x)) 2)))) (let ((e1 (copy-event re :note (if c1 n1 (the (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (first n1))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.22 fomus/version.lisp:1.23 --- fomus/version.lisp:1.22 Thu Dec 1 00:51:37 2005 +++ fomus/version.lisp Sun Jan 8 03:58:43 2006 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 27)) +(defparameter +version+ '(0 1 28)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"