[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
David Psenicka
dpsenicka at common-lisp.net
Thu Jul 21 15:38:46 UTC 2005
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
More information about the Fomus-cvs
mailing list