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)))) ,@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* ,@+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* ,@+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