Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv28667

Modified Files: TODO backend_cmn.lisp backend_ly.lisp backend_xml.lisp version.lisp Log Message: bugs/cmn

--- /project/fomus/cvsroot/fomus/TODO 2006/02/03 07:17:18 1.28 +++ /project/fomus/cvsroot/fomus/TODO 2006/02/05 04:57:33 1.29 @@ -17,11 +17,16 @@ Aesthetic tweaks: avoid staff changes when notes move in other direction re-evaluate initial clef decision in measure 1 + Some more marks: + pedal on/off + double/triple tongue + bartok pizz.

Short Term:

Combine separate sections with different settings into one score Proportional notation + Automatic percussion instrument changes Durations that fill to next/previous note Part properties: override settings for individual parts Number of lines in staff --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/31 08:19:57 1.6 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/05 04:57:33 1.7 @@ -58,6 +58,18 @@ (automatic-beams nil) (automatic-octave-signs nil))) (defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24)))

+;; left out: (:leftheel . ...) (:rightheel . ...) (:lefttoe . ...) (:righttoe . ...)| +(defparameter +cmn-marks+ + '((:accent . accent) (:marcato . marcato) (:staccatissimo . staccato) (:staccato . staccato) (:tenuto . tenuto) + (:portato . (detache (staccato (dy -1/8)))) (:upbow . up-bow) (:downbow . down-bow) + (:thumb . thumb) (:open . open-note) (:stopped . stopped-note) ((:breath :after) . breath-mark) (:fermata . fermata))) + +;; (:arpeggio . ...) (:pizz . ...) (:arco . ...) +;; ((:glissando :after) . ...) ((:portamento :after) . ...) <-- begin/end marks, use setf gliss- and -gliss + +(defparameter +cmn-trmarks+ + '((:prall . inverted-mordent) (:trill . trill) (:mordent . mordent) (:startlongtrill- . trill))) + (defun internalize (x) (typecase x (keyword x) @@ -96,6 +108,7 @@ (er "viewing")))) (er "compiling")))))

