[fomus-cvs] CVS update: fomus/TODO fomus/backend_mid.lisp fomus/postproc.lisp fomus/version.lisp

[David Psenicka]

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"