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