+;; multinote trems??? (defun save-cmn (parts header filename options process view) (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) @@ -103,11 +116,13 @@ (format f "~A" header) (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 + (cmnnote (wnum acc1 acc2 dur hide show caut grace #|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 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)) + (nconc (when (< grace 0) (list 'grace-note)) + (when (>= grace 0) (list 'appoggiatura)) + (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)))))) (when dur (list (or (lookup dur +cmn-durations+) (list 'rq dur)))) @@ -122,11 +137,14 @@ collect (string x)))) "-" (string (code-char (+ 64 de))))))) - (let* ((bv -1) + (let* ((bv -1) (gv -1) (pv -1) (sv -1) (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))) and bbb = (make-hash-table :test 'eq) + and ggg = (make-hash-table :test 'eq) + and ppp = (make-hash-table :test 'eq) + and sss = (make-hash-table :test 'eq) 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 @@ -148,7 +166,7 @@ (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 + ,@(loop with o = 0 and st = 1 and gg and pg and sg and wvy for m in (part-meas p) and stoff = 0 then (+ stoff lmdur) for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) @@ -163,42 +181,109 @@ and tu = (getmark e :starttup) do (setf st (or (third (getmark e '(:staff :voice))) st)) when (and r (not l)) do - (when ee (setf (car ee) '-beam ee nil)) - (event-off e) + (when ee (setf (car ee) '-beam ee nil)) ;;(event-off e) (setf bb e) + when (getmark e '(:glissando :after)) do (setf gg e) + when (getmark e '(:portamento :after)) do (setf pg e) + when (and wvy (getmark e :endlongtrill-)) do (setf (second wvy) co) when (= st si) collect - (let* ((cd (cmndur (event-dur* e) m)) - (y (if (restp e) ; y must be nconcable - (or (lookup cd +cmn-restdurs+) (list 'rest `(rq ,cd))) - (if (chordp e) - (cons 'chord - (nconc - (loop - 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 nil - (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)))) - (list (or (lookup cd +cmn-restdurs+) `(rq ,cd))))) - (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) cd - (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)))))))) - (when (or l r) - (let ((h (gethash bb bbb))) - (nconc y (list (if h - (setf ee (list '-beam- `(svref bvect ,h))) - `(setf (svref bvect ,(setf (gethash bb bbb) (incf bv))) (beam-))))))) - (if (> co o) (nconc y (list `(onset ,co))) y)) + (let ((cd (cmndur (event-dur* e) m))) + (nconc (if (restp e) + (or (lookup cd +cmn-restdurs+) (list 'rest `(rq ,cd))) + (if (chordp e) + (cons 'chord + (nconc + (loop + 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 nil + (getmark e (list :hideacc n)) + (getmark e (list :showacc n)) + (getmark e (list :cautacc n)) + (event-grace e) + #|(getmark e (list :harmonic :touched n))|# + #|(getmark e (list :harmonic :sounding n))|#)) + (list (or (lookup cd +cmn-restdurs+) `(rq ,cd))))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) cd + (getmark e (list :hideacc (event-writtennote e))) + (getmark e (list :showacc (event-writtennote e))) + (getmark e (list :cautacc (event-writtennote e))) + (event-grace e) + #|(getmark e (list :harmonic :touched (event-writtennote e)))|# + #|(getmark e (list :harmonic :sounding (event-writtennote e)))|#))) + (when (> co o) (list `(onset ,co))) + (when (or l r) + (let ((h (gethash bb bbb))) + (list (if h + (setf ee (list '-beam- `(svref bvect ,h))) ;; -beam- will be resetfed + `(setf (svref bvect ,(setf (gethash bb bbb) (incf bv))) (beam-)))))) + (loop for i in + (sort (delete-duplicates + (loop for (a1 . a2) in +cmn-marks+ + nconc (mapcar (lambda (x) (cons a2 (force-list x))) (getmarks e a1))) + :key #'cdr :test #'equal) + (lambda (x y) (cond + ((find (cadr x) +marks-withacc+) nil) + ((find (cadr y) +marks-withacc+) t) + (t (let ((x2 (caddr x)) (y2 (caddr y))) + (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) + (x2 t))))))) + collect (car i)) + (loop for i in + (delete-duplicates + (loop for (a1 . a2) in +cmn-trmarks+ + nconc (mapcar (lambda (x) (let ((f (force-list x))) + (cons a2 (if (eq (first f) :startlongtrill-) (fifth f) (third f))))) + (getmarks e a1))) + :key #'cdr :test #'equal) + collect + `(,(car i) ,@(when (cdr i) + (list `(ornament-sign + ,(ecase (cdr i) + (-2 'double-flat) + (-3/2 'flat-down) + (-1 'flat) + (-1/2 'natural-down) + (0 'natural) + (1/2 'natural-up) + (1 'sharp) + (3/2 'sharp-up) + (2 'double-sharp)) + (scale 1/2 1/2)))) + ,@(when (eq (car i) :startlongtrill-) + (list '(wavy-line t) + (setf wvy (list 'wavy-time nil)))))) + ;; ottavas + (let ((x (getmark e :tremolo))) + (when x (list `(tremolo (tremolo-slashes ,(- (roundint (log (third x) 1/2)) 2)))))) + ;;; start/end tremolos + (cond ((getmark e '(:arpeggio :up)) (list '(arpeggio arrow-up))) + ((getmark e '(:arpeggio :down)) (list '(arpeggio arrow-down))) + ((getmark e :arpeggio) (list 'arpeggio))) + ;;; dynamics + ;;; wedges + ;;; text + ;;; slur svect + (loop + for xxx in (nconc (getmarks e :startslur-) (getmarks e :endslur-)) + collect (let ((h (gethash sg sss))) + (list (if h + `(-slur (svref svect ,h)) + `(setf (svref svect ,(setf (gethash sg sss) (incf sv))) (slur-)))))) + (when (getmark e :glissando) + (let ((h (gethash gg ggg))) + (list (if h + `(-glissando (svref gvect ,h)) + `(setf (svref gvect ,(setf (gethash gg ggg) (incf gv))) (glissando-)))))) + (when (getmark e :portamento) + (let ((h (gethash pg ppp))) + (list (if h + `(-portamento (svref pvect ,h)) + `(setf (svref pvect ,(setf (gethash pg ppp) (incf pv))) (portamento-)))))))) and do (setf o (+ co (cmndur (event-dur* e) m))) finally (when ee (setf (car ee) '-beam))) collect (let ((b (getprop m :barline))) @@ -213,7 +298,12 @@ `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr +cmn-changeableopts+ (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* ,(if (> bv 0) (cons `(bvect (make-array ,(1+ bv))) cmp) cmp) + (let* ,(nconc + (if (> bv 0) (list `(bvect (make-array ,(1+ bv))))) + (if (> gv 0) (list `(gvect (make-array ,(1+ gv))))) + (if (> pv 0) (list `(pvect (make-array ,(1+ pv))))) + (if (> sv 0) (list `(svect (make-array ,(1+ sv))))) + cmp) ,@(labels ((pfn (pps &optional (grp 1)) (loop for e = (pop pps) ; e = part while e --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/03 07:17:18 1.27 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/05 04:57:33 1.28 @@ -117,7 +117,7 @@ (defparameter +lilypond-marks+ '((:accent . "->") (:marcato . "-^") (:staccatissimo . "-|") (:staccato . "-.") (:tenuto . "--") (:portato . "-_") (:upbow . "\upbow") (:downbow . "\downbow") (:thumb . "\thumb") (:leftheel . "\lheel") (:rightheel . "\rheel") (:lefttoe . "\ltoe") (:righttoe . "\rtoe") (:open . "\open") - (:stopped . "-+") #|(:turn . "\turn") (:reverseturn . "\reverseturn")|# (:arpeggio . "\arpeggio") (:pizz . "^"pizz."") (:arco . "^"arco"") + (:stopped . "-+") #|(:turn . "\turn") (:reverseturn . "\reverseturn")|# #|(:arpeggio . "\arpeggio")|# (:pizz . "^"pizz."") (:arco . "^"arco"") ((:breath :after) . " \breathe") ((:glissando :after) . "\glissando") ((:portamento :after) . "\glissando") ((:fermata :short) . "\shortfermata") (:fermata . "\fermata") ((:fermata :long) . "\longfermata") ((:fermata :verylong) . "\verylongfermata")))

--- /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/02/03 07:17:18 1.8 +++ /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/02/05 04:57:33 1.9 @@ -95,12 +95,14 @@ (defparameter +xml-1note-tremolo-kludge+ t) (defparameter +xml-multinote-tremolo-kludge+ t) (defparameter +xml-harmonic-kludge+ t) +(defparameter +xml-partgroups-kludge+ nil)

(defun save-xml (parts header filename options #|process view|#) (when (>= *verbose* 1) (out ";; Saving MusicXML file ~S...~%" filename)) (destructuring-bind (&key (xml-1note-tremolo-kludge +xml-1note-tremolo-kludge+) (xml-multinote-tremolo-kludge +xml-multinote-tremolo-kludge+) - (xml-harmonic-kludge +xml-harmonic-kludge+) &allow-other-keys) options + (xml-harmonic-kludge +xml-harmonic-kludge+) + (xml-partgroups-kludge +xml-partgroups-kludge+)&allow-other-keys) options (with-open-file (f filename :direction :output :if-exists :supersede) (loop for e in +xml-head+ do (format f "~A~%" e)) (format f "<!-- ~A -->~%" header) @@ -137,17 +139,18 @@ ,.(loop for p in parts and pn from 1 for s = (getprops p :startgroup) and e = (getprops p :endgroup) - when s nconc (loop for x in (sort s #'< :key #'second) when (> (second x) 0) collect - `("part-group" (("type" "start") ("number" ,(second x))) - ,@(case (third x) - (:group '(("group-symbol" nil "bracket"))) - (:grandstaff '(("group-symbol" nil "brace")))) - ("group-barline" nil "yes"))) + when (and s (not xml-partgroups-kludge)) + nconc (loop for x in (sort s #'< :key #'second) when (> (second x) 0) collect + `("part-group" (("type" "start") ("number" ,(second x))) + ,@(case (third x) + (:group '(("group-symbol" nil "bracket"))) + (:grandstaff '(("group-symbol" nil "brace")))) + ("group-barline" nil "yes"))) collect `("score-part" ("id" ,(format nil "P~A" pn)) ("part-name" nil ,(or (part-name p) "")) ,@(when (part-abbrev p) `(("part-abbreviation" nil ,(part-abbrev p))))) - when e nconc (loop for x in (sort e #'> :key #'second) when (> (second x) 0) collect - `("part-group" (("type" "stop") ("number" ,(second x))))))) + when (and e (not xml-partgroups-kludge)) nconc (loop for x in (sort e #'> :key #'second) when (> (second x) 0) collect + `("part-group" (("type" "stop") ("number" ,(second x))))))) ,.(loop for p in parts and pn from 1 for pc = (is-percussion p) and ns = (instr-staves (part-instr p)) collect `("part" ("id" ,(format nil "P~A" pn)) ,.(loop with slrlvl = (cons nil nil) and wlvl = (cons nil nil) and olvl = (cons nil nil) and tlvl = (cons nil nil) @@ -242,7 +245,7 @@ ("direction-type" nil ("words" ,+xml-textnotestyle+ ,i)) ,@(when (> ns 1) `(("staff" nil ,(event-staff e)))))))))) - nconc (when (and fi xml-1note-tremolo-kludge) + nconc (when fi (loop for x in (nconc (getmarks e :text) (getmarks e :textdyn) (getmarks e :textnote) (getmarks e :texttempo)) collect `("direction" ("placement" ,(ecase (second x) (:up "above") (:down "below"))) ("direction-type" nil --- /project/fomus/cvsroot/fomus/version.lisp 2006/02/03 07:17:18 1.29 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/05 04:57:33 1.30 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 34)) +(defparameter +version+ '(0 1 35)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"