- fomus-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[fomus-cvs] CVS update: fomus/TODO fomus/backend_mid.lisp fomus/misc.lisp fomus/other.lisp fomus/package.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 30 Nov '05

30 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv3808 Modified Files: TODO backend_mid.lisp misc.lisp other.lisp package.lisp version.lisp Log Message: fixes... Date: Thu Dec 1 00:51:37 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.25 fomus/TODO:1.26 --- fomus/TODO:1.25 Sat Oct 22 22:43:06 2005 +++ fomus/TODO Thu Dec 1 00:51:37 2005 @@ -6,8 +6,8 @@ Quantizing nested tuplets--occasional hangups Many more... Doc: list-instr-syms, list-perc-syms - Doc: CM MIDI backend - Importing MIDI percussion + Specifying percussion from MIDI info + Automatic percussion instrument changes Splitting chords across staves (LilyPond) STAFF, CLEF and other marks for overriding FOMUS's decisions MusicXML backend Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.8 fomus/backend_mid.lisp:1.9 --- fomus/backend_mid.lisp:1.8 Sat Nov 12 19:57:23 2005 +++ fomus/backend_mid.lisp Thu Dec 1 00:51:37 2005 @@ -120,7 +120,7 @@ (defparameter *grace-dur-secs* 1/12) (declaim (special *gracedur*)) -(defparameter *min-amp* 1/5) +(defparameter *min-amp* 1/10) (defparameter *trdur-secs* 1/12) ; trill notes per sec. (and unmeasured tremolos) (declaim (special *trdur*)) (defparameter *tramp* 3/4) @@ -331,7 +331,7 @@ (setf is (delete x is)) (mapc (lambda (e) (nsubstitute t ex e)) ps))))) (cons (car c) (+ (* (car c) 16) (cdr c)))) - and pmn = (when (is-percussion p) (mapcar (lambda (x) (cons (perc-note x) (perc-midinote-ex x))) (instr-percs in))) + and pmn = (when (is-percussion p) (mapcar (lambda (x) (cons (perc-sym x) (perc-midinote-ex x))) (instr-percs in))) do (prenconc (unless (is-percussion p) (loop for i in (chs ch) collect (make-instance *cm-progch* :time 0 :channel i :program ex))) xta) (let ((ap (rassoc p aps))) (when ap (setf aps (delete-if (lambda (x) (and (= (car x) ex) (numberp (cdr x)))) aps) (cdr ap) ch))) @@ -398,7 +398,13 @@ (setf ts (delete-if (lambda (x) (< (midi-endoff (cdr x)) of)) ts)) (if (notep ev) (loop with n0 = (let ((z (force-list (if (chordp ev) (event-notes* ev) (event-note* ev))))) - (if pmn (mapcar (lambda (x) (lookup x pmn)) z) z)) + (if pmn (mapcar (lambda (x) + (let ((m (getmark ev (list :percsym x)))) + (if m + (lookup (third m) pmn) + (lookup x pmn)))) + z) + z)) with ln = (length n0) and cch = (or (when pizz (lookup pizzch aps)) (loop for v in '(:stopped :open :harmonic) Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.11 fomus/misc.lisp:1.12 --- fomus/misc.lisp:1.11 Sat Oct 1 19:28:29 2005 +++ fomus/misc.lisp Thu Dec 1 00:51:37 2005 @@ -256,7 +256,7 @@ do (push ,var ,rt) finally (return ,rt)))) -(declaim (inline lookup)) +#-cmu (declaim (inline lookup)) (defun lookup (item list &rest keys) (declare (type list list)) (cdr (apply #'assoc item list keys))) Index: fomus/other.lisp diff -u fomus/other.lisp:1.11 fomus/other.lisp:1.12 --- fomus/other.lisp:1.11 Fri Nov 11 23:03:16 2005 +++ fomus/other.lisp Thu Dec 1 00:51:37 2005 @@ -87,14 +87,15 @@ (if (numberp n) (unless (svref +note-to-white+ (mod n 12)) (error "Invalid percussion note ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p))) (let ((c (etypecase n ; c = percussion struct - (symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym)) + (symbol #|(find n *percussion* :key #'perc-sym)|# (find n pm :key #'perc-sym)) (perc n)))) (if c - (progn + (progn (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1)) (setf (event-staff* ev) (perc-staff c))) (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))) (setf (event-note ev) (note-to-num (perc-note c))) + (addmark ev (list :percsym (note-to-num (perc-note c)) n)) (when (and *auto-percussion-durs* (perc-autodur c) (not (event-grace ev)) (notany (lambda (x) (declare (type symbol x)) Index: fomus/package.lisp diff -u fomus/package.lisp:1.12 fomus/package.lisp:1.13 --- fomus/package.lisp:1.12 Sat Oct 22 22:43:06 2005 +++ fomus/package.lisp Thu Dec 1 00:51:37 2005 @@ -10,7 +10,7 @@ (defpackage "FOMUS" (:nicknames "FM" "FMS") - (:use "COMMON-LISP" #|"MISCFUNS"|#) + (:use "COMMON-LISP") (:export "FOMUS" "LOAD-INITFILE" ; interface functions "FOMUS-INIT" "FOMUS-NEWTIMESIG" "FOMUS-NEWPART" "FOMUS-NEWMARK" "FOMUS-NEWNOTE" "FOMUS-NEWREST" "FOMUS-EXEC" "FOMUS-PART" "LIST-FOMUS-SETTINGS" "LIST-FOMUS-INSTRUMENTS" "LIST-FOMUS-INSTRGROUPS" "LIST-FOMUS-PERCUSSION" "LIST-FOMUS-CLEFS" Index: fomus/version.lisp diff -u fomus/version.lisp:1.21 fomus/version.lisp:1.22 --- fomus/version.lisp:1.21 Wed Nov 16 02:26:30 2005 +++ fomus/version.lisp Thu Dec 1 00:51:37 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 26)) +(defparameter +version+ '(0 1 27)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 16 Nov '05

