[fomus-cvs] CVS fomus
dpsenicka
dpsenicka at common-lisp.net
Sat Jan 28 20:31:21 UTC 2006
Update of /project/fomus/cvsroot/fomus
In directory common-lisp:/tmp/cvs-serv9366
Modified Files:
accidentals.lisp backend_cmn.lisp backend_ly.lisp
backend_xml.lisp data.lisp marks.lisp misc.lisp postproc.lisp
test.lisp util.lisp version.lisp
Log Message:
bug fixes
--- /project/fomus/cvsroot/fomus/accidentals.lisp 2006/01/19 00:02:35 1.14
+++ /project/fomus/cvsroot/fomus/accidentals.lisp 2006/01/28 20:31:19 1.15
@@ -409,41 +409,42 @@
;; rests are removed already, after chords & ties
;; events are events in 1 measure
(defun acc-nokey-postaccs (events)
- (when *acc-throughout-meas*
- (let ((as (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil))
- (ac (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil)))
- (flet ((fixacc (e n a a2 tl)
- (declare (type noteex e) (type rational n) (type (integer -2 2) a) (type (rational -1/2 1/2) a2) (type boolean tl))
- (let ((w (- n a a2)))
- (if tl
- (setf (svref as w) (unless (and (= a 0) (= a2 0)) (cons a a2)) (svref ac w) t)
- (if (and (= a 0) (= a2 0))
- (when (svref as w) ; show the natural
- (setf (svref as w) nil)
- (rmmark e (list :cautacc w))
- (addmark e (list (if (svref ac w) :cautacc :showacc) w)))
- (if (equal (svref as w) (cons a a2))
- (addmark e (list :hideacc w))
- (setf (svref as w) (cons a a2) (svref ac w) nil)))))))
- (loop
- for e of-type noteex in events
- if (chordp e)
- do (loop
- for n of-type rational in (event-notes* e)
- and a of-type (integer -2 2) in (event-accs e)
- and a2 of-type (rational -1/2 1/2) in (event-addaccs e)
- and tl of-type boolean in (event-tielt e)
- do (fixacc e n a a2 tl))
- else do (fixacc e (event-note* e) (event-acc e) (event-addacc e) (event-tielt e))))))
+ (let ((as (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil))
+ (ac (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil)))
+ (flet ((fixacc (e n a a2 tl)
+ (declare (type noteex e) (type rational n) (type (integer -2 2) a) (type (rational -1/2 1/2) a2) (type boolean tl))
+ (let ((w (- n a a2)))
+ (if tl
+ (setf (svref as w) (unless (and (= a 0) (= a2 0)) (cons a a2)) (svref ac w) t)
+ (if (and (= a 0) (= a2 0))
+ (when (svref as w) ; show the natural
+ (setf (svref as w) nil)
+ (rmmark e (list :cautacc w))
+ (addmark e (list (if (svref ac w) :cautacc :showacc) w)))
+ (if (equal (svref as w) (cons a a2))
+ (addmark e (list :hideacc w))
+ (setf (svref as w) (cons a a2) (svref ac w) nil)))))))
+ (loop
+ for e of-type noteex in events
+ if (chordp e)
+ do (loop
+ for n of-type rational in (event-notes* e)
+ and a of-type (integer -2 2) in (event-accs e)
+ and a2 of-type (rational -1/2 1/2) in (event-addaccs e)
+ and tl of-type boolean in (event-tielt e)
+ do (fixacc e n a a2 tl))
+ else do (fixacc e (event-note* e) (event-acc e) (event-addacc e) (event-tielt e)))))
(print-dot))
;; post processing
(defun postaccs (parts)
- (loop for p of-type partex in parts unless (is-percussion p) do
- (loop for m of-type meas in (part-meas p) do
- (multiple-value-bind (evs rs) (split-list (meas-events m) #'notep)
- (case (auto-accs-fun)
- (:nokey1 (acc-nokey-postaccs evs))
- (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*)))
- (setf (meas-events m) (sort (nconc rs evs) #'sort-offdur))))))
+ (when *acc-throughout-meas*
+ (loop for p of-type partex in parts unless (is-percussion p) do
+ (loop for m of-type meas in (part-meas p) do
+ (multiple-value-bind (evs rs) (split-list (meas-events m) #'notep)
+ (loop for ev of-type cons in (split-into-groups evs #'event-staff) do
+ (case (auto-accs-fun)
+ (:nokey1 (acc-nokey-postaccs (copy-list (sort ev #'sort-offdur))))
+ (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*))))
+ (setf (meas-events m) (sort (nconc rs evs) #'sort-offdur)))))))
--- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/26 05:48:21 1.4
+++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/28 20:31:19 1.5
@@ -8,6 +8,10 @@
(in-package :fomus)
(compile-settings)
+(eval-when (:load-toplevel :execute)
+ (defparameter +cmn-view-exe+ +ghostview-exe+))
+(defparameter +cmn-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app"))
+
(defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%")
(defparameter +cmn-num-note+ (vector "C" nil "D" nil "E" "F" nil "G" nil "A" nil "B"))
@@ -22,9 +26,13 @@
(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/6 . ts)
(1/2 . e) (3/4 . e.) (7/8 . e..)
+ (1/3 . te)
(1 . q) (3/2 . q.) (7/4 . q..)
+ (2/3 . tq)
(2 . h) (3 . h.) (7/2 . h..)
+ (4/3 . th)
(4 . w) (6 . w.)
(8 . dw)))
(defparameter +cmn-restdurs+ '((1/32 . one-twenty-eighth-rest)
@@ -37,10 +45,6 @@
(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)
@@ -48,7 +52,9 @@
(: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)))
+(defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style)
+ (automatic-beams nil) (automatic-octave-signs nil)))
+(defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24)))
(defun internalize (x)
(typecase x
@@ -57,30 +63,55 @@
(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 view-cmn (filename options view)
+ (when (not *cmn-exists*) ;; for viewing only
+ (format t ";; ERROR: Common Music Notation required for CMN output~%")
+ (return-from view-cmn))
+ (when (>= *verbose* 1) (out ";; Compiling/opening ~S for viewing...~%" filename))
+ (destructuring-bind (&key view-exe view-exe-opts out-ext &allow-other-keys) options
+ (flet ((er (str)
+ (format t ";; ERROR: Error ~A CMN file~%" str)
+ (return-from view-cmn)))
+ #+(and (or cmu sbcl openmcl allegro) (or linux darwin unix))
+ (progn
+ (ignore-errors (delete-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))
+ (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir
+ (change-filename filename :name nil :ext nil))
+ (if (ignore-errors (load filename))
+ (progn
+ (unless (probe-file (change-filename filename :ext (or out-ext +cmn-out-ext+))) (er "compiling"))
+ (when view
+ (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program
+ (or view-exe +cmn-view-exe+)
+ (append (or view-exe-opts +cmn-view-opts+)
+ (list (change-filename filename :ext (or out-ext +cmn-out-ext+))))
+ :wait nil)
+ #+allegro (= (run-allegro-cmd
+ (apply #'vector (cons (or view-exe +cmn-view-exe+)
+ (cons (or view-exe +cmn-view-exe+)
+ (append (or view-exe-opts +cmn-view-opts+)
+ (list (change-filename filename :ext (or out-ext +cmn-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 CMN file~%"))))
(defun save-cmn (parts header filename options 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 out-ext &allow-other-keys) options
(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 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))
(case acc (flat "F") (natural "N") (sharp "S") (otherwise ""))
- (format nil "~D" (1- (truncate wnum 12)))))
- (or (lookup dur +cmn-durations+) (list 'rq dur)))
+ (format nil "~D" (1- (truncate wnum 12))))))
+ (when dur (list (or (lookup dur +cmn-durations+) (list 'rq dur))))
(unless (member acc '(nil flat natural sharp)) (list acc)))))
(cmnname (p)
(incf de)
@@ -92,79 +123,98 @@
collect (string x))))
"-"
(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 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 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)
- (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)))))))))))))))
+ (let* ((bv -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)
+ 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 `(meter ,(timesig-num (meas-timesig m)) ,(timesig-den (meas-timesig m)))
+ nconc
+ (loop
+ with bb and ee ;;for (pre e nxe) on (cons nil (nth vi (meas-events m))) ;;while e
+ for e in (nth vi (meas-events m))
+ for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m))
+ and l = (and (notep e) (> (event-beamlt e) 0))
+ and r = (and (notep e) (> (event-beamrt e) 0))
+ 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)
+ (setf bb e)
+ 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))
+ and do (setf o (+ co (cmndur (event-dur* e) m)))
+ finally (when ee (setf (car ee) '-beam)))
+ collect (let ((b (getprop m :barline)))
+ (if (>= o (+ stoff lmdur))
+ (lookup (second b) +cmn-barlines+)
+ (list (lookup (second b) +cmn-barlines+)
+ `(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+)))))
+ `(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* ,cmp
+ (let* ,(if (> bv 0) (cons `(bvect (make-array ,(1+ bv))) cmp) cmp)
,@(labels ((pfn (pps &optional (grp 1))
(loop for e = (pop pps) ; e = part
while e
@@ -179,4 +229,5 @@
else nconc (gethash e phash))))
(pfn parts)))))
f)
- (fresh-line f)))))))
+ (fresh-line f))))))
+ (when process (view-cmn filename options view)))
--- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/26 05:48:21 1.23
+++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/28 20:31:19 1.24
@@ -13,31 +13,12 @@
#+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix))
-#+allegro
-(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)
- (declare (ignore istr))
- (values (if wait (sys:os-wait nil p) 0) ostr)))
-
-#+(or linux darwin unix)
-(defun find-exe (filename)
- (namestring*
- (or #+darwin (probe-file (change-filename filename :dir "/Applications"))
- #+darwin (probe-file (change-filename filename :dir "/Applications/Lilypond.app"))
- #+darwin (probe-file (change-filename filename :dir "/sw/bin"))
- (probe-file (change-filename filename :dir "/usr/local/bin"))
- (probe-file (change-filename filename :dir "/usr/bin"))
- (probe-file (change-filename filename :dir "/bin")))))
-
(eval-when (:load-toplevel :execute)
(defparameter +lilypond-exe+
(or #+darwin (find-exe "lilypond.sh")
(find-exe "lilypond")
#-darwin "lilypond" #+darwin "lilypond.sh"))
- (defparameter +lilypond-view-exe+
- #+darwin (find-exe "open")
- #+(and (or linux unix) (not darwin)) (or (find-exe "ggv") (find-exe "kgv") (find-exe "gv") (find-exe "ghostview") "gv")
- #-(or linux darwin unix) "gv"))
+ (defparameter +lilypond-view-exe+ +ghostview-exe+))
(defparameter +lilypond-opts+ '("--ps"))
(defparameter +lilypond-out-ext+ "ps")
--- /project/fomus/cvsroot/fomus/backend_xml.lisp 2005/10/01 00:49:45 1.4
+++ /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/01/28 20:31:19 1.5
@@ -124,11 +124,12 @@
("sign" nil ,s)
,@(when l `(("line" nil ,l)))
,@(when o `(("clef-octave-change" nil ,o)))))))))
- ,.(loop with nv = (length (meas-voices m))
+ ,.(loop with nv = (length (meas-voices m)) and ts = (meas-timesig m)
for v in (meas-voices m)
- for b = (getprop m :barline)
+ for b = (getprop m :barline) and fi = nil then t
+ when fi collect `("backup" nil ("duration" nil ,(* (- (meas-endoff m) (meas-off m)) (timesig-beat* ts) dv)))
nconc (loop
- with tv and ts = (meas-timesig m)
+ with tv
for e in v nconc
(loop with ch = (chordp e)
for fi = t then nil
@@ -155,15 +156,16 @@
("display-step" nil ,(svref +xml-num-perc-note+ (mod no 12)))
("display-octave" nil ,(floor (1- no) 12)))))
,@(when (restp e) '(("rest" nil)))
+;; ,@(when tl '(("tie" ("type" "stop"))))
+;; ,@(when tr '(("tie" ("type" "start"))))
,@(unless (event-grace e) `(("duration" nil ,(* (event-writtendur e ts) dv))))
,@(when (> nv 1) `(("voice" nil ,(event-voice* e))))
- ,@(when tr '(("tie" ("type" "end"))))
- ,@(when tl '(("tie" ("type" "start"))))
("type" nil ,(lookup (event-writtendur* e ts) +xml-num-durtype+))
,.(loop repeat (nth-value 1 (event-writtendur* e ts)) collect '("dot" nil))
- ,@(let ((ca (getmark e (list :cautacc o))))
- (when (and (notep e) (not pc)
- (or (/= ac 0) (/= aac 0) ca))
+ ,@(let ((ca (getmark e (list :cautacc no))))
+ (when (and (notep e) (not pc) (not tl)
+ (not (getmark e (list :hideacc no)))
+ (or (getmark e (list :showacc no)) (/= ac 0) (/= aac 0) ca))
`(("accidental" ,(when ca '("cautionary" "yes"))
,(svref (svref +xml-num-acctype+ (+ ac 2)) (1+ (* aac 2)))))))
,@(when (event-tup e)
@@ -187,7 +189,10 @@
(loop for i from 1 to bc collect `("beam" ("number" ,i) "continue"))
(loop for i from (1+ bc) to (event-beamlt e) collect `("beam" ("number" ,i) "end"))
(loop for i from (1+ bc) to (event-beamrt e) collect `("beam" ("number" ,i) "begin")))))
- ;; notations
+ ,@(let ((ntr (when tr '(("tied" ("type" "start")))))
+ (ntl (when tl '(("tied" ("type" "stop"))))))
+ (when (or ntr ntl)
+ `(("notations" nil , at ntl , at ntr))))
)
do (let ((ns (mapcar #'rest (getmarks e '(:endtup)))))
(setf tv (delete-if (lambda (x) (find (first x) ns)) tv)))))
--- /project/fomus/cvsroot/fomus/data.lisp 2006/01/19 00:02:35 1.28
+++ /project/fomus/cvsroot/fomus/data.lisp 2006/01/28 20:31:19 1.29
@@ -794,11 +794,11 @@
'((:startslur- :slur- :endslur- nil)
(:startgraceslur- :graceslur- :endgraceslur- nil)
(:starttext- :text- :endtext- :text)
- (:startwedge< :wedge< :endwedge< t)
- (:startwedge> :wedge> :endwedge> t)
- (:startwedge*< :wedge*< :endwedge*< t)
- (:startwedge*> :wedge*> :endwedge*> t)
- (:startlongtrill- :longtrill- :endlongtrill- t)))
+ (:startwedge< :wedge< :endwedge< nil)
+ (:startwedge> :wedge> :endwedge> nil)
+ (:startwedge*< :wedge*< :endwedge*< nil)
+ (:startwedge*> :wedge*> :endwedge*> nil)
+ (:startlongtrill- :longtrill- :endlongtrill- nil)))
(defparameter +marks-spanner-staves+
'((:start8up- :8up- :end8up- :8up)
(:start8down- :8down- :end8down- :8down)))
--- /project/fomus/cvsroot/fomus/marks.lisp 2006/01/26 05:48:21 1.14
+++ /project/fomus/cvsroot/fomus/marks.lisp 2006/01/28 20:31:19 1.15
@@ -53,17 +53,19 @@
(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 and sta
+ with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta and mor of-type list
for (e nxe) of-type ((or noteex restex) (or noteex restex null)) on (reverse (part-events p)) do ; go backwards, find endsyms
+ (setf mor nil)
(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
(loop for x = (popmark e endsym) while x collect (force-list x)))
#'< :key (lambda (x) (or (second x) 1)))
do (let ((lv (or a1 1)))
- (unless (gethash lv ss)
- (setf (gethash lv ss) (incf nu))
- (addmark e (list endsym nu)))))
+ (if (gethash lv ss)
+ (push lv mor)
+ (progn (setf (gethash lv ss) (incf nu))
+ (addmark e (list endsym nu))))))
(loop ; find startsyms
for rr0 of-type cons
in (sort (loop for x = (popmark e startsym)
@@ -85,11 +87,17 @@
(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)))
- (progn
+ (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)))
+ (loop for lv of-type (integer 1) in mor do
+ (unless (gethash lv ss)
+ (setf (gethash lv ss) (incf nu))
+ (addmark e (list endsym nu))))
+ (loop for l of-type (integer 1) being each hash-value in ss
+ if nxe do (unless (getmark e (list endsym l)) (addmark e (list contsym l)))
+ else do (addmark e (list startsym l)))
(push e sta))
(print-dot))))
--- /project/fomus/cvsroot/fomus/misc.lisp 2006/01/19 00:02:35 1.13
+++ /project/fomus/cvsroot/fomus/misc.lisp 2006/01/28 20:31:19 1.14
@@ -67,6 +67,25 @@
(defmacro cons-list (objs places)
`(mapcar #'cons ,objs ,places))
+(declaim (inline namestring*))
+(defun namestring* (filename) (when filename (namestring filename)))
+
+#+allegro
+(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)
+ (declare (ignore istr))
+ (values (if wait (sys:os-wait nil p) 0) ostr)))
+
+#+(or linux darwin unix)
+(defun find-exe (filename)
+ (namestring*
+ (or #+darwin (probe-file (change-filename filename :dir "/Applications"))
+ #+darwin (probe-file (change-filename filename :dir "/Applications/Lilypond.app"))
+ #+darwin (probe-file (change-filename filename :dir "/sw/bin"))
+ (probe-file (change-filename filename :dir "/usr/local/bin"))
+ (probe-file (change-filename filename :dir "/usr/bin"))
+ (probe-file (change-filename filename :dir "/bin")))))
+
(defstruct (heap (:constructor make-heap-aux) (:predicate heapp))
(fun #'+ :type (function (t t) t))
(arr #() :type (array t)))
--- /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/26 05:48:21 1.18
+++ /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/28 20:31:19 1.19
@@ -255,19 +255,23 @@
;; leave middle marks
(defun postproc-spanners (pts)
(declare (type list pts))
- (loop
+ (loop
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 do (addmark e (nconc (list replsym lv) (cddr ma)))))
+ do (loop for v from 0 below (loop for x of-type meas in (part-meas p) maximize (length (meas-voices x))) do
+ (loop with h = (make-hash-table)
+ for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (nth v (meas-voices x))) do
+ (loop
+ for ma of-type cons in (mapcar #'force-list (getmarks e endsym))
+ for lv = (second ma) do
+ (unless (gethash lv h)
+ (rmmark e (if lv (list startsym lv) startsym))
+ (rmmark e (if lv (list endsym lv) endsym))
+ (when replsym (addmark e (nconc (list replsym lv) (cddr ma)))))
+ (remhash lv h))
+ (loop
+ for ma of-type cons in (mapcar #'force-list (getmarks e startsym))
+ do (setf (gethash (second ma) h) t))))
(print-dot))))
(defun postproc-barlines (pts)
@@ -476,10 +480,10 @@
(defun postproc (pts)
(postproc-tremolos pts)
(postproc-timesigs pts)
- (postproc-spanners pts)
(postproc-markaccs pts)
(postproc-midimarks pts)
(postproc-voices pts) ;; voices now separated into lists
+ (postproc-spanners pts)
(postproc-clefs pts)
(postproc-staves pts)
(postproc-measrests pts)
--- /project/fomus/cvsroot/fomus/test.lisp 2006/01/26 05:48:21 1.21
+++ /project/fomus/cvsroot/fomus/test.lisp 2006/01/28 20:31:19 1.22
@@ -5,7 +5,7 @@
;; Example 1
(fomus
- :backend '((:data) (:lilypond :view t) (:midi :tempo 120 :delay 1 :play nil))
+ :backend '((:data) (:lilypond :view t) (:cmn :view t) (:midi :tempo 120 :delay 1 :play nil))
:ensemble-type :orchestra
:parts
(list
--- /project/fomus/cvsroot/fomus/util.lisp 2005/10/22 20:43:06 1.19
+++ /project/fomus/cvsroot/fomus/util.lisp 2006/01/28 20:31:19 1.20
@@ -30,6 +30,15 @@
(or (= (loop for i in '() maximize i) 0) (error "Failed LOOP test in \"util.lisp\"")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FIND GHOSTVIEW
+
+(eval-when (:load-toplevel :execute)
+ (defparameter +ghostview-exe+
+ #+darwin (find-exe "open")
+ #+(and (or linux unix) (not darwin)) (or (find-exe "ggv") (find-exe "kgv") (find-exe "gv") (find-exe "ghostview") "gv")
+ #-(or linux darwin unix) "gv"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROGRESS DOTS, IMMEDIATE OUTPUT
(declaim (type (integer 0) +progress-int+))
@@ -102,9 +111,6 @@
finally
(return (if (< o o2) (nconc r (list (cons o o2))) r))))
-(declaim (inline namestring*))
-(defun namestring* (filename) (when filename (namestring filename)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROPERTIES/MARKS
--- /project/fomus/cvsroot/fomus/version.lisp 2006/01/26 05:48:21 1.25
+++ /project/fomus/cvsroot/fomus/version.lisp 2006/01/28 20:31:19 1.26
@@ -12,7 +12,7 @@
(declaim (type string +title+)
(type cons +version+ +banner+))
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 30))
+(defparameter +version+ '(0 1 31))
(defparameter +banner+
`("Lisp music notation formatter"
"Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"
More information about the Fomus-cvs
mailing list