Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv8816
Modified Files: backend_cmn.lisp backend_ly.lisp marks.lisp postproc.lisp test.lisp version.lisp Log Message: bug fixes
--- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/19 00:02:35 1.3 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/26 05:48:21 1.4 @@ -19,39 +19,69 @@ (:repeatleft . end-repeat-bar) (:repeatright . begin-repeat-bar) (:repeatleftright . begin-and-end-repeat-bar) (:invisible . (bar invisible))))
+(defparameter +cmn-durations+ '((1/16 . 64th) (3/32 . 64th.) + (1/8 . 32nd) (3/16 . 32nd.) + (1/4 . s) (3/8 . s.) (7/16 . s..) + (1/2 . e) (3/4 . e.) (7/8 . e..) + (1 . q) (3/2 . q.) (7/4 . q..) + (2 . h) (3 . h.) (7/2 . h..) + (4 . w) (6 . w.) + (8 . dw))) +(defparameter +cmn-restdurs+ '((1/32 . one-twenty-eighth-rest) + (1/16 . sixty-fourth-rest) + (1/8 . thirty-second-rest) + (1/4 . sixteenth-rest) (3/8 . dotted-sixteenth-rest) + (1/2 . eighth-rest) (3/4 . dotted-eighth-rest) + (1 . quarter-rest) (3/2 . dotted-quarter-rest) + (2 . half-rest) (3 . dotted-half-rest) + (4 . whole-rest) (6 . dotted-whole-rest) + (8 . double-whole-rest))) + +;; french-violin treble tenor-treble soprano mezzo-soprano alto tenor baritone baritone-c +;; baritone-f bass sub-bass double-bass +;; percussion quad-bass double-treble quad-treble + +(defparameter +cmn-clefs+ '((:subbass-8dn . sub-bass) (:bass-8dn . double-bass) (:c-baritone-8dn . baritone-c) (:f-baritone-8dn . baritone-f) (:tenor-8dn . tenor) + (:subbass . sub-bass) (:alto-8dn . alto) (:bass . bass) (:mezzosoprano-8dn . mezzo-soprano) (:c-baritone . baritone-c) (:f-baritone . baritone-f) + (:soprano-8dn . soprano) (:tenor . tenor) (:subbass-8up . sub-bass) (:treble-8dn . tenor-treble) (:alto . alto) (:bass-8up . bass) + (:mezzosoprano . mezzo-soprano) (:c-baritone-8up . baritone-c) (:f-baritone-8up . baritone-f) (:soprano . soprano) (:tenor-8up . tenor) + (:treble . treble) (:alto-8up . alto) (:mezzosoprano-8up . mezzo-soprano) (:soprano-8up . soprano) (:treble-8up . double-treble) + (:percussion . percussion))) + +(defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style))) + +(defun internalize (x) + (typecase x + (keyword x) + (symbol (intern (symbol-name x))) + (list (mapcar #'internalize x)) + (otherwise x))) + +;; (defparameter +cmn-writeflags+ '(:escape t)) + +(defparameter +cmn-out-ext+ "eps") + +;; (defun save-cmn (parts header filename options process view) nil) + (defun save-cmn (parts header filename options process view) - ;; (unless *cmn-exists* ;; for viewing only - ;; (format t ";; ERROR: Common Music Notation required for CMN output~%") - ;; (return-from save-cmn)) - #| - (declare (ignore process view)) + (when (and (not *cmn-exists*) (or process view)) ;; for viewing only + (format t ";; ERROR: Common Music Notation required for CMN output~%") + (return-from save-cmn)) (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) - (destructuring-bind (&key score-attr &allow-other-keys) options + (destructuring-bind (&key score-attr out-ext &allow-other-keys) options (format f "~A" header) - (let ((de 0) (phash (make-hash-table :test 'eq))) - (flet ((cmnnote (wnum acc1 acc2 wdur hide caut harmt harms) + (let ((de 0) (phash (make-hash-table :test 'equal))) + (flet ((cmndur (val m) (* val (timesig-beat* (meas-timesig m)) 4)) + (cmnnote (wnum acc1 acc2 dur hide show caut harmt harms) ;; wdur is actual dur * beat * 4 (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) - (when (and acc caut) (setf acc (list acc 'in-parentheses))) - (list 'note - (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) - (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) - (format nil "~D" (truncate wnum 12)))) - (svref wdur - - - - (if *quartertones* - (conc-strings - (svref +cmn-num-note+ (mod wnum 12)) - (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) - (svref +cmn-num-reg+ (1- (truncate wnum 12))) - (when caut "?")) - (conc-strings - (svref +cmn-num-note+ (mod wnum 12)) - (svref +cmn-num-acc+ (+ acc1 2)) - (svref +cmn-num-reg+ (1- (truncate wnum 12))) - (when caut "?")))) + (when caut (setf acc (list acc 'in-parentheses))) + (when (and (equal acc 'natural) (not show)) (setf acc nil)) + (nconc (list (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) + (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) + (format nil "~D" (1- (truncate wnum 12))))) + (or (lookup dur +cmn-durations+) (list 'rq dur))) + (unless (member acc '(nil flat natural sharp)) (list acc))))) (cmnname (p) (incf de) (intern @@ -64,58 +94,89 @@ (string (code-char (+ 64 de))))))) (let ((cmp (loop for p in parts nconc (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) - (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) - for v in voices and vi from 1 ... - for pna = (format nil "~A~D" cmn-partname vi) nconc - (loop with ns = (instr-staves (part-instr p)) - and o = 0 - for s in ns and si from 1 collect - (setf (maphash p phash) - `(,(if (> ns 1) (format nil "~A~D" pna si) pna0) - (staff - ,@(when (part-name p) (staff-name (part-name p))) - ,@(when (> ns 1) (tied-to (format nil "~A1" pna))) - ,@(loop for m in (part-meas p) nconc - (loop for e in (meas-events m) collect - (let ((nch (if (chordp e) + (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) + for vi from 0 below nvce nconc ; loop through voices + (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) + and ns = (instr-staves (part-instr p)) ; number of staves + for si from 1 to ns + for ipna = (intern (if (> ns 1) + (if (> nvce 0) + (format nil "~A~D~D" pna (1+ vi) si) + (format nil "~A1~D" pna si)) + (if (> nvce 0) + (format nil "~A~D" pna (1+ vi)) + pna))) + do (setf (gethash p phash) (nconc (gethash p phash) (list ipna))) + collect + `(,ipna + (staff bar + ,@(when (and (<= si 1) (part-name p)) (list (list 'staff-name (part-name p)))) + ,@(when (> vi 0) + (list (list 'tied-to (intern (if (> ns 1) + (format nil "~A1~D" pna si) + (format nil "~A1" pna)))))) + ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) + ,@(loop with o = 0 and st = 1 + for m in (part-meas p) + and stoff = 0 then (+ stoff lmdur) + for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) + when (getprop m :startsig) collect (list 'meter (timesig-num (meas-timesig m)) (timesig-den (meas-timesig m))) + nconc + (loop for e in (nth vi (meas-events m)) + for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m)) + do (setf st (or (third (getmark e '(:staff :voice))) st)) + when (= st si) collect + (let ((y (if (restp e) + (or (lookup (cmndur (event-dur* e) m) +cmn-restdurs+) (error "Finish me")) + (if (chordp e) + (cons 'chord (loop - for (n nn) on (event-notes* e) + for n in (event-writtennotes e) and w in (event-writtennotes e) and a in (event-accs e) and a2 in (event-addaccs e) for ha = (getmark e (list :harmonic :touched n)) and hs = (getmark e (list :harmonic :sounding n)) collect (cmnnote w a a2 + (cmndur (event-dur* e) m) + (getmark e (list :hideacc n)) + (getmark e (list :showacc n)) (getmark e (list :cautacc n)) (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n)))) - (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) - (getmark e (list :cautacc (event-note* e))) - (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n)))))))) - collect (let ((b (getprop m :barline))) (lookup (second b) +cmn-barlines+)) - - - - - (write - `(cmn ,score-attr - (let , - - - - - - ,@(labels ((pfn (pps &optional (grp 1)) - (loop for e = (pop pps) ; e = part - for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) - if gr nconc (let* ((gl (second (first (sort gr #'< :key #'second)))) - (ps (pfn (loop for i = e then (pop pps) collect i until (getprop e (list :endgroup gl))) (1+ gl)))) - (ecase (third gr) - ((:group :choirgroup) `((system bracket ,@ps))) - (:grandstaff `((system brace ,@ps))))) - else collect - (loop )))) - (pfn parts))) - :stream f - :escape nil)))|#) \ No newline at end of file + (getmark e (list :harmonic :sounding n))))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) + (cmndur (event-dur* e) m) + (getmark e (list :hideacc (event-writtennote e))) + (getmark e (list :showacc (event-writtennote e))) + (getmark e (list :cautacc (event-writtennote e))) + (getmark e (list :harmonic :touched (event-writtennote e))) + (getmark e (list :harmonic :sounding (event-writtennote e)))))))) + (if (> co o) (nconc y (list (list 'onset co))) y)) + and do (setf o (+ co (cmndur (event-dur e) m)))) + collect (let ((b (getprop m :barline))) + (if (>= o (+ stoff lmdur)) + (lookup (second b) +cmn-barlines+) + (list (lookup (second b) +cmn-barlines+) + (list 'onset (setf o (+ stoff lmdur))))))))))))))) + (prin1 (internalize '(in-package cmn)) f) + (fresh-line f) + (prin1 + (internalize + `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) + :key (lambda (x) (if (consp x) (first x) x)) :from-end t) + (let* ,cmp + ,@(labels ((pfn (pps &optional (grp 1)) + (loop for e = (pop pps) ; e = part + while e + for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) ; startgroups = grp or greater + if gr nconc (let* ((gg (first (sort gr #'< :key #'second))) + (gl (second gg)) ; gl = level + (ps (pfn (loop for i = e then (pop pps) collect i until (getprop e (list :endgroup gl))) (1+ gl)))) + (case (third gg) + ((:group :choirgroup) (list (append '(system bracket) ps))) + (:grandstaff (list (append '(system brace) ps))) + (otherwise (list (append '(system) ps))))) + else nconc (gethash e phash)))) + (pfn parts))))) + f) + (fresh-line f))))))) --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/19 00:02:35 1.22 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/26 05:48:21 1.23 @@ -14,10 +14,10 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix))
#+allegro -(defun run-allegro-cmd (cmd) +(defun run-allegro-cmd (cmd &optional (wait t)) (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) - (sys:os-wait nil p) - ostr)) + (declare (ignore istr)) + (values (if wait (sys:os-wait nil p) 0) ostr)))
#+(or linux darwin unix) (defun find-exe (filename) @@ -78,7 +78,7 @@ (apply #'vector (cons (or view-exe +lilypond-view-exe+) (cons (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+)))))))) 0) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+))))))) nil) 0) (er "viewing")))) (er "compiling"))) #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) @@ -89,7 +89,7 @@ (setf *lilypond-version* (destructuring-bind (&key exe &allow-other-keys) options (let ((os #+(or cmu sbcl openmcl) (make-string-output-stream) - #+allegro (ignore-errors (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v"))))) + #+allegro (ignore-errors (nth-value 1 (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v")))))) #+(or cmu sbcl openmcl) (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) (list "-v") :wait t :output os)) @@ -275,9 +275,9 @@ (cond ((and g1 (getmark e :endgrace)) (if gs (if (< g 0) "\acciaccatura " "\appoggiatura ") "\grace ")) (g1 (if gs (if (< g 0) "\acciaccatura {" "\appoggiatura {") "\grace {")))) "")) - (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\< ") - ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\> ") - (t "")) +;; (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\< ") +;; ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\> ") +;; (t "")) (cond ((getmark e '(:arpeggio :up)) "\arpeggioUp ") ((getmark e '(:arpeggio :down)) "\arpeggioDown ") ((getmark e :arpeggio) "\arpeggioNeutral ") @@ -385,16 +385,19 @@ (2 "\doublesharp"))) when (eq cdi :d) collect "_" and collect (car i))) (cond ((or (getmark e :endwedge<) (getmark e :endwedge>)) "\!") - ((getmark e :startwedge<) "\<") - ((getmark e :startwedge>) "\>") +;; ((getmark e :startwedge<) "\<") +;; ((getmark e :startwedge>) "\>") (t "")) (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+))) - (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\<") - ((and (getmark e :startwedge>) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\>") - (t "")) + (cond ((getmark e :startwedge<) "\< ") + ((getmark e :startwedge>) "\> ") + (t "")) +;; (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\<") +;; ((and (getmark e :startwedge>) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\>") +;; (t "")) (conc-stringlist (loop for x in '(:text :textdyn :texttempo :textnote) and m in (list (or text-markup +lilypond-text+) --- /project/fomus/cvsroot/fomus/marks.lisp 2006/01/19 00:02:35 1.13 +++ /project/fomus/cvsroot/fomus/marks.lisp 2006/01/26 05:48:21 1.14 @@ -53,9 +53,8 @@ (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners do (loop for p of-type partex in pts do (loop - with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 - for e of-type (or noteex restex) in (reverse (part-events p)) ; go backwards, find endsyms - do + with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta + for (e nxe) of-type ((or noteex restex) (or noteex restex null)) on (reverse (part-events p)) do ; go backwards, find endsyms (loop for (xxx a1) of-type (t (or (integer 1) null)) in (sort (nconc (when contsym (loop for x = (popmark e contsym) while x collect (force-list x))) ; a1 is level @@ -64,7 +63,7 @@ do (let ((lv (or a1 1))) (unless (gethash lv ss) (setf (gethash lv ss) (incf nu)) - (addmark e (list endsym nu))))) + (addmark e (list endsym nu))))) (loop ; find startsyms for rr0 of-type cons in (sort (loop for x = (popmark e startsym) @@ -86,9 +85,12 @@ (addmark e (nconc (list startsym n) (when a3 (list a3)) (when a2 (list a2)))) ; fixed order now--level is mandatory 1st argument, string is second if text, modifier is last and optional (decf nu)) (error "Levels for marks ~S, ~S and ~S are out of order at offset ~S, part ~S" startsym contsym endsym (event-foff e) (part-name p))) - #|(error "Missing end mark ~S or ~S for start mark ~S at offset ~S, part ~S" contsym endsym startsym (event-foff e) (part-name p))|#)))) - (loop for l being each hash-value in ss do (addmark e (list contsym l))) - #|finally (or (= nu 0) (error "Missing start mark ~S in part ~S" startsym (part-name p)))|#) + (progn + (loop for (a b) of-type ((or noteex restex) (or noteex restex null)) on sta + if b do (addmark a (list contsym 1)) else do (addmark a (list endsym 1)) + (addmark e (nconc (list startsym 1) (when a3 (list a3)) (when a2 (list a2)))))))))) + (loop for l being each hash-value in ss do (addmark e (list (if nxe contsym startsym) l))) + (push e sta)) (print-dot))))
(defun expand-marks (pts) --- /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/19 00:02:35 1.17 +++ /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/26 05:48:21 1.18 @@ -252,22 +252,22 @@ when (and (list1p g) (restp (first g))) do (addmark (first g) :measrest))) (print-dot)))
+;; leave middle marks (defun postproc-spanners (pts) (declare (type list pts)) (loop - for (startsym xxx endsym replsym) of-type (symbol t symbol symbol) in (append +marks-spanner-voices+ +marks-spanner-staves+) ;; fix any notes with starts/ends on same note + for (startsym xxx endsym replsym) of-type (symbol symbol symbol symbol) in (append +marks-spanner-voices+ +marks-spanner-staves+) ;; fix any notes with starts/ends on same note unless (truep replsym) do (loop for p of-type partex in pts - do (loop for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (meas-events x)) - do (loop - for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) - for lv = (second ma) - when (getmark e (if lv (list endsym lv) endsym)) - do - (rmmark e (if lv (list startsym lv) startsym)) - (rmmark e (if lv (list endsym lv) endsym)) - (when replsym (addmark e (let ((x (cddr ma))) - (if x (cons replsym x) replsym)))))) + do (loop for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (meas-events x)) do + (loop + for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) + for lv = (second ma) + when (getmark e (if lv (list endsym lv) endsym)) + do + (rmmark e (if lv (list startsym lv) startsym)) + (rmmark e (if lv (list endsym lv) endsym)) + when replsym do (addmark e (nconc (list replsym lv) (cddr ma))))) (print-dot))))
(defun postproc-barlines (pts) --- /project/fomus/cvsroot/fomus/test.lisp 2005/11/12 20:42:46 1.20 +++ /project/fomus/cvsroot/fomus/test.lisp 2006/01/26 05:48:21 1.21 @@ -5,7 +5,7 @@ ;; Example 1
(fomus - :backend '((:data) (:lilypond :view nil) (:midi :tempo 120 :delay 1 :play nil)) + :backend '((:data) (:lilypond :view t) (:midi :tempo 120 :delay 1 :play nil)) :ensemble-type :orchestra :parts (list @@ -237,6 +237,7 @@ (fomus :backend '((:data) (:lilypond :view t) (:midi :tempo 80 :delay 1)) :ensemble-type :orchestra + :auto-grace-slurs nil :parts (list (make-part --- /project/fomus/cvsroot/fomus/version.lisp 2006/01/19 00:02:35 1.24 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/01/26 05:48:21 1.25 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 29)) +(defparameter +version+ '(0 1 30)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"