Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv697
Modified Files: TODO backend_ly.lisp backends.lisp data.lisp final.lisp fomus.asd load.lisp main.lisp marks.lisp other.lisp package.lisp postproc.lisp split.lisp util.lisp Added Files: CHANGELOG version.lisp Log Message: Testing/bug fixes Date: Fri Jul 29 10:58:20 2005 Author: dpsenicka
Index: fomus/TODO diff -u fomus/TODO:1.7 fomus/TODO:1.8 --- fomus/TODO:1.7 Wed Jul 27 08:57:37 2005 +++ fomus/TODO Fri Jul 29 10:58:20 2005 @@ -4,6 +4,7 @@
Testing and bug fixes DOC: dynamic marks can take order arguments (backend might not support it) +DOC: update tremolos Adjust scores and penalties for decent results Breath marks (resolve before/after) Note heads
Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.6 fomus/backend_ly.lisp:1.7 --- fomus/backend_ly.lisp:1.6 Wed Jul 27 22:58:50 2005 +++ fomus/backend_ly.lisp Fri Jul 29 10:58:20 2005 @@ -108,14 +108,15 @@ (:mf . "\mf") (:f . "\f") (:ff . "\ff") (:fff . "\fff") (:ffff . "\ffff") (:fffff . "\fffff") (:fp . "\fp") (:sf . "\sf") (:sff . "\sff") (:sp . "\sp") (:spp . "\spp") (:sfz . "\sfz") (:rfz . "\rfz")))
-;; TODO: support texts, spanners and tremelos, remove dependency on ACCIDENTALYS +;; TODO: support texts, spanners and tremelos
-(defun save-lilypond (parts filename options process view) +(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 &allow-other-keys) options (declare (ignore xxx)) - (format f "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) + (format f "~A" header) + ;;(format f "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) (loop for e in +lilypond-head+ do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top (when filehead (loop for e in filehead do (format f "~A~%" e) finally (format f "~%"))) ;; user header (loop for e in +lilypond-defs+ do (format f "~A~%" e) finally (format f "~%")) ;; definitions @@ -185,108 +186,119 @@ (loop for (ee een) on (meas-events m) ; ee = list of events do (loop for (pre e nxe) on (cons nil ee) while e - for fm = (getmark e :measrest) - for cl = (let ((c (getmark e :clef))) - (if (and c (null (fourth c))) (format nil "\clef ~A " (lyclef (second c))) - "")) - and st = (let ((m (getmark e '(:staff :global)))) - (if (and m (null (fourth m))) (lystaff (third m)) "")) - and vo = (if (list>1p (meas-events m)) - (let ((m (getmark e '(:voice :ord1324)))) - (if m - (case (third m) - (1 "\voiceOne ") (2 "\voiceTwo ") (3 "\voiceThree ") (4 "\voiceFour ") (otherwise "\oneVoice ")) + do (let ((fm (getmark e :measrest))) + (let ((cl (let ((c (getmark e :clef))) + (if (and c (null (fourth c))) (format nil "\clef ~A " (lyclef (second c))) + ""))) + (st (let ((m (getmark e '(:staff :global)))) + (if (and m (null (fourth m))) (lystaff (third m)) ""))) + (vo (if (list>1p (meas-events m)) + (let ((m (getmark e '(:voice :ord1324)))) + (if m + (case (third m) + (1 "\voiceOne ") (2 "\voiceTwo ") (3 "\voiceThree ") (4 "\voiceFour ") (otherwise "\oneVoice ")) + "")) "")) - "") - and gr1 = (let ((g (event-grace e))) - (if g - (let ((g1 (getmark e :startgrace))) - (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\acciaccatura " "\appoggiatura ")) - (g1 (if (< g 0) "\acciaccatura {" "\appoggiatura {")))) - "")) - and gr2 = (if (and (event-grace e) (getmark e :endgrace) (not (getmark e :startgrace))) "}" "") - and ot1 = (cond ((or (getmark e :start8up-) (getmark e :8up)) "\octUp ") - ((or (getmark e :start8down-) (getmark e :8down)) "\octDown ")) - and ot2 = (cond ((or (getmark e :end8up-) (getmark e :8up)) " \octReset") - ((or (getmark e :end8down-) (getmark e :8down)) " \octReset")) - and ba = (if (notep e) - (if (chordp e) - (format nil "<~A>" (conc-stringlist - (loop - for (n nn) on (event-notes* e) - and w in (event-writtennotes e) - and a in (event-accs e) - and a2 in (event-addaccs e) - collect (lynote w a a2 (getmark e (list :cautacc n)) #|(getmark e (list :showacc n))|#) - when nn collect " "))) - (lynote (event-writtennote e) (event-acc e) (event-addacc e) - (getmark e (list :cautacc (event-note* e))) #|(getmark e (list :showacc n))|#)) - (if fm (if (event-inv e) "\skip " "R") (if (event-inv e) "s" "r"))) - and du = (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) - (multiple-value-bind (wd ds) (event-writtendur* e ts) - (let ((du (case wd - (2 "\breve") - (4 "\longa") - (otherwise (/ wd))))) - (ecase ds - (0 (format nil "~A" du)) - (1 (format nil "~A." du)) - (2 (format nil "~A.." du)))))) - and tu1 = (let ((uu (sort (getmarks e :starttup) #'< :key #'second))) - (conc-stringlist - (loop for u in uu for r = (third u) - collect (format nil "\times ~A/~A {" (cdr r) (car r))))) ; tup is durmult - and tu2 = (let ((uu (getmarks e :endtup))) - (conc-stringlist - (loop repeat (length uu) collect "}"))) - and ti = (if (and (notep e) (or-list (force-list (event-tiert e)))) "~" "") - and be1 = (if (and (notep e) (= (event-beamlt e) 0) (> (event-beamrt e) 0)) "[" "") - and be2 = (if (and (notep e) (> (event-beamlt e) 0) (= (event-beamrt e) 0)) "]" "") - and bnu = (let ((l (and (notep e) (notep pre) (> (min (event-nbeams e ts) (event-nbeams pre ts)) (event-beamlt e) 0))) - (r (and (notep e) (notep nxe) (> (min (event-nbeams e ts) (event-nbeams nxe ts)) (event-beamrt e) 0)))) - (cond ((and l r) (format nil "\beamLR #~A #~A " (event-beamlt e) (event-beamrt e))) - (l (format nil "\beamL #~A " (event-beamlt e))) - (r (format nil "\beamR #~A " (event-beamrt e))) - (t ""))) - and ar = (conc-stringlist - (loop for i in - (sort (loop for a in +lilypond-marks+ nconc (mapcar #'force-list (getmarks e (car a)))) - (lambda (x y) (let ((x2 (second x)) (y2 (second y))) - (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) - (x2 t))))) - collect (lookup (first i) +lilypond-marks+))) - ;and txt = ... - and we0 = (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\< ") - ((and (getmark e :startwedge>) (getmark e :endwedge-)) "\> ") - (t "")) - and we1 = (cond ((getmark e :endwedge-) "\!") - ((getmark e :startwedge<) "\<") - ((getmark e :startwedge>) "\>") - (t "")) - and we2 = (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge-))) "\<") - ((and (getmark e :startwedge>) (not (getmark e :endwedge-))) "\>") - (t "")) - and dyn = (conc-stringlist - (loop for i in - (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) - collect (lookup (first i) +lilypond-dyns+))) - and s1 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-)) - collect "(")) - and s2 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-)) - collect ")")) - and sl1 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-)) - collect "(")) - and sl2 = (conc-stringlist - (loop - for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-)) - collect ")")) - do (format f "~A " (conc-strings st vo cl ot1 tu1 gr1 we0 bnu ba du sl1 s1 s2 sl2 be1 be2 ti ar we1 dyn #|txt|# we2 gr2 tu2 ot2))) + (gr1 (let ((g (event-grace e))) + (if g + (let ((g1 (getmark e :startgrace))) + (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\acciaccatura " "\appoggiatura ")) + (g1 (if (< g 0) "\acciaccatura {" "\appoggiatura {")))) + ""))) + (gr2 (if (and (event-grace e) (getmark e :endgrace) (not (getmark e :startgrace))) "}" "")) + (ot1 (cond ((or (getmark e :start8up-) (getmark e :8up)) "\octUp ") + ((or (getmark e :start8down-) (getmark e :8down)) "\octDown "))) + (ot2 (cond ((or (getmark e :end8up-) (getmark e :8up)) " \octReset") + ((or (getmark e :end8down-) (getmark e :8down)) " \octReset"))) + (ba (if (notep e) + (if (chordp e) + (format nil "<~A>" (conc-stringlist + (loop + for (n nn) on (event-notes* e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + collect (lynote w a a2 (getmark e (list :cautacc n))) + when nn collect " "))) + (lynote (event-writtennote e) (event-acc e) (event-addacc e) + (getmark e (list :cautacc (event-note* e))))) + (if fm (if (event-inv e) "\skip " "R") (if (event-inv e) "s" "r")))) + (du (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) + (multiple-value-bind (wd ds) (let ((m (or (getmark e :tremolo) + (getmark e :starttremolo) + (getmark e :endtremolo)))) + (if m + (values (third m) 0) + (event-writtendur* e ts))) + (let ((du (case wd + (2 "\breve") + (4 "\longa") + (otherwise (/ wd))))) + (ecase ds + (0 (format nil "~A" du)) + (1 (format nil "~A." du)) + (2 (format nil "~A.." du))))))) + (tu1 (let ((uu (sort (getmarks e :starttup) #'< :key #'second))) + (conc-stringlist + (loop for u in uu for r = (third u) + collect (format nil "\times ~A/~A {" (cdr r) (car r)))))) ; tup is durmult + (tu2 (let ((uu (getmarks e :endtup))) + (conc-stringlist + (loop repeat (length uu) collect "}")))) + (ti (if (and (notep e) (or-list (force-list (event-tiert e)))) "~" "")) + (be1 (if (and (notep e) (= (event-beamlt e) 0) (> (event-beamrt e) 0)) "[" "")) + (be2 (if (and (notep e) (> (event-beamlt e) 0) (= (event-beamrt e) 0)) "]" "")) + (bnu (let ((l (and (notep e) (notep pre) (> (min (event-nbeams e ts) (event-nbeams pre ts)) (event-beamlt e) 0))) + (r (and (notep e) (notep nxe) (> (min (event-nbeams e ts) (event-nbeams nxe ts)) (event-beamrt e) 0)))) + (cond ((and l r) (format nil "\beamLR #~A #~A " (event-beamlt e) (event-beamrt e))) + (l (format nil "\beamL #~A " (event-beamlt e))) + (r (format nil "\beamR #~A " (event-beamrt e))) + (t "")))) + (ar (conc-stringlist + (loop for i in + (sort (loop for a in +lilypond-marks+ nconc (mapcar #'force-list (getmarks e (car a)))) + (lambda (x y) (let ((x2 (second x)) (y2 (second y))) + (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) + (x2 t))))) + collect (lookup (first i) +lilypond-marks+)))) + (we0 (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\< ") + ((and (getmark e :startwedge>) (getmark e :endwedge-)) "\> ") + (t ""))) + (we1 (cond ((getmark e :endwedge-) "\!") + ((getmark e :startwedge<) "\<") + ((getmark e :startwedge>) "\>") + (t ""))) + (we2 (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge-))) "\<") + ((and (getmark e :startwedge>) (not (getmark e :endwedge-))) "\>") + (t ""))) + (dyn (conc-stringlist + (loop for i in + (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) + collect (lookup (first i) +lilypond-dyns+)))) + (mo1 (let ((m (or (getmark e :tremolo) (getmark e :starttremolo)))) + (if m (format nil "\repeat "tremolo" ~A ~A" (second m) + (if (eq (first m) :tremolo) "" "{")) + ""))) + (mo2 (if (getmark e :endtremolo) "}" "")) + (s1 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-)) + collect "("))) + (s2 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-)) + collect ")"))) + (sl1 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-)) + collect "("))) + (sl2 (conc-stringlist + (loop + for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-)) + collect ")")))) + (format f "~A " (conc-strings st vo cl ot1 tu1 gr1 we0 bnu mo1 ; stuff before + ba du sl1 s1 s2 sl2 be1 be2 ti ar we1 dyn #|txt|# we2 ; the actual note w/ attachments + mo2 gr2 tu2 ot2))))) ; stuff after (end brackets) when een do (format f s2)) (format f s3 (let ((x (getprop m :barline)))
Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.3 fomus/backends.lisp:1.4 --- fomus/backends.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/backends.lisp Fri Jul 29 10:58:20 2005 @@ -24,6 +24,6 @@ (defun backend (backend filename parts options process view) (case backend (:data (save-data filename parts)) - (:lilypond (save-lilypond parts filename options process view)) + (:lilypond (save-lilypond parts (format nil "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (otherwise (error "Unknown backend ~S" backend))))
Index: fomus/data.lisp diff -u fomus/data.lisp:1.6 fomus/data.lisp:1.7 --- fomus/data.lisp:1.6 Tue Jul 26 08:00:57 2005 +++ fomus/data.lisp Fri Jul 29 10:58:20 2005 @@ -150,25 +150,25 @@ (instr-staves (check* (integer 1) "Found ~S, expected (INTEGER 1) in STAVES slot" t)) (instr-minp (check* (or null integer) "Found ~S, expected INTEGER in MINP slot" t)) (instr-maxp (check* (or null integer) "Found ~S, expected INTEGER in MAXP slot" t)) - (voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) - (tpose (check* (or null integer) "Found ~S, expected INTEGER in TPOSE slot" t)) - (cleflegls (check* (or* (integer 1) - (cons-of* (integer 1) - (and* (list-of* (list* (and* symbol (check* (satisfies is-clef) "Found ~S, expected valid clef symbol in list in CLEFLEGLS slot" t)) - (and* symbol (check* (find* :up :dn) "Found ~S, expected :UP or :DN in list in CLEFLEGLS slot" t)) - (integer 1))) - (length* <= 2)))) - "Found ~S, expected (INTEGERS 1) or SYMBOLS in the form I, (I (S S I) ...) in CLEFLEGLS slot" t)) - (8uplegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8UPLEGLS slot" t)) - (8dnlegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8DNLEGLS slot" t)) - (percs (check* (or null (list-of* (type* *perc-type*))) "Found ~S, expected list of PERC objects in PERCS slot" t))))) + (instr-voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) + (instr-tpose (check* (or null integer) "Found ~S, expected INTEGER in TPOSE slot" t)) + (instr-cleflegls (check* (or* (integer 1) + (cons-of* (integer 1) + (and* (list-of* (list* (and* symbol (check* (satisfies is-clef) "Found ~S, expected valid clef symbol in list in CLEFLEGLS slot" t)) + (and* symbol (check* (find* :up :dn) "Found ~S, expected :UP or :DN in list in CLEFLEGLS slot" t)) + (integer 1))) + (length* <= 2)))) + "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 (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 (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)))))
;; tpose = mod. for sounding pitch ;; 8up/8down = (threshold-for-ottava-brackets . threshold-for-back-to-normal)
(defparameter *instruments* nil) (eval-when (:load-toplevel :execute) - (defparameter +default-instr+ (make-instr :default :clefs :treble)) + (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :voicelim 5)) (defparameter +instruments+ (list (make-instr :piccolo :clefs :treble :tpose 12) (make-instr :flute :clefs :treble) @@ -407,8 +407,8 @@ (list* x (function* is-clef))) (let* ((x (unique* sy (find* :notehead)))) (list* x (find* ))) ; finish this!!!!!! - (let* ((x (unique* sy :tremolo (find* :righthandtremolo :lefthandtremolo :tremolo))) - (or* x (list* x) (list* x (rational (0)))))) ; tremolos + (let* ((x (unique* sy :tremolo (find* :tremolo :tremolofirst :tremolosecond)))) + (or* x (list* x) (list* x (rational (0))))) ; tremolos (let* ((x (find* :startslur-))) (or* (unique* si 1 x) (unique* si 1 (list* x)) (cons* x (or* (unique* si integer) @@ -492,7 +492,7 @@ '(:endslur- :end8up- :end8down- :endtext- :endtextdyn- :endtexttempo- :endwedge- :fermata :staccatissimo :staccato)) (defparameter +marks-all-ties+ - '(:longtrill :tremolo :lefthandtremolo :righthandtremolo)) + '(:longtrill :tremolo :tremolofirst :tremolosecond))
(defparameter *auto-pizz/arco* t)
Index: fomus/final.lisp diff -u fomus/final.lisp:1.3 fomus/final.lisp:1.4 --- fomus/final.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/final.lisp Fri Jul 29 10:58:20 2005 @@ -27,7 +27,7 @@ when (eq y 'eof) do (error "KEYWORD/ARGUMENT-PAIRS expected in initialization file") do (setf nt0 (find-symbol (conc-strings "*" (symbol-name x) "*") :fomus)) if nt0 collect (find-symbol (conc-strings "*" (symbol-name x) "*") :fomus) into nt and collect y into nt - else do (format t ";; WARNING: Unknown setting ~S~%" x) + else do (format t ";; WARNING: Unknown setting ~S in initialization file~%" x) finally (when nt (eval (cons 'setf nt))) (return t)))))
Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.1.1.1 fomus/fomus.asd:1.2 --- fomus/fomus.asd:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/fomus.asd Fri Jul 29 10:58:20 2005 @@ -10,6 +10,7 @@
:components ((:file "package") + (:file "version" :depends-on ("package")) (:file "misc" :depends-on ("package")) (:file "deps" :depends-on ("package")) (:file "data" :depends-on ("misc" "deps")) @@ -29,10 +30,12 @@ (:file "quantize" :depends-on ("util"))
(:file "backend_ly" :depends-on ("util")) - (:file "backends" :depends-on ("backend_ly")) + (:file "backends" :depends-on ("backend_ly" "version"))
(:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends"))
(:file "interface" :depends-on ("main"))
- (:file "final" :depends-on ("util") :in-order-to ((load-op (load-op "interface")))))) \ No newline at end of file + (:file "final" :depends-on ("util" "version") :in-order-to ((load-op (load-op "interface")))) + + )) \ No newline at end of file
Index: fomus/load.lisp diff -u fomus/load.lisp:1.2 fomus/load.lisp:1.3 --- fomus/load.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/load.lisp Fri Jul 29 10:58:20 2005 @@ -1,11 +1,15 @@ ;; -*-lisp-*- ;; Load file for FOMUS
-(loop for na in - '("package" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" - "backends" "main" "interface" "final") - for cl = (merge-pathnames na *load-pathname*) - for cn = (compile-file-pathname cl) - for wd = (file-write-date cn) - when (or (null wd) (>= (file-write-date cl) (file-write-date cn))) do (compile-file cl) - do (load cn)) \ No newline at end of file +(let ((fl '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" + "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" + "backends" "main" "interface" "final"))) + (when (some (lambda (na) (let* ((cl (merge-pathnames na *load-pathname*)) + (cn (compile-file-pathname cl)) + (wd (file-write-date cn))) + (or (null wd) (>= (file-write-date cl) (file-write-date cn))))) fl) + (loop for na in fl + for cl = (merge-pathnames na *load-pathname*) + for cn = (compile-file-pathname cl) do + (compile-file cl) + (load cn)))) \ No newline at end of file
Index: fomus/main.lisp diff -u fomus/main.lisp:1.6 fomus/main.lisp:1.7 --- fomus/main.lisp:1.6 Tue Jul 26 08:00:57 2005 +++ fomus/main.lisp Fri Jul 29 10:58:20 2005 @@ -49,11 +49,11 @@ ;; keysigs not implemented yet ;; returns data structure ready for output via backends (defun fomus-proc () + (find-cm) (when (and (numberp *verbose*) (>= *verbose* 1)) (out ";; Formatting music...")) (when *debug-filename* (save-debug)) (when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types...")) (check-setting-types) - (find-cm) (check-settings) (set-note-precision (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) @@ -135,6 +135,7 @@ (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...")) + (preproc-tremolos pts) (preproc-cautaccs pts) (when *auto-grace-slurs* (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs))
Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.5 fomus/marks.lisp:1.6 --- fomus/marks.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/marks.lisp Fri Jul 29 10:58:20 2005 @@ -76,20 +76,6 @@ do (loop for e in (part-events p) when (popmark e ma) do (addmark e rs) (addmark e re)) (print-dot))))
-;; clean -;; deletes marks at incorrect places in tied notes/chords -;; expects measures and chords -(defun clean-ties (pts) - (loop for p in pts - do (loop for m in (part-meas p) - do (loop - for e in (remove-if-not #'notep (meas-events m)) - when (and (event-tielt e) (and-list (force-list (event-tielt e)))) - do (mapc (lambda (x) (rmmark e x)) +marks-first-tie+) - when (and (event-tiert e) (and-list (force-list (event-tiert e)))) - do (mapc (lambda (x) (rmmark e x)) +marks-last-tie+))) (print-dot))) - -;; (defun distribute-marks (pts mks) (loop with pas = (loop for p in pts collect (cons (mapcan
Index: fomus/other.lisp diff -u fomus/other.lisp:1.3 fomus/other.lisp:1.4 --- fomus/other.lisp:1.3 Tue Jul 26 08:00:57 2005 +++ fomus/other.lisp Fri Jul 29 10:58:20 2005 @@ -56,6 +56,13 @@ finally (when so (setf (part-events p) (sort (part-events p) #'sort-offdur)))) (print-dot)))
+(defun preproc-tremolos (parts) + (loop for p in parts do + (loop for e in (part-events p) + for m = (or (popmark e :tremolofirst) (popmark e :tremolosecond)) + when m do (let ((x (force-list m))) + (addmark e (list (first x) (second x) (event-note* e))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PERCUSSION
Index: fomus/package.lisp diff -u fomus/package.lisp:1.6 fomus/package.lisp:1.7 --- fomus/package.lisp:1.6 Wed Jul 27 08:57:37 2005 +++ fomus/package.lisp Fri Jul 29 10:58:20 2005 @@ -46,15 +46,6 @@ (in-package :fomus)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 5)) -(defparameter +banner+ - `("Lisp music notation formatter" - "Copyright (c) 2005 David Psenicka, All Rights Reserved" - "See file "COPYING" for terms of use and distribution.")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; GLOBAL
(defparameter *verbose* 2)
Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.2 fomus/postproc.lisp:1.3 --- fomus/postproc.lisp:1.2 Mon Jul 25 09:56:03 2005 +++ fomus/postproc.lisp Fri Jul 29 10:58:20 2005 @@ -251,6 +251,89 @@ else when o do (addmark e b) (setf o nil)))) (print-dot))))
+;; preproc-tremolos already +;; must be called before preproc-tuplets, actually, should be before any other postprocs +(defun postproc-tremolos (pts) + (loop with fx + for p in pts do + (loop for m in (part-meas p) do + (loop with ee + for e in (meas-events m) do + (let* ((li nil) + (ma (or (force-list (popmark e :tremolo)) + (loop with xf + for x = (popmark e :tremolofirst) + while x + unless xf do (setf xf x) + do (push (third x) li) + finally (when xf (rmmark e :tremolosecond) (return xf))) + (loop with xf + for x = (popmark e :tremolosecond) + while x + unless xf do (setf xf x) + do (push (third x) li) + finally (return xf))))) + (if ma (let* ((d (second ma)) + (w (if d (let ((x (event-writtendur (copy-event e :dur d) (meas-timesig m)))) + (loop-return-lastmin (diff i x) for i = 1/8 then (/ i 2))) + 1/32))) + (let ((wd (event-writtendur e (meas-timesig m)))) + (multiple-value-bind (d o) (floor wd w) + (let ((re (if (> o 0) + (let ((x (split-event* e (- (event-endoff e) (* (event-dur* e) (/ o d)))))) + (let ((bm (min (event-nbeams (car x) (meas-timesig m)) (event-nbeams (cdr x) (meas-timesig m))))) + (setf (event-beamrt (car x)) bm (event-beamlt (cdr x)) bm)) + (push (cdr x) ee) + (setf fx t) + (car x)) + e))) + (let ((sy (first ma))) ; number of divisions, durational value of tremolo marking + (if (or (not (chordp re)) (eq sy :tremolo)) + (progn (push re ee) (addmark re (list :tremolo d w))) + (loop for n0 in (event-notes* re) + and nn in (event-note re) + and lt in (event-tielt re) + and rt in (event-tiert re) + if (if (eq sy :tremolofirst) (find n0 li) (not (find n0 li))) + collect nn into n1 and collect lt into lt1 + else collect nn into n2 and collect rt into rt2 + finally + (if (and n1 n2) + (let ((c1 (list>1p n1)) + (c2 (list>1p n2)) + (d2 (/ (event-dur* re) 2))) + (let ((e1 (copy-event re + :note (if c1 n1 (first n1)) + :tielt (if c1 lt1 (first lt1)) + :tiert (when c1 '(nil)) + :beamrt 0)) + (e2 (copy-event re + :off (+ (event-off e) d2) + :note (if c2 n2 (first n2)) + :tielt (when c2 '(nil)) + :tiert (if c2 rt2 (first rt2)) + :beamlt 0))) + (setf (event-dur* e1) d2 (event-dur* e2) d2) + (push e1 ee) (push e2 ee) (setf fx t) + (addmark e1 (list :starttremolo (/ d 2) w)) + (addmark e2 (list :endtremolo (/ d 2) w)))) + (progn (push re ee) (addmark re (list :tremolo d w))))))))))) + (push e ee))) + finally + (loop for g in (split-into-groups (setf (meas-events m) (sort ee #'sort-offdur)) #'event-voice*) do + (loop for (a b) on (sort g #'sort-offdur) + when (and b + (or (getmark a :tremolo) (getmark a :starttremolo) (getmark a :endtremolo)) + (or (getmark b :tremolo) (getmark b :starttremolo) (getmark b :endtremolo))) + do + (setf (event-tiert a) (when (consp (event-tiert a)) (make-list (length (event-tiert a)))) + (event-tielt b) (when (consp (event-tielt b)) (make-list (length (event-tielt b))))) + (when (or (getmark a :starttremolo) (getmark a :endtremolo) + (getmark b :starttremolo) (getmark b :endtremolo)) + (setf (event-beamrt a) 0 (event-beamlt b) 0)))))) + (print-dot) + finally (when fx (clean-ties pts)))) + (defun postproc-text (pts) (loop for p in pts do (loop for m in (part-meas p) @@ -294,6 +377,7 @@
;; do lots of nice things for the backend functions (defun postproc (pts) + (postproc-tremolos pts) (postproc-timesigs pts) (postproc-spanners pts) (postproc-voices pts) ;; voices now separated into lists
Index: fomus/split.lisp diff -u fomus/split.lisp:1.5 fomus/split.lisp:1.6 --- fomus/split.lisp:1.5 Wed Jul 27 08:57:37 2005 +++ fomus/split.lisp Fri Jul 29 10:58:20 2005 @@ -82,24 +82,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PREPROCESS
-;; return cons of two events (either may be nil) -;; copy = insure that returned events are copies -;; tup is inserted into first (left-side) return only -(defun split-event (event off &optional tup dmu) - (cond ((<= (event-endoff event) off) (cons (copy-event event :tup (cons (force-list tup) (force-list dmu))) nil)) - ((<= off (event-off event)) (cons nil (copy-event event))) - (t (etypecase event - (note (cons (copy-event event - :dur (- off (event-off event)) ; shouldn't be dealing with grace note - :tiert (if (chordp event) (make-list (length (event-tiert event)) :initial-element t) t) - :tup (cons (force-list tup) (force-list dmu))) - (copy-event event - :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 (force-list tup) (force-list dmu))) - (copy-event event :off off :dur (- (event-endoff event) off)))))))) - ;; adds rests, ties overlapping notes of different durs ;; returns values: notes in measure, notes outside measure ;; expects voices separated into parts, input is sorted, output is sorted
Index: fomus/util.lisp diff -u fomus/util.lisp:1.5 fomus/util.lisp:1.6 --- fomus/util.lisp:1.5 Tue Jul 26 08:00:57 2005 +++ fomus/util.lisp Fri Jul 29 10:58:20 2005 @@ -273,7 +273,7 @@ (sort (copy-list props) (lambda (x y) (string< (prin1-to-string (force-list x)) (prin1-to-string (force-list y))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; CHORDS +;; CHORDS/SPLITTING
;; list = sorted list of events of same offset/duration ;; rests are discarded @@ -296,6 +296,40 @@ :tiert (mapcar #'cddr x))) (copy-event (first r) :marks (combmarks r)))))
+;; return cons of two events (either may be nil) +;; copy = insure that returned events are copies +;; tup is inserted into first (left-side) return only unless both is t +(defun split-event (event off &optional tup dmu tup2) + (cond ((<= (event-endoff event) off) (cons (copy-event event :tup (cons (force-list tup) (force-list dmu))) nil)) + ((<= off (event-off event)) (cons nil (if tup2 (copy-event event :tup (cons (force-list tup2) (force-list dmu))) (copy-event event)))) + (t (etypecase event + (note (cons (copy-event event + :dur (- off (event-off event)) ; shouldn't be dealing with grace note + :tiert (if (chordp event) (make-list (length (event-tiert event)) :initial-element t) t) + :tup (cons (force-list tup) (force-list dmu))) + (if tup2 + (copy-event event + :off off + :dur (- (event-endoff event) off) + :tielt (if (chordp event) (make-list (length (event-tielt event)) :initial-element t) t) + :tup (cons (force-list tup2) (force-list dmu))) + (copy-event event + :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 (force-list tup) (force-list dmu))) + (if tup2 + (copy-event event :off off :dur (- (event-endoff event) off) :tup (cons (force-list tup2) (force-list dmu))) + (copy-event event :off off :dur (- (event-endoff event) off))))))))) + +(declaim (inline split-event*)) +(defun split-event* (event off) + (let ((du (event-dur* event) ) + (u (car (event-tup event)))) + (split-event event off + (when u (cons (* (first u) (/ (- off (event-off event)) du)) (rest u))) (cdr (event-tup event)) + (when u (cons (* (first u) (/ (- (event-endoff event) off) du)) (rest u)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; USER MARKS
@@ -319,6 +353,19 @@ do (mapc (lambda (x) (funcall fun x (rest me))) (remove-if-not (lambda (e) (and (> (event-endoff e) o1) (or (null o2) (< (event-off e) o2)))) events)))) +;; clean +;; deletes marks at incorrect places in tied notes/chords +;; expects measures and chords +(defun clean-ties (pts) + (loop for p in pts + do (loop for m in (part-meas p) + do (loop + for e in (remove-if-not #'notep (meas-events m)) + when (or (and (event-tielt e) (and-list (force-list (event-tielt e)))) (getmark e :endtremolo)) + do (mapc (lambda (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) (rmmark e x)) +marks-last-tie+))) (print-dot))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STAVES