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 ,@ntl ,@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"