16 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv16091 Modified Files: accidentals.lisp version.lisp Log Message: Date: Wed Nov 16 02:26:30 2005 Author: dpsenicka Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.12 fomus/accidentals.lisp:1.13 --- fomus/accidentals.lisp:1.12 Sat Nov 12 21:42:46 2005 +++ fomus/accidentals.lisp Wed Nov 16 02:26:30 2005 @@ -93,17 +93,22 @@ (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/3)) +(defparameter *acc-aug-dim-int-score* (float 1/2)) (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*)) + (declare (type rational n) (type (or (integer -2 2) (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*)) +(defun nokeyq-notepen (n a) + (declare (type rational n) (type (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) a)) + (* (loop + for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (nokeyq-spell n a))) + minimize (diff (car a) e)) *acc-spelling-penalty*)) ;; scores of 1 are perfect ;; tie is if accidentals must be in same direction @@ -160,7 +165,7 @@ (evd nil :type list) (o 0 :type (rational 0)) (co 0 :type (integer 0))) ; sc = score-so-far (evt - evd), ret = return events, re = num. remaining, events from, evc = events to consider when redoing, evd = events to redo -(defun acc-nokey (events choices spellfun intscorefun name conv) ; events in one part +(defun acc-nokey (events choices spellfun penfun intscorefun name conv) ; events in one part (declare (type list events choices) (type (function (rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (values (or (integer 0 6) null) (or integer null))) spellfun) (type (function (boolean rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0) @@ -223,7 +228,7 @@ collect (cons (let* ((eua (event-useracc e)) (ne (event-note* e)) - (su (- 1.0 (nokey-notepen ne eua))) (di 1.0)) + (su (- 1.0 (funcall penfun 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 @@ -292,9 +297,9 @@ (case (auto-accs-fun) (:nokey1 (if *quartertones* (acc-nokey evs (if *use-double-accs* +acc-qtones-double+ +acc-qtones-single+) - #'nokeyq-spell #'nokeyq-intscore (part-name e) #'nokey-convert-qtone) + #'nokeyq-spell #'nokeyq-notepen #'nokeyq-intscore (part-name e) #'nokey-convert-qtone) (acc-nokey evs (if *use-double-accs* +acc-double+ +acc-single+) - #'nokey-spell #'nokey-intscore (part-name e) #'identity))) + #'nokey-spell #'nokey-notepen #'nokey-intscore (part-name e) #'identity))) (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*)))) #'sort-offdur))))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.20 fomus/version.lisp:1.21 --- fomus/version.lisp:1.20 Sat Nov 12 21:42:46 2005 +++ fomus/version.lisp Wed Nov 16 02:26:30 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 25)) +(defparameter +version+ '(0 1 26)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_ly.lisp fomus/data.lisp fomus/main.lisp fomus/parts.lisp fomus/test.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 12 Nov '05

12 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv1863 Modified Files: accidentals.lisp backend_ly.lisp data.lisp main.lisp parts.lisp test.lisp version.lisp Log Message: ... Date: Sat Nov 12 21:42:46 2005 Author: dpsenicka Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.11 fomus/accidentals.lisp:1.12 --- fomus/accidentals.lisp:1.11 Sat Nov 12 19:57:23 2005 +++ fomus/accidentals.lisp Sat Nov 12 21:42:46 2005 @@ -204,9 +204,13 @@ 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))))))) + (let ((mx (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + maximize (event-endoff (cdr e))))) + (setf s (nokeynode-sc no)) + (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + if (>= (event-endoff (cdr e)) mx) + collect (cdr e) + else do (incf s (car e))))))) (c (cons w (let ((o (- oo mxd))) (remove-if (lambda (e) (declare (type noteex e)) @@ -281,7 +285,7 @@ (declare (ignorable keysigs)) (loop for e of-type partex in parts - unless (or (is-percussion e) (not (string= (part-name e) "Vln."))) + unless (is-percussion e) do (multiple-value-bind (evs rs) (split-list (part-events e) #'notep) (setf (part-events e) (sort (nconc rs Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.20 fomus/backend_ly.lisp:1.21 --- fomus/backend_ly.lisp:1.20 Sat Oct 22 22:43:06 2005 +++ fomus/backend_ly.lisp Sat Nov 12 21:42:46 2005 @@ -401,6 +401,8 @@ (loop repeat (length uu) collect "}"))) (cond ((or (getmark e :end8up-) (getmark e :8up)) " \\octReset") ((or (getmark e :end8down-) (getmark e :8down)) " \\octReset")))))) + (let ((b (getprop m :barline))) + (when b (format f "\\bar \"~A\" " (lookup (second b) +lilypond-barlines+)))) (format f "| %~A~% ~A" mn (if nxm " " ""))) (if (< vce (1- nvce)) (format f "} \\\\~% ") (format f "}~% >>~%"))) (format f "}~%~%") Index: fomus/data.lisp diff -u fomus/data.lisp:1.26 fomus/data.lisp:1.27 --- fomus/data.lisp:1.26 Fri Nov 11 23:03:16 2005 +++ fomus/data.lisp Sat Nov 12 21:42:46 2005 @@ -440,7 +440,7 @@ :accordion :harmonica :ukulele :mandolin :guitar :bass-guitar :soprano :mezzo-soprano :contralto :tenor :tenor-8dn :baritone :bass (:group :soprano-choir :alto-choir :tenor-choir :bass-choir) - (:group (:group :violin) (:group :viola) (:group :violoncello) (:group :contrabass))) + (:group (:group :violin) (:group :viola) (:group :cello) (:group :contrabass))) (cons :small-ensemble (loop for e in +instruments+ Index: fomus/main.lisp diff -u fomus/main.lisp:1.18 fomus/main.lisp:1.19 --- fomus/main.lisp:1.18 Fri Nov 11 23:03:16 2005 +++ fomus/main.lisp Sat Nov 12 21:42:46 2005 @@ -189,7 +189,7 @@ (defun fomus-main () (find-cm) - (when (find :cmn (force-list2some *backend*) :key #'first) (find-cmn)) + (when (find :cmn (force-list2some *backend*) :key (lambda (x) (first (force-list x)))) (find-cmn)) (let ((r (fomus-proc))) (loop for x of-type (or symbol cons) in (force-list2some *backend*) do (let ((xx (force-list x))) Index: fomus/parts.lisp diff -u fomus/parts.lisp:1.7 fomus/parts.lisp:1.8 --- fomus/parts.lisp:1.7 Wed Aug 31 23:17:59 2005 +++ fomus/parts.lisp Sat Nov 12 21:42:46 2005 @@ -119,60 +119,3 @@ (getprop l '(:endgroup 1))) (addprop f '(:startgroup 0)) ; add a global group if there isn't one (addprop l '(:endgroup 0))))))) - -;; (defun group-parts (pts) -;; (declare (type list pts)) -;; (labels ((nu (in sp tv &optional i) -;; (declare (type symbol in) (type (cons symbol list) sp) (type boolean tv) (type (or (integer 0) null) i)) -;; (loop -;; with fs = (unless (and tv (eq (the symbol (first sp)) :grandstaff)) (the symbol (first sp))) -;; for s of-type (or cons symbol) in (rest sp) -;; and j from 0 -;; if (consp s) -;; do (let ((l (nu in s tv j))) -;; (when l (return (cons (cons i fs) l)))) -;; else if (eq in s) do (return (list (cons i fs)))))) -;; (let ((gs nil)) ; in the middle of grandstaff? -;; (flet ((en (p l ty) -;; (declare (type partex p) (type (integer 1) l) (type symbol ty)) -;; (if (and (getprop p (list :startgroup l)) (not gs)) ; eliminate 1-staff braces -;; (rmprop p (list :startgroup l)) -;; (addprop p (list :endgroup l))) -;; (when (eq ty :grandstaff) (setf gs nil))) -;; (ad (p l ty) -;; (declare (type partex p) (type (integer 1) l) (type symbol ty)) -;; (addprop p (list :startgroup l ty)) -;; (when (eq ty :grandstaff) (setf gs t)))) -;; (loop -;; for (lp p) of-type ((or part null) part) on (cons nil pts) and ii downfrom -1 -;; and l = g -;; for g = (when p (or (rest (nu (instr-sym (part-instr p)) (cons nil (instr-groups)) (<= (instr-staves (part-instr p)) 1))) -;; (if (> (instr-staves (part-instr p)) 1) -;; (list (cons ii :grandstaff)) -;; (list (cons ii nil))))) -;; do -;; (loop -;; for ll on l and gg on g and i from 1 -;; while (equal (the (cons integer symbol) (first ll)) (the (cons integer symbol) (first gg))) -;; finally -;; (loop -;; for l on ll and g on gg and j from i -;; do -;; (let ((x (cdr (the (cons * symbol) (first l))))) (when (or x gs) (en lp j x))) -;; (let ((x (cdr (the (cons * symbol) (first g))))) (when x (ad p j x))) -;; finally -;; (loop -;; for ll on l and k from j -;; do (let ((x (cdr (the (cons * symbol) (first ll))))) (when (or x gs) (en lp k x)))) -;; (loop -;; for gg on g and k from j -;; do (let ((x (cdr (the (cons * symbol) (first gg))))) (when x (ad p k x)))))) -;; (print-dot)) -;; (let ((f (first pts)) -;; (l (last-element pts))) -;; (declare (type partex f l)) -;; (unless (and (getprop f '(:startgroup 1)) -;; (notany (lambda (p) (declare (type partex p)) (getprop p '(:startgroup 1))) (rest pts)) -;; (getprop l '(:endgroup 1))) -;; (addprop f '(:startgroup 0)) ; add a global group if there isn't one -;; (addprop l '(:endgroup 0)))))))) Index: fomus/test.lisp diff -u fomus/test.lisp:1.19 fomus/test.lisp:1.20 --- fomus/test.lisp:1.19 Sat Oct 22 22:43:06 2005 +++ fomus/test.lisp Sat Nov 12 21:42:46 2005 @@ -129,7 +129,7 @@ (fomus :backend '((:data) (:lilypond :view t)) - :ensemble-type :small-ensemble + :ensemble-type :orchestra :parts (list (make-part :name "Piano 1" @@ -154,6 +154,22 @@ (make-part :name "Clarinet 2" :instr :bf-clarinet + :events (list (make-note :off 4 :dur 1 :note 60))) + (make-part + :name "Violin" + :instr :violin + :events (list (make-note :off 4 :dur 1 :note 60))) + (make-part + :name "Violin" + :instr :violin + :events (list (make-note :off 4 :dur 1 :note 60))) + (make-part + :name "Cello" + :instr :cello + :events (list (make-note :off 4 :dur 1 :note 60))) + (make-part + :name "Cello" + :instr :cello :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Tuba" Index: fomus/version.lisp diff -u fomus/version.lisp:1.19 fomus/version.lisp:1.20 --- fomus/version.lisp:1.19 Sat Nov 12 19:57:59 2005 +++ fomus/version.lisp Sat Nov 12 21:42:46 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 24)) +(defparameter +version+ '(0 1 25)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/version.lisp
by dpsenicka＠common-lisp.net 12 Nov '05

12 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv26726 Modified Files: version.lisp Log Message: accidentals improvement Date: Sat Nov 12 19:57:59 2005 Author: dpsenicka Index: fomus/version.lisp diff -u fomus/version.lisp:1.18 fomus/version.lisp:1.19 --- fomus/version.lisp:1.18 Sat Nov 12 03:20:58 2005 +++ fomus/version.lisp Sat Nov 12 19:57:59 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 23)) +(defparameter +version+ '(0 1 24)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_mid.lisp
by dpsenicka＠common-lisp.net 12 Nov '05

12 Nov '05

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

1 0

[fomus-cvs] CVS update: fomus/backend_mid.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 12 Nov '05

12 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv18508 Modified Files: backend_mid.lisp version.lisp Log Message: bug fix Date: Sat Nov 12 03:20:59 2005 Author: dpsenicka Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.6 fomus/backend_mid.lisp:1.7 --- fomus/backend_mid.lisp:1.6 Sat Oct 22 22:43:06 2005 +++ fomus/backend_mid.lisp Sat Nov 12 03:20:58 2005 @@ -419,13 +419,15 @@ ch) for n in n0 and x from 1 and tr in (force-list (or (event-tiert ev) '(nil))) + and tl in (force-list (or (event-tielt ev) '(nil))) for bot = t then nil and top = (= x ln) for i = (find-if (lambda (y) (= (midi-note (cdr y)) n)) ts) ; i = (marks . tiedobj) unless (getmark ev (list :harmonic :touched n)) - if i do (setf (midi-dur* (cdr i)) (- (event-endoff ev) (midi-off (cdr i))) - (car i) (delete-duplicates (nconc (midi-marks ev bot top pmn) - (car i)) - :test #'equal)) + if (and i tl) + do (setf (midi-dur* (cdr i)) (- (event-endoff ev) (midi-off (cdr i))) + (car i) (delete-duplicates (nconc (midi-marks ev bot top pmn) + (car i)) + :test #'equal)) else collect (let ((i (cons (midi-marks ev bot top pmn) (make-instance *cm-midi* @@ -439,8 +441,7 @@ i) end end) (list (cons (midi-marks ev t t pmn) (make-instance *cm-midi* :channel ch :time of :duration du - :keynum nil - :amplitude 0))))) + :keynum nil :amplitude 0))))) when mi nconc mi))) ; list is (marks . objs) (lambda (x y) (midi-sort (cdr x) (cdr y)))) for (ms . e) = (first r) Index: fomus/version.lisp diff -u fomus/version.lisp:1.17 fomus/version.lisp:1.18 --- fomus/version.lisp:1.17 Fri Nov 11 23:38:17 2005 +++ fomus/version.lisp Sat Nov 12 03:20:58 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 22)) +(defparameter +version+ '(0 1 23)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/classes.lisp
by dpsenicka＠common-lisp.net 11 Nov '05

11 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv2753 Modified Files: classes.lisp Log Message: bugfix Date: Fri Nov 11 23:49:36 2005 Author: dpsenicka Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.13 fomus/classes.lisp:1.14 --- fomus/classes.lisp:1.13 Fri Nov 11 23:38:17 2005 +++ fomus/classes.lisp Fri Nov 11 23:49:35 2005 @@ -311,7 +311,7 @@ (defgeneric copy-event (ev &key &allow-other-keys)) (defmethod copy-event ((ev note) &key (off (event-off ev)) (id (obj-id ev)) (partid (event-partid ev)) (dur (event-dur ev)) (marks (event-marks ev)) (voice (event-voice ev)) (note (event-note ev))) - (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or (real (0)) symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) + (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or real symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) (type (or real symbol cons) note)) (make-noteex :id id :partid partid :off off @@ -319,7 +319,7 @@ :note note)) (defmethod copy-event ((ev rest) &key (off (event-off ev)) (id (obj-id ev)) (partid (event-partid ev)) (dur (event-dur ev)) (marks (event-marks ev)) (voice (event-voice ev))) - (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or (real (0)) symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice)) + (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or real symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice)) (make-restex :id id :partid partid :off off :dur dur :marks marks :voice voice)) @@ -332,7 +332,7 @@ (defmethod copy-event ((ev noteex) &key (off (event-off ev)) (id (obj-id ev)) (partid (event-partid ev)) (dur (event-dur ev)) (marks (event-marks ev)) (voice (event-voice ev)) (note (event-note ev)) (tup (event-tup ev)) (tielt (event-tielt ev)) (tiert (event-tiert ev)) (beamlt (event-beamlt ev)) (beamrt (event-beamrt ev))) - (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or (real (0)) symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) + (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or real symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) (type (or real symbol cons) note) (type (or boolean list) tielt tiert) (type (or (integer 0) symbol list) beamlt) (type (or (integer 0) symbol) beamrt)) (make-noteex :id id :partid partid :off off @@ -342,7 +342,7 @@ :tielt tielt :tiert tiert :beamlt beamlt :beamrt beamrt)) (defmethod copy-event ((ev restex) &key (off (event-off ev)) (id (obj-id ev)) (partid (event-partid ev)) (dur (event-dur ev)) (marks (event-marks ev)) (voice (event-voice ev)) (tup (event-tup ev)) (inv (event-inv ev))) - (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or (real (0)) symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) + (declare (type (or (real 0)) off) (type (or symbol real null) partid) (type (or real symbol cons) dur) (type list marks) (type (or (integer 1 4) cons) voice) (type (or boolean list) inv)) (make-restex :id id :partid partid :off off

1 0

[fomus-cvs] CVS update: fomus/classes.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 11 Nov '05

11 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv1703 Modified Files: classes.lisp version.lisp Log Message: another bug fix Date: Fri Nov 11 23:38:17 2005 Author: dpsenicka Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.12 fomus/classes.lisp:1.13 --- fomus/classes.lisp:1.12 Sat Sep 3 21:57:14 2005 +++ fomus/classes.lisp Fri Nov 11 23:38:17 2005 @@ -37,7 +37,7 @@ (voice :type (or (integer 1 4) cons) :accessor event-voice :initform 1 :initarg :voice))) ; (defclass dur-base (mark) - ((dur :type (or (real 0) symbol cons) :accessor event-dur :initform 1 :initarg :dur))) ; rational number or (num . grace), grace = integer <0 if w/ slash (in some situations, effects how algorithm sees vertical alignment) + ((dur :type (or real symbol cons) :accessor event-dur :initform 1 :initarg :dur))) ; rational number or (num . grace), grace = integer <0 if w/ slash (in some situations, effects how algorithm sees vertical alignment) (defclass note (dur-base) ((note :type (or real symbol cons) :accessor event-note :initform nil :initarg :note))) ; number, symbol, or cons of note num/sym and accidental: -1, 0 or 1 (or -2 or 2), or list of possibilities #+sbcl Index: fomus/version.lisp diff -u fomus/version.lisp:1.16 fomus/version.lisp:1.17 --- fomus/version.lisp:1.16 Fri Nov 11 23:03:16 2005 +++ fomus/version.lisp Fri Nov 11 23:38:17 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 21)) +(defparameter +version+ '(0 1 22)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/backend_cmn.lisp fomus/backends.lisp fomus/data.lisp fomus/deps.lisp fomus/final.lisp fomus/fomus.asd fomus/load.lisp fomus/main.lisp fomus/other.lisp fomus/postproc.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 11 Nov '05

11 Nov '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv31832 Modified Files: backend_cmn.lisp backends.lisp data.lisp deps.lisp final.lisp fomus.asd load.lisp main.lisp other.lisp postproc.lisp version.lisp Log Message: more bug fixes Date: Fri Nov 11 23:03:17 2005 Author: dpsenicka Index: fomus/backend_cmn.lisp diff -u fomus/backend_cmn.lisp:1.1 fomus/backend_cmn.lisp:1.2 --- fomus/backend_cmn.lisp:1.1 Sat Oct 1 02:49:45 2005 +++ fomus/backend_cmn.lisp Fri Nov 11 23:03:16 2005 @@ -8,5 +8,29 @@ (in-package :fomus) (compile-settings) +(defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%") + (defun save-cmn (parts header filename options process view) - (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) \ No newline at end of file + ;; (unless *cmn-exists* ;; for viewing only + ;; (format t ";; ERROR: Common Music Notation required for CMN output~%") + ;; (return-from save-cmn)) + (declare (ignore process view)) + (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) + (with-open-file (f filename :direction :output :if-exists :supersede) + (destructuring-bind (&key score-attr &allow-other-keys) options + (format f "~A" header) + (write + `(cmn ,score-attr + ,@(labels ((pfn (pps &optional (grp 1)) + (loop for e = (pop pps) + for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) + if gr nconc (let* ((gl (second (first (sort gr #'< :key #'second)))) + (ps (pfn (loop for i = e then (pop pps) collect i until (getprop e (list :endgroup gl))) (1+ gl)))) + (ecase (third gr) + ((:group :choirgroup) `((system bracket ,@ps))) + (:grandstaff `((system brace ,@ps))))) + else collect + (loop )))) + (pfn parts))) + :stream f + :escape nil)))) \ No newline at end of file Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.11 fomus/backends.lisp:1.12 --- fomus/backends.lisp:1.11 Sat Oct 22 22:43:06 2005 +++ fomus/backends.lisp Fri Nov 11 23:03:16 2005 @@ -12,7 +12,7 @@ (declaim (type cons +backendexts+)) (defparameter +backendexts+ - '((:data . "fms") #|(:cmn . "cmn")|# (:lilypond . "ly") (:musicxml . "xml") (:midi . "mid") #|(:portmidi . "pm") (:midishare . "ms")|#)) + '((: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+)))) @@ -37,7 +37,7 @@ (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)) + (:cmn (save-cmn 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)) Index: fomus/data.lisp diff -u fomus/data.lisp:1.25 fomus/data.lisp:1.26 --- fomus/data.lisp:1.25 Sat Oct 22 22:43:06 2005 +++ fomus/data.lisp Fri Nov 11 23:03:16 2005 @@ -271,7 +271,7 @@ "Found ~S, expected (INTEGERS 1) or SYMBOLS in the form I, (I (S S I) ...) in CLEFLEGLS slot" t)) (instr-8uplegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected NIL, (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8UPLEGLS slot" t)) (instr-8dnlegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected NIL, (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8DNLEGLS slot" t)) - (instr-percs (check* (or* null (list-of* (type* +perc-type+)) (list-of* (cons* symbol (key-arg-pairs* ,@+perc-keys+)))) + (instr-percs (check* (or* null (list-of* (or* (type* +perc-type+) (cons* symbol (key-arg-pairs* ,@+perc-keys+))))) "Found ~S, expected list of PERC objects or (SYMBOL/(INTEGER 0 127) KEYWORD/ARGUMENT-PAIRS...) in PERCS slot" t)) (instr-midiprgch-im (check* (or* null (integer 0 127) (list-of* (integer 0 127))) "Found ~S, expected NIL, (integer 0 127) or list of (integer 0 127) in MIDIPRGCH-IM slot" t)) Index: fomus/deps.lisp diff -u fomus/deps.lisp:1.7 fomus/deps.lisp:1.8 --- fomus/deps.lisp:1.7 Sat Oct 22 22:43:06 2005 +++ fomus/deps.lisp Fri Nov 11 23:03:16 2005 @@ -58,3 +58,14 @@ *cm-midipbend* (find-symbol "MIDI-PITCH-BEND" :cm) *cm-rts* (ignore-errors (symbol-function (find-symbol "RTS" :cm))) ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; COMMON MUSIC NOTATION + +(defparameter *cmn-exists* nil) + +(defun find-cmn () + (when (and (not *cmn-exists*) (find-package "CMN")) + (when (>= *verbose* 2) (format t ";; Common Music Notation package detected~%")) + (setf *cmn-exists* t + ))) \ No newline at end of file Index: fomus/final.lisp diff -u fomus/final.lisp:1.7 fomus/final.lisp:1.8 --- fomus/final.lisp:1.7 Sun Aug 21 21:17:40 2005 +++ fomus/final.lisp Fri Nov 11 23:03:16 2005 @@ -48,7 +48,7 @@ (conc-stringlist (loop for e in +banner+ collect (format nil ";; ~A~%" e)))))) (eval-when (:load-toplevel :execute) - (find-cm)) + (find-cm) (find-cmn)) (eval-when (:load-toplevel :execute) (load-initfile)) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.16 fomus/fomus.asd:1.17 --- fomus/fomus.asd:1.16 Sat Oct 22 22:43:06 2005 +++ fomus/fomus.asd Fri Nov 11 23:03:16 2005 @@ -31,10 +31,11 @@ (:file "voices" :depends-on ("util")) (:file "quantize" :depends-on ("util" "splitrules")) + (:file "backend_cmn" :depends-on ("util")) (: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" "backend_mid" "version")) + (:file "backends" :depends-on ("backend_cmn" "backend_ly" "backend_xml" "backend_mid" "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.7 fomus/load.lisp:1.8 --- fomus/load.lisp:1.7 Sat Oct 1 02:49:45 2005 +++ fomus/load.lisp Fri Nov 11 23:03:16 2005 @@ -2,7 +2,7 @@ ;; Load file for FOMUS (loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "splitrules" "accidentals" "beams" "marks" - "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" + "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_cmn" "backend_ly" "backend_xml" "backend_mid" "backends" "main" "interface" "final") and nw for na in fl Index: fomus/main.lisp diff -u fomus/main.lisp:1.17 fomus/main.lisp:1.18 --- fomus/main.lisp:1.17 Sat Oct 22 22:43:06 2005 +++ fomus/main.lisp Fri Nov 11 23:03:16 2005 @@ -52,7 +52,6 @@ ;; keysigs not implemented yet ;; returns data structure ready for output via backends (defun fomus-proc () - (find-cm) (when (and (numberp *verbose*) (>= *verbose* 1)) (out "~&;; Formatting music...")) (when *debug-filename* (save-debug)) (when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types...")) @@ -189,6 +188,8 @@ ;; MAIN (defun fomus-main () + (find-cm) + (when (find :cmn (force-list2some *backend*) :key #'first) (find-cmn)) (let ((r (fomus-proc))) (loop for x of-type (or symbol cons) in (force-list2some *backend*) do (let ((xx (force-list x))) Index: fomus/other.lisp diff -u fomus/other.lisp:1.10 fomus/other.lisp:1.11 --- fomus/other.lisp:1.10 Sat Oct 1 02:49:45 2005 +++ fomus/other.lisp Fri Nov 11 23:03:16 2005 @@ -17,19 +17,18 @@ (defun check-ranges (pts) (declare (type list pts)) (loop - with f for p of-type partex in pts unless (is-percussion p) - do (loop - with i = (part-instr p) - with mi = (when (instr-minp i) (+ (instr-minp i) (or (instr-tpose i) 0))) and ma = (when (instr-maxp i) (+ (instr-maxp i) (or (instr-tpose i) 0))) - for e of-type (or noteex restex) in (part-events p) - when (notep e) - do (let ((n (event-note* e))) - (when (or (and mi (< n mi)) (and ma (> n ma))) - (unless f (setf f t) (format t "~%; ")) - (format t "~&;; WARNING: Note ~S is out of range at offset ~S, part ~S" n (event-foff e) (part-name p)) - (return)))) (print-dot))) + do (loop with i = (part-instr p) + for mm in (list (when (instr-minp i) (+ (instr-minp i) (or (instr-tpose i) 0))) (when (instr-maxp i) (+ (instr-maxp i) (or (instr-tpose i) 0)))) + and co in (list #'< #'>) when mm do + (loop + for e of-type (or noteex restex) in (part-events p) + when (notep e) + do (let ((n (event-note* e))) + (when (funcall co n mm) + (format t "~&;; WARNING: Note ~S is out of range at offset ~S, part ~S" n (event-foff e) (part-name p)) + (return))))) (print-dot))) (defun transpose (pts) (declare (type list pts)) @@ -85,7 +84,8 @@ (loop with pm = (instr-percs (part-instr p)) for ev of-type (or noteex restex) in (part-events p) do (let ((n (event-note ev))) ; n = value of note slot - (unless (numberp n) + (if (numberp n) (unless (svref +note-to-white+ (mod n 12)) + (error "Invalid percussion note ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p))) (let ((c (etypecase n ; c = percussion struct (symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym)) (perc n)))) @@ -95,7 +95,11 @@ (setf (event-staff* ev) (perc-staff c))) (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))) (setf (event-note ev) (note-to-num (perc-note c))) - (when (and *auto-percussion-durs* (perc-autodur c) (not (event-grace ev))) (addmark ev :autodur))) + (when (and *auto-percussion-durs* (perc-autodur c) (not (event-grace ev)) + (notany (lambda (x) + (declare (type symbol x)) + (getmark ev x)) + '(:tremolo :tremolofirst :tremolosecond :longtrill))) (addmark ev :autodur))) (if (is-note n) (setf (event-note ev) (note-to-num n)) (error "Unknown percussion specifier ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p)))))))) (print-dot))) @@ -122,10 +126,7 @@ for p of-type partex in parts do (loop with oo = mt for ev of-type (or noteex restex) in (reverse (part-events p)) - when (and (popmark ev :autodur) (notany (lambda (x) - (declare (type symbol x)) - (getmark ev x)) - '(:tremolo :tremolofirst :tremolosecond :longtrill))) + when (popmark ev :autodur) do (setf (event-autodur ev) t (event-dur ev) (if (= oo (event-off ev)) lb (- oo (event-off ev)))) when (and #|(notep ev)|# (< (event-off ev) oo)) do (setf oo (event-off ev))) (print-dot))) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.14 fomus/postproc.lisp:1.15 --- fomus/postproc.lisp:1.14 Sat Oct 22 22:43:06 2005 +++ fomus/postproc.lisp Fri Nov 11 23:03:16 2005 @@ -163,7 +163,9 @@ (if pc (addmark e (list m in)) ; just get rid of the accidental (let ((a (- (+ n in) wn))) (if (and (or (/= a 0) (/= (svref as wn) 0)) - (or (/= a 0) *acc-throughout-meas*)) (addmark e (list m in a)) (addmark e (list m in)))))) + (or (/= a 0) *acc-throughout-meas*)) + (addmark e (list m in a)) + (addmark e (list m in)))))) (loop for n of-type integer in (if (chordp e) (event-writtennotes e) (force-list (event-writtennote e))) and a of-type (integer -2 2) in (if (chordp e) (event-accs e) (force-list (event-acc e))) and aa of-type (rational -1/2 1/2) in (if (chordp e) (event-addaccs e) (force-list (event-addacc e))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.15 fomus/version.lisp:1.16 --- fomus/version.lisp:1.15 Sat Oct 22 22:43:06 2005 +++ fomus/version.lisp Fri Nov 11 23:03:16 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 20)) +(defparameter +version+ '(0 1 21)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[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