[fomus-cvs] CVS fomus
dpsenicka
dpsenicka at common-lisp.net
Sun Feb 5 04:57:33 UTC 2006
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"
More information about the Fomus-cvs
mailing list