Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv26700
Modified Files: accidentals.lisp backend_mid.lisp Log Message: accidentals improvement Date: Sat Nov 12 19:57:23 2005 Author: dpsenicka
Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.10 fomus/accidentals.lisp:1.11 --- fomus/accidentals.lisp:1.10 Tue Aug 30 00:28:03 2005 +++ fomus/accidentals.lisp Sat Nov 12 19:57:23 2005 @@ -93,12 +93,18 @@
(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*)) (defparameter *acc-diatonic-int-score* (float 7/8)) -(defparameter *acc-aug-dim-int-score* (float 1/2)) +(defparameter *acc-aug-dim-int-score* (float 1/3)) (defparameter *acc-spelling-penalty* (float 1/4)) (defparameter *acc-good-unison-score* (float 1)) (defparameter *acc-bad-unison-score* (float 3/8)) (defparameter *acc-similar-qtone-score* (float 1/3))
+(defun nokey-notepen (n a) + (declare (type rational n) (type (integer -2 2) a)) + (* (loop + for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (nokey-spell n a))) + minimize (diff a e)) *acc-spelling-penalty*)) + ;; scores of 1 are perfect ;; tie is if accidentals must be in same direction (defun nokey-intscore (tie note1 acc1 off1 eoff1 note2 acc2 off2 eoff2 &optional qt) ; returns 0 to 1 (or nil) @@ -113,23 +119,18 @@ (values note2 acc2 off2 eoff2 note1 acc1 off1 eoff1))) (declare (ignorable o1 eo1 o2 eo2)) (multiple-value-bind (i q) (nokey-int n1 a1 n2 a2) - (flet ((aa (n a) - (declare (type rational n) (type (integer -2 2) a)) - (* (loop - for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (nokey-spell n a))) - minimize (diff a e)) *acc-spelling-penalty*))) - (let ((v (- (cond ((and tie (/= i (svref +nokey-harmints+ (mod (diff n1 n2) 12))) #|(or (and (< acc1 0) (> acc2 0)) (and (> acc1 0) (< acc2 0)))|#) 0.0) - ((find q (svref +nokey-niceints1+ i)) *acc-diatonic-int-score*) - ((and (= i 0) ; unisons special case - (or - (and (>= a1 0) (= (- a2 a1) 1)) - (and (<= a1 0) (= (- a2 a1) -1)))) - (if (<= eo1 o2) *acc-good-unison-score* *acc-bad-unison-score*)) - ((find q (svref +nokey-niceints2+ i)) *acc-aug-dim-int-score*) - (t 0.0)) - (aa n1 a1) - (aa n2 a2)))) - (if qt v (max v 0.0))))))) + (let ((v (- (cond ((and tie (/= i (svref +nokey-harmints+ (mod (diff n1 n2) 12))) #|(or (and (< acc1 0) (> acc2 0)) (and (> acc1 0) (< acc2 0)))|#) 0.0) + ((find q (svref +nokey-niceints1+ i)) *acc-diatonic-int-score*) + ((and (= i 0) ; unisons special case + (or + (and (>= a1 0) (= (- a2 a1) 1)) + (and (<= a1 0) (= (- a2 a1) -1)))) + (if (<= eo1 o2) *acc-good-unison-score* *acc-bad-unison-score*)) + ((find q (svref +nokey-niceints2+ i)) *acc-aug-dim-int-score*) + (t 0.0)) + (nokey-notepen n1 a1) + (nokey-notepen n2 a2)))) + (if qt v (max v 0.0)))))) (defun nokeyq-intscore (tie note1 acc1 off1 eoff1 note2 acc2 off2 eoff2) (declare (type boolean tie) (type (cons (integer -2 2) (rational -1/2 1/2)) acc1 acc2) (type rational note1 note2) (type (rational 0) off1 eoff1 off2 eoff2)) (let ((aa1 (car acc1)) (aa2 (car acc2)) @@ -198,14 +199,15 @@ collect (let ((w (copy-event f :note (cons (event-note* f) e))) (s (nokeynode-sc no))) (let ((d (cons w - (loop ; keep only relevant notes that will need rescoring (endoff > - 8 beats) - ;;with o = (- oo mxd) - for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) ; e is (score . event) - if (> (event-endoff (cdr e)) oo) ; endoff will = offset for grace notes! - ;;if (> (event-endoff (cdr e)) o) ; endoff will = offset for grace notes! - collect (cdr e) ; collect just the events - else do (incf s (car e))))) - (c (cons w (let ((o (- oo mxd #|mxd|#))) + (or (loop ; keep only relevant notes that will need rescoring (endoff > - ? beats) + for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) ; e is (score . event) + if (> (event-endoff (cdr e)) oo) ; endoff will = offset for grace notes! + collect (cdr e) ; collect just the events + else do (incf s (car e))) + (let ((a (loop-return-argmax (event-endoff (cdr e)) + for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no)))) + (when a (decf s (car a)) (list (cdr a))))))) + (c (cons w (let ((o (- oo mxd))) (remove-if (lambda (e) (declare (type noteex e)) (<= (event-endoff e) o)) @@ -215,15 +217,16 @@ :evd (loop for e of-type noteex in d collect (cons - (let ((su 0.0) (di 0.0)) + (let* ((eua (event-useracc e)) + (ne (event-note* e)) + (su (- 1.0 (nokey-notepen ne eua))) (di 1.0)) (declare (type #-openmcl (float 0) #+openmcl float su di)) (loop ; plus optimistic 1 scores for rest in range for e0 of-type noteex in lf while (<= (event-off e0) (event-off e)) do (incf su) (incf di)) (loop - with ne = (event-note* e) - and eoe = (event-endoff e) + with eoe = (event-endoff e) and foe = (float (event-off e)) and feoe = (float (event-endoff e)) for e0 of-type noteex in c @@ -232,11 +235,11 @@ (ti (and (event-acctie e) (event-acctie e0) (eq (event-acctie e) (event-acctie e0)))) (x (nokey-notedist ti ne foe feoe ne0 (event-off e0) eoe0))) (incf su (* (funcall intscorefun ti - ne (event-useracc e) (event-off e) eoe + ne eua (event-off e) eoe ne0 (event-useracc e0) (event-off e0) eoe0) x)) (incf di x))) - (if (> di 0.0) (/ su di) 1.0)) + #|(if (> di 0.0) (/ su di) 1.0)|# (/ su di)) e)) :re (1- (nokeynode-re no)) :ret (cons w (nokeynode-ret no)) :evs lf))))) @@ -278,7 +281,7 @@ (declare (ignorable keysigs)) (loop for e of-type partex in parts - unless (is-percussion e) + unless (or (is-percussion e) (not (string= (part-name e) "Vln."))) do (multiple-value-bind (evs rs) (split-list (part-events e) #'notep) (setf (part-events e) (sort (nconc rs
Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.7 fomus/backend_mid.lisp:1.8 --- fomus/backend_mid.lisp:1.7 Sat Nov 12 03:20:58 2005 +++ fomus/backend_mid.lisp Sat Nov 12 19:57:23 2005 @@ -142,7 +142,7 @@ ;; return values: replacement note(s), offset increment for remaining notes ;; how to handle dynamics, arco, pizz??? (make them "persistant" marks?) (defun midi-default-events-fun (ev mark arg1 arg2) - (labels ((amp (n) (+ *min-amp* (* (/ (1+ n) 11) (- 1 *min-amp*)))) #|(ainc (n) (/ (* n (- 1 *min-amp*)) 17))|# + (labels ((amp (n) (+ *min-amp* (* (/ (1+ n) 11) (- 1 *min-amp*)))) (trem (s) (loop for v in ev nconc (loop with db = (/ (midi-dur v) (max (if (<= arg2 1/32) (/ (midi-dur v) *trdur*) (min (/ (midi-dur v) *trdur*) arg1)) 1)) @@ -189,8 +189,8 @@ for o from (midi-off ev) below (midi-endoff ev) by db and pt = t then nil collect (make-instance *cm-midi* :channel (midi-ch ev) :time o :duration du :keynum (if pt (midi-note ev) arg1) :amplitude (* (midi-vel ev) *tramp*)))) - (:pizz #|(list (make-instance (make-instance *cm-progch* :time 0 :channel (midi-ch ev) :program 45)) ev)|# ev) - (:arco #|(list (make-instance (make-instance *cm-progch* :time 0 :channel (midi-ch ev) :program arg1)) ev)|# ev) ; arg1 = program num. of instr. + (:pizz ev) + (:arco ev) ; arg1 = program num. of instr. (:fermata (case arg1 (:short (let ((i (* (midi-dur ev) (1- (first *fermata-mults*))))) (setf (midi-dur* ev) (+ (midi-dur ev) i)) (values ev i))) (:long (let ((i (* (midi-dur ev) (1- (second *fermata-mults*))))) (setf (midi-dur* ev) (+ (midi-dur ev) i)) (values ev i))) @@ -229,17 +229,6 @@ (:open ev) (:staccato (setf (midi-dur* ev) (* (midi-dur ev) *staccato-mult*)) ev) (:staccatissimo (setf (midi-dur* ev) (* (midi-dur ev) *staccatissimo-mult*)) ev) - ;; (:lineprall ev) - ;; (:prallup ev) - ;; (:pralldown ev) - ;; (:downmordent ev) - ;; (:upmordent ev) - ;; (:downprall ev) - ;; (:upprall ev) - ;; (:prallmordent ev) - ;; (:prallprall ev) - ;; (:reverseturn ev) - ;; (:turn ev) ((:prall :trill :mordent) (let ((md (/ (midi-dur ev) 2))) (cons