August 2005 - fomus-cvs@common-lisp.net - mailman3.common-lisp.net

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/backend_ly.lisp fomus/data.lisp fomus/fomus.asd fomus/interface.lisp fomus/main.lisp fomus/marks.lisp fomus/parts.lisp fomus/postproc.lisp fomus/split.lisp fomus/test.lisp fomus/util.lisp fomus/version.lisp fomus/voices.lisp
by dpsenicka＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20725 Modified Files: CHANGELOG TODO backend_ly.lisp data.lisp fomus.asd interface.lisp main.lisp marks.lisp parts.lisp postproc.lisp split.lisp test.lisp util.lisp version.lisp voices.lisp Log Message: testing/bug fixes Date: Wed Aug 31 23:18:00 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.10 fomus/CHANGELOG:1.11 --- fomus/CHANGELOG:1.10 Wed Aug 31 16:07:10 2005 +++ fomus/CHANGELOG Wed Aug 31 23:17:59 2005 @@ -1,3 +1,10 @@ +v0.1.13 + + Testing/bug fixes: + BACKEND setting + combining notes from multiple voices into one + default part orderings/groupings + v0.1.12 Testing/bug fixes: Index: fomus/TODO diff -u fomus/TODO:1.18 fomus/TODO:1.19 --- fomus/TODO:1.18 Wed Aug 31 17:56:06 2005 +++ fomus/TODO Wed Aug 31 23:17:59 2005 @@ -3,19 +3,19 @@ Immediate: Testing and bug fixes - Nested tuplets not working yet - Automatic multivoice notes not working yet Splitting chords across staves (LilyPond) - :STAFF and other marks for overriding FOMUS's decisions + STAFF, CLEF and other marks for overriding FOMUS's decisions MusicXML backend MIDI output to CM Durations that fill to next/previous note - Proofread/finish documentation, add easy examples + Proofread/finish documentation: + most often used settings + easy, indexed examples of all features Tuplet bracket setting - DOC: :instruments setting update + Marks affecting all voices Aesthetic tweaks: - Avoid staff changes when notes move in other direction - Re-evaluate initial clef decision in measure 1 + avoid staff changes when notes move in other direction + re-evaluate initial clef decision in measure 1 Short Term: Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.15 fomus/backend_ly.lisp:1.16 --- fomus/backend_ly.lisp:1.15 Wed Aug 31 16:07:10 2005 +++ fomus/backend_ly.lisp Wed Aug 31 23:17:59 2005 @@ -383,7 +383,10 @@ for (xxx nu ty) in (sort (getprops p :startgroup) #'< :key #'second) do (if ty (ecase ty - (:group (format f "~A\\new ~A <<~%" (make-string in :initial-element #\space) (if (<= nu 1) "StaffGroup" "InnerStaffGroup"))) + ((:group :choirgroup) (format f "~A\\new ~A <<~%" (make-string in :initial-element #\space) + (ecase ty + (:group (if (<= nu 1) "StaffGroup" "InnerStaffGroup")) + (:choirgroup (if (<= nu 1) "ChoirStaff" "InnerChoirStaff"))))) (:grandstaff (format f "~A\\new PianoStaff <<~%" (make-string in :initial-element #\space)))) (format f "~A<<~%" (make-string in :initial-element #\space))) (incf in 2)) Index: fomus/data.lisp diff -u fomus/data.lisp:1.20 fomus/data.lisp:1.21 --- fomus/data.lisp:1.20 Wed Aug 31 17:56:06 2005 +++ fomus/data.lisp Wed Aug 31 23:17:59 2005 @@ -353,7 +353,7 @@ (declaim (type cons +instr-group-tree-type-aux+ +instr-group-tree-type+)) (defparameter +instr-group-tree-type-aux+ - '(or* (satisfies is-instr) (list-of* (cons* (or null (member :group :grandstaff)) (list-of* +instr-group-tree-type-aux+))))) + '(or* (satisfies is-instr) (list-of* (cons* (member :group :choirgroup :grandstaff) (list-of* +instr-group-tree-type-aux+))))) (defparameter +instr-group-tree-type+ '(list-of* (cons* symbol (list-of* +instr-group-tree-type-aux+)))) @@ -385,15 +385,15 @@ (cons :small-ensemble (loop for e in +instruments+ for sy = (instr-sym e) - if (or (eq sy :percussion) (find sy '(:timpani :glockenspiel :xylophone :vibraphone :marimba :chimes :celesta))) collect sy into p + if (or (eq sy :percussion) (find sy '(:timpani :glockenspiel :xylophone :vibraphone :marimba :chimes :celesta))) collect (list :group sy) into p else if (eq sy :organ-manuals) collect '(:group (:grandstaff :organ-manuals) :organ-pedals) into k else if (eq sy :organ-pedals) do (progn nil) else if (= (instr-staves e) 2) collect (list :grandstaff sy) into k else if (find sy '(:soprano :mezzo-soprano :contralto :tenor :tenor-8dn :baritone :bass)) collect sy into v else if (find sy '(:soprano-choir :alto-choir :tenor-choir :bass-choir)) collect sy into c else collect (cons (list :group sy) (/ (+ (instr-minp e) (instr-maxp e)) 2)) into i - finally (return (nconc (list (cons nil (mapcar #'car (sort i #'> :key #'cdr)))) (list (cons nil p)) - v (list (cons :group c)) k)))))) + finally (return (nconc (mapcar #'car (sort i #'> :key #'cdr)) p + (list (cons :choirgroup v)) (list (cons :choirgroup c)) k)))))) (defun make-instrex* (instr) (declare (type instr instr)) @@ -639,11 +639,22 @@ (defun is-restmarksym (sym) (find sym +marks-rests+)) +(declaim (type cons +marks-unimportant+)) +(defparameter +marks-important+ + '(:longtrill :arco :pizz :startgraceslur- :graceslur- :endgraceslur- :startwedge> :startwedge< :wedge- :endwedge- + :rfz :sfz :spp :sp :sff :sf :fp :ffffff :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp :pppppp + :fermata :arpeggio :glissando :breath :harmonic + :stopped :open :staccato :staccatissimo + :lineprall :prallup :pralldown :downmordent :upmordent :downprall :upprall :prallmordent + :prallprall :mordent :prall :trill :reverseturn :turn :righttoe :lefttoe :rightheel :leftheel + :thumb :flageolet :downbow :upbow :portato :tenuto :marcato :accent :notehead + :startslur- :slur- :endslur- :textnote :textdyn)) + (declaim (type boolean *auto-pizz/arco*)) (defparameter *auto-pizz/arco* t) ;; marks only at beginning or end of tied notes -(declaim (type cons +marks-first-tie+ +marks-last-tie+ +marks-all-ties+ +marks-on-off+ +marks-before-after+ +marks-indiv-voices+ +(declaim (type cons +marks-first-tie+ +marks-last-tie+ #|+marks-all-ties+|# +marks-on-off+ +marks-before-after+ +marks-indiv-voices+ +marks-spanner-voices+ +marks-spanner-staves+ +marks-expand+ +marks-defaultup+)) (defparameter +marks-first-tie+ '(:startslur- :startgraceslur- :start8up- :start8down- :starttext- #|:starttextdyn- :starttexttempo-|# :startwedge< :startwedge> :endgraceslur- @@ -652,14 +663,14 @@ :accent :marcato :tenuto :portato :upbow :downbow :flageolet :thumb :leftheel :rightheel :lefttoe :righttoe :turn :reverseturn :trill :prall :mordent :prallprall :prallmordent :upprall :downprall :upmordent :downmordent :pralldown :prallup :lineprall - :pizz :arco :open :stopped :breath + :pizz :arco :open :stopped :notehead :harmonic :arpeggio :glissando :portamento ; special ones :cautacc :8up :8down :clef)) (defparameter +marks-last-tie+ '(:endslur- :end8up- :end8down- :endtext- #|:endtextdyn- :endtexttempo-|# :endwedge- - :fermata :staccatissimo :staccato)) -(defparameter +marks-all-ties+ - '(:longtrill :tremolo :tremolofirst :tremolosecond)) + :fermata :staccatissimo :staccato :breath)) +;; (defparameter +marks-all-ties+ +;; '(:longtrill :tremolo :tremolofirst :tremolosecond)) (defparameter +marks-on-off+ '((*auto-pizz/arco* . (:pizz . :arco)))) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.8 fomus/fomus.asd:1.9 --- fomus/fomus.asd:1.8 Tue Aug 30 00:28:03 2005 +++ fomus/fomus.asd Wed Aug 31 23:17:59 2005 @@ -4,7 +4,7 @@ (asdf:defsystem "fomus" :description "Lisp music notation formatter" - :version "0.1.11" + :version "0.1.13" :author "David Psenicka" :licence "LLGPL" Index: fomus/interface.lisp diff -u fomus/interface.lisp:1.5 fomus/interface.lisp:1.6 --- fomus/interface.lisp:1.5 Sun Aug 21 21:17:41 2005 +++ fomus/interface.lisp Wed Aug 31 23:17:59 2005 @@ -40,8 +40,14 @@ `(destructuring-bind (&key ,@(mapcar (lambda (x y) (list x y)) n v) other-keys) args (declare (ignore other-keys)) (progv (quote ,v) (list ,@n) - (fomus-main)))))) - (if allow-other-keys (fma) (fm)))) + (fomus-main))))) + #+(or cmu sbcl) + (wa (&body forms) + `(handler-bind ((style-warning (lambda (x) (declare (ignore x)) (muffle-warning)))) + ,@forms))) + (if allow-other-keys + #+(or cmu sbcl) (wa (fma)) #-(or cmu sbcl) (fma) + #+(or cmu sbcl) (wa (fm)) #-(or cmu sbcl) (fm)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INTERFACE MULTIPLE FUNCTION CALL Index: fomus/main.lisp diff -u fomus/main.lisp:1.14 fomus/main.lisp:1.15 --- fomus/main.lisp:1.14 Wed Aug 31 17:56:06 2005 +++ fomus/main.lisp Wed Aug 31 23:17:59 2005 @@ -156,6 +156,7 @@ (when (>= *verbose* 2) (out "~&; Cautionary accidentals...")) (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs)) (when (>= *verbose* 2) (out "~&; Chords...")) + (marks-beforeafter pts) (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1) (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.10 fomus/marks.lisp:1.11 --- fomus/marks.lisp:1.10 Sun Aug 21 21:17:41 2005 +++ fomus/marks.lisp Wed Aug 31 23:17:59 2005 @@ -38,8 +38,8 @@ ;; this will translate the user input format to a more rigid format for the backends (defun clean-spanners (pts spanners) (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners - do (loop for p of-type partex in pts - do (loop + do (loop for p of-type partex in pts do + (loop with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 for e of-type (or noteex restex) in (reverse (part-events p)) ; go backwards, find endsyms do @@ -74,7 +74,9 @@ (decf nu)) (error "Levels for marks ~S, ~S and ~S are out of order at offset ~S, part ~S" startsym contsym endsym (event-foff e) (part-name p))) (error "Missing ending mark ~S or ~S for starting mark ~S at offset ~S, part ~S" contsym endsym startsym (event-foff e) (part-name p)))))) - finally (or (= nu 0) (error "Missing starting mark ~S in part ~S" startsym (part-name p)))) (print-dot)))) + (loop for l being each hash-value in ss do (addmark e (list contsym l))) + finally (or (= nu 0) (error "Missing starting mark ~S in part ~S" startsym (part-name p)))) + (print-dot)))) (defun expand-marks (pts) (loop for (ma . (rs . re)) of-type (symbol . (symbol . symbol)) in +marks-expand+ do @@ -180,4 +182,29 @@ finally (loop for p of-type partex in pts do (rmprop p :quant) (loop for e of-type (or noteex restex) in (part-events p) do - (setf (event-marks e) (remove-duplicates (event-marks e) :test #'equal)))))) \ No newline at end of file + (setf (event-marks e) (remove-duplicates (event-marks e) :test #'equal)))))) + +(defun marks-beforeafter (pts) + (declare (type list pts)) + (loop with xx for p of-type partex in pts do + (loop for m of-type meas in (part-meas p) do + ;;(loop for g of-type list in (meas-voices m) do + (loop for (e0 e1 e2) of-type (noteex (or noteex null) (or noteex null)) + on (cons nil (remove-if-not #'notep (meas-events m))) while e1 do + (loop for (a . d) of-type (symbol . symbol) in +marks-before-after+ + for k = (force-list (popmark e1 a)) + when k do + (push (cons (ecase (or (second k) d) + (:before e0) + (:after e1)) + (list (first k) :after)) + xx) + (push (cons (ecase (or (second k) d) + (:before e1) + (:after e2)) + (list (first k) :before)) + xx)))) ;) + (print-dot) + finally + (loop for (e . m) of-type ((or noteex restex) . cons) in xx when e do (addmark e m)))) + Index: fomus/parts.lisp diff -u fomus/parts.lisp:1.6 fomus/parts.lisp:1.7 --- fomus/parts.lisp:1.6 Sun Aug 28 23:31:27 2005 +++ fomus/parts.lisp Wed Aug 31 23:17:59 2005 @@ -101,15 +101,15 @@ (loop for l on ll and g on gg and j from i do - (let ((x (cdr (the (cons * symbol) (first l))))) (when x (en lp j x))) - (let ((x (cdr (the (cons * symbol) (first g))))) (when x (ad p j x))) + (let ((x (cdr (the (cons * symbol) (first l))))) (en lp j x)) + (let ((x (cdr (the (cons * symbol) (first g))))) (ad p j x)) finally (loop for ll on l and k from j - do (let ((x (cdr (the (cons * symbol) (first ll))))) (when x (en lp k x)))) + do (let ((x (cdr (the (cons * symbol) (first ll))))) (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)))))) + do (let ((x (cdr (the (cons * symbol) (first gg))))) (ad p k x))))) (print-dot)) (let ((f (first pts)) (l (last-element pts))) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.10 fomus/postproc.lisp:1.11 --- fomus/postproc.lisp:1.10 Wed Aug 31 16:07:10 2005 +++ fomus/postproc.lisp Wed Aug 31 23:17:59 2005 @@ -413,35 +413,11 @@ for p of-type partex in pts do (loop for m of-type meas in (part-meas p) do (loop for g of-type list in (meas-voices m) do - (loop for e of-type (or noteex restex) in g do (setf (event-marks e) (sort-props (event-marks e))))) + (loop for e of-type (or noteex restex) in g do (setf (event-marks e) (sort-marks (event-marks e))))) (setf (meas-props m) (sort-props (meas-props m)))) (setf (part-props p) (sort-props (part-props p))) (print-dot))) -(defun postproc-marks-beforeafter (pts) - (declare (type list pts)) - (loop with xx for p of-type partex in pts do - (loop for m of-type meas in (part-meas p) do - (loop for g of-type list in (meas-voices m) do - (loop for (e0 e1 e2) of-type ((or noteex restex null) (or noteex restex null) (or noteex restex null)) - on (cons nil g) while e1 do - (loop for (a . d) of-type (symbol . symbol) in +marks-before-after+ - for k = (force-list (popmark e1 a)) - when k do - (push (cons (ecase (or (second k) d) - (:before e0) - (:after e1)) - (list (first k) :after)) - xx) - (push (cons (ecase (or (second k) d) - (:before e1) - (:after e2)) - (list (first k) :before)) - xx))))) - (print-dot) - finally - (loop for (e . m) of-type ((or noteex restex) . cons) in xx when e do (addmark e m)))) - ;; do lots of nice things for the backend functions (defun postproc (pts) (postproc-tremolos pts) @@ -455,6 +431,6 @@ (postproc-graces pts) (postproc-marksonoff pts) (postproc-text pts) - (postproc-marks-beforeafter pts) + ;;(postproc-marks-beforeafter pts) (postproc-barlines pts)) Index: fomus/split.lisp diff -u fomus/split.lisp:1.15 fomus/split.lisp:1.16 --- fomus/split.lisp:1.15 Sun Aug 28 06:32:47 2005 +++ fomus/split.lisp Wed Aug 31 23:17:59 2005 @@ -335,8 +335,8 @@ (declare (type (or noteex restex null) e1 e2) (type cons es)) (if (and (restp e1) (restp e2) (not (find (event-off e2) (event-nomerge e1))) - (equal (list (event-dur* e1) (sort-marks (event-marks e1)) (event-tup e1)) - (list (event-dur* e2) (sort-marks (event-marks e2)) (event-tup e2)))) + (equal (list (event-dur* e1) (sort-marks (important-marks (event-marks e1))) (event-tup e1)) + (list (event-dur* e2) (sort-marks (important-marks (event-marks e2))) (event-tup e2)))) (cons (copy-event e1 :dur (* (event-dur* e1) 2) :tup (cons (when (car (event-tup e1)) Index: fomus/test.lisp diff -u fomus/test.lisp:1.10 fomus/test.lisp:1.11 --- fomus/test.lisp:1.10 Wed Aug 31 17:56:06 2005 +++ fomus/test.lisp Wed Aug 31 23:18:00 2005 @@ -80,7 +80,6 @@ (fomus :backend '(:data (:lilypond :view t)) :ensemble-type :orchestra - :verbose 2 :beat-division 8 :max-tuplet '(7 3) :parts (list @@ -130,36 +129,36 @@ (fomus :backend '((:data) (:lilypond :view t)) - :ensemble-type :orchestra + :ensemble-type :small-ensemble :parts (list (make-part :name "Piano 1" :instr :piano - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Piano 2" :instr :piano - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Flute 1" :instr :flute - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Flute 2" :instr :flute - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Clarinet 1" :instr :bf-clarinet - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Clarinet 2" :instr :bf-clarinet - :events (list (make-note :off 0 :dur 1 :note 60))) + :events (list (make-note :off 4 :dur 1 :note 60))) (make-part :name "Tuba" :instr :tuba - :events (list (make-note :off 0 :dur 1 :note 36))))) + :events (list (make-note :off 4 :dur 1 :note 36))))) ;; Mark objects @@ -788,27 +787,25 @@ (0 :woodblock) (1 :snaredrum))))))) -(let ((*break-on-signals* t)) - (fomus ; :auto-multivoice-notes (not working yet) - :backend '(:lilypond :view t) - :ensemble-type :orchestra - :parts - (list - (make-part - :name "Violin" - :instr :violin - :events - (loop repeat 2 nconc - (loop - for off from 0 to 40 by 1/2 - collect (make-note :off off - :voice '(1 2) - :dur (if (< off 40) 1/2 1) - :note (+ 55 (random 19))))))))) - -(WARN KERNEL:SIMPLE-STYLE-WARNING :FORMAT-CONTROL "Variable ~S defined but never used." :FORMAT-ARGUMENTS ...) +(fomus ; :auto-multivoice-notes + :backend '(:lilypond :view t) + :ensemble-type :orchestra + :auto-multivoice-notes nil + :parts + (list + (make-part + :name "Violin" + :instr :violin + :events + (loop for b in '(55 67) nconc + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :voice '(1 2) + :dur (if (< off 10) 1/2 1) + :note (+ b (random 19)))))))) -(fomus ; :auto-percussion-durs +(fomus ; :auto-percussion-durs :backend '((:data) (:lilypond :view t)) :ensemble-type :orchestra :auto-percussion-durs nil @@ -823,7 +820,7 @@ (0 :woodblock) (1 :snaredrum))))))) -(fomus ; :auto-pizz/arco +(fomus ; :auto-pizz/arco :backend '((:data) (:lilypond :view t)) :ensemble-type :orchestra :beat-division 8 @@ -843,7 +840,7 @@ (0 '(:pizz)) (1 '(:arco)))))) -(fomus ; :auto-override-timesigs +(fomus ; :auto-override-timesigs :backend '((:data) (:lilypond :view t )) :ensemble-type :orchestra :verbose 2 Index: fomus/util.lisp diff -u fomus/util.lisp:1.15 fomus/util.lisp:1.16 --- fomus/util.lisp:1.15 Wed Aug 31 17:56:06 2005 +++ fomus/util.lisp Wed Aug 31 23:18:00 2005 @@ -337,6 +337,11 @@ (declaim (inline sort-marks)) (defun sort-marks (marks) (declare (type list marks)) (sort-props marks)) +(declaim (inline important-marks)) +(defun important-marks (marks) + (declare (type list marks)) + (remove-if-not (lambda (x) (find (first (force-list x)) +marks-important+)) marks)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CHORDS/SPLITTING @@ -454,7 +459,12 @@ when (and (restp e) (popmark e :splitrt)) do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-first-rest+) when (and (restp e) (popmark e :splitlt)) - do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-rest+))) (print-dot))) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-rest+) + do (loop for sp in (list +marks-spanner-voices+ +marks-spanner-staves+) do + (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in sp + do (loop for (xxx n) in (getmarks e startsym) do (rmmark e (list contsym n))) + do (loop for (xxx n) in (getmarks e endsym) do (rmmark e (list contsym n))))))) + (print-dot))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STAVES @@ -795,13 +805,13 @@ (if format (labels ((aux (li ta) (let ((br (first li))) - (format t "~A" (case br (:group "[ ") (:grandstaff "{ ") ((nil) "| ") (otherwise " "))) + (format t "~A" (case br (:group "[ ") (:grandstaff "{ ") (:choirgroup "| ") (otherwise " "))) (loop for (e en) on (rest li) if (consp e) do (aux e (+ ta 2)) (if en (format t "~%;~VT" ta) (format t "~A" (case br (:group " ]") (:grandstaff " }") ((nil) " |") (otherwise "")))) else do (if en (format t "~A~%;~VT" e ta) (format t "~A~A" - e (case br (:group " ]") (:grandstaff " }") ((nil) " |") (otherwise "")))))))) + e (case br (:group " ]") (:grandstaff " }") (:choirgroup " |") (otherwise "")))))))) (loop for (e en) on ss do (format t "; ~A~%~%;" (first e)) (aux e 3) when en do (format t "~%~%"))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.7 fomus/version.lisp:1.8 --- fomus/version.lisp:1.7 Wed Aug 31 16:07:10 2005 +++ fomus/version.lisp Wed Aug 31 23:18:00 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 12)) +(defparameter +version+ '(0 1 13)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved" Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.9 fomus/voices.lisp:1.10 --- fomus/voices.lisp:1.9 Tue Aug 30 00:28:04 2005 +++ fomus/voices.lisp Wed Aug 31 23:18:00 2005 @@ -230,7 +230,11 @@ (declare (type cons x)) (mapc (lambda (y) (declare (type restex y)) (setf (event-inv y) t)) ; leave top-most equivalent rest (rest (sort (delete-if #'event-inv x) #'< :key #'event-voice*)))) ; distr-rest function should have left at least one visible voice - (split-into-groups re (lambda (x) (declare (type restex x)) (list (event-staff x) (event-off x) (event-dur* x) (event-tupfrac x) (sort-props (event-marks x)))) :test 'equal))) + (split-into-groups re + (lambda (x) + (declare (type restex x)) + (list (event-staff x) (event-off x) (event-dur* x) (event-tupfrac x) (sort-marks (important-marks (event-marks x))))) + :test 'equal))) (if *auto-multivoice-notes* (setf (meas-events meas) (sort (nconc re @@ -239,8 +243,10 @@ (split-into-groups no (lambda (x) (declare (type noteex x)) (list (event-staff x) (event-off x) (event-dur* x) (event-grace x) (event-tupfrac x) - (delete-if (lambda (x) (declare (type (or symbol cons) x)) (find (if (listp x) (first x) x) +marks-indiv-voices+)) - (sort-props (event-marks x))) + (delete-if (lambda (x) + (declare (type (or symbol cons) x)) + (find (if (listp x) (first x) x) +marks-indiv-voices+)) + (sort-marks (important-marks (event-marks x)))) (event-beamlt x) (event-beamrt x))) :test 'equal))) (mapcan (lambda (x0) ; sequence of adjacent notes to assemble into chords

1 0

[fomus-cvs] CVS update: fomus/TODO fomus/data.lisp fomus/main.lisp fomus/test.lisp fomus/util.lisp
by dpsenicka＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv26517 Modified Files: TODO data.lisp main.lisp test.lisp util.lisp Log Message: bug fixes Date: Wed Aug 31 17:56:06 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.17 fomus/TODO:1.18 --- fomus/TODO:1.17 Wed Aug 31 16:07:10 2005 +++ fomus/TODO Wed Aug 31 17:56:06 2005 @@ -9,10 +9,13 @@ :STAFF and other marks for overriding FOMUS's decisions MusicXML backend MIDI output to CM - Avoid staff changes when notes move in other direction Durations that fill to next/previous note Proofread/finish documentation, add easy examples Tuplet bracket setting + DOC: :instruments setting update + Aesthetic tweaks: + Avoid staff changes when notes move in other direction + Re-evaluate initial clef decision in measure 1 Short Term: Index: fomus/data.lisp diff -u fomus/data.lisp:1.19 fomus/data.lisp:1.20 --- fomus/data.lisp:1.19 Wed Aug 31 16:35:15 2005 +++ fomus/data.lisp Wed Aug 31 17:56:06 2005 @@ -463,7 +463,7 @@ ;; exported symbols/arguments to main function (declaim (type cons +settings+)) (defparameter +settings+ - '((:debug-filename (or null string)) (:verbose (integer 0 2)) + `((:debug-filename (or null string)) (:verbose (integer 0 2)) (:use-cm boolean) (:cm-scale t) (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (or* symbol (cons* symbol key-arg-pairs*)))) "(SYMBOL KEYWORD/ARGUMENTS-PAIRS...) or list of (SYMBOL KEYWORD/ARGUMENTS-PAIRS...)") @@ -475,7 +475,7 @@ (:events (or* null (list-of* (or* (type* +note-type+) (type* +rest-type+) (type* +mark-type+)))) "list of NOTE or REST objects") (:check-ranges boolean) (:transpose boolean) - (:instruments (or* null (list-of* (type* +instr-type+))) "list of INSTR objects") + (:instruments (or* null (list-of* (or* (type* +instr-type+) (cons* symbol (key-arg-pairs* ,@+instr-keys+))))) "list of INSTR objects") (:instr-groups (or* null (type* +instr-group-tree-type+)) "list of nested lists of SYMBOLS") (:default-instr (type* +instr-type+) "INSTR object") (:ensemble-type (or* null symbol (cons* symbol (list-of* +instr-group-tree-type-aux+))) "NIL, SYMBOL or nested lists of SYMBOLS") Index: fomus/main.lisp diff -u fomus/main.lisp:1.13 fomus/main.lisp:1.14 --- fomus/main.lisp:1.13 Sun Aug 28 23:31:27 2005 +++ fomus/main.lisp Wed Aug 31 17:56:06 2005 @@ -59,127 +59,128 @@ (check-setting-types) (check-settings) (let ((*max-tuplet* (force-list *max-tuplet*))) ; normalize some parameters - (set-note-precision - (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) - #-debug (declare (ignore rm)) - #+debug (when rm (error "Error in FOMUS-PROC")) - (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (declare (type (or note rest mark) x)) (or (notep x) (restp x)))) - (let ((pts (progn - (loop for p of-type part in *parts* and i from 0 - do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp - (lambda (x) (declare (type (or note rest mark timesig) x)) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks - (flet ((gpi () - (or (part-partid p) - (setf (part-partid p) - (loop - for s = (gensym) - while (find s *parts* :key #'part-partid) - finally (return s)))))) - (mapc (lambda (x) - (declare (type timesig x)) - (unless (timesig-partids x) - (setf (timesig-partids x) (gpi)))) - ti) - (mapc (lambda (x) - (declare (type mark x)) - (unless (event-partid x) - (setf (event-partid x) (gpi)))) - ma)) - (prenconc ti *timesigs*) - (prenconc ke *keysigs*) - (prenconc ma mks) - (multiple-value-bind (eo ep) (split-list evs #'event-partid) - (setf (part-events p) ep) - (prenconc eo *events*)))) - (setf *timesigs* (mapcar #'make-timesigex* *timesigs*)) - (loop - with h = (get-timesigs *timesigs* *parts*) - for i from 0 and e in *parts* - for (evs rm) of-type (list list) on (split-list* *events* (mapcar #'part-partid *parts*) :key #'event-partid) - collect (make-partex* e i evs (gethash e h)) - finally (when rm (error "No matching part for event with partid ~S" (event-partid (first rm)))))))) ; make copied list of part-exs w/ sorted events - #+debug (fomus-proc-check pts 'start) - (track-progress +progress-int+ - (when (find-if #'is-percussion pts) - (when (>= *verbose* 2) (out "~&; Percussion...")) ; before voices & clefs - (percussion pts)) ; was after accs - (autodurs-preproc pts) - (if *auto-quantize* - (progn (when (>= *verbose* 2) (out "~&; Quantizing...")) - (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize)) - (quantize-generic pts)) - (when *check-ranges* - (when (>= *verbose* 2) (out "~&; Ranges...")) - (check-ranges pts) #+debug (fomus-proc-check pts 'ranges)) - (preproc-noteheads pts) - (when *transpose* - (when (>= *verbose* 2) (out "~&; Transpositions...")) - (transpose pts) #+debug (fomus-proc-check pts 'transpose)) - (if *auto-accidentals* - (progn (when (>= *verbose* 2) (out "~&; Accidentals...")) - (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs)) - (accidentals-generic pts)) - (if *auto-voicing* - (progn (when (>= *verbose* 2) (out "~&; Voices...")) - (voices pts) #+debug (fomus-proc-check pts 'voices)) - (voices-generic pts)) - (reset-tempslots pts nil) - (if *auto-staff/clef-changes* - (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided - (clefs pts) #+debug (fomus-proc-check pts 'clefs)) - (clefs-generic pts)) - (reset-tempslots pts nil) - (distribute-marks pts mks) - (reset-tempslots pts nil) - (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED - (when *auto-ottavas* ; (before clean-spanners) - (when (>= *verbose* 2) (out "~&; Ottavas...")) - (ottavas pts) #+debug (fomus-proc-check pts 'ottavas)) - (when (>= *verbose* 2) (out "~&; Staff spanners...")) - (clean-spanners pts +marks-spanner-staves+) #+debug (fomus-proc-check pts 'spanners1) - (setf pts (sep-voices (assemble-parts pts))) ; ********** STAVES TOGETHER, VOICES SEPARATED - (when (>= *verbose* 2) (out "~&; Voice spanners...")) - (expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks) - (clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2) - (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) - (when (find-if #'is-percussion pts) (autodurs *timesigs* pts)) ;; uses beamrt until after split function - (preproc-tremolos pts) - (preproc-cautaccs pts) - (when *auto-grace-slurs* - (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) - (when (>= *verbose* 2) (out "~&; Measures...")) - (init-parts *timesigs* pts) ; ----- MEASURES - #+debug (fomus-proc-check pts 'measures) - #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x))))) - (when *auto-cautionary-accs* - (when (>= *verbose* 2) (out "~&; Cautionary accidentals...")) - (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs)) - (when (>= *verbose* 2) (out "~&; Chords...")) - (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS - (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1) - (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) - (split-preproc-backends pts) - (split pts) #+debug (fomus-proc-check pts 'ties) - (reset-tempslots pts 0) - (reset-resttempslots pts) - (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2) - (when *auto-beams* - (when (>= *verbose* 2) (out "~&; Beams...")) - (beams pts) #+debug (fomus-proc-check pts 'beams)) - (when (>= *verbose* 2) (out "~&; Staff/voice layouts...")) - (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER - (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests) - (when (or *auto-multivoice-rests* *auto-multivoice-notes*) - (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes)) - (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs) - (when (>= *verbose* 2) (out "~&; Post processing...")) - (postaccs pts) #+debug (fomus-proc-check pts 'postaccs) - (postproc pts) #+debug (fomus-proc-check pts 'postproc) - (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts) - (group-parts pts) #+debug (fomus-proc-check pts 'groupparts) - (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops) - (when (>= *verbose* 1) (format t "~&")) - pts))))))) + (set-instruments + (set-note-precision + (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) + #-debug (declare (ignore rm)) + #+debug (when rm (error "Error in FOMUS-PROC")) + (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (declare (type (or note rest mark) x)) (or (notep x) (restp x)))) + (let ((pts (progn + (loop for p of-type part in *parts* and i from 0 + do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp + (lambda (x) (declare (type (or note rest mark timesig) x)) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks + (flet ((gpi () + (or (part-partid p) + (setf (part-partid p) + (loop + for s = (gensym) + while (find s *parts* :key #'part-partid) + finally (return s)))))) + (mapc (lambda (x) + (declare (type timesig x)) + (unless (timesig-partids x) + (setf (timesig-partids x) (gpi)))) + ti) + (mapc (lambda (x) + (declare (type mark x)) + (unless (event-partid x) + (setf (event-partid x) (gpi)))) + ma)) + (prenconc ti *timesigs*) + (prenconc ke *keysigs*) + (prenconc ma mks) + (multiple-value-bind (eo ep) (split-list evs #'event-partid) + (setf (part-events p) ep) + (prenconc eo *events*)))) + (setf *timesigs* (mapcar #'make-timesigex* *timesigs*)) + (loop + with h = (get-timesigs *timesigs* *parts*) + for i from 0 and e in *parts* + for (evs rm) of-type (list list) on (split-list* *events* (mapcar #'part-partid *parts*) :key #'event-partid) + collect (make-partex* e i evs (gethash e h)) + finally (when rm (error "No matching part for event with partid ~S" (event-partid (first rm)))))))) ; make copied list of part-exs w/ sorted events + #+debug (fomus-proc-check pts 'start) + (track-progress +progress-int+ + (when (find-if #'is-percussion pts) + (when (>= *verbose* 2) (out "~&; Percussion...")) ; before voices & clefs + (percussion pts)) ; was after accs + (autodurs-preproc pts) + (if *auto-quantize* + (progn (when (>= *verbose* 2) (out "~&; Quantizing...")) + (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize)) + (quantize-generic pts)) + (when *check-ranges* + (when (>= *verbose* 2) (out "~&; Ranges...")) + (check-ranges pts) #+debug (fomus-proc-check pts 'ranges)) + (preproc-noteheads pts) + (when *transpose* + (when (>= *verbose* 2) (out "~&; Transpositions...")) + (transpose pts) #+debug (fomus-proc-check pts 'transpose)) + (if *auto-accidentals* + (progn (when (>= *verbose* 2) (out "~&; Accidentals...")) + (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs)) + (accidentals-generic pts)) + (if *auto-voicing* + (progn (when (>= *verbose* 2) (out "~&; Voices...")) + (voices pts) #+debug (fomus-proc-check pts 'voices)) + (voices-generic pts)) + (reset-tempslots pts nil) + (if *auto-staff/clef-changes* + (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided + (clefs pts) #+debug (fomus-proc-check pts 'clefs)) + (clefs-generic pts)) + (reset-tempslots pts nil) + (distribute-marks pts mks) + (reset-tempslots pts nil) + (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED + (when *auto-ottavas* ; (before clean-spanners) + (when (>= *verbose* 2) (out "~&; Ottavas...")) + (ottavas pts) #+debug (fomus-proc-check pts 'ottavas)) + (when (>= *verbose* 2) (out "~&; Staff spanners...")) + (clean-spanners pts +marks-spanner-staves+) #+debug (fomus-proc-check pts 'spanners1) + (setf pts (sep-voices (assemble-parts pts))) ; ********** STAVES TOGETHER, VOICES SEPARATED + (when (>= *verbose* 2) (out "~&; Voice spanners...")) + (expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks) + (clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2) + (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) + (when (find-if #'is-percussion pts) (autodurs *timesigs* pts)) ;; uses beamrt until after split function + (preproc-tremolos pts) + (preproc-cautaccs pts) + (when *auto-grace-slurs* + (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) + (when (>= *verbose* 2) (out "~&; Measures...")) + (init-parts *timesigs* pts) ; ----- MEASURES + #+debug (fomus-proc-check pts 'measures) + #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x))))) + (when *auto-cautionary-accs* + (when (>= *verbose* 2) (out "~&; Cautionary accidentals...")) + (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs)) + (when (>= *verbose* 2) (out "~&; Chords...")) + (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS + (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1) + (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) + (split-preproc-backends pts) + (split pts) #+debug (fomus-proc-check pts 'ties) + (reset-tempslots pts 0) + (reset-resttempslots pts) + (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2) + (when *auto-beams* + (when (>= *verbose* 2) (out "~&; Beams...")) + (beams pts) #+debug (fomus-proc-check pts 'beams)) + (when (>= *verbose* 2) (out "~&; Staff/voice layouts...")) + (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER + (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests) + (when (or *auto-multivoice-rests* *auto-multivoice-notes*) + (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes)) + (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs) + (when (>= *verbose* 2) (out "~&; Post processing...")) + (postaccs pts) #+debug (fomus-proc-check pts 'postaccs) + (postproc pts) #+debug (fomus-proc-check pts 'postproc) + (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts) + (group-parts pts) #+debug (fomus-proc-check pts 'groupparts) + (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops) + (when (>= *verbose* 1) (format t "~&")) + pts)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; MAIN Index: fomus/test.lisp diff -u fomus/test.lisp:1.9 fomus/test.lisp:1.10 --- fomus/test.lisp:1.9 Wed Aug 31 16:07:10 2005 +++ fomus/test.lisp Wed Aug 31 17:56:06 2005 @@ -342,12 +342,12 @@ :parts (list (make-part - :name "Violin" - :instr :violin + :name "Cello" + :instr :cello :events (loop for off from 0 to 10 by 1/2 - for note = (+ 55 (random 25)) + for note = (+ 36 (random 25)) collect (make-note :off off :dur (if (< off 10) 1/2 1) :note note Index: fomus/util.lisp diff -u fomus/util.lisp:1.14 fomus/util.lisp:1.15 --- fomus/util.lisp:1.14 Wed Aug 31 16:07:10 2005 +++ fomus/util.lisp Wed Aug 31 17:56:06 2005 @@ -659,7 +659,14 @@ *min-tuplet-dur* *beat-division* (setf *min-tuplet-dur* (/ *beat-division*)))) (when (< *max-tuplet-dur* *min-tuplet-dur*) (format t "~&;; WARNING: Value ~S of setting :MAX-TUPLET-DUR is smaller than value of setting :MIN-TUPLET-DUR--changing to ~S" - *max-tuplet-dur* (setf *max-tuplet-dur* *min-tuplet-dur*)))) + *max-tuplet-dur* (setf *max-tuplet-dur* *min-tuplet-dur*)))) + +(defmacro set-instruments (&body forms) + `(let ((*instruments* + (loop for e of-type (or instr cons) in *instruments* + if (consp e) collect (apply #'copy-instr (find (first e) +instruments+ :key #'instr-sym) (rest e)) + else collect e))) + ,@forms)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INTERNAL OBJECT CONSTRUCTORS @@ -760,14 +767,15 @@ (format t "; ~A~VT~A~VT~A~%" sy tc (or t2 t1) tl (prin1-to-string (symbol-value (find-symbol (conc-strings "*" (symbol-name sy) "*") :fomus))))))) (defun list-fomus-instruments () - (loop with li = (remove-duplicates (append *instruments* +instruments+) :key #'instr-sym :from-end t) - with c = (+ (loop for e in li maximize (length (symbol-name (instr-sym e)))) 3) - for e in li - do (format t "; ~A~VT~A~%" - (instr-sym e) c - (conc-stringlist - (loop for (s sn) on (rest +instr-keys+) - collect (format nil (if sn "~A: ~S " "~A: ~S") (string-downcase s) (slot-value e (intern (symbol-name s) :fomus)))))))) + (set-instruments + (loop with li = (remove-duplicates (append *instruments* +instruments+) :key #'instr-sym :from-end t) + with c = (+ (loop for e in li maximize (length (symbol-name (instr-sym e)))) 3) + for e in li + do (format t "; ~A~VT~A~%" + (instr-sym e) c + (conc-stringlist + (loop for (s sn) on (rest +instr-keys+) + collect (format nil (if sn "~A: ~S " "~A: ~S") (string-downcase s) (slot-value e (intern (symbol-name s) :fomus))))))))) (defun list-fomus-percussion () (loop with li = (remove-duplicates *percussion* :key #'perc-sym :from-end t) @@ -808,6 +816,7 @@ do (format t "; ~A~5T~{ ~A~}~%" s r))) (defun get-midi-instr (prog &key (default *default-instr*)) - (or (find prog *instruments* :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) - (find prog +instruments+ :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) - default)) \ No newline at end of file + (set-instruments + (or (find prog *instruments* :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) + (find prog +instruments+ :key #'instr-midiprgch-im :test (lambda (x p) (find x (force-list p)))) + default))) \ No newline at end of file

1 0

[fomus-cvs] CVS update: fomus/backends.lisp fomus/data.lisp fomus/misc.lisp
by dpsenicka＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv21177 Modified Files: backends.lisp data.lisp misc.lisp Log Message: bug fix Date: Wed Aug 31 16:35:15 2005 Author: dpsenicka Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.8 fomus/backends.lisp:1.9 --- fomus/backends.lisp:1.8 Sun Aug 28 23:31:27 2005 +++ fomus/backends.lisp Wed Aug 31 16:35:15 2005 @@ -29,7 +29,7 @@ (fresh-line f))) (defun split-preproc-backends (pts) - (loop for x of-type (or symbol cons) in (force-list2some *backend*) + (loop for x in (force-list2some *backend*) do (case (first (force-list x)) (:lilypond (split-preproc-lilypond pts))))) Index: fomus/data.lisp diff -u fomus/data.lisp:1.18 fomus/data.lisp:1.19 --- fomus/data.lisp:1.18 Wed Aug 31 16:07:10 2005 +++ fomus/data.lisp Wed Aug 31 16:35:15 2005 @@ -342,7 +342,7 @@ (make-instr :violin :clefs :treble :8uplegls '(5 2) :minp 55 :maxp 103 :midiprgch-im '(40 110) :midiprgch-ex 40) (make-instr :viola :clefs '(:treble :alto) :8uplegls '(5 2) :minp 48 :maxp 93 :midiprgch-im 41 :midiprgch-ex 41) - (make-instr :violoncello :clefs '(:bass :tenor :treble) :minp 36 :maxp 84 :midiprgch-im 42 :midiprgch-ex 42) + (make-instr :cello :clefs '(:bass :tenor :treble) :minp 36 :maxp 84 :midiprgch-im 42 :midiprgch-ex 42) (make-instr :contrabass :clefs '(:bass :tenor) :tpose -12 :minp 28 :maxp 67 :midiprgch-im 43 :midiprgch-ex 43)))) (eval-when (:compile-toplevel :load-toplevel :execute) Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.8 fomus/misc.lisp:1.9 --- fomus/misc.lisp:1.8 Sun Aug 28 23:31:27 2005 +++ fomus/misc.lisp Wed Aug 31 16:35:15 2005 @@ -57,11 +57,11 @@ (if (listp list) (copy-list list) (list list))) (defun force-list2some (list) (let ((x (force-list list))) - (if (or (null x) (some #'listp x)) x + (if (or (null x) (some #'consp x)) x (list x)))) (defun force-list2all (list) (let ((x (force-list list))) - (if (or (null x) (every #'listp x)) x + (if (or (null x) (every #'consp x)) x (list x)))) (defmacro cons-list (objs places)

1 0

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/backend_ly.lisp fomus/data.lisp fomus/postproc.lisp fomus/splitrules.lisp fomus/test.lisp fomus/util.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv19199 Modified Files: CHANGELOG TODO backend_ly.lisp data.lisp postproc.lisp splitrules.lisp test.lisp util.lisp version.lisp Log Message: testing/bug fixes Date: Wed Aug 31 16:07:11 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.9 fomus/CHANGELOG:1.10 --- fomus/CHANGELOG:1.9 Tue Aug 30 00:28:03 2005 +++ fomus/CHANGELOG Wed Aug 31 16:07:10 2005 @@ -1,11 +1,17 @@ +v0.1.12 + + Testing/bug fixes: + nested tuplets + v0.1.11 Testing/bug fixes: errors involving 0 durations parsing user input user rests and rest marks - switching functionality on/off w/ auto- settings - Support for user rests, pizz/arco markings + switching functionality on/off w/ AUTO- settings + user rests, pizz/arco markings + part ordering (parts with grand staves) v0.1.10 @@ -17,16 +23,16 @@ v0.1.9 Testing/bug fixes + compiling/viewing LilyPond files Added QUALITY setting Eliminated complex score/penalty settings (will replace with simple presets) Other changes to settings - Adjustments to note splitting/tying - Fixed issues with compiling/viewing LilyPond files + Adjustments to note splitting/tying More speed improvements v0.1.8 and earlier: Testing/bug fixes + tremolos, text, glissandi/portamenti, arpeggios, harmonics, note heads Some speed improvements (more needed) - Support for tremolos, text, glissandi/portamenti, arpeggios, harmonics, note heads Improved quantize algorithm Index: fomus/TODO diff -u fomus/TODO:1.16 fomus/TODO:1.17 --- fomus/TODO:1.16 Tue Aug 30 00:28:03 2005 +++ fomus/TODO Wed Aug 31 16:07:10 2005 @@ -12,9 +12,11 @@ Avoid staff changes when notes move in other direction Durations that fill to next/previous note Proofread/finish documentation, add easy examples + Tuplet bracket setting Short Term: + Part properties: override settings for individual parts CMN backend MIDI to percussion Number of lines in staff Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.14 fomus/backend_ly.lisp:1.15 --- fomus/backend_ly.lisp:1.14 Sun Aug 28 23:31:27 2005 +++ fomus/backend_ly.lisp Wed Aug 31 16:07:10 2005 @@ -169,12 +169,7 @@ do (destructuring-bind (&key (lily-partname (lyname p)) lily-parthead ;; extra header information for part (list of strings) &allow-other-keys) (part-opts p) - (let ((ns (instr-staves (part-instr p))) - #|(sa 1)|#) -;; (flet ((lystaff (s) -;; (if (/= s sa) -;; (format nil "\\change Staff = ~A " (code-char (+ 64 (setf sa s)))) -;; ""))) + (let ((ns (instr-staves (part-instr p)))) (push lily-partname nms) (format f "~A = {~%" lily-partname) (when (part-name p) (format f " \\set Staff.instrument = ~S~%" (part-name p))) Index: fomus/data.lisp diff -u fomus/data.lisp:1.17 fomus/data.lisp:1.18 --- fomus/data.lisp:1.17 Tue Aug 30 00:28:03 2005 +++ fomus/data.lisp Wed Aug 31 16:07:10 2005 @@ -212,8 +212,8 @@ "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*))) "Found ~S, expected list of PERC objects in PERCS slot" t)) - (instr-midiprgch-im (check* (or null (integer 0 127) (list-of* (integer 0 127))) + (instr-percs (check* (or* null (list-of* (type* *perc-type*))) "Found ~S, expected list of PERC objects 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)) (instr-midiprgch-ex (check* (or null (integer 0 127)) "Found ~S, expected NIL, (integer 0 127) in MIDIPRGCH-EX slot" t))))) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.9 fomus/postproc.lisp:1.10 --- fomus/postproc.lisp:1.9 Tue Aug 30 00:28:03 2005 +++ fomus/postproc.lisp Wed Aug 31 16:07:10 2005 @@ -50,7 +50,7 @@ ;; returns ratio to display: (cons num1 num2) (defun tupratio (rat writunit events ts) (declare (type (rational (0)) rat writunit) (type cons events) (type timesig-repl ts)) - (let ((m (loop with x of-type (rational 1) = (max (/ writunit (loop for e of-type (or noteex restex) in events maximize (event-writtendur e ts))) 1) + (let ((m (loop with x of-type rational = (/ writunit (loop for e of-type (or noteex restex) in events maximize (event-writtendur e ts))) for i = 1 then (* i 2) when (>= i x) do (return i)))) (cons (* (numerator rat) m) (* (denominator rat) m)))) @@ -67,17 +67,17 @@ (loop with l = (length *max-tuplet*) with lvl = -1 - and tp = (make-array l :element-type '(integer 0) :initial-element 0) + and tp = (make-array l :element-type '(rational 0 1) :initial-element 0) and uu = (make-array l :element-type '(or (rational (0)) null) :initial-element nil) and ll = (make-array l :element-type 'list :initial-element nil) for e of-type (or noteex restex) in ee - do (loop + do (loop with td = (reverse (event-tupdurmult e)) and i = -1 - for f of-type (rational (0)) in (nreverse (event-tupfrac e)) - and u of-type (rational (0)) in td + for f of-type (rational (0)) in (reverse (event-tupfrac e)) ; larger to smaller + and u of-type (rational (0)) in td ; durmults do (incf i) - when (> i lvl) do (setf (svref uu i) u (svref ll i) nil) ; start + when (> i lvl) do (setf (svref uu i) u (svref ll i) nil) ; start new count when (>= i lvl) do (incf (svref tp i) f) do (push e (svref ll i)) finally @@ -86,17 +86,17 @@ while (and (>= j 0) (>= (svref tp j) 1)) do (setf (svref tp j) 0) - (let* ((el (nreverse (svref ll j))) ; events in order + (let* ((el (reverse (svref ll j))) ; events in order (ef (first el))) (declare (type (or noteex restex) ef)) (addmark ef - (let ((w (unitwritdur (- (event-endoff e) (event-off ef)) (event-tupdurmult e) (meas-timesig m)))) + (let* ((w (unitwritdur (- (event-endoff e) (event-off ef)) (nthcdr (- i j) (event-tupdurmult e)) #|(- i j)|# (meas-timesig m)))) (multiple-value-bind (wr wd) (writtendur* w) - (list :starttup (1+ i) - (tupratio (svref uu j) w el (meas-timesig m)) - (or #|(list1p el)|# ; bracket? - (< j i) ; not innermost - (loop + (list :starttup (1+ j) + (tupratio (svref uu j) w el (meas-timesig m)) ; tupratio as cons + (or ; bracket? + (< j i) ; not innermost--use bracket (make this a setting later) + (loop ; innermost for (x1 x2 x3) of-type ((or (or noteex restex) null) (or (or noteex restex) null) (or (or noteex restex) null)) on (cons nil el) while x2 when (or (if x1 @@ -106,12 +106,12 @@ (or (restp x2) (= (event-beamrt x2) 0)) (and (notep x2) (> (event-beamrt x2) 0)))) do (return t))) - (cons wr wd))))) ; i is tup index, next value is bracket t/nil, next two are written tuplet unit value + (cons wr wd))))) ; i is tup index, next value is bracket t/nil, next cons is written value of tuplet-unit-dur (addmark e (list :endtup (1+ j)))) ; end finally (setf lvl j)))) (loop for e of-type (or noteex restex) in gg do (setf (event-tup e) nil)) - (loop for e of-type (or noteex restex) in ee do (setf (event-tup e) (nreverse (event-tupdurmult e))))) (print-dot)))) + (loop for e of-type (or noteex restex) in ee do (setf (event-tup e) (reverse (event-tupdurmult e))))) (print-dot)))) (defun postproc-graces (pts) (declare (type list pts)) Index: fomus/splitrules.lisp diff -u fomus/splitrules.lisp:1.3 fomus/splitrules.lisp:1.4 --- fomus/splitrules.lisp:1.3 Tue Aug 30 00:28:03 2005 +++ fomus/splitrules.lisp Wed Aug 31 16:07:10 2005 @@ -91,8 +91,7 @@ (declare (type baserule rule) (type (member nil t :s) tups)) (let ((mt (first (if (baseunitp rule) (loop for e on *max-tuplet* for xxx in (rule-tup rule) finally (return e)) - *max-tuplet*))) ; max tuplet for next nesting level - #|(mn (length mt))|#) ; max nesting depth + *max-tuplet*)))) ; max tuplet for next nesting level (flet ((dv2 (n) (declare (type (integer 1) n)) (loop for n2 = (/ n 2) while (integerp n2) do (setf n n2)) @@ -109,7 +108,7 @@ (cons (if (list>1p x) x (first x)) (loop for (e1 e2) of-type ((rational 0 1) (or (rational 0 1) null)) on (cons 0 (append x '(1))) while e2 for ii in (if (listp i) i (list i (- tup i))) and tt = (- e2 e1) and a1 = t then a2 - for a2 = (and (expof2 e2) (expof2 (- tup e2))) collect + for a2 = (or (= e2 1) (and (expof2 e2) (expof2 (- tup e2)))) collect (if (and (<= ii 1) (if (unitp rule) (rule-sim rule) t)) (make-unit-nodiv :tup (cons tt tu) :comp (rule-comp rule) :dmu dmu :tlt t :trt t) (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii)))))))))) @@ -196,7 +195,7 @@ (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation (snd (/ 1/2 num) t nil)) (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)))))))) - (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (when (and tups mt (or (initdivp rule) (and (sigp rule) (rule-top rule)) (and (rule-alt rule) (rule-art rule)))) (loop with nu = (if (rule-comp rule) (* num 3/2) num) for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division @@ -235,10 +234,10 @@ (list (list 1/8 (un 1/8 :l t t) (und 7/8 nil t)))))) (when (and (al *shortlongshort-notes-level*) (rule-alt rule) (rule-art rule) ex) (list (list '(1/4 3/4) (un 1/4 :l t t) (und 1/2 t t) (un 1/4 :r t t)))) ; longer note in middle - (when #|(debugn-if (>= (length (rule-tup rule)) 1) "~A ~A ~A ~A" - tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))))|# - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (when (and tups mt (or (initdivp rule) (and (sigp rule) (rule-top rule)) + (if (and (baseunitp rule) (rule-tup rule)) + (or (rule-alt rule) (rule-art rule)) + (and (rule-alt rule) (rule-art rule))))) (loop for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division unless (expof2 (/ (rule-div rule) j)) Index: fomus/test.lisp diff -u fomus/test.lisp:1.8 fomus/test.lisp:1.9 --- fomus/test.lisp:1.8 Tue Aug 30 00:28:03 2005 +++ fomus/test.lisp Wed Aug 31 16:07:10 2005 @@ -75,10 +75,10 @@ (0 '(:accent)) (1 '(:staccato)))))) -;; Nested Tuplets (not working yet) +;; Nested Tuplets (fomus - :backend '((:data) (:lilypond :view t)) + :backend '(:data (:lilypond :view t)) :ensemble-type :orchestra :verbose 2 :beat-division 8 @@ -102,8 +102,6 @@ (0 '(:accent)) (1 '(:staccato)))))) -;; TESTS - ;; Parts with no events (fomus @@ -128,6 +126,8 @@ :instr :tuba :events nil))) +;; Part ordering/grouping + (fomus :backend '((:data) (:lilypond :view t)) :ensemble-type :orchestra @@ -788,22 +788,25 @@ (0 :woodblock) (1 :snaredrum))))))) -(fomus ; :auto-multivoice-notes (not working yet) - :backend '((:data) (:lilypond :view t)) - :ensemble-type :orchestra - :parts - (list - (make-part - :name "Violin" - :instr :violin - :events - (loop repeat 2 nconc - (loop - for off from 0 to 40 by 1/2 - collect (make-note :off off - :voice '(1 2) - :dur (if (< off 40) 1/2 1) - :note (+ 55 (random 19)))))))) +(let ((*break-on-signals* t)) + (fomus ; :auto-multivoice-notes (not working yet) + :backend '(:lilypond :view t) + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Violin" + :instr :violin + :events + (loop repeat 2 nconc + (loop + for off from 0 to 40 by 1/2 + collect (make-note :off off + :voice '(1 2) + :dur (if (< off 40) 1/2 1) + :note (+ 55 (random 19))))))))) + +(WARN KERNEL:SIMPLE-STYLE-WARNING :FORMAT-CONTROL "Variable ~S defined but never used." :FORMAT-ARGUMENTS ...) (fomus ; :auto-percussion-durs :backend '((:data) (:lilypond :view t)) Index: fomus/util.lisp diff -u fomus/util.lisp:1.13 fomus/util.lisp:1.14 --- fomus/util.lisp:1.13 Tue Aug 30 00:28:04 2005 +++ fomus/util.lisp Wed Aug 31 16:07:10 2005 @@ -269,10 +269,14 @@ (if (notep ev) (max (- (roundint (log (event-writtendur* ev ts) 1/2)) 2) 0) 0)) ;; given duration of entire tuplet & dmu list, return unit of tuplet (1/8 = eighth note, etc.) -(defun unitwritdur (dur dmu ts) +(defun unitwritdur (dur dmu ts) ; ndmu = the level that applies (declare (type (rational (0)) dur) (type list dmu) (type timesig-repl ts)) - (/ (* (effectdur dur dmu) (timesig-beat* ts)) + (/ (* (effectdur dur dmu) (timesig-beat* ts)) ; written dur w/o dots info of entire tuplet (numerator (first dmu)))) +;; (loop with re = (* (effectdur dur dmu) (timesig-beat* ts)) ; written dur w/o dots info of entire tuplet +;; repeat (1+ ndmu) for x in dmu +;; do (setf re (/ re (numerator x))) +;; finally (return re))) (declaim (inline chordp)) (defun chordp (ev) Index: fomus/version.lisp diff -u fomus/version.lisp:1.6 fomus/version.lisp:1.7 --- fomus/version.lisp:1.6 Tue Aug 30 00:28:04 2005 +++ fomus/version.lisp Wed Aug 31 16:07:10 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 11)) +(defparameter +version+ '(0 1 12)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/accidentals.lisp fomus/classes.lisp fomus/data.lisp fomus/fomus.asd fomus/postproc.lisp fomus/quantize.lisp fomus/splitrules.lisp fomus/staves.lisp fomus/test.lisp fomus/util.lisp fomus/version.lisp fomus/voices.lisp
by dpsenicka＠common-lisp.net 29 Aug '05

29 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv14351 Modified Files: CHANGELOG TODO accidentals.lisp classes.lisp data.lisp fomus.asd postproc.lisp quantize.lisp splitrules.lisp staves.lisp test.lisp util.lisp version.lisp voices.lisp Log Message: testing/bug fixes Date: Tue Aug 30 00:28:04 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.8 fomus/CHANGELOG:1.9 --- fomus/CHANGELOG:1.8 Sat Aug 27 20:13:21 2005 +++ fomus/CHANGELOG Tue Aug 30 00:28:03 2005 @@ -1,6 +1,17 @@ +v0.1.11 + + Testing/bug fixes: + errors involving 0 durations + parsing user input + user rests and rest marks + switching functionality on/off w/ auto- settings + Support for user rests, pizz/arco markings + v0.1.10 - Testing/bug fixes: quantizing (integrated with splitting/tying now) + Testing/bug fixes: + quantizing (integrated with splitting/tying now) + many other bugs Automatic durations for percussion instruments v0.1.9 Index: fomus/TODO diff -u fomus/TODO:1.15 fomus/TODO:1.16 --- fomus/TODO:1.15 Sat Aug 27 20:13:21 2005 +++ fomus/TODO Tue Aug 30 00:28:03 2005 @@ -3,13 +3,15 @@ Immediate: Testing and bug fixes - Nested tuplets - Splitting chords across staves + Nested tuplets not working yet + Automatic multivoice notes not working yet + Splitting chords across staves (LilyPond) :STAFF and other marks for overriding FOMUS's decisions MusicXML backend MIDI output to CM Avoid staff changes when notes move in other direction - Proofread/finish documentation, add many easy examples + Durations that fill to next/previous note + Proofread/finish documentation, add easy examples Short Term: Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.9 fomus/accidentals.lisp:1.10 --- fomus/accidentals.lisp:1.9 Sun Aug 21 21:17:40 2005 +++ fomus/accidentals.lisp Tue Aug 30 00:28:03 2005 @@ -18,7 +18,7 @@ (declaim (type boolean *auto-accidentals* *auto-cautionary-accs*)) (defparameter *auto-accidentals* t) -(defparameter *auto-cautionary-accs* t) +(defparameter *auto-cautionary-accs* nil) ;; NOKEY! @@ -191,7 +191,7 @@ (let ((x (event-useracc f))) (if (and (listp x) (listp (rest x))) x (list x)))) - cho :key #'equal) ; e = lists of accs. + cho :test #'equal) ; e = lists of accs. when (funcall spellfun o a) collect a) (loop for a in cho if (funcall spellfun o a) collect a) ; ignore user's suggestion (error "No accidentals possible for note ~S at offset ~S, part ~S" (event-note f) (event-foff f) name)) @@ -305,13 +305,20 @@ (mapcar #'nokey-convert-qtone +acc-qtones-double+) +acc-double+) for e of-type (or noteex restex) in (part-events p) - for n of-type rational = (event-note* e) and a of-type (integer -2 2) = (event-acc e) and q of-type (rational -1/2 1/2) = (event-addacc e) + for n = (event-note* e) ;;and a of-type (integer -2 2) = (event-acc e) and q of-type (rational -1/2 1/2) = (event-addacc e) + for ua = (let ((u (event-useracc e))) + (if (list1p u) (if (consp (first u)) (first u) (cons (first u) 0)) + (if u (error "Only one accidental allowed when :AUTO-ACCIDENTALS is NIL in note at offset ~S, part ~S" (event-foff e) (part-name p)) + (cons 0 0)))) unless (and (if *quartertones* - (find (cons a q) cho :test #'equal) - (find a cho)) - (nokeyq-spell n (list a q))) - do (error "Invalid note spelling ~S at offset ~S, part ~S" (cond ((/= q 0) (list n a q)) ((/= a 0) (list n a)) (t (list n))) - (event-foff e) (part-name p))))) + (find ua cho :test #'equal) + (find (car ua) cho)) + (nokeyq-spell n ua)) + do (error "Invalid note spelling ~S at offset ~S, part ~S" (cond ((/= (cdr ua) 0) (list n (car ua) (cdr ua))) + ((/= (car ua) 0) (list n (car ua))) + (t (list n))) + (event-foff e) (part-name p)) + do (setf (event-note e) (cons n ua))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CAUTIONARY ACCIDENTALS @@ -325,8 +332,8 @@ (defparameter *caut-acc-ottavas* t) (defparameter *caut-acc-octaves* 1) ; can be a number (for number of octaves above/below) or t for all -(defparameter *caut-acc-next-meas* nil) -(defparameter *caut-acc-after-one-meas* nil) ; no cautionary accidental after one measure +(defparameter *caut-acc-next-meas* t) +(defparameter *caut-acc-after-one-meas* t) ; no cautionary accidental after one measure ;; rests are removed already, before chords or ties (defun acc-nokey-cautaccs (meas) Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.10 fomus/classes.lisp:1.11 --- fomus/classes.lisp:1.10 Sun Aug 28 06:32:47 2005 +++ fomus/classes.lisp Tue Aug 30 00:28:03 2005 @@ -143,7 +143,8 @@ (if (consp (event-note ev)) (let ((x (cdr (event-note ev)))) (declare (type (or cons rational) x)) - (if (consp x) (the rational (cdr x)) 0)) 0)) + (if (consp x) (the rational (cdr x)) 0)) + 0)) (defun event-addaccs (ev) (declare (type note ev)) (mapcar (lambda (e) Index: fomus/data.lisp diff -u fomus/data.lisp:1.16 fomus/data.lisp:1.17 --- fomus/data.lisp:1.16 Sun Aug 28 23:31:27 2005 +++ fomus/data.lisp Tue Aug 30 00:28:03 2005 @@ -82,19 +82,19 @@ (no (note-to-num (if (consp no) (first no) no)))) (if a (cons no (mapcar (lambda (x) (if (and (listp x) (list>1p x)) - (cons (acc-to-num (first x)) (acc-to-num (second x))) - (acc-to-num x))) + (cons (acc-to-num (first x) 1) (acc-to-num (second x) 1/2)) + (acc-to-num x 1))) a)) no))) (declaim (type cons +accnum+)) (defparameter +accnum+ '(("S" . 1) ("+" . 1) ("F" . -1) ("-" . -1) ("SS" . 2) ("++" . 2) ("FF" . -2) ("--" . -2) ("N" . 0))) ;;(declaim (inline acc-to-num)) -(defun acc-to-num (acc) +(defun acc-to-num (acc prec) (if (symbolp acc) (lookup (symbol-name acc) +accnum+ :test #'string=) - (roundto acc *note-precision*))) + (roundto acc prec))) (defun is-acc (acc) - (or (realp acc) (find (symbol-name acc) +accnum+ :key #'car :test #'string=))) + (typecase acc (real acc) (symbol (find (symbol-name acc) +accnum+ :key #'car :test #'string=)))) (defun dur-to-num (dur bt) (if (and *cm-rhythmfun* *use-cm* (symbolp dur)) @@ -627,8 +627,13 @@ ;; include :staff but not :clef (defparameter +marks-rests+ - '(:fermata :breath :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- + '(:fermata :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- :text- :endtext- #|:starttexttempo- :starttextdyn-|# :starttext-)) + +(defparameter +marks-first-rest+ + '(:textnote :texttempo :textdyn :text :text- :starttext-)) +(defparameter +marks-last-rest+ + '(:fermata :endtext-)) (declaim (inline is-restmarksym)) (defun is-restmarksym (sym) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.7 fomus/fomus.asd:1.8 --- fomus/fomus.asd:1.7 Sun Aug 28 23:31:27 2005 +++ fomus/fomus.asd Tue Aug 30 00:28:03 2005 @@ -4,7 +4,7 @@ (asdf:defsystem "fomus" :description "Lisp music notation formatter" - :version "0.1.10" + :version "0.1.11" :author "David Psenicka" :licence "LLGPL" Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.8 fomus/postproc.lisp:1.9 --- fomus/postproc.lisp:1.8 Sat Aug 27 20:13:21 2005 +++ fomus/postproc.lisp Tue Aug 30 00:28:03 2005 @@ -264,8 +264,9 @@ (loop for g of-type list in (meas-voices m) do (loop for e of-type (or noteex restex) in g + do (rmmark e b) if (getmark e a) do (if o (rmmark e a) (setf o t)) - else when o do (addmark e b) (setf o nil)))) + else when (and o (notep e) (not (or-list (force-list (event-tielt e))))) do (addmark e b) (setf o nil)))) (print-dot)))) ;; preproc-tremolos already @@ -359,38 +360,51 @@ (declare (type list pts)) (loop for p of-type partex in pts do (loop for m of-type meas in (part-meas p) - do (loop with a = (loop for v of-type list in (meas-voices m) append (remove-if (lambda (x) (declare (type (or noteex restex) x)) (and (restp x) (event-inv x))) v)) + do (loop with a = (loop for v of-type list in (meas-voices m) + append (remove-if (lambda (x) (declare (type (or noteex restex) x)) (and (restp x) (event-inv x))) v)) for v of-type list in (meas-voices m) - do (loop for e of-type (or noteex restex) in v - for tx = (or (popmark e :starttext-) - (popmark e :startwedge<) (popmark e :startwedge>) (popmark e :startlongtrill-) - (popmark e :text) (popmark e :texttempo) (popmark e :textdyn) (popmark e :textnote)) - while tx do - (loop with o = (event-voice* e) - for y of-type (integer 1 4) in (delete-duplicates - (loop for x of-type (or noteex restex) in a - when (and (= (event-staff x) (event-staff e)) - (/= (event-voice* x) o) - (> (event-endoff x) (event-off a)) - (< (event-off x) (event-endoff a))) - collect (event-voice* x))) - count (< y o) into u ; number of voices above text note - count (> y o) into d ; number of voices below text note - finally - (cond ((= d u) - (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list (or (find :up tx) (find :down tx) (if (find (first tx) +marks-defaultup+) :up :down)) - (find-if #'stringp tx)))))) - ((< d u) (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list :down (find-if #'stringp tx)))))) - ((> d u) (addmark e (cons (first tx) - (nconc - (let ((x (find-if #'numberp tx))) (when x (list x))) - (list :up (find-if #'stringp tx))))))))))) (print-dot))) + do (loop for e of-type (or noteex restex) in v do + (loop + with mks + for tx = (or (popmark e :starttext-) + (popmark e :startwedge<) (popmark e :startwedge>) (popmark e :startlongtrill-) + (popmark e :text) (popmark e :texttempo) (popmark e :textdyn) (popmark e :textnote)) + while tx do + (loop with o = (event-voice* e) + for y of-type (integer 1 4) + in (delete-duplicates + (loop for x of-type (or noteex restex) in a + when (and (= (event-staff x) (event-staff e)) + (/= (event-voice* x) o) + (> (event-endoff x) (event-off a)) + (< (event-off x) (event-endoff a))) + collect (event-voice* x))) + count (< y o) into u ; number of voices above text note + count (> y o) into d ; number of voices below text note + finally + (cond ((= d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list (or (find :up tx) (find :down tx) (if (or (find (first tx) +marks-defaultup+) + (>= (event-staff e) (instr-staves (part-instr p)))) + :up :down)) + (find-if #'stringp tx)))) + mks)) + ((< d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list :down (find-if #'stringp tx)))) + mks)) + ((> d u) + (push (cons (first tx) + (nconc + (let ((x (find-if #'numberp tx))) (when x (list x))) + (list :up (find-if #'stringp tx)))) + mks)))) + finally (mapc (lambda (m) (declare (type cons m)) (addmark e m)) mks))))) + (print-dot))) ;; not included with other postprocs here--in fomus-proc function (defun postpostproc-sortprops (pts) Index: fomus/quantize.lisp diff -u fomus/quantize.lisp:1.10 fomus/quantize.lisp:1.11 --- fomus/quantize.lisp:1.10 Sat Aug 27 20:13:21 2005 +++ fomus/quantize.lisp Tue Aug 30 00:28:03 2005 @@ -162,7 +162,7 @@ (defun quantize-generic (parts) (loop for p in parts do (loop for e in (part-events p) do - (setf (event-dur* e) (rationalize (event-dur* e)) (event-off e) (rationalize (event-off e)))))) + (setf (event-dur* e) (rationalize (or (event-gracedur e) (event-dur* e))) (event-off e) (rationalize (event-off e)))))) #|(cons pts (list o1 o2))|# #|(cons nil nil)|# ;; (uu00 (i) Index: fomus/splitrules.lisp diff -u fomus/splitrules.lisp:1.2 fomus/splitrules.lisp:1.3 --- fomus/splitrules.lisp:1.2 Sun Aug 28 23:31:27 2005 +++ fomus/splitrules.lisp Tue Aug 30 00:28:03 2005 @@ -182,7 +182,7 @@ (when (and (al *shortlongshort-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) ex (or (not (rule-comp rule)) (>= num 4))) (list (list '(1/4 3/4) (si 1/4 :l t t) (snd 1/2 t t) (si 1/4 :r t t)))) ; longer note in middle - (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3)) + (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) (>= num 3) (not (rule-comp rule))) (cond ((integerp num) (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.8 fomus/staves.lisp:1.9 --- fomus/staves.lisp:1.8 Sun Aug 28 06:32:47 2005 +++ fomus/staves.lisp Tue Aug 30 00:28:03 2005 @@ -315,7 +315,7 @@ (defun distr-rests-byconfl (parts) (declare (type list parts)) (loop - with rl of-type (cons (cons (rational 0) (rational 0)) list) + with rl of-type list ; (cons (cons (rational 0) (rational 0)) list) and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible for p of-type partex in (remove-if #'is-percussion parts) for sv = (> (instr-staves (part-instr p)) 1) do Index: fomus/test.lisp diff -u fomus/test.lisp:1.7 fomus/test.lisp:1.8 --- fomus/test.lisp:1.7 Sun Aug 28 23:31:27 2005 +++ fomus/test.lisp Tue Aug 30 00:28:03 2005 @@ -523,8 +523,7 @@ :marks (when (<= (random 3) 0) '(:staccato))))))) -;; MusicXML -;; (not working yet) +;; MusicXML (not working yet) (fomus :backend '((:data) (:musicxml)) @@ -571,7 +570,7 @@ :name "Piano" :instr :piano :events - (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata)) + (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata (:text "Here!"))) (loop for off from 0 below 19/2 by 1/2 collect (make-note :off off @@ -580,7 +579,291 @@ :marks (when (<= (random 3) 0) '(:staccato)))))))) +;; Auto Pizz/Arco + +(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :beat-division 8 + :quartertones t + :parts (list + (make-part + :name "Violin" + :instr :violin)) + :events (loop repeat 5 + for off = (random 1.0) then (+ off (1+ (random 1.0))) + and dur = (random 1.0) + collect (make-note :off off + :dur dur + :note (+ 55 (/ (random 25) 2)) + :marks (case (random 2) + (0 '(:pizz)))))) + ;; Auto On/Offs + +(fomus ; :auto-accidentals + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + and note = (+ 48 (random 25)) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note (list note (svref #(0 -1 0 -1 0 0 1 0 -1 0 -1 0) (mod note 12)))))))) + +(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :quartertones t + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note '(60.5 (-1 -0.5))))))) + +(fomus ; :auto-cautionary-accs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-accidentals nil + :auto-cautionary-accs t + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + and note = (+ 48 (random 25)) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note (list note (svref #(0 -1 0 -1 0 0 1 0 -1 0 -1 0) (mod note 12)))))))) + +(fomus ; :auto-ottavas + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-ottavas nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 20 by 1/2 + and note = (+ 72 (random 37)) + collect (make-note :off off + :dur (if (< off 20) 1/2 1) + :note note))))) + +(fomus ; :auto-voicing + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-voicing nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 10 by 1/2 + collect (make-note :off off + :voice '(1) ; (1+ (random 2)) + :dur (if (< off 10) 1/2 1) + :note (+ 48 (random 25))))))) + +(fomus ; :auto-grace-slurs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-grace-slurs nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-beams + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-beams nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-quantize + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-quantize nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 4 by 1/2 + for note = (+ 48 (random 25)) + nconc (loop repeat (random 4) for grace from -100 + collect (make-note :off off + :dur (list 1/4 grace) + :note (if (= (random 2) 0) (- note (random 6)) (+ note (random 6))))) + collect (make-note :off off + :dur (if (< off 10) 1/2 1) + :note note + :marks (when (<= (random 3) 0) + '(:staccato))))))) + +(fomus ; :auto-staff/clef-changes + :backend '((:data) (:lilypond :view t )) + :ensemble-type :orchestra + :quality 1/2 + :auto-staff/clef-changes nil + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 100 by 1/2 + collect (make-note :off off + :dur (if (< off 100) 1/2 1) + :note (+ 48 (random 25))))))) + +(fomus ; :auto-multivoice-rests + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-multivoice-rests nil + :parts (list + (make-part + :name "Percussion" + :instr (list :percussion :percs (list (make-perc :woodblock :voice 1 :note 'e4) + (make-perc :snaredrum :voice 2 :note 'a3))) + :events (loop for o from 0 to 50 by 1/2 when (= (random 4) 0) collect + (make-note :off o :dur 1/2 + :note (case (random 2) + (0 :woodblock) + (1 :snaredrum))))))) + +(fomus ; :auto-multivoice-notes (not working yet) + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Violin" + :instr :violin + :events + (loop repeat 2 nconc + (loop + for off from 0 to 40 by 1/2 + collect (make-note :off off + :voice '(1 2) + :dur (if (< off 40) 1/2 1) + :note (+ 55 (random 19)))))))) + +(fomus ; :auto-percussion-durs + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :auto-percussion-durs nil + :parts (list + (make-part + :name "Percussion" + :instr (list :percussion :percs (list (make-perc :woodblock :note 'e4 :autodur t) + (make-perc :snaredrum :note 'a3 :autodur t))) + :events (loop for o from 0 to 40 by 1/2 when (= (random 2) 0) collect + (make-note :off o + :note (case (random 2) + (0 :woodblock) + (1 :snaredrum))))))) + +(fomus ; :auto-pizz/arco + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :beat-division 8 + :quartertones t + :auto-pizz/arco nil + :parts (list + (make-part + :name "Violin" + :instr :violin)) + :events (loop repeat 5 + for off = (random 1.0) then (+ off (1+ (random 1.0))) + and dur = (random 1.0) + collect (make-note :off off + :dur dur + :note (+ 55 (/ (random 25) 2)) + :marks (case (random 2) + (0 '(:pizz)) + (1 '(:arco)))))) + +(fomus ; :auto-override-timesigs + :backend '((:data) (:lilypond :view t )) + :ensemble-type :orchestra + :verbose 2 + :quality 1/2 + :auto-override-timesigs nil + :global + (list (make-timesig :off 0 :time '(4 4)) (make-timesig :off 10 :time '(4 4)) (make-timesig :off 11 :time '(4 4))) + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (loop + for off from 0 to 20 by 1/2 + collect (make-note :off off + :dur (if (< off 20) 1/2 1) + :note (+ 48 (random 25)) + :marks (when (<= (random 3) 0) + '(:staccato))))))) + ;; User Overrides -;; Auto Pizz/Arco +;; Grace note rests ;; Mark Spanners +;; Compound meter +;; Auto Time Signatures \ No newline at end of file Index: fomus/util.lisp diff -u fomus/util.lisp:1.12 fomus/util.lisp:1.13 --- fomus/util.lisp:1.12 Sun Aug 28 23:31:27 2005 +++ fomus/util.lisp Tue Aug 30 00:28:04 2005 @@ -390,10 +390,13 @@ :off off :dur (- (event-endoff event) off) :tielt (if (chordp event) (make-list (length (event-tielt event)) :initial-element t) t)))))) - (rest (cons (copy-event event :dur (- off (event-off event)) :tup (cons tup dmu)) + (rest (cons (copy-event event :dur (- off (event-off event)) :tup (cons tup dmu) + :marks (if (event-marks event) (cons :splitlt (event-marks event)))) (if tup2 - (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons tup2 dmu)) - (copy-event event :off off :dur (- (event-endoff event) off))))))))) + (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons tup2 dmu) + :marks (if (event-marks event) (cons :splitrt (event-marks event)))) + (copy-event event :off off :dur (- (event-endoff event) off) + :marks (if (event-marks event) (cons :splitrt (event-marks event))))))))))) ;; (declaim (inline split-event*)) (defun split-event* (event off) @@ -439,11 +442,15 @@ (loop for p of-type partex in pts do (loop for m of-type meas in (part-meas p) do (loop - for e of-type noteex in (remove-if-not #'notep (meas-events m)) - when (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo)) + for e of-type (or noteex restex) in (meas-events m) + when (and (notep e) (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo))) do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-first-tie+) - when (or (and (event-tiert e) (and-list (force-list (event-tiert e)))) (getmark e :starttremolo)) - do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-tie+))) (print-dot))) + when (and (notep e) (or (and (event-tiert e) (and-list (force-list (event-tiert e)))) (getmark e :starttremolo))) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-tie+) + when (and (restp e) (popmark e :splitrt)) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-first-rest+) + when (and (restp e) (popmark e :splitlt)) + do (mapc (lambda (x) (declare (type symbol x)) (rmmark e x)) +marks-last-rest+))) (print-dot))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STAVES @@ -556,22 +563,25 @@ collect (loop with at for (ts nx) of-type (timesig (or timesig null)) - on (let ((x (merge-linear - (sort (delete-if-not (lambda (x) (or (null (timesig-partids x)) (find (part-partid p) (timesig-partids x)))) - (copy-list timesigs)) ; ts = current time sig, n = next group - #'< :key #'timesig-off) - (lambda (x y) (if (= (timesig-off x) (timesig-off y)) - (cond ((and (null (timesig-partids x)) (timesig-partids y)) y) - ((and (timesig-partids x) (null (timesig-partids y))) x) - (t (error "Conflicting time signature/part IDs assignment at offset ~S, part ~S" - (timesig-foff x) (part-name p))))))))) - (if (or (null x) (> (timesig-off (first x)) 0)) - (cons (copy-timesig dts :off 0) x) - x)) - when (or (null *auto-override-timesigs*) - (= (timesig-off ts) 0) - (null nx) - (>= (- (timesig-off nx) (timesig-off ts)) (or *min-auto-timesig-dur* 0))) + on (let ((z (let ((x (merge-linear + (sort (delete-if-not (lambda (x) (or (null (timesig-partids x)) (find (part-partid p) (timesig-partids x)))) + (copy-list timesigs)) ; ts = current time sig, n = next group + #'< :key #'timesig-off) + (lambda (x y) (if (= (timesig-off x) (timesig-off y)) + (cond ((and (null (timesig-partids x)) (timesig-partids y)) y) + ((and (timesig-partids x) (null (timesig-partids y))) x) + (t (error "Conflicting time signature/part IDs assignment at offset ~S, part ~S" + (timesig-foff x) (part-name p))))))))) + (if (or (null x) (> (timesig-off (first x)) 0)) + (cons (copy-timesig dts :off 0) x) + x)))) + (if *auto-override-timesigs* + (loop for (e1 e2) of-type (timesig (or timesig null)) on z + when (or (<= (timesig-off e1) 0) + (null e2) + (>= (- (timesig-off e2) (timesig-off e1)) (or *min-auto-timesig-dur* 0))) + collect e1) + z)) do (setf at (ut ts p (when nx (timesig-off nx)) (car at))) ; (print-dot) finally (return at))) do (ut at p mx lo) #|(print-dot)|#)))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.5 fomus/version.lisp:1.6 --- fomus/version.lisp:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/version.lisp Tue Aug 30 00:28:04 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 10)) +(defparameter +version+ '(0 1 11)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved" Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.8 fomus/voices.lisp:1.9 --- fomus/voices.lisp:1.8 Sun Aug 21 21:17:41 2005 +++ fomus/voices.lisp Tue Aug 30 00:28:04 2005 @@ -176,17 +176,19 @@ :remscoregreaterfun #'remscoregreaterfun))) (error "Cannot distribute voices within limits of specified instrument in part ~S" name)))))) -(defun voices-setvoice (events) +(defun voices-setvoice (events name) (declare (type list events)) (loop for e of-type (or noteex restex) in events when (listp (event-voice e)) do - (setf (event-voice e) (if (event-voice e) (first (event-voice e)) 1)))) + (setf (event-voice e) (if (event-voice e) (if (list>1p (event-voice e)) + (error "Only one voice allowed when :AUTO-VOICING is NIL in note at offset ~S, part ~S" (event-foff e) name) + (first (event-voice e))) 1)))) ;; distribute ambiguous voice assignments (lists) (defun voices (parts) (declare (type list parts)) (loop for e of-type partex in parts - if (is-percussion e) do (voices-setvoice (part-events e)) + if (is-percussion e) do (voices-setvoice (part-events e) (part-name e)) else do (multiple-value-bind (evs rs) (split-list (part-events e) #'notep) (setf (part-events e) (sort (nconc (loop ; copy rests to all voices if voice slot is a list @@ -200,7 +202,7 @@ (defun voices-generic (parts) (declare (type list parts)) - (loop for p of-type partex in parts do (voices-setvoice (part-events p)))) + (loop for p of-type partex in parts do (voices-setvoice (part-events p) (part-name p)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; COMBINE VOICES

1 0

[fomus-cvs] CVS update: fomus/backend_ly.lisp fomus/backend_xml.lisp fomus/backends.lisp fomus/data.lisp fomus/fomus.asd fomus/main.lisp fomus/misc.lisp fomus/parts.lisp fomus/splitrules.lisp fomus/test.lisp fomus/util.lisp
by dpsenicka＠common-lisp.net 28 Aug '05

28 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv8185 Modified Files: backend_ly.lisp backend_xml.lisp backends.lisp data.lisp fomus.asd main.lisp misc.lisp parts.lisp splitrules.lisp test.lisp util.lisp Log Message: bug fixes Date: Sun Aug 28 23:31:28 2005 Author: dpsenicka Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.13 fomus/backend_ly.lisp:1.14 --- fomus/backend_ly.lisp:1.13 Sat Aug 27 20:13:21 2005 +++ fomus/backend_ly.lisp Sun Aug 28 23:31:27 2005 @@ -39,8 +39,7 @@ (defun view-lilypond (filename options view) (when (>= *verbose* 1) (out ";; Compiling/opening ~S for viewing...~%" filename)) - (destructuring-bind (xxx &key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options - (declare (ignore xxx)) + (destructuring-bind (&key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options (flet ((er (str) (format t ";; ERROR: Error ~A lilypond file~%" str) (return-from view-lilypond))) @@ -137,8 +136,7 @@ (defun save-lilypond (parts header filename options process view) (when (>= *verbose* 1) (out ";; Saving Lilypond file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) - (destructuring-bind (xxx &key filehead scorehead text-markup textdyn-markup texttempo-markup textnote-markup &allow-other-keys) options - (declare (ignore xxx)) + (destructuring-bind (&key filehead scorehead text-markup textdyn-markup texttempo-markup textnote-markup &allow-other-keys) options (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 @@ -221,7 +219,7 @@ "")) "") (let ((m (getmark e '(:staff :voice)))) - (if m #|(and m (null (fourth m)))|# (format nil "\\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) + (if (and m (> ns 1)) #|(and m (null (fourth m)))|# (format nil "\\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) #|(print (lystaff (third m)))|# "")) (let ((c (getmark e :clef))) (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c))) Index: fomus/backend_xml.lisp diff -u fomus/backend_xml.lisp:1.2 fomus/backend_xml.lisp:1.3 --- fomus/backend_xml.lisp:1.2 Sun Aug 21 21:17:40 2005 +++ fomus/backend_xml.lisp Sun Aug 28 23:31:27 2005 @@ -45,7 +45,7 @@ (defun write-xml (cont str &optional (ind 0)) (destructuring-bind (ta ar0 &rest re) cont - (let ((ar (conc-stringlist (loop for (a va) in (force-list2 ar0) collect (format nil " ~A=\"~A\"" a va))))) + (let ((ar (conc-stringlist (loop for (a va) in (force-list2all ar0) collect (format nil " ~A=\"~A\"" a va))))) (if re (if (consp (first re)) (progn (format str "~V,0T<~A~A>~%" ind ta ar) Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.7 fomus/backends.lisp:1.8 --- fomus/backends.lisp:1.7 Sun Aug 21 21:17:40 2005 +++ fomus/backends.lisp Sun Aug 28 23:31:27 2005 @@ -29,10 +29,9 @@ (fresh-line f))) (defun split-preproc-backends (pts) - (loop for x of-type (or symbol cons) in (or (force-list2 *backend*) '((:data))) - do (let ((ba (first (force-list x)))) - (case ba - (:lilypond (split-preproc-lilypond pts)))))) + (loop for x of-type (or symbol cons) in (force-list2some *backend*) + do (case (first (force-list x)) + (:lilypond (split-preproc-lilypond pts))))) (defun backend (backend filename parts options process view) (declare (type symbol backend) (type list parts) (type list options) (type boolean process) (type boolean view)) Index: fomus/data.lisp diff -u fomus/data.lisp:1.15 fomus/data.lisp:1.16 --- fomus/data.lisp:1.15 Sun Aug 28 06:32:47 2005 +++ fomus/data.lisp Sun Aug 28 23:31:27 2005 @@ -465,7 +465,7 @@ (defparameter +settings+ '((:debug-filename (or null string)) (:verbose (integer 0 2)) (:use-cm boolean) (:cm-scale t) - (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (cons* symbol key-arg-pairs*))) + (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (or* symbol (cons* symbol key-arg-pairs*)))) "(SYMBOL KEYWORD/ARGUMENTS-PAIRS...) or list of (SYMBOL KEYWORD/ARGUMENTS-PAIRS...)") (:filename string) (:quality (real (0))) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.6 fomus/fomus.asd:1.7 --- fomus/fomus.asd:1.6 Sun Aug 28 06:32:47 2005 +++ fomus/fomus.asd Sun Aug 28 23:31:27 2005 @@ -33,7 +33,7 @@ (:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) - (:file "backends" :depends-on ("backend_ly" "version")) + (:file "backends" :depends-on ("backend_ly" "backend_xml" "version")) (:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends")) Index: fomus/main.lisp diff -u fomus/main.lisp:1.12 fomus/main.lisp:1.13 --- fomus/main.lisp:1.12 Sat Aug 27 20:13:21 2005 +++ fomus/main.lisp Sun Aug 28 23:31:27 2005 @@ -186,17 +186,18 @@ (defun fomus-main () (let ((r (fomus-proc))) - (loop for x of-type (or symbol cons) in (or (force-list2 *backend*) '((:data))) - do (destructuring-bind (ba &key filename process view &allow-other-keys) (force-list x) - (declare (type symbol ba) (type boolean process view)) - (backend ba - (namestring - (merge-pathnames (or filename (change-filename *filename* :ext (lookup ba +backendexts+))) - #+cmu (ext:default-directory) - #+sbcl (sb-unix:posix-getcwd) - #+openmcl (ccl:mac-default-directory) - #+allegro (excl:current-directory))) - r x (or process view) view)))) + (loop for x of-type (or symbol cons) in (force-list2some *backend*) + do (let ((xx (force-list x))) + (destructuring-bind (ba &key filename process view &allow-other-keys) xx + (declare (type symbol ba) (type boolean process view)) + (backend ba + (namestring + (merge-pathnames (or filename (change-filename *filename* :ext (lookup ba +backendexts+))) + #+cmu (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd) + #+openmcl (ccl:mac-default-directory) + #+allegro (excl:current-directory))) + r (rest xx) (or process view) view))))) t) ;; #+allegro (excl:current-directory) Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.7 fomus/misc.lisp:1.8 --- fomus/misc.lisp:1.7 Sun Aug 28 06:32:47 2005 +++ fomus/misc.lisp Sun Aug 28 23:31:27 2005 @@ -55,7 +55,11 @@ (if (listp list) list (list list))) (defun force-newlist (list) (if (listp list) (copy-list list) (list list))) -(defun force-list2 (list) +(defun force-list2some (list) + (let ((x (force-list list))) + (if (or (null x) (some #'listp x)) x + (list x)))) +(defun force-list2all (list) (let ((x (force-list list))) (if (or (null x) (every #'listp x)) x (list x)))) Index: fomus/parts.lisp diff -u fomus/parts.lisp:1.5 fomus/parts.lisp:1.6 --- fomus/parts.lisp:1.5 Sun Aug 21 21:17:41 2005 +++ fomus/parts.lisp Sun Aug 28 23:31:27 2005 @@ -55,7 +55,7 @@ (labels ((fl (l) (declare (type list l)) (loop for e of-type (or cons symbol) in l - if (consp e) nconc (fl (rest e)) else collect e))) ; listp + if (consp e) nconc (fl (rest e)) else collect e))) (let ((l (fl (instr-groups)))) (flet ((srt (x y) (let ((px (position (instr-sym (part-instr x)) l)) @@ -73,51 +73,106 @@ 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) ; listp + 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)) ; was 0? - (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)) - (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)))) + (flet ((en (p l ty) + (declare (type partex p) (type (integer 1) l) (type symbol ty)) + (if (and (getprop p (list :startgroup l)) (not (eq ty :grandstaff))) ; eliminate 1-staff braces + (rmprop p (list :startgroup l)) + (addprop p (list :endgroup l)))) + (ad (p l ty) + (declare (type partex p) (type (integer 1) l) (type symbol ty)) + (addprop p (list :startgroup l ty)))) + (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))) + do (let ((x (cdr (the (cons * symbol) (first ll))))) (when (eq x :grandstaff) (en lp i x) (ad p i x))) + finally (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))))) + for l on ll and g on gg and j from i do + (let ((x (cdr (the (cons * symbol) (first l))))) (when x (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 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 anyways - (addprop l '(:endgroup 0)))))))) + for ll on l and k from j + do (let ((x (cdr (the (cons * symbol) (first ll))))) (when x (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))))))) + +;; (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/splitrules.lisp diff -u fomus/splitrules.lisp:1.1 fomus/splitrules.lisp:1.2 --- fomus/splitrules.lisp:1.1 Sun Aug 28 06:32:47 2005 +++ fomus/splitrules.lisp Sun Aug 28 23:31:27 2005 @@ -144,7 +144,7 @@ (make-unit :div 2 #|(if (rule-comp rule) 3 2)|# :tup nil :alt t :art t :irr (not ex) #|(or (rule-comp rule) (not ex))|# :comp (rule-comp rule))))))) (nconc (etypecase rule (initdiv (loop - for ee of-type cons in (force-list2 (rule-list rule)) + for ee of-type cons in (force-list2all (rule-list rule)) #+debug unless #+debug (= (apply #'+ ee) num) #+debug do #+debug (error "Error in SPLIT-RULES-BYLEVEL") collect (loop Index: fomus/test.lisp diff -u fomus/test.lisp:1.6 fomus/test.lisp:1.7 --- fomus/test.lisp:1.6 Sun Aug 28 06:32:47 2005 +++ fomus/test.lisp Sun Aug 28 23:31:27 2005 @@ -128,6 +128,39 @@ :instr :tuba :events nil))) +(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :parts (list + (make-part + :name "Piano 1" + :instr :piano + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Piano 2" + :instr :piano + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Flute 1" + :instr :flute + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Flute 2" + :instr :flute + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Clarinet 1" + :instr :bf-clarinet + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Clarinet 2" + :instr :bf-clarinet + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Tuba" + :instr :tuba + :events (list (make-note :off 0 :dur 1 :note 36))))) + ;; Mark objects (fomus Index: fomus/util.lisp diff -u fomus/util.lisp:1.11 fomus/util.lisp:1.12 --- fomus/util.lisp:1.11 Sat Aug 27 20:13:21 2005 +++ fomus/util.lisp Sun Aug 28 23:31:27 2005 @@ -204,7 +204,7 @@ (defun timesig-div* (ts) (declare (type timesig-repl ts)) - (or (force-list2 (timesig-div ts)) + (or (force-list2all (timesig-div ts)) (when *use-default-meas-divs* (let ((nb (timesig-nbeats ts))) (or (lookup nb *default-meas-divs*) @@ -722,7 +722,7 @@ (defmethod make-timesigex* ((ts timesig)) (let ((nt (copy-timesig ts :off (roundto (timesig-off ts) (/ (beat-division ts))) - :div (force-list2 (timesig-div ts)) + :div (force-list2all (timesig-div ts)) :time (cons (first (timesig-time ts)) (second (timesig-time ts))) :repl (let ((x (mapcar #'make-timesigex* (force-list (timesig-repl ts))))) (if (list1p x) (first x) x))))) @@ -730,7 +730,7 @@ nt)) (defmethod make-timesigex* ((ts timesig-repl)) (let ((nt (copy-timesig-repl ts - :div (force-list2 (timesig-div ts)) + :div (force-list2all (timesig-div ts)) :time (cons (first (timesig-time ts)) (second (timesig-time ts)))))) (timesig-check nt) nt))

1 0

[fomus-cvs] CVS update: fomus/splitrules.lisp fomus/README fomus/classes.lisp fomus/data.lisp fomus/fomus.asd fomus/load.lisp fomus/misc.lisp fomus/split.lisp fomus/staves.lisp fomus/test.lisp
by dpsenicka＠common-lisp.net 28 Aug '05

28 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv4326 Modified Files: README classes.lisp data.lisp fomus.asd load.lisp misc.lisp split.lisp staves.lisp test.lisp Added Files: splitrules.lisp Log Message: bug fixes Date: Sun Aug 28 06:32:47 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.6 fomus/README:1.7 --- fomus/README:1.6 Sat Aug 27 21:22:43 2005 +++ fomus/README Sun Aug 28 06:32:47 2005 @@ -29,4 +29,3 @@ If you wish to report a bug, make FOMUS generate a debug file (the default filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the DEBUG-FILENAME setting in the FOMUS documentation for more information. -! \ No newline at end of file Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.9 fomus/classes.lisp:1.10 --- fomus/classes.lisp:1.9 Sat Aug 27 20:13:21 2005 +++ fomus/classes.lisp Sun Aug 28 06:32:47 2005 @@ -13,9 +13,9 @@ (defclass fomusobj-base () ((id :accessor obj-id :initform nil :initarg :id))) ; fomus doesn't use this! -(defclass event-base (fomusobj-base) ; an event in fomus is an object with an offset--also confusingly refers to a note or rest +(defclass event-base (fomusobj-base) ((off :type (real 0) :accessor event-off :initform nil :initarg :off) - (partid :type (or symbol real null) :accessor event-partid :initform nil :initarg :partid))) ; offsets are in beats + (partid :type (or symbol real null) :accessor event-partid :initform nil :initarg :partid))) (defclass timesig-repl (fomusobj-base) ((time :type cons :accessor timesig-time :initform '(4 4) :initarg :time) Index: fomus/data.lisp diff -u fomus/data.lisp:1.14 fomus/data.lisp:1.15 --- fomus/data.lisp:1.14 Sat Aug 27 20:13:21 2005 +++ fomus/data.lisp Sun Aug 28 06:32:47 2005 @@ -625,6 +625,7 @@ *checktype-markserr* t) (type* +notemarks-type+))) +;; include :staff but not :clef (defparameter +marks-rests+ '(:fermata :breath :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- :text- :endtext- #|:starttexttempo- :starttextdyn-|# :starttext-)) @@ -636,18 +637,13 @@ (declaim (type boolean *auto-pizz/arco*)) (defparameter *auto-pizz/arco* t) -;; ordering for accidentals is specified w/ second parameter slot in list (might not be relevant, depends on backend), ex.: (:staccato 1) (:fermata 2) -;; exceptions: (:finger 4 5), (:tremolo 1/4-dur-in-beats) (:righthandtremolo 1/8) (:lefthandtremolo t-unmeasured) -;; format of slurs is (:startslur- :dotted 1), (:slur- 1), (:endslur- :dotted)--order of 2nd and 3rd arguments don't matter -;; format of running-trills after processing is :startrunningtrill- and :endrunningtrill- (USER SHOULD JUST USE :RUNNINGTRILL) -;; format of texts is (:textnote "sul A") ;; marks only at beginning or end of tied notes (declaim (type cons +marks-first-tie+ +marks-last-tie+ +marks-all-ties+ +marks-on-off+ +marks-before-after+ +marks-indiv-voices+ +marks-spanner-voices+ +marks-spanner-staves+ +marks-expand+ +marks-defaultup+)) (defparameter +marks-first-tie+ '(:startslur- :startgraceslur- :start8up- :start8down- :starttext- #|:starttextdyn- :starttexttempo-|# :startwedge< :startwedge> :endgraceslur- :ppppp :pppp :ppp :pp :p :mp :mf :f :ff :fff :ffff :fffff :fp :sf :sff :sp :spp :sfz :rfz - :text :textdyn :textnote :texttempo ; up, down and dyn are italicized, tempo is slightly larger and above + :text :textdyn :textnote :texttempo ; up, down and dyn are italicized, tempo is larger and above :accent :marcato :tenuto :portato :upbow :downbow :flageolet :thumb :leftheel :rightheel :lefttoe :righttoe :turn :reverseturn :trill :prall :mordent :prallprall :prallmordent :upprall :downprall :upmordent :downmordent :pralldown :prallup :lineprall Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.5 fomus/fomus.asd:1.6 --- fomus/fomus.asd:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/fomus.asd Sun Aug 28 06:32:47 2005 @@ -16,6 +16,8 @@ (:file "data" :depends-on ("misc" "deps")) (:file "classes" :depends-on ("data")) (:file "util" :depends-on ("classes")) + + (:file "splitrules" :depends-on ("misc")) (:file "accidentals" :depends-on ("util")) (:file "beams" :depends-on ("util")) @@ -24,10 +26,10 @@ (:file "ottavas" :depends-on ("util")) (:file "parts" :depends-on ("util")) (:file "postproc" :depends-on ("util")) - (:file "split" :depends-on ("util")) + (:file "split" :depends-on ("util" "splitrules")) (:file "staves" :depends-on ("util")) (:file "voices" :depends-on ("util")) - (:file "quantize" :depends-on ("util" "accidentals")) + (:file "quantize" :depends-on ("util" "splitrules")) (:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) Index: fomus/load.lisp diff -u fomus/load.lisp:1.5 fomus/load.lisp:1.6 --- fomus/load.lisp:1.5 Mon Aug 15 21:46:10 2005 +++ fomus/load.lisp Sun Aug 28 06:32:47 2005 @@ -1,7 +1,7 @@ ;; -*-lisp-*- ;; Load file for FOMUS -(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" +(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "splitrules" "accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" "backend_xml" "backends" "main" "interface" "final") and nw Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.6 fomus/misc.lisp:1.7 --- fomus/misc.lisp:1.6 Sat Aug 27 20:13:21 2005 +++ fomus/misc.lisp Sun Aug 28 06:32:47 2005 @@ -57,7 +57,7 @@ (if (listp list) (copy-list list) (list list))) (defun force-list2 (list) (let ((x (force-list list))) - (if (or (null x) (some #'listp x)) x + (if (or (null x) (every #'listp x)) x (list x)))) (defmacro cons-list (objs places) Index: fomus/split.lisp diff -u fomus/split.lisp:1.14 fomus/split.lisp:1.15 --- fomus/split.lisp:1.14 Sat Aug 27 20:13:21 2005 +++ fomus/split.lisp Sun Aug 28 06:32:47 2005 @@ -207,254 +207,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SPLITTER -;; tup in place of div -(defun split-tupdurmult (tup div) - (declare (type (integer 2) tup) (type (rational 1) div)) - (/ tup (loop-return-firstmin (diff d tup) for d = (loop for x1 = div then x2 for x2 = (/ x1 2) while (integerp x2) finally (return x1)) then (* d 2)))) - -;; returns list of new rules for given rule: (number-or-list-of-divs newrule1 newrule2...) -;; structures for easy debugging and tweeking -(defclass baserule () nil) -(defclass basesplit () - ((alt :type boolean :accessor rule-alt :initform nil :initarg :alt) ; alt/art = attached/anchored left/right (at a div-2 boundary) - (art :type boolean :accessor rule-art :initform nil :initarg :art) - (init :type list :accessor rule-init :initform nil :initarg :init) - (irr :type boolean :accessor rule-irr :initform nil :initarg :irr))) ; t if parent is irregular (not expof2) -(defclass basenodiv () - ((tlt :type boolean :accessor rule-tlt :initform nil :initarg :tlt) ; tlt/trt = t if tie allowed on that side, nil if not allowed - (trt :type boolean :accessor rule-trt :initform nil :initarg :trt))) -(defclass basecomp () - ((comp :type boolean :accessor rule-comp :initform nil :initarg :comp))) -(defclass baseunit () - ((tup :type list :accessor rule-tup :initform nil :initarg :tup) ; tup members multiplied together gives the actual fraction - (dmu :type list :accessor rule-dmu :initform nil :initarg :dmu))) -(defclass baseinit () - ((time :type (cons (integer 1) (integer 1)) :accessor rule-time :initform '(1 1) :initarg :time) - (beat :type (rational (0)) :accessor rule-beat :initform 1 :initarg :beat))) - -(defclass initdiv (baserule baseinit basecomp) - ((list :type list :accessor rule-list :initform nil :initarg :list) - (tsoff :type (rational 0) :accessor rule-tsoff :initform 0 :initarg :tsoff))) -(defclass sig (baserule basesplit baseinit basecomp) - ((top :type boolean :accessor rule-top :initform nil :initarg :top))) -(defclass unit (baserule basesplit baseunit basecomp) - ((div :type (integer 2) :accessor rule-div :initform 1 :initarg :div) ; 2? - (sim :type (or null (rational (0))) :accessor rule-sim :initform nil :initarg :sim) - (sis :type (integer 0 1) :accessor rule-sis :initform 0 :initarg :sis))) -(defclass sig-nodiv (baserule basenodiv basecomp) ()) -(defclass unit-nodiv (baserule basenodiv baseunit basecomp) - ((rst :type boolean :accessor rule-rst :initform nil :initarg :rst))) - -(defprint initdiv time comp beat list tsoff) -(defprint sig time comp beat alt art irr init top) -(defprint unit div comp alt art irr init tup dmu sim sis) -(defprint sig-nodiv comp tlt trt) -(defprint unit-nodiv tup comp dmu tlt trt rst) - -;;(declaim (inline basesplitp basenodivp basecompp baseunitp baseinitp initdivp sigp unitp sig-nodiv-p unit-nodiv-p)) -(defun basesplitp (o) (typep o 'basesplit)) -(defun basenodivp (o) (typep o 'basenodiv)) -(defun basecompp (o) (typep o 'basecomp)) -(defun baseunitp (o) (typep o 'baseunit)) -(defun baseinitp (o) (typep o 'baseinit)) -(defun initdivp (o) (typep o 'initdiv)) -(defun sigp (o) (typep o 'sig)) -(defun unitp (o) (typep o 'unit)) -(defun sig-nodiv-p (o) (typep o 'sig-nodiv)) -(defun unit-nodiv-p (o) (typep o 'unit-nodiv)) - -(defmacro make-initdiv (&rest args) `(make-instance 'initdiv ,@args)) -(defmacro make-sig (&rest args) `(make-instance 'sig ,@args)) -(defmacro make-unit (&rest args) `(make-instance 'unit ,@args)) -(defmacro make-sig-nodiv (&rest args) `(make-instance 'sig-nodiv ,@args)) -(defmacro make-unit-nodiv (&rest args) `(make-instance 'unit-nodiv ,@args)) - -;;(declaim (inline rule-num rule-den)) -(defun rule-num (r) (declare (type baseinit r)) (the (integer 1) (car (rule-time r)))) -(defun rule-den (r) (declare (type baseinit r)) (the (integer 1) (cdr (rule-time r)))) - -(declaim (type (member t :all :top :sig) *dotted-note-level*) - (type (member t :all :top :sig) *shortlongshort-notes-level*) - (type boolean *syncopated-notes-level*)) -(defparameter *dotted-note-level* t) ; can = (t or :all), :top or :sig for levels where dotted notes are allowed, nil = no dotted notes -(defparameter *shortlongshort-notes-level* t) ; = (same as above) if special rhythmic patterns allowed (tied syncopations) -(defparameter *syncopated-notes-level* t) ; b bah.. bah.. bah.. b - -(declaim (type boolean *double-dotted-notes* *tuplet-dotted-rests*)) -(defparameter *double-dotted-notes* t) ; = t if can use double dotted notes -(defparameter *tuplet-dotted-rests* t) - -(defun split-rules-bylevel (rule tups) ; tups = tuplets are allowed, :s = simple - (declare (type baserule rule) (type (member nil t :s) tups)) - (let ((mt (first (if (baseunitp rule) - (loop for e on *max-tuplet* for xxx in (rule-tup rule) finally (return e)) - *max-tuplet*))) ; max tuplet for next nesting level - #|(mn (length mt))|#) ; max nesting depth - (flet ((dv2 (n) - (declare (type (integer 1) n)) - (loop for n2 = (/ n 2) while (integerp n2) do (setf n n2)) - (max n 2))) - (flet ((divs (tup div &optional ntup ndmu) - (declare (type (integer 2) tup) (type (rational 1) div) (type list ntup ndmu)) - (let ((tu (force-list ntup)) - (dmu (cons (split-tupdurmult tup div) ndmu)) - (ir (when *tuplet-dotted-rests* (not (expof2 tup))))) - (loop - for i of-type (or cons (integer 1)) in (tuplet-division tup) - collect - (let ((x (if (listp i) (loop with x = 0 for y of-type (integer 1) in (butlast i) collect (/ (incf x y) tup)) (list (/ i tup))))) - (cons (if (list>1p x) x (first x)) - (loop for (e1 e2) of-type ((rational 0 1) (or (rational 0 1) null)) on (cons 0 (append x '(1))) while e2 - for ii in (if (listp i) i (list i (- tup i))) and tt = (- e2 e1) and a1 = t then a2 - for a2 = (and (expof2 e2) (expof2 (- tup e2))) collect - (if (and (<= ii 1) (if (unitp rule) (rule-sim rule) t)) - (make-unit-nodiv :tup (cons tt tu) :comp (rule-comp rule) :dmu dmu :tlt t :trt t) - (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii)))))))))) - (sort (etypecase rule - ((or initdiv sig) - (let* ((num (/ (rule-num rule) (* (rule-den rule) (rule-beat rule)))) ; 3/8 is treated like 1/4, etc. - (ex (expof2 num))) ; in compound meter, num = 1 for 3/8 - (flet ((al (sy) - (declare (type (member t :all :top :sig) sy)) - (or (find sy '(t :all :sig)) - (and (eq sy :top) (or (initdivp rule) (rule-top rule))))) - (in (n al ar in) ; n = division ratio - (declare (type (rational (0) (1)) n) (type boolean al ar) (type list in)) - (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) - (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) - :alt al :art ar :init in :irr (not ex) :comp (rule-comp rule)) - (make-unit :div (if (rule-comp rule) 3 2) :tup nil :alt t :art t :init in :irr (not ex) :comp (rule-comp rule)))) - (snd (n tl tr) - (declare (type (rational (0) (1)) n) (type boolean tl tr)) - (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# - (make-sig-nodiv :comp (rule-comp rule) :tlt tl :trt tr :comp (rule-comp rule)) - (make-unit-nodiv :tup nil :tlt tl :trt tr :comp (rule-comp rule))))) - (flet ((si (n wh al ar) ; n = division ratio, >1/4 or >3/8 comp. is designated with :sig, smaller durations become units - (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar)) - (etypecase rule - (initdiv (in n al ar nil)) - (sig (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# - (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) - :alt (if (eq wh :l) (and (rule-alt rule) al) (and (rule-alt rule) (rule-art rule) al)) - :art (if (eq wh :r) (and (rule-art rule) ar) (and (rule-alt rule) (rule-art rule) ar)) - :irr (not ex) :comp (rule-comp rule)) - (make-unit :div 2 #|(if (rule-comp rule) 3 2)|# :tup nil :alt t :art t :irr (not ex) #|(or (rule-comp rule) (not ex))|# :comp (rule-comp rule))))))) - (nconc (etypecase rule - (initdiv (loop - for ee of-type cons in (force-list2 (rule-list rule)) - #+debug unless #+debug (= (apply #'+ ee) num) - #+debug do #+debug (error "Error in SPLIT-RULES-BYLEVEL") - collect (loop - for (e en) of-type ((rational (0)) (or (rational (0)) null)) on ee - sum e into s - collect (/ e num) into ee ; split durs - when en collect (/ s num) into ll ; split points - finally (return (cons (if (list>1p ll) ll (car ll)) - (loop - for (i n) of-type ((rational (0)) (or (rational (0)) null)) on ee - and x of-type (rational (0) 1) in (append ll '(1)) - and la = t then aa - for aa = (let ((xx (* x num))) - (and (expof2 xx) (or (= num xx) (expof2 (- num xx))))) - collect (in i la (or (null n) aa) ee))))))) - (sig (loop - for nn of-type (integer 2) in (or (lowmult (numerator num)) (if (rule-comp rule) '(3) '(2))) - nconc (loop - for j from 1 below nn - for x of-type (rational (0) (1)) = (/ j nn) ; x is the ratio - for xx = (* x num) and co = (and (rule-comp rule) (<= num 1)) - when (or (and co (expof2 (* xx 3/2))) - (expof2 xx) (expof2 (- num xx))) - collect (let ((aa (or (and co (expof2 (* xx 3/2)) (expof2 (* (- num xx) 3/2))) - (and (expof2 xx) (expof2 (- num xx)))))) - (list x (si x :l t aa) (si (- 1 x) :r aa t))))))) - (when (and (al *dotted-note-level*) (or (initdivp rule) (rule-alt rule)) ex (not (rule-comp rule))) - (nconc (list (list 3/4 (snd 3/4 t nil) (si 1/4 :r t t))) ; dotted notes - (when *double-dotted-notes* - (list (list 7/8 (snd 7/8 t nil) (si 1/8 :r t t)))))) - (when (and (al *dotted-note-level*) (or (initdivp rule) (rule-art rule)) ex (not (rule-comp rule))) - (nconc (list (list 1/4 (si 1/4 :l t t) (snd 3/4 nil t)) ) - (when *double-dotted-notes* - (list (list 1/8 (si 1/8 :l t t) (snd 7/8 nil t)))))) - (when (and (al *shortlongshort-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) - ex (or (not (rule-comp rule)) (>= num 4))) - (list (list '(1/4 3/4) (si 1/4 :l t t) (snd 1/2 t t) (si 1/4 :r t t)))) ; longer note in middle - (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3)) - (not (rule-comp rule))) - (cond ((integerp num) - (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation - (snd (/ 1/2 num) t nil)) - (make-list (1- num) :initial-element (snd (/ num) nil nil)) - (list (snd (/ 1/2 num) nil t))))) - ((= (denominator num) 2) - (nconc (list (nconc (list (loop for i from 1 below num collect (/ i num))) ; regular off beat syncopation - (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)) - (list (snd (/ 1/2 num) nil t)))) - (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation - (snd (/ 1/2 num) t nil)) - (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)))))))) - (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) - (loop - with nu = (if (rule-comp rule) (* num 3/2) num) - for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division - unless (expof2 (/ nu j)) - nconc (divs j nu)))))))) - (unit ; unit is at divide-by-2 level - (let ((ex (expof2 (rule-div rule)))) - (flet ((al (sy) - (declare (type (member t :all :top :sig) sy)) - (find sy '(t :all))) - (tu (n) - (declare (type (rational (0) (1)) n)) - (when (rule-tup rule) - (cons (* (the (rational (0)) (first (rule-tup rule))) n) (rest (rule-tup rule)))))) - (flet ((un (n wh al ar &optional d) - (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar) (type (or (integer 1) null) d)) - (if (and (rule-sim rule) (<= (* (rule-sim rule) n) 1)) - (make-unit-nodiv :tup (tu n) :dmu (rule-dmu rule) :tlt t :trt t :comp (rule-comp rule) :rst t) - (make-unit :div (if d (dv2 d) 2) :tup (tu n) :dmu (rule-dmu rule) - :alt (if (eq wh :l) (and (rule-alt rule) al) (and (rule-alt rule) (rule-art rule) al)) - :art (if (eq wh :r) (and (rule-art rule) ar) (and (rule-alt rule) (rule-art rule) ar)) - :irr (not ex) :comp (rule-comp rule) :sim (when (rule-sim rule) (* (rule-sim rule) n))))) - (und (n tl tr) (make-unit-nodiv :tup (tu n) :dmu (rule-dmu rule) :tlt tl :trt tr :comp (rule-comp rule)))) - (nconc (loop for nn of-type (integer 2) in (or (lowmult (rule-div rule)) '(2)) - nconc (loop for j from 1 below nn collect - (let ((x (/ j nn)) - (aa (and (expof2 j) (expof2 (- nn j))))) - (list x (un x :l t aa j) (un (- 1 x) :r aa t (- nn j)))))) - (when (and (al *dotted-note-level*) (rule-alt rule) ex) - (nconc (list (list 3/4 (und 3/4 t nil) (un 1/4 :r t t))) ; dotted notes - (when *double-dotted-notes* - (list (list 7/8 (und 7/8 t nil) (un 1/8 :r t t)))))) - (when (and (al *dotted-note-level*) (rule-art rule) ex) - (nconc (list (list 1/4 (un 1/4 :l t t) (und 3/4 nil t))) - (when *double-dotted-notes* - (list (list 1/8 (un 1/8 :l t t) (und 7/8 nil t)))))) - (when (and (al *shortlongshort-notes-level*) (rule-alt rule) (rule-art rule) ex) - (list (list '(1/4 3/4) (un 1/4 :l t t) (und 1/2 t t) (un 1/4 :r t t)))) ; longer note in middle - (when #|(debugn-if (>= (length (rule-tup rule)) 1) "~A ~A ~A ~A" - tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))))|# - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) - (loop - for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division - unless (expof2 (/ (rule-div rule) j)) - nconc (divs j (rule-div rule) (rule-tup rule) (rule-dmu rule)))))))))) - (lambda (x0 y0) - (declare (type (cons (or cons (rational (0) (1))) *) x0 y0)) - (let ((x (car x0)) (y (car y0))) - (declare (type (or cons (rational (0) (1))) x y)) - (let ((xm (if (listp x) (the (rational (0) (1)) (ave-list x)) x)) - (ym (if (listp y) (the (rational (0) (1)) (ave-list y)) y))) - (let ((xd (diff xm 1/2)) - (yd (diff ym 1/2))) - (if (= xd yd) - (if (= xm ym) - (cond ((listp x) t) - ((listp y) nil)) - (> xm ym)) - (< xd yd))))))))))) - (declaim (type (real (0)) *min-split-all-parts-dur*)) (defparameter *min-split-all-parts-dur* 3/2) Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.7 fomus/staves.lisp:1.8 --- fomus/staves.lisp:1.7 Sun Aug 21 21:17:41 2005 +++ fomus/staves.lisp Sun Aug 28 06:32:47 2005 @@ -227,12 +227,12 @@ (loop for e of-type (or noteex restex) in (part-events p) do (rmmark e :clef)) ;;(addprop p (list :clef :percussion)) else do + (get-usermarks (part-events p) :staff :startstaff- :staff- :endstaff- + (lambda (e s) + (declare (type (or noteex restex) e) (type list s)) + (if (notep e) (setf (event-userstaff e) (force-list (first s))) (addmark e (list :userstaff (first s))))) + (part-name p)) (multiple-value-bind (no re) (split-list (part-events p) #'notep) - (get-usermarks no :staff :startstaff- :staff- :endstaff- - (lambda (e s) - (declare (type (or noteex restex) e) (type list s)) - (setf (event-userstaff e) (force-list (first s)))) - (part-name p)) (get-usermarks no :clef :startclef- :clef- :endclef- (lambda (e c) (declare (type (or noteex restex) e) (type list c)) @@ -249,12 +249,13 @@ do (loop with s of-type (or list (integer 1)) for e of-type (or noteex restex) in (sort g #'sort-offdur) - if (and (restp e) (null (event-userstaff e))) do (if (listp s) (push e s) (setf (event-staff* e) s)) + if (and (restp e) (null (getmark e :userstaff))) do (if (listp s) (push e s) (setf (event-staff* e) s)) else do - (let ((v (if (restp e) (event-userstaff e) (event-staff e)))) - (if (listp s) + (let ((v (if (restp e) (second (popmark e :userstaff)) (event-staff e)))) + (when v + (when (listp s) (mapc (lambda (x) (declare (type restex x)) (setf (event-staff* x) v)) s)) - (setf s v)))))) + (setf s v))))))) (defun clefs-generic (parts) (loop for p of-type partex in parts Index: fomus/test.lisp diff -u fomus/test.lisp:1.5 fomus/test.lisp:1.6 --- fomus/test.lisp:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/test.lisp Sun Aug 28 06:32:47 2005 @@ -527,6 +527,26 @@ (1 :snaredrum))))))) ;; User Rests + +(fomus + :backend '((:data) (:lilypond :view t)) + :verbose 2 + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata)) + (loop + for off from 0 below 19/2 by 1/2 + collect (make-note :off off + :dur 1/2 + :note (+ 48 (random 25)) + :marks (when (<= (random 3) 0) + '(:staccato)))))))) + ;; Auto On/Offs ;; User Overrides ;; Auto Pizz/Arco

1 0

[fomus-cvs] CVS update: fomus/README
by dpsenicka＠common-lisp.net 27 Aug '05

27 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv31234 Modified Files: README Log Message: readme update Date: Sat Aug 27 21:22:44 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.5 fomus/README:1.6 --- fomus/README:1.5 Sun Aug 7 02:31:06 2005 +++ fomus/README Sat Aug 27 21:22:43 2005 @@ -3,27 +3,30 @@ See file "COPYING" for terms of use and distribution. + Fomus is alpha software, and still has a lot of testing and bug fixing to go before all of its features are useable. Not all features that appear in the -documentation are implemented yet. Also, some parts of the program are running -rather slowly. +documentation are implemented or working yet. + The program is available via anonymous CVS. To download it, type the following: cd path_to_install_directory cvs -z3 -d :pserver:anonymous:anonymous@common-lisp.net:/project/fomus/cvsroot co fomus + See the file "fomus.html" in the doc directory for instructions on how to use the program. The following command loads FOMUS into lisp: (load "path_to_fomus_directory/load.lisp") (use-package :fm) -The program is being developed in SBCL, but should also compile in CMUCL and -OpenMCL. It will eventually run in Allegro Common Lisp and CLISP. There are -problems compiling it in SBCL v0.9.0 (and probably earlier versions) in Darwin -(errors related to memory management). + +The program is being developed in CMUCL, but should also compile in SBCL and +OpenMCL. It will eventually run in Allegro Common Lisp and CLISP. + If you wish to report a bug, make FOMUS generate a debug file (the default filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the DEBUG-FILENAME setting in the FOMUS documentation for more information. +! \ No newline at end of file

1 0

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

21 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv6856 Modified Files: classes.lisp Log Message: bug fix Date: Mon Aug 22 01:55:02 2005 Author: dpsenicka Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.7 fomus/classes.lisp:1.8 --- fomus/classes.lisp:1.7 Sun Aug 21 21:17:40 2005 +++ fomus/classes.lisp Mon Aug 22 01:55:01 2005 @@ -224,9 +224,8 @@ ,xx)))) ;; aliases -(declaim (inline timesig-off part-meas meas-voices)) +(declaim (inline timesig-off meas-voices)) (defun timesig-off (ev) (declare (type event-base ev)) (event-off ev)) -(defun part-meas (ev) (declare (type partex ev)) (part-events ev)) (defun meas-voices (ev) (declare (type meas ev)) (meas-events ev)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -279,6 +278,9 @@ (loop for m in (part-meas p) do (loop for e in (meas-events m) when (restp e) do (setf (event-inv e) nil))))) + +(declaim (inline part-meas)) +(defun part-meas (ev) (declare (type partex ev)) (part-events ev)) (declaim (inline make-noteex make-restex make-partex)) (defun make-noteex (&rest args) (apply #'make-instance 'noteex args))

1 0

[fomus-cvs] CVS update: fomus/voices.lisp
by dpsenicka＠common-lisp.net 15 Aug '05

15 Aug '05

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv7642 Modified Files: voices.lisp Log Message: Bug fix Date: Tue Aug 16 01:53:22 2005 Author: dpsenicka Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.6 fomus/voices.lisp:1.7 --- fomus/voices.lisp:1.6 Mon Aug 15 21:46:11 2005 +++ fomus/voices.lisp Tue Aug 16 01:53:20 2005 @@ -52,7 +52,7 @@ (declare (type rational note1 note2)) (expt *voice-octave-dist-sc* (/ (diff note1 note2) 12.0))) (defun voices-notedist-aux2 (off1 eoff1 off2 eoff2 beatdist sc) ; by offset - (declare (type (rational 0) off1 eoff1 off2 eoff2) (type #-openmcl (float 0) #+openmcl float beatdist) (type #-openmcl (float 0 1) #+openmcl float sc)) + (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-openmcl (float 0 1) #+openmcl float sc)) (let ((d (max (- (float off2) (float eoff1)) (- (float off1) (float eoff2)) 0.0))) (if (>= d (* *max-voice-beat-dist-mul* beatdist)) 0.0 (expt sc d))))

1 0