[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_mid.lisp
David Psenicka
dpsenicka at common-lisp.net
Sat Nov 12 18:57:24 UTC 2005
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
More information about the Fomus-cvs
mailing list