Ornamentations

Accidentals + :QUARTERTONES + :ACC-THROUGHOUT-MEAS :ACC-USE-DOUBLE @@ -474,7 +476,7 @@ Designates which function is to be used for determining note spellings. - Current possible values are :DEFAULT, :NOKEY1 and :NOKEY-QTONES1. + Current possible values are :DEFAULT and :NOKEY1. :DEFAULT is equivalent to :NOKEY1. @@ -628,8 +630,6 @@ Floating point numbers are treated with the RATIONALIZE function in this case (this isn't recommended). If offsets and durations of events aren't "notatable" then FOMUS will complain with an error. - - Note that mark objects aren't quantized (see class MARK for details). @@ -1462,6 +1462,21 @@ grace notes so that they don't exceed the durations of the notes they precede. This only applies to grace notes that are automatically generated by the quantizing algorithm. + + + + + + :QUARTERTONES + + + If set to T, FOMUS rounds pitches to quartertone values + and uses quartertone notation in the score. + + This only works if the algorithm specified by the AUTO-ACCS-FUN setting + supports it. + + Currently, :NOKEY1 supports quartertones. From dpsenicka at common-lisp.net Thu Jul 21 15:38:46 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Thu, 21 Jul 2005 17:38:46 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/README fomus/TODO fomus/accidentals.lisp fomus/backend_ly.lisp fomus/classes.lisp fomus/data.lisp fomus/final.lisp fomus/load.lisp fomus/main.lisp fomus/marks.lisp fomus/package.lisp fomus/quantize.lisp fomus/util.lisp Message-ID: <20050721153846.1F3FC88525@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv23246 Modified Files: TODO accidentals.lisp backend_ly.lisp classes.lisp data.lisp final.lisp load.lisp main.lisp marks.lisp package.lisp quantize.lisp util.lisp Added Files: README Log Message: Testing and bug fixes Date: Thu Jul 21 17:38:43 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.1.1.1 fomus/TODO:1.2 --- fomus/TODO:1.1.1.1 Tue Jul 19 20:17:01 2005 +++ fomus/TODO Thu Jul 21 17:38:42 2005 @@ -15,6 +15,7 @@ MIDI backend Profile and optimize code for speed Reorganize code, update comments +Reorganize settings MIDI input interface Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.1.1.1 fomus/accidentals.lisp:1.2 --- fomus/accidentals.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005 +++ fomus/accidentals.lisp Thu Jul 21 17:38:42 2005 @@ -221,20 +221,21 @@ (setf (part-events e) (sort (nconc rs (case (auto-accs-fun) - (:nokey1 (acc-nokey evs (if *acc-use-double* '(-2 -1 0 1 2) '(-1 0 1)) - #'nokey-spell #'nokey-intscore (part-name e) #'identity)) - (:nokey-qtones1 (acc-nokey evs (if *acc-use-double* - '(-2 -1 0 1 2 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2)) - '(-1 0 1 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2))) - #'nokeyq-spell #'nokeyq-intscore (part-name e) - (lambda (x) (if (consp x) x (cons x 0))))) + (:nokey1 (if *quartertones* + (acc-nokey evs (if *acc-use-double* + '(-2 -1 0 1 2 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2)) + '(-1 0 1 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2))) + #'nokeyq-spell #'nokeyq-intscore (part-name e) + (lambda (x) (if (consp x) x (cons x 0)))) + (acc-nokey evs (if *acc-use-double* '(-2 -1 0 1 2) '(-1 0 1)) + #'nokey-spell #'nokey-intscore (part-name e) #'identity))) (otherwise (error "Unknown accidental assignment function ~A" *auto-accs-fun*)))) #'sort-offdur))))) (defmacro set-note-precision (&body forms) - `(let ((*note-precision* + `(let ((*note-precision* (case (auto-accs-fun) - (:nokey-qtones1 1/2) + (:nokey1 (if *quartertones* 1/2 1)) (otherwise 1)))) , at forms)) @@ -299,7 +300,7 @@ #'sort-offdur))) (mapcar #'part-meas pa)))) (case (auto-accs-fun) ; m is list of measures (everything is sorted) - ((:nokey1 :nokey-qtones1) (acc-nokey-cautaccs ms)) + (:nokey1 (acc-nokey-cautaccs ms)) (otherwise (error "Unknown accidental assignment function ~A" *auto-accs-fun*)))))) (defun preproc-cautaccs (parts) @@ -349,7 +350,7 @@ (loop for m in (part-meas p) do (multiple-value-bind (evs rs) (split-list (meas-events m) #'notep) (case (auto-accs-fun) - ((:nokey1 :nokey-qtones1) (acc-nokey-postaccs evs)) + (:nokey1 (acc-nokey-postaccs evs)) (otherwise (error "Unknown accidental assignment function ~A" *auto-accs-fun*))) (setf (meas-events m) (sort (nconc rs evs) #'sort-offdur)))))) Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.1.1.1 fomus/backend_ly.lisp:1.2 --- fomus/backend_ly.lisp:1.1.1.1 Tue Jul 19 20:17:00 2005 +++ fomus/backend_ly.lisp Thu Jul 21 17:38:42 2005 @@ -115,233 +115,232 @@ (defun save-lilypond (parts filename options view) (when (>= *verbose* 1) (out ";; Saving Lilypond file \"~A\"...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) - (let ((qu (= *note-precision* 1/2))) - (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+)) - (loop for e in (if qu +lilypond-headq+ +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 - (let ((de 0) (nms nil)) - (flet ((lynote (wnum acc1 acc2 caut) - (if qu - (conc-strings - (svref +lilypond-num-note+ (mod wnum 12)) - (svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# - (when caut "?")) - (conc-strings - (svref +lilypond-num-note+ (mod wnum 12)) - (svref +lilypond-num-acc+ (+ acc1 2)) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# - (when caut "?")))) - (lyname (p) - (incf de) - (conc-strings - (string-downcase - (conc-stringlist (loop for x across (part-name p) - when (alpha-char-p x) - collect (string x)))) - (string (code-char (+ 64 de))))) - (lyclef (c) - (ecase c (:treble "treble") (:alto "alto") (:tenor "tenor") (:bass "bass") (:percussion "percussion")))) - (loop - for p in parts - do (destructuring-bind (&key (lily-partname (lyname p)) - 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)))) - ""))) - (push lily-partname nms) - (format f "~A = {~%" lily-partname) - (when (part-name p) (format f " ~A~%" (format nil +lilypond-set-instrument+ (part-name p)))) - (when (part-abbrev p) (format f " ~A~%" (format nil +lilypond-set-instr+ (part-abbrev p)))) - (when (or (null *timesig-style*) (eq *timesig-style* :fraction)) - (if (> ns 1) - (loop for s from 1 to ns do - (format f " ~A~A~%" (lystaff s) +lilypond-set-timesig-style-frac+)) - (format f " ~A~%" +lilypond-set-timesig-style-frac+))) - (when (eq *tuplet-style* :ratio) (format f " ~A~%" +lilypond-set-tup-style-ratio+)) - (format f " \\autoBeamOff~%") - (if *acc-throughout-meas* - (format f " ~A~%" +lilypond-set-acc-style-default+) - (format f " ~A~%" +lilypond-set-acc-style-forget+)) + (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+)) + (loop for e in (if *quartertones* +lilypond-headq+ +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 + (let ((de 0) (nms nil)) + (flet ((lynote (wnum acc1 acc2 caut) + (if *quartertones* + (conc-strings + (svref +lilypond-num-note+ (mod wnum 12)) + (svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (when caut "?")) + (conc-strings + (svref +lilypond-num-note+ (mod wnum 12)) + (svref +lilypond-num-acc+ (+ acc1 2)) + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (when caut "?")))) + (lyname (p) + (incf de) + (conc-strings + (string-downcase + (conc-stringlist (loop for x across (part-name p) + when (alpha-char-p x) + collect (string x)))) + (string (code-char (+ 64 de))))) + (lyclef (c) + (ecase c (:treble "treble") (:alto "alto") (:tenor "tenor") (:bass "bass") (:percussion "percussion")))) + (loop + for p in parts + do (destructuring-bind (&key (lily-partname (lyname p)) + 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)))) + ""))) + (push lily-partname nms) + (format f "~A = {~%" lily-partname) + (when (part-name p) (format f " ~A~%" (format nil +lilypond-set-instrument+ (part-name p)))) + (when (part-abbrev p) (format f " ~A~%" (format nil +lilypond-set-instr+ (part-abbrev p)))) + (when (or (null *timesig-style*) (eq *timesig-style* :fraction)) (if (> ns 1) - (loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do - (format f " ~A\\clef ~A~%" (lystaff s) (lyclef cl))) - (format f " \\clef ~A~%" (lyclef (second (getprop p :clef))))) - (loop for e in parthead do (format f " ~A~%" e)) - (format f "~%") - (loop - for m in (part-meas p) and mn from 1 - for ts = (meas-timesig m) do - (when (getprop m :startsig) (format f " \\time ~A/~A~%" (timesig-num ts) (timesig-den ts))) - (multiple-value-bind (s1 s2 s3) - (if (list>1p (meas-events m)) - (values " << { " "} \\\\~% { " "} >> ~A| % ~A~%") - (values " " nil "~A| % ~A~%")) - (format f s1) - (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 ")) - "")) - "") - 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 (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 i +lilypond-marks+))) + (loop for s from 1 to ns do + (format f " ~A~A~%" (lystaff s) +lilypond-set-timesig-style-frac+)) + (format f " ~A~%" +lilypond-set-timesig-style-frac+))) + (when (eq *tuplet-style* :ratio) (format f " ~A~%" +lilypond-set-tup-style-ratio+)) + (format f " \\autoBeamOff~%") + (if *acc-throughout-meas* + (format f " ~A~%" +lilypond-set-acc-style-default+) + (format f " ~A~%" +lilypond-set-acc-style-forget+)) + (if (> ns 1) + (loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do + (format f " ~A\\clef ~A~%" (lystaff s) (lyclef cl))) + (format f " \\clef ~A~%" (lyclef (second (getprop p :clef))))) + (loop for e in parthead do (format f " ~A~%" e)) + (format f "~%") + (loop + for m in (part-meas p) and mn from 1 + for ts = (meas-timesig m) do + (when (getprop m :startsig) (format f " \\time ~A/~A~%" (timesig-num ts) (timesig-den ts))) + (multiple-value-bind (s1 s2 s3) + (if (list>1p (meas-events m)) + (values " << { " "} \\\\~% { " "} >> ~A| % ~A~%") + (values " " nil "~A| % ~A~%")) + (format f s1) + (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 ")) + "")) + "") + 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 (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 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 - (sort (loop for a in +lilypond-dyns+ nconc (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 i +lilypond-marks+))) - and s1 = (conc-stringlist - (loop - for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :startslur-)) - collect "(")) - and s2 = (conc-stringlist - (loop - for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :endslur-)) - collect ")")) - and sl1 = (conc-stringlist - (loop - for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :startslur-)) - collect "(")) - and sl2 = (conc-stringlist - (loop - for xxx in (remove-if (lambda (x) (/= (third 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))) - when een do (format f s2)) - (format f s3 - (let ((x (getprop m :barline))) - (if x (format nil "\\bar \"~A\" " (lookup (second x) +lilypond-barlines+)) "")) - mn))) - (format f "}~%~%") - (if (> ns 1) - (format f "~A = {~% ~A~%}~%~%" - (conc-strings lily-partname "S") - (conc-stringlist - (loop with nu = 0 - for n = nil then (timesig-num (meas-timesig m)) - and d = nil then (timesig-den (meas-timesig m)) - for m in (part-meas p) - when (and (getprop m :startsig) (> nu 0)) - collect (format nil "\\skip 1*~A/~A*~A " n d nu) into re and do (setf nu 0) - do (incf nu) - finally (return (nconc re (list (format nil "\\skip 1*~A/~A*~A" n d nu)))))))))))) - (format f "\\score {~%") ;; score block - (loop for e in scorehead do (format f " ~A~%" e)) - (when (or *title* *subtitle* *composer*) - (format f " \\header {~%") - (when *title* (format f " title = \"~A\"~%" *title*)) - (when *subtitle* (format f " subtitle = \"~A\"~%" *subtitle*)) - (when *composer* (format f " composer = \"~A\"~%" *composer*)) - (format f " }~%")) - (loop - with in = 2 - for p in parts and nm in (nreverse nms) do - (loop - 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"))) - (:grandstaff (format f "~A\\new PianoStaff <<~%" (make-string in :initial-element #\space)))) - (format f "~A<<~%" (make-string in :initial-element #\space))) - (incf in 2)) - (let ((ns (instr-staves (part-instr p)))) - (if (<= ns 1) - (format f "~A\\new Staff \\~A~%" (make-string in :initial-element #\space) nm) - (progn - (loop for s from 1 to ns do (format f "~A\\context Staff = ~A \\~A~%" - (make-string in :initial-element #\space) - (code-char (+ 64 s)) - (conc-strings nm "S"))) - (format f "~A\\context Staff = A \\new Voice \\~A~%" (make-string in :initial-element #\space) nm)))) - (loop - for xxx in (getprops p :endgroup) - do (decf in 2) (format f "~A>>~%" (make-string in :initial-element #\space)))) - (format f "}~%")))))) + 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 + (sort (loop for a in +lilypond-dyns+ nconc (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 i +lilypond-marks+))) + and s1 = (conc-stringlist + (loop + for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :startslur-)) + collect "(")) + and s2 = (conc-stringlist + (loop + for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :endslur-)) + collect ")")) + and sl1 = (conc-stringlist + (loop + for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :startslur-)) + collect "(")) + and sl2 = (conc-stringlist + (loop + for xxx in (remove-if (lambda (x) (/= (third 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))) + when een do (format f s2)) + (format f s3 + (let ((x (getprop m :barline))) + (if x (format nil "\\bar \"~A\" " (lookup (second x) +lilypond-barlines+)) "")) + mn))) + (format f "}~%~%") + (if (> ns 1) + (format f "~A = {~% ~A~%}~%~%" + (conc-strings lily-partname "S") + (conc-stringlist + (loop with nu = 0 + for n = nil then (timesig-num (meas-timesig m)) + and d = nil then (timesig-den (meas-timesig m)) + for m in (part-meas p) + when (and (getprop m :startsig) (> nu 0)) + collect (format nil "\\skip 1*~A/~A*~A " n d nu) into re and do (setf nu 0) + do (incf nu) + finally (return (nconc re (list (format nil "\\skip 1*~A/~A*~A" n d nu)))))))))))) + (format f "\\score {~%") ;; score block + (loop for e in scorehead do (format f " ~A~%" e)) + (when (or *title* *subtitle* *composer*) + (format f " \\header {~%") + (when *title* (format f " title = \"~A\"~%" *title*)) + (when *subtitle* (format f " subtitle = \"~A\"~%" *subtitle*)) + (when *composer* (format f " composer = \"~A\"~%" *composer*)) + (format f " }~%")) + (loop + with in = 2 + for p in parts and nm in (nreverse nms) do + (loop + 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"))) + (:grandstaff (format f "~A\\new PianoStaff <<~%" (make-string in :initial-element #\space)))) + (format f "~A<<~%" (make-string in :initial-element #\space))) + (incf in 2)) + (let ((ns (instr-staves (part-instr p)))) + (if (<= ns 1) + (format f "~A\\new Staff \\~A~%" (make-string in :initial-element #\space) nm) + (progn + (loop for s from 1 to ns do (format f "~A\\context Staff = ~A \\~A~%" + (make-string in :initial-element #\space) + (code-char (+ 64 s)) + (conc-strings nm "S"))) + (format f "~A\\context Staff = A \\new Voice \\~A~%" (make-string in :initial-element #\space) nm)))) + (loop + for xxx in (getprops p :endgroup) + do (decf in 2) (format f "~A>>~%" (make-string in :initial-element #\space)))) + (format f "}~%"))))) (when view (view-lilypond filename options))) Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.1.1.1 fomus/classes.lisp:1.2 --- fomus/classes.lisp:1.1.1.1 Tue Jul 19 20:16:58 2005 +++ fomus/classes.lisp Thu Jul 21 17:38:42 2005 @@ -287,7 +287,7 @@ (defparameter +timesig-repl-type+ '(class* timesig-repl - (time (check* (and* (list-of* (integer 1)) (length* = 2)) "Found ~A, expected list ((INTEGER 1) (INTEGER 1)) in TIME slot" t)) + (time (check* (and* (list* (integer 1) (integer 1))) "Found ~A, expected list ((INTEGER 1) (INTEGER 1)) in TIME slot" t)) (beat (check* (or null (rational (0))) "Found ~A, expected (RATIONAL (0)) in BEAT slot" t)) (div (check* (or* null (list-of* (rational (0))) (list-of-unique* (list-of* (rational (0))))) "Found ~A, expected list of (RATIONAL (0)) or ((RATIONAL (0)) ...) in DIV slot" t)) (comp (check* boolean) "Found ~A, expected BOOLEAN in COMP slot" t) @@ -344,10 +344,10 @@ (class* part (name (check* (or null string) "Found ~A, expected STRING in NAME slot" t)) (abbrev (check* (or null string) "Found ~A, expected STRING in ABBREV slot" t)) - (opts (check* key-arg-pairs* "Found ~A, expected KEYWORD/ARGUMENT PAIRS in OPTS slot" t)) + (opts (check* key-arg-pairs* "Found ~A, expected KEYWORD/ARGUMENT-PAIRS in OPTS slot" t)) (events (check* (or* null (list-of* (check* (or note rest mark timesig) "Found ~A, expected NOTE, REST or TIMESIG in list in EVENTS slot" t))) "Expected list of NOTE, REST or TIMESIG in EVENTS slot")) - (instr (check* (or symbol instr (cons symbol (key-arg-pairs* , at +instr-keys+))) "Found ~A, expected SYMBOL, INSTR or (SYMBOL KEYWORD/ARGUMENT PAIRS) in INSTR slot" t)) + (instr (check* (or* symbol instr (cons* symbol (key-arg-pairs* , at +instr-keys+))) "Found ~A, expected SYMBOL, INSTR or (SYMBOL KEYWORD/ARGUMENT-PAIRS...) in INSTR slot" t)) (partid (check* (or symbol real) "Found ~A, expected SYMBOL or REAL in PARTID slot" t)))) (with-error* (part "~~A, part ~A" (function part-name)) (class* part Index: fomus/data.lisp diff -u fomus/data.lisp:1.1.1.1 fomus/data.lisp:1.2 --- fomus/data.lisp:1.1.1.1 Tue Jul 19 20:16:57 2005 +++ fomus/data.lisp Thu Jul 21 17:38:42 2005 @@ -23,8 +23,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; QUANTIZING -(declaim (special *note-precision*)) - ;; nested tuplets indicated by a list (defparameter *max-tuplet* 7) @@ -33,6 +31,10 @@ (defparameter *min-tuplet-dur* 1/2) ; fraction of beat smallest tuplets should span at minimum (1/2 = half a beat, etc.)--can be nil (defparameter *max-tuplet-dur* 4) +;; pitch quantizing +(declaim (special *note-precision*)) +(defparameter *quartertones* nil) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CONVERSION @@ -283,7 +285,7 @@ (:use-cm boolean) (:cm-scale t) (:loadxmls-fun (or function string symbol)) (:backend (or* (cons* symbol key-arg-pairs*) (list-of* (cons* symbol key-arg-pairs*))) - "(SYMBOL KEYWORD/ARGUMENTS PAIRS ...) or list of (SYMBOL KEYWORD/ARGUMENTS PAIRS ...)") + "(SYMBOL KEYWORD/ARGUMENTS-PAIRS...) or list of (SYMBOL KEYWORD/ARGUMENTS-PAIRS...)") (:base-filename string) (:global (or* null (list-of* (type* +timesig-type+))) "list of TIMESIG objects") @@ -304,7 +306,8 @@ (:default-grace-dur (rational (0))) (:default-grace-num integer) (:effective-grace-dur-mul (rational (0))) (:min-auto-timesig-dur (rational (0))) (:default-timesig (type* +timesig-repl-type+) "TIMESIG object") - + + (:quartertones boolean) (:auto-accidentals boolean) (:auto-cautionary-accs boolean) (:auto-staff/clef-changes boolean) (:auto-ottavas boolean) (:auto-grace-slurs boolean) (:auto-voicing boolean) (:auto-beams boolean) (:auto-quantize boolean) (:auto-multivoice-rests boolean) (:auto-multivoice-notes boolean) Index: fomus/final.lisp diff -u fomus/final.lisp:1.1.1.1 fomus/final.lisp:1.2 --- fomus/final.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/final.lisp Thu Jul 21 17:38:43 2005 @@ -24,7 +24,7 @@ for x = (read f nil 'eof) until (eq x 'eof) for y = (read f nil 'eof) - when (eq y 'eof) do (error "KEYWORD/ARGUMENT PAIRS expected in initialization file") + 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 ~A~%" x) @@ -43,10 +43,10 @@ ;; print load greeting (eval-when (:load-toplevel :execute) - (when (>= *verbose* 1) (format t ";; ~A v~A.~A.~A~%;; ~A~%;; ~A~%;; ~A~%~%" + (when (>= *verbose* 1) (format t ";; ~A v~A.~A.~A~%~A~%" +title+ (first +version+) (second +version+) (third +version+) - +subtitle+ +copyright+ +termscond+))) + (conc-stringlist (loop for e in +banner+ collect (format nil ";; ~A~%" e)))))) (eval-when (:load-toplevel :execute) (load-initfile)) Index: fomus/load.lisp diff -u fomus/load.lisp:1.1.1.1 fomus/load.lisp:1.2 --- fomus/load.lisp:1.1.1.1 Tue Jul 19 20:17:01 2005 +++ fomus/load.lisp Thu Jul 21 17:38:43 2005 @@ -1,11 +1,11 @@ ;; -*-lisp-*- ;; Load file for FOMUS -(with-open-file (f (merge-pathnames "fomus.asd" *load-pathname*) :direction :input) - (destructuring-bind (xxx1 xxx2 &key components &allow-other-keys) (read f) - (declare (ignore xxx1 xxx2)) - (loop for (xxx na) in components - for cl = (merge-pathnames na *load-pathname*) - for cn = (compile-file-pathname cl) - when (>= (file-write-date cl) (file-write-date cn)) do (compile-file cl) - do (load cn)))) \ No newline at end of file +(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 Index: fomus/main.lisp diff -u fomus/main.lisp:1.1.1.1 fomus/main.lisp:1.2 --- fomus/main.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005 +++ fomus/main.lisp Thu Jul 21 17:38:43 2005 @@ -34,7 +34,9 @@ (defun save-debug () (when (>= *verbose* 2) (out "~&; Saving debug file \"~A\"..." *debug-filename*)) (with-open-file (f *debug-filename* :direction :output :if-exists :supersede) - (format f ";; -*-lisp-*-~%;; ~A v~A.~A.~A~%~%(FOMUS~%" +title+ (first +version+) (second +version+) (third +version+)) + (format f ";; -*-lisp-*-~%;; ~A v~A.~A.~A~%;; ~A ~A~%~%(FOMUS~%" + +title+ (first +version+) (second +version+) (third +version+) + (lisp-implementation-type) (lisp-implementation-version)) (mapc (lambda (s) (format f " ~S ~S~&" (first s) (let ((x (symbol-value (find-symbol (conc-strings "*" (symbol-name (first s)) "*") :fomus)))) @@ -183,6 +185,6 @@ (let ((r (fomus-proc))) (loop for x in (or (force-list2 *backend*) '((:data))) do (destructuring-bind (ba &key filename view &allow-other-keys) x - (set-note-precision (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x view))))) + (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x view)))) t) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.1.1.1 fomus/marks.lisp:1.2 --- fomus/marks.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/marks.lisp Thu Jul 21 17:38:43 2005 @@ -99,7 +99,7 @@ for k = (pop mks) while k do (loop with fo = (listp (event-off k)) ; fuzzy offset? (next available note forwards or backwards) with nu = (if fo (first (event-off k)) (event-off k)) - with o = (abs nu) and di = (>= nu 0) ; offset and direction + with o0 = (abs nu) and di = (>= nu 0) ; offset and direction for m in (event-marks k) do (loop with fl = (force-list m) with sy = (first fl) @@ -133,15 +133,21 @@ collect e) (if (null vo) l (remove-if-not (lambda (e) (find (event-voice* e) vo)) l))))) (if re r (remove-if #'restp r))))) - (if di - (if fo - (loop for e in (rm fo) until (> (event-off e) o) finally (return e)) - (loop for (e1 e2) on (cons nil (rm fo)) until (or (null e2) (> (event-off e2) o)) - finally (return (or e1 e2)))) - (if fo - (loop for e in (rm ba) until (< (event-endoff e) o) finally (return e)) - (loop for (e1 e2) on (cons nil (rm ba)) until (or (null e2) (< (event-endoff e2) o)) - finally (return (or e1 e2)))))))) + (let ((o (let ((q (getprop p :quant))) ; fix quantize error + (if q (let ((x (find-if (lambda (x) (and (<= (car x) o0) (>= (cdr x) o0))) (rest q)))) + (if x (cdr x) o0)) + o0)))) + (if di + (if fo + (loop for e in (rm fo) until (> (event-off e) o) finally (return e)) + (loop for (e1 e2) on (cons nil (rm fo)) until (or (null e2) (> (event-off e2) o)) + finally (return (or e1 e2)))) + (if fo + (loop for e in (rm ba) until (< (event-endoff e) o) finally (return e)) + (loop for (e1 e2) on (cons nil (rm ba)) until (or (null e2) (< (event-endoff e2) o)) + finally (return (or e1 e2))))))))) (if (eq sy :mark) (push (copy-event k :off (second fl) :voice (event-voice* ev) :marks (list (cddr fl))) mks) - (addmark ev m))))) (print-dot))) \ No newline at end of file + (addmark ev m))))) + (print-dot) + finally (mapc (lambda (p) (rmprop p :quant)) pts))) \ No newline at end of file Index: fomus/package.lisp diff -u fomus/package.lisp:1.1.1.1 fomus/package.lisp:1.2 --- fomus/package.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005 +++ fomus/package.lisp Thu Jul 21 17:38:43 2005 @@ -20,6 +20,7 @@ (:use "COMMON-LISP" #|"MISCFUNS"|#) (:export "FOMUS" "LOAD-INITFILE" ; interface functions "FOMUS-INIT" "FOMUS-NEWTIMESIG" "FOMUS-NEWPART" "FOMUS-NEWMARK" "FOMUS-NEWNOTE" "FOMUS-NEWREST" "FOMUS-EXEC" "FOMUS-PART" + "LIST-FOMUS-SETTINGS" ; make/copy functions "MAKE-TIMESIG" "MAKE-TIMESIG-REPL" "MAKE-PART" "MARK-MARK" "MAKE-NOTE" "MAKE-REST" "MAKE-INSTR" "MAKE-PERC" "COPY-INSTR" "COPY-PERC" "MAKE-MEAS" "COPY-TIMESIG" "COPY-TIMESIG-REPL" "COPY-EVENT" "COPY-PART" "COPY-MEAS" @@ -56,10 +57,11 @@ (use-package "DBG" "FM"))) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 0)) -(defparameter +subtitle+ "Lisp music notation formatter") -(defparameter +copyright+ "Copyright (c) 2005 David Psenicka, All Rights Reserved") -(defparameter +termscond+ "See file \"COPYING\" for terms of use and distribution") +(defparameter +version+ '(0 1 1)) +(defparameter +banner+ + `("Lisp music notation formatter" + "Copyright (c) 2005 David Psenicka, All Rights Reserved" + "See file \"COPYING\" for terms of use and distribution.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; GLOBAL Index: fomus/quantize.lisp diff -u fomus/quantize.lisp:1.1.1.1 fomus/quantize.lisp:1.2 --- fomus/quantize.lisp:1.1.1.1 Tue Jul 19 20:17:00 2005 +++ fomus/quantize.lisp Thu Jul 21 17:38:43 2005 @@ -97,16 +97,20 @@ #'<))) (loop with mg = (or (max-list (loop for e in (part-events p) when (event-grace e) collect (event-grace e))) (1- *default-grace-num*)) + and ad for e in (part-events p) do (let ((o (event-off e))) (loop while (and (list>1p qs) (< (second qs) o)) do (pop qs)) (let ((e1 (loop-return-firstmin (diff x o) for x in qs))) (if (event-grace e) - (setf (event-off e) e1 - (event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s)))))) - (let ((x (roundto (event-gracedur e) bd))) - (when (<= x 0) bd x)))) + (progn + (push (cons (event-off e) e1) ad) + (setf (event-off e) e1 + (event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s)))))) + (let ((x (roundto (event-gracedur e) bd))) + (when (<= x 0) bd x))))) (let ((e2 (let ((o (event-endoff e))) (loop-return-lastmin (diff x o) for x in qs)))) + (push (cons (event-off e) e1) ad) (setf (event-off e) e1) (let ((x (- e2 e1))) (if (<= x 0) @@ -115,7 +119,21 @@ (setf (event-dur e) (cons (- (loop for i in qs until (> i e1) finally (return i)) e1) (incf mg)))) - (setf (event-dur* e) x)))))))))) + (progn + (push (cons (event-endoff e) e2) ad) + (setf (event-dur* e) x)))))))) + finally + (addprop p (cons :quant + (merge-all ad (lambda (x y) (let ((x1 (car x)) (x2 (cdr x)) + (y1 (car y)) (y2 (cdr y))) + (when (= x2 y2) + (cons (if (< x1 x2) + #+debug (if (<= y1 y2) (min x1 y1) (error "Error in QUANTIZE-BYFIT 3")) + #-debug (min x1 y1) + #+debug (if (>= y1 y2) (max x1 y1) (error "Error in QUANTIZE-BYFIT 4")) + #-debug (max x1 y1)) + x2)))) + :call-rev nil)))))) (print-dot))))) (defun quantize (timesigs parts) Index: fomus/util.lisp diff -u fomus/util.lisp:1.1.1.1 fomus/util.lisp:1.2 --- fomus/util.lisp:1.1.1.1 Tue Jul 19 20:16:58 2005 +++ fomus/util.lisp Thu Jul 21 17:38:43 2005 @@ -569,3 +569,15 @@ :time (cons (first (timesig-time ts)) (second (timesig-time ts)))))) (timesig-check nt) nt)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; USER UTILITIES + +(defun list-fomus-settings () + (let* ((tc (+ 2 (max (1+ (loop for x in +settings+ maximize (length (symbol-name (first x))))) 4))) + (tl (+ tc 1 (max (loop for (xxx t1 t2) in +settings+ maximize (length (or t2 (princ-to-string t1)))) 4)))) + (format t "; NAME~VTTYPE~VTDEFAULT VALUE~%~%" tc tl) + (loop for (sy t1 t2) in +settings+ do + (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))))))) + + \ No newline at end of file From dpsenicka at common-lisp.net Sat Jul 23 09:23:19 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Sat, 23 Jul 2005 11:23:19 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/TODO fomus/accidentals.lisp fomus/backend_ly.lisp fomus/classes.lisp fomus/data.lisp fomus/interface.lisp fomus/main.lisp fomus/marks.lisp fomus/misc.lisp fomus/package.lisp fomus/split.lisp fomus/util.lisp Message-ID: <20050723092319.F338E88526@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20942 Modified Files: TODO accidentals.lisp backend_ly.lisp classes.lisp data.lisp interface.lisp main.lisp marks.lisp misc.lisp package.lisp split.lisp util.lisp Log Message: Testing/bug fixes Date: Sat Jul 23 11:23:14 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.2 fomus/TODO:1.3 --- fomus/TODO:1.2 Thu Jul 21 17:38:42 2005 +++ fomus/TODO Sat Jul 23 11:23:14 2005 @@ -3,6 +3,12 @@ IMMEDIATE Testing and bug fixes +BUG: :startslur- and :slur- marks +BUG: error in beams in CMUCL +DOC: dynamics marks can take order arguments (backend might not support it) +DOC: make sure user knows to use the package +DOC: make sure user knows about :default-beat setting +Adjust scores and penalties for decent results @@ -17,6 +23,7 @@ Reorganize code, update comments Reorganize settings MIDI input interface +Support for polymeters in backends @@ -24,4 +31,4 @@ Features for proportional notation (generate hidden rests of constant duration?) Key signatures (key detection algorithm) -Combine sections with different settings into one score +Combine separately notated sections with different settings into one score (concatenate multiple .fms files?) Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.2 fomus/accidentals.lisp:1.3 --- fomus/accidentals.lisp:1.2 Thu Jul 21 17:38:42 2005 +++ fomus/accidentals.lisp Sat Jul 23 11:23:14 2005 @@ -114,7 +114,7 @@ (aa n2 a2)))) (if qt v (max v 0))))))) (defun nokeyq-intscore (tie note1 acc1 off1 eoff1 note2 acc2 off2 eoff2) - (let ((s (nokey-intscore (- note1 (cdr acc1)) (car acc1) off1 eoff1 (- note2 (cdr acc2)) (car acc2) off2 eoff2 t))) + (let ((s (nokey-intscore tie (- note1 (cdr acc1)) (car acc1) off1 eoff1 (- note2 (cdr acc2)) (car acc2) off2 eoff2 t))) (if (and (= (cdr acc1) 0) (= (cdr acc2) 0)) (max s 0) (let ((a1 (if (= (cdr acc1) 0) (car acc1) (cdr acc1))) (a2 (if (= (cdr acc2) 0) (car acc2) (cdr acc2)))) Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.2 fomus/backend_ly.lisp:1.3 --- fomus/backend_ly.lisp:1.2 Thu Jul 21 17:38:42 2005 +++ fomus/backend_ly.lisp Sat Jul 23 11:23:14 2005 @@ -69,9 +69,6 @@ ;; LILYPOND BACKEND (defparameter +lilypond-head+ - '("\\version \"2.4.2\"" - "\\include \"english.ly\"")) -(defparameter +lilypond-headq+ ;; quarter tones aren't supported in english '("\\version \"2.4.2\"")) (defparameter +lilypond-defs+ '("octUp = #(set-octavation 1)" @@ -83,8 +80,8 @@ )) (defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b")) -(defparameter +lilypond-num-acc+ (vector "ff" "f" "" "s" "ss")) -(defparameter +lilypond-num-accq+ (vector (vector nil "eseh") (vector "eseh" "es" "eh") (vector "eh" "" "ih") (vector "ih" "is" "isih") (vector nil "isis"))) +(defparameter +lilypond-num-acc+ (vector "eses" "es" "" "is" "isis")) +(defparameter +lilypond-num-accq+ (vector (vector nil "eses") (vector "eseh" "es" "eh") (vector "eh" "" "ih") (vector "ih" "is" "isih") (vector nil "isis"))) (defparameter +lilypond-num-reg+ (vector ",,," ",," "," "" "'" "''" "'''" "''''" "'''''")) (defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . ""))) @@ -118,7 +115,7 @@ (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+)) - (loop for e in (if *quartertones* +lilypond-headq+ +lilypond-head+) do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top + (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 (let ((de 0) (nms nil)) @@ -252,11 +249,11 @@ (t ""))) and ar = (conc-stringlist (loop for i in - (sort (loop for a in +lilypond-marks+ nconc (getmarks e (car a))) + (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 i +lilypond-marks+))) + 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-)) "\\> ") @@ -270,26 +267,23 @@ (t "")) and dyn = (conc-stringlist (loop for i in - (sort (loop for a in +lilypond-dyns+ nconc (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 i +lilypond-marks+))) + (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 (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :startslur-)) + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-)) collect "(")) and s2 = (conc-stringlist (loop - for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :endslur-)) + for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-)) collect ")")) and sl1 = (conc-stringlist (loop - for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :startslur-)) + for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-)) collect "(")) and sl2 = (conc-stringlist (loop - for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :endslur-)) + 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))) when een do (format f s2)) Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.2 fomus/classes.lisp:1.3 --- fomus/classes.lisp:1.2 Thu Jul 21 17:38:42 2005 +++ fomus/classes.lisp Sat Jul 23 11:23:14 2005 @@ -120,7 +120,7 @@ (declaim (inline timesig-num timesig-den)) (defun timesig-num (ts) (car (timesig-time ts))) (defun timesig-den (ts) (cdr (timesig-time ts))) -(defun timesig-beat* (ts) (if (timesig-comp ts) (/ 3 (timesig-den ts)) (or (timesig-beat ts) (/ (timesig-den ts))))) +(defun timesig-beat* (ts) (if (timesig-comp ts) (/ 3 (timesig-den ts)) (or (timesig-beat ts) *default-beat* (/ (timesig-den ts))))) (declaim (inline obj-partid)) (defgeneric obj-partid (x)) Index: fomus/data.lisp diff -u fomus/data.lisp:1.2 fomus/data.lisp:1.3 --- fomus/data.lisp:1.2 Thu Jul 21 17:38:42 2005 +++ fomus/data.lisp Sat Jul 23 11:23:14 2005 @@ -31,6 +31,8 @@ (defparameter *min-tuplet-dur* 1/2) ; fraction of beat smallest tuplets should span at minimum (1/2 = half a beat, etc.)--can be nil (defparameter *max-tuplet-dur* 4) +(defparameter *default-beat* nil) + ;; pitch quantizing (declaim (special *note-precision*)) (defparameter *quartertones* nil) @@ -321,7 +323,8 @@ (:default-meas-divs (or* null (list-of* (cons* (rational 0) (list-of* (list-of* (rational 0)))))) "list of ((RATIONAL (0)) (((RATIONAL (0)) ...) ...))") (:use-default-tuplet-divs boolean) (:default-tuplet-divs (or* null (list-of* (cons* (integer 1) (list-of* (list-of* (integer 1)))))) "list of ((INTEGER 1) (((INTEGER 1) ...) ...))") - + + (:default-beat (or null (rational (0)))) (:beat-division (or* (integer 1) (and (list* (integer 1) (integer 1)) (length* = 2))) "(INTEGER 1) or ((INTEGER 1) (INTEGER 1))") (:min-tuplet-dur (real (0))) (:max-tuplet-dur (real (0))) (:min-simple-tuplet-dur (real (0))) (:max-tuplet (or* (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)") @@ -377,9 +380,9 @@ :startwedge> :startwedge< :wedge- :endwedge- :startgraceslur- :graceslur- :endgraceslur- :clef- :endclef- - :rfz :sfz :spp :sp :sff :sf :fp :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp - :cautacc)))) - x (list* x)) ; spanners w/ only 1 level, non-articulations + :cautacc + :rfz :sfz :spp :sp :sff :sf :fp :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp)))) + (or* x (list* x))) ; spanners w/ only 1 level, non-articulations (let* ((x (unique* sy (find* :fermata)))) (or* x (list* x) (list* x (find* :short :long :verylong)))) (let* ((x (unique* sy (find* :arpeggio)))) @@ -399,7 +402,7 @@ :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)))) - (or* x (list* x) (list* x integer))) ; articulations, some spanners + (or* x (list* x) (list* x integer))) ; articulations, dynamics, some spanners (let* ((x (unique* sy :clef (find* :clef :startclef-)))) (list* x (function* is-clef))) (let* ((x (unique* sy (find* :notehead)))) @@ -412,7 +415,7 @@ (unique* si 1 (eql* :dotted)) (list* (unique* si integer) (eql* :dotted)) (list* (eql* :dotted) (unique* si integer)))))) ; startslur- - (let* ((x (unique* sy (find* :slur- :endslur-)))) + (let* ((x (find* :slur- :endslur-))) (or* (unique* si 1 x) (unique* si 1 (list* x)) (list* x (unique* si integer)))) (let* ((x (find* :textnote :texttempo :textdyn :text))) (list* x string)) ; text @@ -435,21 +438,30 @@ (list* string (unique* tx integer)) (list* (unique* tx integer) string)))))) +(defparameter *checktype-markerr* "Found ~A, expected valid/unique mark") +(defparameter *checktype-markserr* "Found ~A, expected list of valid marks") + (defparameter +notemarks-type+ - '(with-unique* (sy si tt td tx) - (list-of* - (check* (type* +notemark-type+) "Found ~A, expected valid mark" t)))) + '(check* + (with-unique* (sy si tt td tx) + (list-of* + (check* (type* +notemark-type+) *checktype-markerr* t))) + *checktype-markserr* t)) (defparameter +markmarks-type+ - '(with-unique* (sy si tt td tx) - (list-of* - (check* (or* (type* +notemark-type+) - (cons (eql* :mark) (cons (or* (real 0) (list* real)) (and* list (type* +notemark-type+))))) - "Found ~A, expected valid mark" t)))) + '(check* + (with-unique* (sy si tt td tx) + (list-of* + (check* (or* (type* +notemark-type+) + (cons (eql* :mark) (cons (or* (real 0) (list* real)) (and* list (type* +notemark-type+))))) + *checktype-markerr* t))) + *checktype-markserr* t)) (defparameter +restmarks-type+ '(and* - (list-of* (check* (or* (satisfies is-restmarksym) (cons* (satisfies is-restmarksym) list)) "Found ~A, expected valid mark" t)) + (check* + (list-of* (check* (or* (satisfies is-restmarksym) (cons* (satisfies is-restmarksym) list)) *checktype-markerr* t)) + *checktype-markserr* t) (type* +notemarks-type+))) (defparameter +marks-rests+ Index: fomus/interface.lisp diff -u fomus/interface.lisp:1.1.1.1 fomus/interface.lisp:1.2 --- fomus/interface.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/interface.lisp Sat Jul 23 11:23:14 2005 @@ -72,6 +72,10 @@ (let ((re (apply #'make-instance 'rest :partid partid args))) (push re *fomus-events*) t)) +(defun fomus-newmark (partid &rest args) + (let ((re (apply #'make-instance 'mark :partid partid args))) + (push re *fomus-events*) + t)) ;;(declaim (inline fomus-part)) (defun fomus-part (sym) @@ -81,9 +85,9 @@ (defun fomus-exec (&rest args) (unwind-protect (apply #'fomus - :global *fomus-global* - :parts (nreverse *fomus-parts*) - :events *fomus-events* + :global (append *global* *fomus-global*) + :parts (append *parts* (nreverse *fomus-parts*)) + :events (append *events* *fomus-events*) (append args *fomus-args*)) (fomus-init))) Index: fomus/main.lisp diff -u fomus/main.lisp:1.2 fomus/main.lisp:1.3 --- fomus/main.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/main.lisp Sat Jul 23 11:23:14 2005 @@ -52,7 +52,7 @@ (when (and (numberp *verbose*) (>= *verbose* 1)) (out ";; Formatting music...")) (when *debug-filename* (save-debug)) (when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types...")) - (check-settings-types) + (check-setting-types) (find-cm) (check-settings) (multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp) @@ -151,7 +151,7 @@ (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...")) + (when (>= *verbose* 2) (out "~&; Splits/ties/rests...")) (split pts) #+debug (fomus-proc-check pts 'ties) (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2) (when *auto-beams* Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.2 fomus/marks.lisp:1.3 --- fomus/marks.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/marks.lisp Sat Jul 23 11:23:14 2005 @@ -63,7 +63,7 @@ (addmark e (if a2 (list startsym n a2) (list startsym n))) ; fixed order now--level is mandatory 1st argument, modifier is optional (decf nu)) (error "Levels for marks ~A, ~A and ~A are out of order at offset ~A, part ~A" startsym contsym endsym (event-foff e) (part-name p))) - (error "Missing ending marks ~A or ~A for starting mark ~A at offset ~A, part ~A" contsym endsym startsym (event-foff e) (part-name p)))))) + (error "Missing ending mark ~A or ~A for starting mark ~A at offset ~A, part ~A" contsym endsym startsym (event-foff e) (part-name p)))))) finally (or (= nu 0) (error "Missing starting mark ~A in part ~A" startsym (part-name p)))) (print-dot)))) (defun expand-marks (pts) Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.1.1.1 fomus/misc.lisp:1.2 --- fomus/misc.lisp:1.1.1.1 Tue Jul 19 20:16:56 2005 +++ fomus/misc.lisp Sat Jul 23 11:23:14 2005 @@ -301,7 +301,7 @@ ;; slightly more complicated type checking (defun check-type* (obj type &optional er un lt) (flet ((get-error (x) - (apply #'format nil (first x) + (apply #'format nil (typecase (first x) (symbol (symbol-value (first x))) (otherwise (first x))) (mapcar (lambda (z) (if (truep z) obj (cond ((functionp z) (funcall z obj)) @@ -341,7 +341,7 @@ (o (if th se obj))) (unless (find o (cdr x) :test #'equal) (push o (cdr x)) - (check-type* obj se er un lt)))) + (check-type* obj (or th se) er un lt)))) (let* (mapcar (lambda (x) (push (cons (first x) (second x)) lt)) fi) (check-type* obj se er un lt)) (error* (let ((x (get-error ty))) (if er (error er x) (error x)))) (with-error* (if (or (stringp (first fi)) (check-type* obj (first fi) er un lt)) Index: fomus/package.lisp diff -u fomus/package.lisp:1.2 fomus/package.lisp:1.3 --- fomus/package.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/package.lisp Sat Jul 23 11:23:14 2005 @@ -8,10 +8,6 @@ (eval-when (:compile-toplevel) (declaim (optimize (safety 3) (debug 3)))) -;; debug feature flag -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew :debug *features*)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PACKAGE @@ -57,7 +53,7 @@ (use-package "DBG" "FM"))) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 1)) +(defparameter +version+ '(0 1 2)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved" Index: fomus/split.lisp diff -u fomus/split.lisp:1.1.1.1 fomus/split.lisp:1.2 --- fomus/split.lisp:1.1.1.1 Tue Jul 19 20:16:57 2005 +++ fomus/split.lisp Sat Jul 23 11:23:14 2005 @@ -233,7 +233,7 @@ (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* :top) ; b bah.. bah.. bah.. b +(defparameter *syncopated-notes-level* t) ; b bah.. bah.. bah.. b (defparameter *double-dotted-notes* t) ; = t if can use double dotted notes (defparameter *tuplet-dotted-rests* t) @@ -274,18 +274,18 @@ (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) (if #|(> num (/ n))|# (if (rule-comp rule) (>= 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))))) + (snd (n 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 (etypecase rule (initdiv (in n al ar nil)) - (sig (if #|(> num (/ n))|# (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 (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))))))) + (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 in (force-list2 (rule-list rule)) @@ -304,7 +304,7 @@ (and (expof2 xx) (or (= num xx) (expof2 (- num xx))))) collect (in i la (or (null n) aa) ee))))))) (sig (loop - for nn in (or (lowmult num) (if (rule-comp rule) '(3) '(2))) + for nn in (or (lowmult (numerator num)) (if (rule-comp rule) '(3) '(2))) nconc (loop for j from 1 below nn for x = (/ j nn) ; x is the ratio @@ -324,13 +324,21 @@ (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 (al *syncopated-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3)) + (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))) - (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))))) + (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 (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) (loop with nu = (if (rule-comp rule) (* num 3/2) num) @@ -366,7 +374,7 @@ (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 + (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 (and tups (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) (let ((l (length (force-list (rule-tup rule))))) (when (< l mn) Index: fomus/util.lisp diff -u fomus/util.lisp:1.2 fomus/util.lisp:1.3 --- fomus/util.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/util.lisp Sat Jul 23 11:23:14 2005 @@ -183,7 +183,7 @@ for x = (let ((bb (* nb d))) (or (lookup bb *default-meas-divs*) (lookup bb +default-meas-divs+))) - when x do (return (mapcar (lambda (y) (/ y d)) x)))))))) + when x do (return (loop for y in x collect (mapcar (lambda (z) (/ z d)) y))))))))) (defparameter *effective-grace-dur-mul* 1/2) ; multiplier for effective duration of grace notes--use this in any algorithm that needs a small durational value for grace notes @@ -475,7 +475,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CHECK SETTINGS -(defun check-settings-types () +(defun check-setting-types () (loop for (sy ty er) in +settings+ do (let ((v (symbol-value (find-symbol (conc-strings "*" (symbol-name sy) "*") :fomus)))) (or (check-type* v ty) (error "Found ~A, expected ~A in setting ~A" v (or er ty) sy))))) From dpsenicka at common-lisp.net Mon Jul 25 07:56:10 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Mon, 25 Jul 2005 09:56:10 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/README fomus/TODO fomus/backend_ly.lisp fomus/backends.lisp fomus/data.lisp fomus/main.lisp fomus/marks.lisp fomus/package.lisp fomus/postproc.lisp fomus/quantize.lisp fomus/split.lisp fomus/voices.lisp Message-ID: <20050725075610.14F9688165@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv10374 Modified Files: README TODO backend_ly.lisp backends.lisp data.lisp main.lisp marks.lisp package.lisp postproc.lisp quantize.lisp split.lisp voices.lisp Log Message: Testing/bug fixes Date: Mon Jul 25 09:56:03 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.1 fomus/README:1.2 --- fomus/README:1.1 Thu Jul 21 17:38:42 2005 +++ fomus/README Mon Jul 25 09:56:03 2005 @@ -2,12 +2,15 @@ Lisp music notation formatter Fomus is alpha software, and still has a lot of testing and bug fixing to go -before all of its features are useable. +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 +slowly due to some settings being currently set to conservative values. 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 be supported in Allegro Common Lisp and CLISP. Index: fomus/TODO diff -u fomus/TODO:1.3 fomus/TODO:1.4 --- fomus/TODO:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/TODO Mon Jul 25 09:56:03 2005 @@ -3,12 +3,15 @@ IMMEDIATE Testing and bug fixes -BUG: :startslur- and :slur- marks +Information on anonymous CVS downloading BUG: error in beams in CMUCL -DOC: dynamics marks can take order arguments (backend might not support it) -DOC: make sure user knows to use the package -DOC: make sure user knows about :default-beat setting +DOC: dynamic marks can take order arguments (backend might not support it) +DOC: other interface functions +DOC: part properties Adjust scores and penalties for decent results +Breath marks (resolve before/after) +Noteheads +Fix fingering mark (no finger number argument) @@ -24,6 +27,9 @@ Reorganize settings MIDI input interface Support for polymeters in backends +Integrate user graceslur overrides +Levels for single text marks +Remove redundant dynamic marks Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.3 fomus/backend_ly.lisp:1.4 --- fomus/backend_ly.lisp:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/backend_ly.lisp Mon Jul 25 09:56:03 2005 @@ -43,7 +43,7 @@ (defparameter +lilypond-out-ext+ "ps") (defparameter +lilypond-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app")) -(defun view-lilypond (filename options) +(defun view-lilypond (filename options view) (when (>= *verbose* 1) (out ";; Compiling/opening \"~A\" for viewing...~%" filename)) (destructuring-bind (xxx &key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options (declare (ignore xxx)) @@ -58,10 +58,11 @@ (append (or exe-opts +lilypond-opts+) (list filename)) :wait t #|:output *standard-output*|#) (progn (unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling")) - (unless (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or view-exe +lilypond-view-exe+) - (append (or view-exe-opts +lilypond-view-opts+) (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - :wait nil #|:output *standard-output*|#) - (er "viewing"))) + (when view + (unless (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) + :wait nil #|:output *standard-output*|#) + (er "viewing")))) (er "compiling"))) #-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) @@ -109,7 +110,7 @@ ;; TODO: support texts, spanners and tremelos, remove dependency on ACCIDENTALYS -(defun save-lilypond (parts filename options view) +(defun save-lilypond (parts filename options process view) (when (>= *verbose* 1) (out ";; Saving Lilypond file \"~A\"...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) (destructuring-bind (xxx &key filehead scorehead &allow-other-keys) options @@ -144,7 +145,7 @@ (loop for p in parts do (destructuring-bind (&key (lily-partname (lyname p)) - parthead ;; extra header information for part (list of strings) + 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)) @@ -170,7 +171,7 @@ (loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do (format f " ~A\\clef ~A~%" (lystaff s) (lyclef cl))) (format f " \\clef ~A~%" (lyclef (second (getprop p :clef))))) - (loop for e in parthead do (format f " ~A~%" e)) + (loop for e in lily-parthead do (format f " ~A~%" e)) (format f "~%") (loop for m in (part-meas p) and mn from 1 @@ -336,5 +337,5 @@ for xxx in (getprops p :endgroup) do (decf in 2) (format f "~A>>~%" (make-string in :initial-element #\space)))) (format f "}~%"))))) - (when view (view-lilypond filename options))) + (when process (view-lilypond filename options view))) Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.1.1.1 fomus/backends.lisp:1.2 --- fomus/backends.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005 +++ fomus/backends.lisp Mon Jul 25 09:56:03 2005 @@ -21,9 +21,9 @@ (prin1 parts f) (fresh-line f))) -(defun backend (backend filename parts options view) +(defun backend (backend filename parts options process view) (case backend (:data (save-data filename parts)) - (:lilypond (save-lilypond parts filename options view)) + (:lilypond (save-lilypond parts filename options process view)) (otherwise (error "Unknown backend ~A" backend)))) Index: fomus/data.lisp diff -u fomus/data.lisp:1.3 fomus/data.lisp:1.4 --- fomus/data.lisp:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/data.lisp Mon Jul 25 09:56:03 2005 @@ -31,7 +31,7 @@ (defparameter *min-tuplet-dur* 1/2) ; fraction of beat smallest tuplets should span at minimum (1/2 = half a beat, etc.)--can be nil (defparameter *max-tuplet-dur* 4) -(defparameter *default-beat* nil) +(defparameter *default-beat* 1/4) ;; pitch quantizing (declaim (special *note-precision*)) @@ -304,7 +304,7 @@ (:timesig-style (or* null (find* :fraction :common)) ":FRACTION or :COMMON") (:tuplet-style (or* null (find* :ratio :single)) ":RATIO or :SINGLE") - (:quantize-adjust-grace-durs boolean) + ;;(:quantize-adjust-grace-durs boolean) (:default-grace-dur (rational (0))) (:default-grace-num integer) (:effective-grace-dur-mul (rational (0))) (:min-auto-timesig-dur (rational (0))) (:default-timesig (type* +timesig-repl-type+) "TIMESIG object") @@ -314,6 +314,7 @@ (:auto-ottavas boolean) (:auto-grace-slurs boolean) (:auto-voicing boolean) (:auto-beams boolean) (:auto-quantize boolean) (:auto-multivoice-rests boolean) (:auto-multivoice-notes boolean) (:auto-override-timesigs boolean) + (:auto-pizz/arco boolean) (:split-fun symbol) (:auto-accs-fun symbol) (:auto-voices-fun symbol) (:auto-distr-rests-fun symbol) (:auto-multivoice-comb-fun symbol) (:auto-ottavas-fun symbol) (:auto-beam-fun symbol) (:auto-quantize-fun symbol) @@ -331,7 +332,7 @@ (:tuplet-dotted-rests boolean) (:double-dotted-notes boolean) (:dotted-note-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") (:shortlongshort-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") - (:syncopated-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") + (:syncopated-notes-level boolean) (:acc-engine-heap (integer 100)) (:acc-importance-score (real (0) 1)) (:acc-importance-steps (integer 1)) (:voice-engine-heap (integer 100)) (:voice-importance-score (real (0) 1)) (:voice-importance-steps (integer 1)) @@ -391,7 +392,7 @@ (or* (unique* sy :glissbefore x) (list* (unique* sy :glissbefore x)) (list* (unique* sy :glissbefore x) (eql* :before)) (list* (unique* sy :glissafter x) (eql* :after)))) (let* ((x (find* :breath))) - (or* (unique* sy :breathbefore x) (list* (unique* sy :breathbefore x)) + (or* (unique* sy :breathafter x) (list* (unique* sy :breathafter x)) (list* (unique* sy :breathbefore x) (eql* :before)) (list* (unique* sy :breathafter x) (eql* :after)))) (let* ((x (find* :harmonic))) (or* (cons* (unique* sy :harmtouched x) @@ -494,8 +495,10 @@ (defparameter +marks-all-ties+ '(:longtrill :tremolo :lefthandtremolo :righthandtremolo)) +(defparameter *auto-pizz/arco* t) + (defparameter +marks-on-off+ - '((:pizz . :arco))) + '((*auto-pizz/arco* . (:pizz . :arco)))) ;; marks that prevent notes from combining into chords if they differ (defparameter +marks-indiv-voices+ Index: fomus/main.lisp diff -u fomus/main.lisp:1.3 fomus/main.lisp:1.4 --- fomus/main.lisp:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/main.lisp Mon Jul 25 09:56:03 2005 @@ -58,7 +58,7 @@ (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 (mks *events*) (split-list *events* #'markp) + (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (or (notep x) (restp x)))) (let ((pts (progn (loop for p in *parts* and i from 0 do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp @@ -124,23 +124,20 @@ (reset-tempslots pts 0) (distribute-marks pts mks) (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED - (if *auto-quantize* (clean-quantize pts)) + ;;(if *auto-quantize* (clean-quantize pts)) (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 pts)) #+debug (fomus-proc-check pts 'sepvoices) (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 (and (>= *verbose* 2) (and *auto-grace-slurs* *auto-cautionary-accs*)) - (out "~&; Voice items...")) + (when (>= *verbose* 2) (out "~&; Miscellaneous items...")) (preproc-cautaccs pts) (when *auto-grace-slurs* (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs)) - ;; (setf pts (sep-voices (assemble-parts pts))) (when (>= *verbose* 2) (out "~&; Measures...")) (init-parts *timesigs* pts) ; ----- MEASURES #+debug (fomus-proc-check pts 'measures) @@ -184,7 +181,7 @@ (defun fomus-main () (let ((r (fomus-proc))) (loop for x in (or (force-list2 *backend*) '((:data))) - do (destructuring-bind (ba &key filename view &allow-other-keys) x - (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x view)))) + do (destructuring-bind (ba &key filename process view &allow-other-keys) x + (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x (or process view) view)))) t) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.3 fomus/marks.lisp:1.4 --- fomus/marks.lisp:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/marks.lisp Mon Jul 25 09:56:03 2005 @@ -17,13 +17,17 @@ (defun grace-slurs (pts) (loop for p in pts do - (loop for e in (part-events p) do (rmmark e :startgraceslur-) (rmmark e :graceslur-) (rmmark e :endgraceslur-)) (loop for e in (delete-if (lambda (x) (notany #'event-grace x)) (split-into-groups (part-events p) #'event-off)) - for s = (sort e #'sort-offdur) - do - (addmark (first s) :startgraceslur-) - (addmark (find-if-not #'event-grace s) :endgraceslur-)) + for s = (sort e (complement #'sort-offdur)) + do (loop with sl and li + for x in s + when (or (getmark x :endgraceslur-) (getmark x :graceslur-)) + do (if sl (error "Missing STARTGRACESLUR- mark in part ~A, offset ~A" (part-name p) (event-foff e)) (setf sl t)) (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-) (setf li nil)) + unless sl do (push x li) + when (getmark x :startgraceslur-) do (if sl (setf sl nil) (error "Missing GRACESLUR-/ENDGRACESLUR- slur mark in part ~A, offset ~A" (part-name p) (event-foff e))) + finally + (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-)))) (print-dot))) ;; must be in separate voices @@ -134,7 +138,11 @@ (if (null vo) l (remove-if-not (lambda (e) (find (event-voice* e) vo)) l))))) (if re r (remove-if #'restp r))))) (let ((o (let ((q (getprop p :quant))) ; fix quantize error - (if q (let ((x (find-if (lambda (x) (and (<= (car x) o0) (>= (cdr x) o0))) (rest q)))) + (if q (let ((x (find-if (lambda (x) (and (funcall (caar x) o0) + (if (< (cdar x) (cdr x)) + (< o0 (cdr x)) ; --> + (> o0 (cdr x))))) ; <-- + (rest q)))) (if x (cdr x) o0)) o0)))) (if di Index: fomus/package.lisp diff -u fomus/package.lisp:1.3 fomus/package.lisp:1.4 --- fomus/package.lisp:1.3 Sat Jul 23 11:23:14 2005 +++ fomus/package.lisp Mon Jul 25 09:56:03 2005 @@ -53,7 +53,7 @@ (use-package "DBG" "FM"))) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 2)) +(defparameter +version+ '(0 1 3)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved" Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.1.1.1 fomus/postproc.lisp:1.2 --- fomus/postproc.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005 +++ fomus/postproc.lisp Mon Jul 25 09:56:03 2005 @@ -241,7 +241,7 @@ (addprop m (list :barline :final)))) (print-dot))) (defun postproc-marksonoff (pts) - (loop for (a . b) in +marks-on-off+ do + (loop for (v . (a . b)) in +marks-on-off+ when (symbol-value v) do (loop with o for p in pts do (loop for m in (part-meas p) do (loop for g in (meas-voices m) do Index: fomus/quantize.lisp diff -u fomus/quantize.lisp:1.2 fomus/quantize.lisp:1.3 --- fomus/quantize.lisp:1.2 Thu Jul 21 17:38:43 2005 +++ fomus/quantize.lisp Mon Jul 25 09:56:03 2005 @@ -80,7 +80,7 @@ collect (adj (dv o (loop for i in ep when (<= i os) collect i) e1 ts) (dv os (loop for i in ep when (>= i os) collect i) e2 ts)))))))) (loop for p in parts - for ph = (gethash p h) + for ph = (gethash p h) ; ph = timesigs for part do (let* ((ee (sort (delete-duplicates (loop for e in (part-events p) collect (event-off e) collect (event-endoff e))) #'<)) (qs (sort (delete-duplicates @@ -102,38 +102,56 @@ (let ((o (event-off e))) (loop while (and (list>1p qs) (< (second qs) o)) do (pop qs)) (let ((e1 (loop-return-firstmin (diff x o) for x in qs))) - (if (event-grace e) + (flet ((aa (oo ee) + (cond ((< oo ee) (push (cons (cons #'>= oo) ee) ad)) ; --> + ((> oo ee) (push (cons (cons #'< oo) ; <-- + (loop for (x1 x2) on qs until (or (null x2) (>= x2 ee)) + finally (return x1))) + ad))))) + (if (event-grace e) (progn - (push (cons (event-off e) e1) ad) + (cond ((< (event-off e) e1) (push (cons (cons #'>= (event-off e)) e1) ad)) ; --> + ((> (event-off e) e1) (push (cons (cons #'<= (event-off e)) e1) ad))) ; <-- (setf (event-off e) e1 (event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s)))))) (let ((x (roundto (event-gracedur e) bd))) (when (<= x 0) bd x))))) (let ((e2 (let ((o (event-endoff e))) (loop-return-lastmin (diff x o) for x in qs)))) - (push (cons (event-off e) e1) ad) + (aa (event-off e) e1) (setf (event-off e) e1) (let ((x (- e2 e1))) (if (<= x 0) (progn - (addmark e :grace) + (debugn "gr: ~A" e) + (aa (event-endoff e) e1) + ;; (addmark e :grace) (setf (event-dur e) - (cons (- (loop for i in qs until (> i e1) finally (return i)) e1) + (cons *default-grace-dur* #|(- (loop for i in qs until (> i e1) finally (return i)) e1)|# (incf mg)))) (progn - (push (cons (event-endoff e) e2) ad) - (setf (event-dur* e) x)))))))) + (aa (event-endoff e) e2) + (setf (event-dur* e) x))))))))) finally - (addprop p (cons :quant - (merge-all ad (lambda (x y) (let ((x1 (car x)) (x2 (cdr x)) - (y1 (car y)) (y2 (cdr y))) - (when (= x2 y2) - (cons (if (< x1 x2) - #+debug (if (<= y1 y2) (min x1 y1) (error "Error in QUANTIZE-BYFIT 3")) - #-debug (min x1 y1) - #+debug (if (>= y1 y2) (max x1 y1) (error "Error in QUANTIZE-BYFIT 4")) - #-debug (max x1 y1)) - x2)))) - :call-rev nil)))))) + (addprop p (cons :quant ; temporary prop: collection of all point movements + (merge-all ad (lambda (x y) (let ((x1 (cdar x)) (x2 (cdr x)) + (y1 (cdar y)) (y2 (cdr y))) + (cond ((and (< x1 x2) (< y1 y2)) ; --> + (when (and (>= x2 y1) (>= y2 x1)) ; always #'>= + (cons (if (< x1 y1) (car x) (car y)) + (max x2 y2)))) + ((and (> x1 x2) (> y1 y2)) ; <-- + (cond ((or (and (> x1 y2) (> y1 x2)) ; overlap + (and (= x1 y2) (eq (caar x) #'<=)) ; touching + (and (= y1 x2) (eq (caar y) #'<=))) + (cons (cond ((= x1 y1) (cons (if (or (eq (caar x) #'<=) + (eq (caar y) #'<=)) + #'<= #'<) + x1)) + ((> x1 y1) (car x)) + (t (car y))) + (min x2 y2)))))))) + :call-rev nil))) + (setf (part-events p) (sort (part-events p) #'sort-offdur))))) (print-dot))))) (defun quantize (timesigs parts) @@ -141,24 +159,27 @@ (:quantize1 (quantize-byfit timesigs parts)) (otherwise (error "Unknown quantize function ~A" *auto-quantize-fun*)))) -(defparameter *quantize-adjust-grace-durs* t) +;; (defparameter *quantize-adjust-grace-durs* t) -(defun clean-quantize (parts) - (loop for p in parts do - (loop for v in (split-into-groups (part-events p) #'event-voice*) do - (when *quantize-adjust-grace-durs* - (loop with d - for e in (sort (copy-list v) (complement #'sort-offdur)) - if (getmark e :grace) - do (setf (event-dur* e) (if d (min d *default-grace-dur*) *default-grace-dur*)) - else if (event-grace e) do (setf d nil) else do (setf d (event-dur* e)))) - (loop with g and di = (>= *default-grace-num* 0) ; di = t if forward and default grace >= 0 - for e in (sort v (if di #'sort-offdur (complement #'sort-offdur))) - if (popmark e :grace) - do (setf (event-grace* e) (setf g (if g - (if di (max (1+ g) *default-grace-num*) (min (1- g) *default-grace-num*)) - *default-grace-num*))) - else if (event-grace e) do (setf g (event-grace e)))))) +;; (defun clean-quantize (parts) +;; (when *quantize-adjust-grace-durs* +;; (loop for p in parts do +;; (loop for v in (split-into-groups (part-events p) #'event-voice*) do +;; (loop with d and do +;; for e in (sort (copy-list v) (complement #'sort-offdur)) +;; if (and d (getmark e :grace) (eql (event-off e) do)) +;; do (setf (event-dur* e) (let for x = *default-grace-dur* then (/ x 2) until (<= x d) finally (return x))) +;; else if (notep e) do (setf d (event-dur* e)) +;; else do (setf d nil) +;; do (setf do (event-off e)))) +;; ;; (loop with g and di = (>= *default-grace-num* 0) ; di = t if forward and default grace >= 0 +;; ;; for e in (sort v (if di #'sort-offdur (complement #'sort-offdur))) +;; ;; if (popmark e :grace) +;; ;; do (setf (event-grace* e) (setf g (if g +;; ;; (if di (max (1+ g) *default-grace-num*) (min (1- g) *default-grace-num*)) +;; ;; *default-grace-num*))) +;; ;; else if (event-grace e) do (setf g (event-grace e))) +;; ))) (defun quantize-generic (parts) (loop for p in parts do Index: fomus/split.lisp diff -u fomus/split.lisp:1.2 fomus/split.lisp:1.3 --- fomus/split.lisp:1.2 Sat Jul 23 11:23:14 2005 +++ fomus/split.lisp Mon Jul 25 09:56:03 2005 @@ -144,6 +144,14 @@ (setf gs (loop for e in (split-into-groups gs (lambda (x) (cons (event-off x) (event-grace x))) :test 'equal) ; put vertical notes into chords (note = list of notes, combine all attributes) if (list>1p e) collect (make-chord e) else collect (first e))) + (loop ; split places at grace note offsets + for g in gs + for i = (event-off g) + do (setf ns (loop + for e in ns + for (j . k) = (split-event e i) + when j collect j + when k collect k))) (loop for e in (nconc gs ns) ; separate notes belonging to next measure--notes after endoff already split if (< (event-off e) endoff) collect e into v1 @@ -505,7 +513,7 @@ (let ((x (sort (copy-list li) (complement #'sort-offdur)))) (setf li (ex (second x) (first x) x)))))) li)) - (let ((lm (/ (* (beat-division timesig) 4)))) + (let ((lm (/ (* (beat-division timesig) 65536)))) (flet ((scorefun (nd) ; score relative to ea. level (if (splitnode-pts nd) (loop @@ -588,10 +596,10 @@ (mn (drst (loop for e in nds append (splitnode-evs e)) rl))))))) (solutfun (nd) ; complete/valid? (if (splitnode-pts nd) - (let ((x (splitnode-rl nd))) - (every (lambda (n) (or (truep n) (split-valid n off endoff x))) (splitnode-evs nd))) - (or (truep (splitnode-evs nd)) - (split-valid (splitnode-evs nd) off endoff (splitnode-rl nd)))))) + (let ((x (splitnode-rl nd))) + (every (lambda (n) (or (truep n) (split-valid n off endoff x))) (splitnode-evs nd))) + (or (truep (splitnode-evs nd)) + (split-valid (splitnode-evs nd) off endoff (splitnode-rl nd)))))) (multiple-value-bind (evs grs) (loop for p in events Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.1.1.1 fomus/voices.lisp:1.2 --- fomus/voices.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005 +++ fomus/voices.lisp Mon Jul 25 09:56:03 2005 @@ -148,7 +148,7 @@ :heaplim *voice-engine-heap* :scoregreaterfun #'scoregreaterfun :remscoregreaterfun #'remscoregreaterfun))) - (error "Cannot find voice distribution for part ~A" name)))))) + (error "Cannot distribute voices for part ~A" name)))))) (defun voices-setvoice (events) (loop for e in events when (listp (event-voice e)) do From dpsenicka at common-lisp.net Tue Jul 26 06:01:06 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Tue, 26 Jul 2005 08:01:06 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/README fomus/TODO fomus/accidentals.lisp fomus/data.lisp fomus/main.lisp fomus/other.lisp fomus/util.lisp Message-ID: <20050726060106.AA6188853D@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv32341 Modified Files: README TODO accidentals.lisp data.lisp main.lisp other.lisp util.lisp Log Message: Testing/bug fixes Date: Tue Jul 26 08:00:59 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.3 fomus/README:1.4 --- fomus/README:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/README Tue Jul 26 08:00:57 2005 @@ -20,8 +20,10 @@ (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. +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). 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 +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. Index: fomus/TODO diff -u fomus/TODO:1.5 fomus/TODO:1.6 --- fomus/TODO:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/TODO Tue Jul 26 08:00:57 2005 @@ -16,6 +16,7 @@ SHORT TERM +Number of lines in staff Global timesig-repl list MINP and MAXP instrument ranges MusicXML backend Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.4 fomus/accidentals.lisp:1.5 --- fomus/accidentals.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/accidentals.lisp Tue Jul 26 08:00:57 2005 @@ -154,7 +154,7 @@ (list x)))) ; e = lists of accs. if (funcall spellfun o a) collect a) (loop for a in (mapcar conv choices) if (funcall spellfun o a) collect a) ; ignore user's suggestion - (error "No accidentals possible for note ~S, offset ~S, part ~S" (event-note f) (event-foff f) name)) + (error "No accidentals possible for note ~S at offset ~S, part ~S" (event-note f) (event-foff f) name)) collect (let ((w (copy-event f :note (cons (event-note* f) e))) (s (nokeynode-sc no))) (let ((d (cons w Index: fomus/data.lisp diff -u fomus/data.lisp:1.5 fomus/data.lisp:1.6 --- fomus/data.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/data.lisp Tue Jul 26 08:00:57 2005 @@ -42,20 +42,19 @@ (defparameter +notenum+ (vector 9 11 0 2 4 5 7)) (defun note-to-num (note) - (if (keywordp note) note - (roundto - (if (and *cm-exists* *use-cm*) - (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note)) - (if (symbolp note) - (let* ((s (symbol-name note)) - (b (svref +notenum+ (- (char-int (aref s 0)) 65))) - (a (case (aref s 1) - ((#\+ #\S) (incf b) 2) - ((#\- #\F) (decf b) 2) - (otherwise 1)))) - (+ (* (parse-integer (subseq s a)) 12) b 12)) - note)) - *note-precision*))) + (roundto + (if (and *cm-exists* *use-cm*) + (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note)) + (if (symbolp note) + (let* ((s (symbol-name note)) + (b (svref +notenum+ (- (char-int (aref s 0)) 65))) + (a (case (aref s 1) + ((#\+ #\S) (incf b) 2) + ((#\- #\F) (decf b) 2) + (otherwise 1)))) + (+ (* (parse-integer (subseq s a)) 12) b 12)) + note)) + *note-precision*)) (defun is-note (note) (let ((*note-precision* 1)) (numberp (ignore-errors (note-to-num note))))) (defun parse-usernote (no) Index: fomus/main.lisp diff -u fomus/main.lisp:1.5 fomus/main.lisp:1.6 --- fomus/main.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/main.lisp Tue Jul 26 08:00:57 2005 @@ -55,119 +55,119 @@ (check-setting-types) (find-cm) (check-settings) - (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) (or (notep x) (restp x)))) - (let ((pts (progn - (loop for p in *parts* and i from 0 - do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp - (lambda (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) - (unless (timesig-partids x) - (setf (timesig-partids x) (gpi)))) - ti) - (mapc (lambda (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*)) - (set-note-precision + (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) (or (notep x) (restp x)))) + (let ((pts (progn + (loop for p in *parts* and i from 0 + do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp + (lambda (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) + (unless (timesig-partids x) + (setf (timesig-partids x) (gpi)))) + ti) + (mapc (lambda (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) 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" (first *events*)))))))) ; make copied list of part-exs w/ sorted events - #+debug (fomus-proc-check pts 'start) - (track-progress +progress-int+ - (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-harmonics 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)) - (reset-tempslots pts nil) - (when (and (>= *verbose* 2) (find-if #'is-percussion pts)) - (out "~&; Percussion...") ; before voices & clefs - (percussion pts)) - (if *auto-voicing* - (progn (when (>= *verbose* 2) (out "~&; Voices...")) - (voices pts) #+debug (fomus-proc-check pts 'voices)) - (voices-generic pts)) - (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 0) - (distribute-marks pts mks) - (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED - ;;(if *auto-quantize* (clean-quantize pts)) - (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...")) - (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 pts) #+debug (fomus-proc-check pts 'ties) - (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* 2) (format t "~&")) - pts))))) + finally (when rm (error "No matching part for event with partid ~S" (first *events*))))))) ; make copied list of part-exs w/ sorted events + #+debug (fomus-proc-check pts 'start) + (track-progress +progress-int+ + (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-harmonics 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)) + (reset-tempslots pts nil) + (when (and (>= *verbose* 2) (find-if #'is-percussion pts)) + (out "~&; Percussion...") ; before voices & clefs + (percussion pts)) + (if *auto-voicing* + (progn (when (>= *verbose* 2) (out "~&; Voices...")) + (voices pts) #+debug (fomus-proc-check pts 'voices)) + (voices-generic pts)) + (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 0) + (distribute-marks pts mks) + (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED + ;;(if *auto-quantize* (clean-quantize pts)) + (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...")) + (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 pts) #+debug (fomus-proc-check pts 'ties) + (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* 2) (format t "~&")) + pts)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; MAIN Index: fomus/other.lisp diff -u fomus/other.lisp:1.2 fomus/other.lisp:1.3 --- fomus/other.lisp:1.2 Tue Jul 26 01:15:53 2005 +++ fomus/other.lisp Tue Jul 26 08:00:57 2005 @@ -64,13 +64,18 @@ when (is-percussion p) do (loop with pm = (instr-percs (part-instr p)) for ev in (part-events p) do - (let ((n (event-note ev))) + (let ((n (event-note ev))) ; n = value of note slot (unless (numberp n) - (let ((c (etypecase n + (let ((c (etypecase n ; c = percussion struct (symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym)) (perc n)))) - (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1)) - (setf (event-staff* ev) (perc-staff c))) - (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))))))) + (if c + (progn + (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1)) + (setf (event-staff* ev) (perc-staff c))) + (when (perc-voice c) (setf (event-voice* ev) (perc-voice c))) + (setf (event-note ev) (note-to-num (perc-note c)))) + (if (is-note n) (setf (event-note ev) (note-to-num n)) + (error "Unknown percussion specifier ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p)))))))) (print-dot))) Index: fomus/util.lisp diff -u fomus/util.lisp:1.4 fomus/util.lisp:1.5 --- fomus/util.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/util.lisp Tue Jul 26 08:00:57 2005 @@ -501,15 +501,13 @@ :dur (get-dur ev ts) :marks (event-marks ev) :voice (event-voice ev) - :note (let ((n (event-note ev))) - (if (is-percussion pa) - (unless (numberp n) - (perc-note (etypecase n - (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym) - (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa)))) - (perc n))) - n) - (parse-usernote n))))) + :note (if (is-percussion pa) (event-note ev) + ;; (if (numberp n) n + ;; (perc-note (etypecase n + ;; (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym) + ;; (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa)))) + ;; (perc n)))) + (parse-usernote (event-note ev))))) (defmethod make-eventex* ((ev rest) ts pa) (declare (ignore pa)) (make-restex From dpsenicka at common-lisp.net Tue Jul 26 06:01:06 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Tue, 26 Jul 2005 08:01:06 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/doc/objects.xml Message-ID: <20050726060106.B69498853E@common-lisp.net> Update of /project/fomus/cvsroot/fomus/doc In directory common-lisp.net:/tmp/cvs-serv32341/doc Modified Files: objects.xml Log Message: Testing/bug fixes Date: Tue Jul 26 08:01:05 2005 Author: dpsenicka Index: fomus/doc/objects.xml diff -u fomus/doc/objects.xml:1.6 fomus/doc/objects.xml:1.7 --- fomus/doc/objects.xml:1.6 Tue Jul 26 01:16:01 2005 +++ fomus/doc/objects.xml Tue Jul 26 08:01:05 2005 @@ -1401,7 +1401,7 @@ This is an integer or symbol designating where the instrument's notes are to appear on the staff. - The value is interpreted as if notated with a treble clef signature. + The value is interpreted with middle C in the center as if notated with an alto clef signature. See EVENT-NOTE in the NOTE class for information on specifying notes with symbols. From dpsenicka at common-lisp.net Wed Jul 27 06:57:40 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Wed, 27 Jul 2005 08:57:40 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/test.lisp fomus/TODO fomus/beams.lisp fomus/package.lisp fomus/quantize.lisp fomus/split.lisp fomus/staves.lisp Message-ID: <20050727065740.B4FE3880DC@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv31290 Modified Files: TODO beams.lisp package.lisp quantize.lisp split.lisp staves.lisp Added Files: test.lisp Log Message: Testing/bug fixes Date: Wed Jul 27 08:57:38 2005 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.6 fomus/TODO:1.7 --- fomus/TODO:1.6 Tue Jul 26 08:00:57 2005 +++ fomus/TODO Wed Jul 27 08:57:37 2005 @@ -3,13 +3,10 @@ IMMEDIATE Testing and bug fixes -DOC: Information on anonymous CVS downloading DOC: dynamic marks can take order arguments (backend might not support it) -DOC: other interface functions -DOC: part properties Adjust scores and penalties for decent results Breath marks (resolve before/after) -Noteheads +Note heads Finish fingering mark (no finger number argument) @@ -30,6 +27,7 @@ Integrate user graceslur overrides Levels for single text marks Remove redundant dynamic marks +Easier grace note numbering Index: fomus/beams.lisp diff -u fomus/beams.lisp:1.2 fomus/beams.lisp:1.3 --- fomus/beams.lisp:1.2 Tue Jul 26 01:15:53 2005 +++ fomus/beams.lisp Wed Jul 27 08:57:37 2005 @@ -93,7 +93,7 @@ collect e0 do (incf o (event-writtendur e0 ts dmu)) finally (setf ee ee0)))) ; x is in forward order - (when re (push re rr) (setf re nil)) ; first of re is the largest offset + (when re (push re rr) (setf re nil)) ; first of re is the largest offset (let ((xr (spt x nil nil (event-tupdurmult e) (1+ tf)))) (when xa (nconc (last-element xr) (list xa))) ; "prepend" for continuous beaming xr)) @@ -129,19 +129,20 @@ when (and (notep e0) (notep e1)) do (setf (event-beamrt e1) (min dv (event-nbeams e0 ts) (event-nbeams e1 ts))))) (cons spf spb)))) - (fb (spf spb) + (fb (spf spb) (let ((ll nil) (lr nil)) ; fix beams that don't have enough + ;;(debugn-if (= (meas-off m) 8) "~A" spf) (loop for ee in spf do (loop for (e0 e1) on ee while e1 - for nb = (event-nbeams e1 ts) ;(min dv (event-nbeams e1 ts)) - when (and (notep e0) (notep e1) (> (event-nbeams e0 ts) 0) + for nb = (event-nbeams e1 ts) + when (and (notep e0) (notep e1) (> (event-beamrt e0) 0) ; (event-nbeams e0 ts) (and (< (event-beamlt e1) nb) (< (event-beamrt e1) nb))) do (push (cons (event-nbeams e1 ts) e1) ll))) (loop for ee in spb do (loop for (e0 e1) on ee while e1 - for nb = (event-nbeams e1 ts) ;(min dv (event-nbeams e1 ts)) - when (and (notep e0) (notep e1) (> (event-nbeams e0 ts) 0) + for nb = (event-nbeams e1 ts) + when (and (notep e0) (notep e1) (> (event-beamlt e0) 0) ; (event-nbeams e0 ts) (and (< (event-beamlt e1) nb) (< (event-beamrt e1) nb))) do (push (cons (event-nbeams e1 ts) e1) lr))) (loop for (nb . e) in ll do (setf (event-beamlt e) nb)) @@ -163,12 +164,11 @@ finally (loop for (f . b) in (nreverse ag) do (fb f b)) (fb (list evs) (list (reverse evs)))))) - (let ((gg (split-into-groups grs #'event-off))) + (let ((gg (mapcar (lambda (x) (sort x #'sort-offdur)) (split-into-groups grs #'event-off)))) (loop for gr in gg - do (loop for (e0 e1 e2) on gr while e2 + do (loop for (e1 e2) on gr while e2 for nb = (event-nbeams e1 ts) - when (and (notep e0) (notep e1)) do (setf (event-beamlt e1) (min (event-nbeams e0 ts) nb)) - when (and (notep e1) (notep e2)) do (setf (event-beamrt e1) (min (event-nbeams e2 ts) nb)))) + when (and (notep e1) (notep e2)) do (let ((x (min (event-nbeams e2 ts) nb))) (setf (event-beamrt e1) x (event-beamlt e2) x)))) (let ((ll nil) (lr nil)) ; fix beams that don't have enough (loop for ee in gg do (loop for (e0 e1) on ee while e1 Index: fomus/package.lisp diff -u fomus/package.lisp:1.5 fomus/package.lisp:1.6 --- fomus/package.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/package.lisp Wed Jul 27 08:57:37 2005 @@ -48,7 +48,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 4)) +(defparameter +version+ '(0 1 5)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved" Index: fomus/quantize.lisp diff -u fomus/quantize.lisp:1.4 fomus/quantize.lisp:1.5 --- fomus/quantize.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/quantize.lisp Wed Jul 27 08:57:37 2005 @@ -18,7 +18,7 @@ (defun auto-quantize-fun () (if (eq *auto-quantize-fun* :default) :quantize1 *auto-quantize-fun*)) (defparameter *auto-quantize* t) -(defparameter *default-grace-dur* 1/2) ; dur, grace# +(defparameter *default-grace-dur* 1/4) ; dur, grace# (defparameter *default-grace-num* 0) (defun byfit-score (evpts qpts) @@ -114,8 +114,7 @@ ((> (event-off e) e1) (push (cons (cons #'<= (event-off e)) e1) ad))) ; <-- (setf (event-off e) e1 (event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s)))))) - (let ((x (roundto (event-gracedur e) bd))) - (when (<= x 0) bd x))))) + (max bd (roundto (event-gracedur e) bd))))) (let ((e2 (let ((o (event-endoff e))) (loop-return-lastmin (diff x o) for x in qs)))) (aa (event-off e) e1) (setf (event-off e) e1) Index: fomus/split.lisp diff -u fomus/split.lisp:1.4 fomus/split.lisp:1.5 --- fomus/split.lisp:1.4 Tue Jul 26 01:15:53 2005 +++ fomus/split.lisp Wed Jul 27 08:57:37 2005 @@ -103,7 +103,7 @@ ;; 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 -(defun split-preproc (evs off endoff) +(defun split-preproc (evs off endoff voc) (multiple-value-bind (gs ns) (split-list evs #'event-grace) (loop ; get rid of unison overlaps for el on ns @@ -120,12 +120,11 @@ (lambda (x y) (and (= (event-note* x) (event-note* y)) (= (event-off x) (event-off y)) (= (event-grace x) (event-grace y)))))) - (setf ns (let ((vc (if ns (event-voice* (first ns)) 1))) ; fill holes w/ rests - (nconc (mapcar (lambda (x) (make-restex :off (car x) :dur (- (cdr x) (car x)) :voice vc)) - (get-holes (merge-linear (mapcar (lambda (x) (cons (event-off x) (event-endoff x))) ns) - (lambda (x y) (when (<= (car y) (cdr x)) (cons (car x) (cdr y))))) - off endoff)) - ns))) + (setf ns (nconc (mapcar (lambda (x) (make-restex :off (car x) :dur (- (cdr x) (car x)) :voice voc)) + (get-holes (merge-linear (mapcar (lambda (x) (cons (event-off x) (event-endoff x))) ns) + (lambda (x y) (when (<= (car y) (cdr x)) (cons (car x) (cdr y))))) + off endoff)) + ns)) (loop for x in ns ; split overlapping events collect (event-off x) into s @@ -144,7 +143,7 @@ (setf gs (loop for e in (split-into-groups gs (lambda (x) (cons (event-off x) (event-grace x))) :test 'equal) ; put vertical notes into chords (note = list of notes, combine all attributes) if (list>1p e) collect (make-chord e) else collect (first e))) - (loop ; split places at grace note offsets + (loop ; split places at grace note offsets for g in gs for i = (event-off g) do (setf ns (loop @@ -163,7 +162,9 @@ (loop with r ; leftover tied notes for m in (part-meas p) do - (multiple-value-bind (e n) (split-preproc (nconc r (meas-events m)) (meas-off m) (meas-endoff m)) + (multiple-value-bind (e n) (split-preproc (nconc r (meas-events m)) (meas-off m) (meas-endoff m) + (let ((i (find-if #'meas-events (part-meas p)))) + (if i (event-voice* (first (meas-events i))) 1))) (setf (meas-events m) e r n))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.2 fomus/staves.lisp:1.3 --- fomus/staves.lisp:1.2 Tue Jul 26 01:15:53 2005 +++ fomus/staves.lisp Wed Jul 27 08:57:37 2005 @@ -275,7 +275,7 @@ (defun distr-rests-byconfl (parts) (loop with rl and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible - for p in parts + for p in (remove-if #'is-percussion parts) for sv = (> (instr-staves (part-instr p)) 1) do (loop for v in (loop with v for m in (part-meas p) do (loop for e in (meas-events m) do (pushnew (event-voice* e) v)) finally (return v)) do From dpsenicka at common-lisp.net Wed Jul 27 20:58:51 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Wed, 27 Jul 2005 22:58:51 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/backend_ly.lisp Message-ID: <20050727205851.C1961880DB@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20706 Modified Files: backend_ly.lisp Log Message: Fixed title/subtitle/composer header Date: Wed Jul 27 22:58:50 2005 Author: dpsenicka Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.5 fomus/backend_ly.lisp:1.6 --- fomus/backend_ly.lisp:1.5 Tue Jul 26 01:15:53 2005 +++ fomus/backend_ly.lisp Wed Jul 27 22:58:50 2005 @@ -305,14 +305,14 @@ collect (format nil "\\skip 1*~A/~A*~A " n d nu) into re and do (setf nu 0) do (incf nu) finally (return (nconc re (list (format nil "\\skip 1*~A/~A*~A" n d nu)))))))))))) + (when (or *title* *subtitle* *composer*) + (format f "\\header {~%") + (when *title* (format f " title = ~S~%" *title*)) + (when *subtitle* (format f " subtitle = ~S~%" *subtitle*)) + (when *composer* (format f " composer = ~S~%" *composer*)) + (format f "}~%~%")) (format f "\\score {~%") ;; score block (loop for e in scorehead do (format f " ~A~%" e)) - (when (or *title* *subtitle* *composer*) - (format f " \\header {~%") - (when *title* (format f " title = ~S~%" *title*)) - (when *subtitle* (format f " subtitle = ~S~%" *subtitle*)) - (when *composer* (format f " composer = ~S~%" *composer*)) - (format f " }~%")) (loop with in = 2 for p in parts and nm in (nreverse nms) do From dpsenicka at common-lisp.net Fri Jul 29 08:58:27 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Fri, 29 Jul 2005 10:58:27 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/CHANGELOG fomus/version.lisp fomus/TODO fomus/backend_ly.lisp fomus/backends.lisp fomus/data.lisp fomus/final.lisp fomus/fomus.asd fomus/load.lisp fomus/main.lisp fomus/marks.lisp fomus/other.lisp fomus/package.lisp fomus/postproc.lisp fomus/split.lisp fomus/util.lisp Message-ID: <20050729085827.96CF3880DE@common-lisp.net> 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 From dpsenicka at common-lisp.net Fri Jul 29 18:55:50 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Fri, 29 Jul 2005 20:55:50 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/data.lisp fomus/split.lisp fomus/voices.lisp Message-ID: <20050729185550.36F86880DC@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv8208 Modified Files: CHANGELOG TODO data.lisp split.lisp voices.lisp Log Message: Bug fixes Date: Fri Jul 29 20:55:43 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.1 fomus/CHANGELOG:1.2 --- fomus/CHANGELOG:1.1 Fri Jul 29 10:58:20 2005 +++ fomus/CHANGELOG Fri Jul 29 20:55:43 2005 @@ -2,3 +2,4 @@ Testing/bug fixes Support for tremolos + Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM Index: fomus/TODO diff -u fomus/TODO:1.8 fomus/TODO:1.9 --- fomus/TODO:1.8 Fri Jul 29 10:58:20 2005 +++ fomus/TODO Fri Jul 29 20:55:43 2005 @@ -4,7 +4,7 @@ Testing and bug fixes DOC: dynamic marks can take order arguments (backend might not support it) -DOC: update tremolos +DOC: :beat-division and tuplets Adjust scores and penalties for decent results Breath marks (resolve before/after) Note heads Index: fomus/data.lisp diff -u fomus/data.lisp:1.7 fomus/data.lisp:1.8 --- fomus/data.lisp:1.7 Fri Jul 29 10:58:20 2005 +++ fomus/data.lisp Fri Jul 29 20:55:43 2005 @@ -129,17 +129,17 @@ ;; 8up/down leglines = (cons into-ottava outof-ottava), or I think it can also be just a number ;;(declaim (inline make-instr)) (defstruct (instr (:constructor make-instr-aux) (:copier nil) (:predicate instrp)) - sym clefs (staves 1) minp maxp (voicelim 1) tpose (cleflegls 2) + sym clefs (staves 1) minp maxp (simultlim 1) tpose (cleflegls 2) 8uplegls 8dnlegls percs) -(defparameter +instr-keys+ '(:sym :clefs :staves :minp :maxp :voicelim :tpose :cleflegls :8uplegls :8dnlegls :percs)) +(defparameter +instr-keys+ '(:sym :clefs :staves :minp :maxp :simultlim :tpose :cleflegls :8uplegls :8dnlegls :percs)) (defun make-instr (sym &rest args) (apply #'make-instr-aux :sym sym args)) ;;(declaim (inline copy-instr)) (defun copy-instr (instr &key (sym (instr-sym instr)) (clefs (instr-clefs instr)) (staves (instr-staves instr)) (minp (instr-minp instr)) (maxp (instr-maxp instr)) - (voicelim (instr-voicelim instr)) (tpose (instr-tpose instr)) (cleflegls (instr-cleflegls instr)) (8uplegls (instr-8uplegls instr)) + (simultlim (instr-simultlim instr)) (tpose (instr-tpose instr)) (cleflegls (instr-cleflegls instr)) (8uplegls (instr-8uplegls instr)) (8dnlegls (instr-8dnlegls instr)) (percs (instr-percs instr))) - (make-instr-aux :sym sym :clefs clefs :staves staves :minp minp :maxp maxp :voicelim voicelim :tpose tpose :cleflegls cleflegls + (make-instr-aux :sym sym :clefs clefs :staves staves :minp minp :maxp maxp :simultlim simultlim :tpose tpose :cleflegls cleflegls :8uplegls 8uplegls :8dnlegls 8dnlegls :percs percs)) (defparameter +instr-type+ @@ -150,7 +150,7 @@ (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)) - (instr-voicelim (check* (integer 1) "Found ~S, expected (INTEGER 1) in VOICELIM slot" t)) + (instr-simultlim (check* (integer 1) "Found ~S, expected (INTEGER 1) in SIMULTLIM 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) @@ -168,7 +168,7 @@ (defparameter *instruments* nil) (eval-when (:load-toplevel :execute) - (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :voicelim 5)) + (defparameter +default-instr+ (make-instr :default :clefs '(:treble :bass) :simultlim 5)) (defparameter +instruments+ (list (make-instr :piccolo :clefs :treble :tpose 12) (make-instr :flute :clefs :treble) @@ -190,10 +190,10 @@ (make-instr :viola :clefs '(:treble :alto) :8uplegls '(5 2)) (make-instr :cello :clefs '(:bass :tenor :treble)) (make-instr :contrabass :clefs '(:bass :tenor) :tpose -12) - (make-instr :harp :clefs '(:treble :bass) :staves 2 :voicelim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) - (make-instr :piano :clefs '(:treble :bass) :staves 2 :voicelim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) - (make-instr :xylophone :clefs '(:treble) :voicelim 2 :tpose 12 :8uplegls '(5 2)) - (make-instr :marimba :clefs '(:treble :bass) :voicelim 2 :8uplegls '(5 2)) + (make-instr :harp :clefs '(:treble :bass) :staves 2 :simultlim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) + (make-instr :piano :clefs '(:treble :bass) :staves 2 :simultlim 5 :8uplegls '(5 2) :8dnlegls '(5 2)) + (make-instr :xylophone :clefs '(:treble) :simultlim 2 :tpose 12 :8uplegls '(5 2)) + (make-instr :marimba :clefs '(:treble :bass) :simultlim 2 :8uplegls '(5 2)) (make-instr :percussion :clefs :percussion) (make-instr :timpani :clefs :bass)))) @@ -327,7 +327,7 @@ (:default-beat (or null (rational (0)))) (:beat-division (or* (integer 1) (and (list* (integer 1) (integer 1)) (length* = 2))) "(INTEGER 1) or ((INTEGER 1) (INTEGER 1))") (:min-tuplet-dur (real (0))) (:max-tuplet-dur (real (0))) (:min-simple-tuplet-dur (real (0))) - (:max-tuplet (or* (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)") + (:max-tuplet (or* null (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)") (:tuplet-dotted-rests boolean) (:double-dotted-notes boolean) (:dotted-note-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") (:shortlongshort-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG") Index: fomus/split.lisp diff -u fomus/split.lisp:1.6 fomus/split.lisp:1.7 --- fomus/split.lisp:1.6 Fri Jul 29 10:58:20 2005 +++ fomus/split.lisp Fri Jul 29 20:55:43 2005 @@ -330,7 +330,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 (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (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 in (primes2 (first mt)) ; only primes--number isn't actual tuplet, just division @@ -366,7 +366,7 @@ (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 (and tups (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) + (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) (let ((l (length (force-list (rule-tup rule))))) (when (< l mn) (loop Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.3 fomus/voices.lisp:1.4 --- fomus/voices.lisp:1.3 Tue Jul 26 01:15:53 2005 +++ fomus/voices.lisp Fri Jul 29 20:55:43 2005 @@ -104,7 +104,7 @@ (c (cons w (let ((o (- oo (* *voice-full-beat-dist* *max-voice-beat-dist-mul*)))) (remove-if (lambda (e) (<= (event-endoff e) o)) (voicenode-evc no)))))) - (when (let ((i (instr-voicelim instr))) + (when (let ((i (instr-simultlim instr))) (or (null i) (<= (count-if (lambda (x) (and (> (event-endoff x) oo) (= (event-voice x) e))) c) i))) (make-voicenode :sc s :evc c From dpsenicka at common-lisp.net Sun Jul 31 05:39:33 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Sun, 31 Jul 2005 07:39:33 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/split.lisp fomus/util.lisp Message-ID: <20050731053933.D960A880DE@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv13174 Modified Files: split.lisp util.lisp Log Message: Testing/bug fixes Date: Sun Jul 31 07:39:32 2005 Author: dpsenicka Index: fomus/split.lisp diff -u fomus/split.lisp:1.8 fomus/split.lisp:1.9 --- fomus/split.lisp:1.8 Sun Jul 31 01:48:55 2005 +++ fomus/split.lisp Sun Jul 31 07:39:32 2005 @@ -477,7 +477,11 @@ (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)))) - (cons (copy-event e1 :dur (* (event-dur* e1) 2)) + (cons (copy-event e1 :dur (* (event-dur* e1) 2) + :tup (cons (when (car (event-tup e1)) + (cons (* (caar (event-tup e1)) 2) + (cdr (event-tup e1)))) + (cdr (event-tup e1)))) (delete e1 (delete e2 es))) es))) (when (or (initdivp rl) (basesplitp rl)) Index: fomus/util.lisp diff -u fomus/util.lisp:1.7 fomus/util.lisp:1.8 --- fomus/util.lisp:1.7 Sun Jul 31 01:48:55 2005 +++ fomus/util.lisp Sun Jul 31 07:39:32 2005 @@ -1,7 +1,7 @@ ;; -*- lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;************************************************************************************************** -;; FOMUS v0.1.0 +;; FOMUS ;; util.lisp ;;************************************************************************************************** @@ -344,7 +344,8 @@ (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) (/ (- off (event-off event)) du)) (rest u))) + (cdr (event-tup event)) (when u (cons (* (first u) (/ (- (event-endoff event) off) du)) (rest u)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From dpsenicka at common-lisp.net Sun Jul 31 07:35:11 2005 From: dpsenicka at common-lisp.net (David Psenicka) Date: Sun, 31 Jul 2005 09:35:11 +0200 (CEST) Subject: [fomus-cvs] CVS update: fomus/CHANGELOG fomus/TODO fomus/backend_ly.lisp fomus/data.lisp fomus/postproc.lisp fomus/split.lisp Message-ID: <20050731073511.1F44C88526@common-lisp.net> Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv20655 Modified Files: CHANGELOG TODO backend_ly.lisp data.lisp postproc.lisp split.lisp Log Message: Testing/bug fixes Date: Sun Jul 31 09:35:07 2005 Author: dpsenicka Index: fomus/CHANGELOG diff -u fomus/CHANGELOG:1.3 fomus/CHANGELOG:1.4 --- fomus/CHANGELOG:1.3 Sun Jul 31 01:48:54 2005 +++ fomus/CHANGELOG Sun Jul 31 09:35:07 2005 @@ -1,8 +1,11 @@ - Testing/bug fixes - Improved quantize algorithm +CHANGELOG -v0.1.6, 7/29/05 + Testing/bug fixes + Support for text, glissandi/portamenti, arpeggios (not all tested yet) + Improved quantize algorithm - Testing/bug fixes - Support for tremolos - Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM +v0.1.6, 7/29/05: + + Testing/bug fixes + Support for tremolos + Changed INSTR-VOICELIM slot in INSTR class to INSTR-SIMULTLIM Index: fomus/TODO diff -u fomus/TODO:1.10 fomus/TODO:1.11 --- fomus/TODO:1.10 Sun Jul 31 01:48:54 2005 +++ fomus/TODO Sun Jul 31 09:35:07 2005 @@ -1,39 +1,38 @@ -TODO LIST: +TODO LIST -IMMEDIATE +Immediate: -Testing and bug fixes -DOC: dynamic marks can take order arguments (backend might not support it) -DOC: LilyPond options: text-markup textdyn-markup texttempo-markup textnote-markup -DOC: remove :texttempo- and :endtexttempo- and related spanner marks -Adjust scores and penalties for decent results -Note heads -Finish fingering mark (no finger number argument) - - - -SHORT TERM - -Number of lines in staff -Global timesig-repl list -MINP and MAXP instrument ranges -MusicXML backend -CMN backend -MIDI backend -Profile and optimize code for speed -Update comments -Reorganize settings -MIDI input interface -Support for polymeters in backends -Integrate user graceslur overrides -Levels for single text marks -Remove redundant dynamic marks -Easier grace note numbering - - - -LONG TERM - -Features for proportional notation (generate hidden rests of constant duration?) -Key signatures (key detection algorithm) -Combine separately notated sections with different settings into one score (concatenate multiple .fms files?) + Testing and bug fixes + DOC: dynamic marks can take order arguments (backend might not support it) + DOC: LilyPond options: text-markup textdyn-markup texttempo-markup textnote-markup + DOC: remove :texttempo- and :endtexttempo- and related spanner marks + DOC: update text markings + Adjust scores and penalties for better/faster results + Note heads + Harmonics + Finish fingering mark (no finger number argument) + +Short Term: + + Number of lines in staff + Global timesig-repl list + MINP and MAXP instrument ranges + MusicXML backend + CMN backend + MIDI backend + Profile and optimize code for speed + Update comments + Reorganize settings + MIDI input interface + Support for polymeters in backends + Integrate user graceslur overrides + Levels for single text marks + Remove redundant dynamic marks + Easier grace note numbering + When deleting unisons, merge marks + +Long Term: + + Features for proportional notation (generate hidden rests?) + Key signatures (key detection algorithm) + Combine separately notated sections with different settings into one score (concatenate multiple .fms files?) Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.8 fomus/backend_ly.lisp:1.9 --- fomus/backend_ly.lisp:1.8 Sun Jul 31 01:48:54 2005 +++ fomus/backend_ly.lisp Sun Jul 31 09:35:07 2005 @@ -78,7 +78,7 @@ "beamL = #(def-music-function (location num) (number?) #{\\set stemLeftBeamCount = #$num #})" "beamR = #(def-music-function (location num) (number?) #{\\set stemRightBeamCount = #$num #})" "beamLR = #(def-music-function (location numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" "" - "textSpan = #(def-music-function (location dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #'($str . \"\") #})" + "textSpan = #(def-music-function (location dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" )) (defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b")) @@ -113,7 +113,7 @@ (:fp . "\\fp") (:sf . "\\sf") (:sff . "\\sff") (:sp . "\\sp") (:spp . "\\spp") (:sfz . "\\sfz") (:rfz . "\\rfz"))) (defparameter +lilypond-text+ "\\markup{\\italic{~A}}") -(defparameter +lilypond-textdyn+ "\\markup{\\italic{\\bold{\\huge{~A}}}}") +(defparameter +lilypond-textdyn+ "\\markup{\\dynamic{\\italic{\\bold{~A}}}}") (defparameter +lilypond-texttempo+ "\\markup{\\bold{\\huge{~A}}}") (defparameter +lilypond-textnote+ "\\markup{\\italic{~A}}") @@ -295,15 +295,15 @@ (or textdyn-markup +lilypond-textdyn+) (or texttempo-markup +lilypond-texttempo+) (or textnote-markup +lilypond-textnote+)) - nconc (loop for (xxx str di) in (getmarks e x) + nconc (loop for (xxx di str) in (getmarks e x) collect (conc-strings (ecase di (:up "^") (:down "_")) (format nil m str)))))) - (xs1 (let ((m (getmark e :starttext-))) ; can't have more than one at once - (if m (format nil "\\textSpan #~A #\"~A \" " (ecase (fourth m) (:up 1) (:down -1)) (third e)) ""))) - (xs2 (let ((m (getmark e :starttext-))) + (xs1 (let ((m (getmark e '(:starttext- 1)))) ; can't have more than one at once + (if m (format nil "\\textSpan #~A #\"~A \" " (ecase (third m) (:up 1) (:down -1)) (fourth m)) ""))) + (xs2 (let ((m (getmark e '(:starttext- 1)))) (if m "\\startTextSpan" ""))) - (xs3 (let ((m (or (getmark e :endtext-)))) + (xs3 (let ((m (getmark e '(:endtext- 1)))) (if m "\\stopTextSpan" ""))) (s1 (conc-stringlist (loop Index: fomus/data.lisp diff -u fomus/data.lisp:1.9 fomus/data.lisp:1.10 --- fomus/data.lisp:1.9 Sun Jul 31 01:48:54 2005 +++ fomus/data.lisp Sun Jul 31 09:35:07 2005 @@ -419,13 +419,13 @@ (let* ((x (find* :slur- :endslur-))) (or* (unique* si 1 x) (unique* si 1 (list* x)) (list* x (unique* si integer)))) (let* ((x (find* :textnote :texttempo :textdyn :text))) - (or* (list* x string) (list* x string (find* :up :down)))) ; text + (or* (list* x string) (list* x string (find* :up :down)) (list* x (find* :up :down) string))) ; text (let* ((x (find* :text- :endtext-))) - (or* x (list* x) (list* x (unique* #|tdn|# tx integer)))) + (or* (unique* tx 1 x) (unique* tx 1 (list* x)) (list* x (unique* tx integer)))) (let* ((x (find* :starttext-))) - (cons* x (or* (unique* tx 1 string) - (unique* tx 1 string (find* :up :down)) - (unique* tx 1 (find* :up :down) string) + (cons* x (or* (unique* tx 1 (list* string)) + (unique* tx 1 (list* string (find* :up :down))) + (unique* tx 1 (list* (find* :up :down) string)) (list* string (unique* tx integer)) (list* (unique* tx integer) string) (list* (find* :up :down) string (unique* tx integer)) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.4 fomus/postproc.lisp:1.5 --- fomus/postproc.lisp:1.4 Sun Jul 31 01:48:55 2005 +++ fomus/postproc.lisp Sun Jul 31 09:35:07 2005 @@ -322,18 +322,18 @@ (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)))))) + finally (setf (meas-events m) (sort ee #'sort-offdur)))) + (loop for g in (split-into-groups (loop for x in (part-meas p) append (meas-events x)) #'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)))) @@ -355,15 +355,23 @@ (> (event-endoff x) (event-off a)) (< (event-off x) (event-endoff a))) collect (event-voice* x))) - count (< y o) into u - count (> y o) into d + 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) (cons - (if (find (first tx) +marks-defaultup+) :up :down) - (rest tx))))) - ((< d u) (addmark e (cons (first tx) (cons :down (rest tx))))) - ((> d u) (addmark e (cons (first tx) (cons :up (rest tx)))))))))) (print-dot))) + (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))) ;; not included with other postprocs here--in fomus-proc function (defun postpostproc-sortprops (pts) Index: fomus/split.lisp diff -u fomus/split.lisp:1.9 fomus/split.lisp:1.10 --- fomus/split.lisp:1.9 Sun Jul 31 07:39:32 2005 +++ fomus/split.lisp Sun Jul 31 09:35:07 2005 @@ -148,7 +148,10 @@ (multiple-value-bind (e n) (split-preproc (nconc r (meas-events m)) (meas-off m) (meas-endoff m) (let ((i (find-if #'meas-events (part-meas p)))) (if i (event-voice* (first (meas-events i))) 1))) - (setf (meas-events m) e r n))))) + (setf (meas-events m) e + r (loop for x in n if (chordp x) + nconc (mapcar (lambda (y t1 t2) (copy-event x :note y :tielt t1 :tiert t2)) + (event-note x) (event-tielt x) (event-tiert x)) else collect x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SPLITTER