[fomus-cvs] CVS fomus
dpsenicka
dpsenicka at common-lisp.net
Thu Jan 26 05:48:22 UTC 2006
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 , at ps)))
- (:grandstaff `((system brace , at 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"
More information about the Fomus-cvs
mailing list