fomus-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
January 2006
- 1 participants
- 4 discussions
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"
1
0
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 ,@ps)))
- (:grandstaff `((system brace ,@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"
1
0
![](https://secure.gravatar.com/avatar/99f08d8522d913118b0e22104fcb9d1c.jpg?s=120&d=mm&r=g)
[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_cmn.lisp fomus/backend_ly.lisp fomus/classes.lisp fomus/data.lisp fomus/main.lisp fomus/marks.lisp fomus/misc.lisp fomus/postproc.lisp fomus/staves.lisp fomus/version.lisp fomus/voices.lisp
by dpsenicka@common-lisp.net 19 Jan '06
by dpsenicka@common-lisp.net 19 Jan '06
19 Jan '06
Update of /project/fomus/cvsroot/fomus
In directory common-lisp:/tmp/cvs-serv29848
Modified Files:
accidentals.lisp backend_cmn.lisp backend_ly.lisp classes.lisp
data.lisp main.lisp marks.lisp misc.lisp postproc.lisp
staves.lisp version.lisp voices.lisp
Log Message:
more fixes
Date: Wed Jan 18 18:02:35 2006
Author: dpsenicka
Index: fomus/accidentals.lisp
diff -u fomus/accidentals.lisp:1.13 fomus/accidentals.lisp:1.14
--- fomus/accidentals.lisp:1.13 Tue Nov 15 19:26:30 2005
+++ fomus/accidentals.lisp Wed Jan 18 18:02:35 2006
@@ -67,15 +67,15 @@
;; numbers to determine importance of accidentals
(declaim (type (real 1) *max-acc-beat-dist-mul*))
(defparameter *max-acc-beat-dist-mul* 2) ; number of beats of rest before not caring about interval spelling
-(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-dist-score*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-dist-score*))
(defparameter *acc-dist-score* (float 1/3))
-(declaim (type #-openmcl (float (0)) #+openmcl float *acc-beat-dist* *acc-octave-dist*))
+(declaim (type #-(or openmcl allegro) (float (0)) #+(or openmcl allegro) float *acc-beat-dist* *acc-octave-dist*))
(defparameter *acc-beat-dist* (float 3/2)) ; number of beats where beat distance score = acc-dist-score
(defparameter *acc-octave-dist* (float 2)) ; number of octaves where octave distance score = acc-dist-score (default is 1.0 octaves = 2 beats = 2/3 of total score)
;; don't need to check if beat distance is past max
-(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-beat-dist-sc* *acc-octave-dist-sc*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-beat-dist-sc* *acc-octave-dist-sc*))
(declaim (special *acc-beat-dist-sc* *acc-octave-dist-sc*))
(defun nokey-notedist (tie note1 off1 eoff1 note2 off2 eoff2)
(declare (type boolean tie) (type rational note1 note2) (type (real 0) off1 eoff1 off2 eoff2))
@@ -91,7 +91,8 @@
(defparameter +nokey-penalty+ (vector '(1) '(-1 1) '(-1) '(1) '(-1 1) '(-1 1) '(-1)))
(defparameter +nokey-harmints+ (vector 0 1 1 2 2 3 4 4 5 5 6 6))
-(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float
+ *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*))
(defparameter *acc-diatonic-int-score* (float 7/8))
(defparameter *acc-aug-dim-int-score* (float 1/2))
(defparameter *acc-spelling-penalty* (float 1/4))
@@ -157,7 +158,7 @@
;; depth-first search branching down only top score group (same scores)
;; DESTRUCTIVE
(defstruct (nokeynode (:copier nil) (:predicate nokeynodep))
- (sc 0.0 :type (float 0))
+ (sc 0.0 :type #-allegro (float 0) #+allegro float)
(ret nil :type list)
(re 0 :type (integer 0))
(evs nil :type list)
@@ -170,7 +171,7 @@
(type (function (rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (values (or (integer 0 6) null) (or integer null))) spellfun)
(type (function (boolean rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0)
rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0))
- #-openmcl (float 0 1) #+openmcl float) intscorefun)
+ #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float) intscorefun)
(type (or string null) name) (type (function ((or (cons (integer -2 2) (rational -1/2 1/2)) (integer -2 2))) cons) conv))
(let ((co 0)
(mxd (* *acc-beat-dist* *max-acc-beat-dist-mul*))
@@ -179,7 +180,7 @@
(flet ((scorefun (no) ; optimistic score
(declare (type nokeynode no))
(cons (+ (nokeynode-sc no)
- (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (nokeynode-evd no) sum (car e))
+ (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (nokeynode-evd no) sum (car e))
(nokeynode-re no)) ; unexplored accidentals all scores of 1
(nokeynode-co no)))
(expandfun (no)
@@ -205,14 +206,14 @@
(s (nokeynode-sc no)))
(let ((d (cons w
(or (loop ; keep only relevant notes that will need rescoring (endoff > - ? beats)
- for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) ; e is (score . event)
+ for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) ; e is (score . event)
if (> (event-endoff (cdr e)) oo) ; endoff will = offset for grace notes!
collect (cdr e) ; collect just the events
else do (incf s (car e)))
- (let ((mx (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no)
+ (let ((mx (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no)
maximize (event-endoff (cdr e)))))
(setf s (nokeynode-sc no))
- (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no)
+ (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no)
if (>= (event-endoff (cdr e)) mx)
collect (cdr e)
else do (incf s (car e)))))))
@@ -229,7 +230,7 @@
(let* ((eua (event-useracc e))
(ne (event-note* e))
(su (- 1.0 (funcall penfun ne eua))) (di 1.0))
- (declare (type #-openmcl (float 0) #+openmcl float su di))
+ (declare (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float su di))
(loop ; plus optimistic 1 scores for rest in range
for e0 of-type noteex in lf
while (<= (event-off e0) (event-off e))
@@ -252,9 +253,9 @@
e))
:re (1- (nokeynode-re no)) :ret (cons w (nokeynode-ret no))
:evs lf)))))
- (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (> (car s1) (car s2)))
+ (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (> (car s1) (car s2)))
(remscoregreaterfun (r1 r2)
- (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2))
+ (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2))
(if (= (cdr r1) (cdr r2)) (< (car r1) (car r2)) (< (cdr r1) (cdr r2))))
(solutfun (no) (declare (type nokeynode no)) (null (nokeynode-evs no))))
(nokeynode-ret
@@ -262,13 +263,13 @@
(*acc-engine-heap* (max (roundint (* *acc-engine-heap* *quality*)) 1))
(*acc-beat-dist-sc* (expt *acc-dist-score* (/ *acc-beat-dist*)))
(*acc-octave-dist-sc* (expt *acc-dist-score* (/ *acc-octave-dist*))))
- (a*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already
- #'scorefun
- #'expandfun
- #'solutfun
- :heaplim *acc-engine-heap*
- :scoregreaterfun #'scoregreaterfun
- :remscoregreaterfun #'remscoregreaterfun))
+ (bfs*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already
+ #'scorefun
+ #'expandfun
+ #'solutfun
+ :heaplim *acc-engine-heap*
+ :scoregreaterfun #'scoregreaterfun
+ :remscoregreaterfun #'remscoregreaterfun))
(error "Cannot find valid note spellings for part ~S" name)))))) ; return events sorted
(declaim (type boolean *use-double-accs*))
@@ -405,8 +406,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; POST PROCESSING
-;; (defparameter *acc-throughout-meas* t)
-
;; rests are removed already, after chords & ties
;; events are events in 1 measure
(defun acc-nokey-postaccs (events)
Index: fomus/backend_cmn.lisp
diff -u fomus/backend_cmn.lisp:1.2 fomus/backend_cmn.lisp:1.3
--- fomus/backend_cmn.lisp:1.2 Fri Nov 11 16:03:16 2005
+++ fomus/backend_cmn.lisp Wed Jan 18 18:02:35 2006
@@ -10,20 +10,105 @@
(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"))
+(defparameter +cmn-num-acc+ (vector 'double-flat 'flat 'natural 'sharp 'double-sharp))
+(defparameter +cmn-num-accq+ (vector (vector nil 'double-flat) (vector 'flat-down 'flat 'natural-down) (vector 'natural-down 'natural 'natural-up)
+ (vector 'natural-up 'sharp 'sharp-up) (vector nil 'double-sharp)))
+
+(defparameter +cmn-barlines+ '((nil . bar) (:single . bar) (:double . interior-double-bar) (:final . double-bar)
+ (:repeatleft . end-repeat-bar) (:repeatright . begin-repeat-bar) (:repeatleftright . begin-and-end-repeat-bar)
+ (:invisible . (bar invisible))))
+
(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 (>= *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
(format f "~A" header)
+ (let ((de 0) (phash (make-hash-table :test 'eq)))
+ (flet ((cmnnote (wnum acc1 acc2 wdur hide caut harmt harms)
+ (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 "?"))))
+ (cmnname (p)
+ (incf de)
+ (intern
+ (conc-strings
+ (string-upcase
+ (conc-stringlist (loop for x across (part-name p)
+ when (alpha-char-p x)
+ 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 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
+ for (n nn) on (event-notes* 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
+ (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)
- for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup))
+ (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)
@@ -33,4 +118,4 @@
(loop ))))
(pfn parts)))
:stream f
- :escape nil))))
\ No newline at end of file
+ :escape nil)))|#)
\ No newline at end of file
Index: fomus/backend_ly.lisp
diff -u fomus/backend_ly.lisp:1.21 fomus/backend_ly.lisp:1.22
--- fomus/backend_ly.lisp:1.21 Sat Nov 12 14:42:46 2005
+++ fomus/backend_ly.lisp Wed Jan 18 18:02:35 2006
@@ -13,6 +13,12 @@
#+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix))
+#+allegro
+(defun run-allegro-cmd (cmd)
+ (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))
+
#+(or linux darwin unix)
(defun find-exe (filename)
(namestring*
@@ -43,31 +49,51 @@
(flet ((er (str)
(format t ";; ERROR: Error ~A lilypond file~%" str)
(return-from view-lilypond)))
- #+(and (or cmu sbcl openmcl) (or linux darwin unix))
+ #+(and (or cmu sbcl openmcl allegro) (or linux darwin unix))
(progn
(ignore-errors (delete-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))))
- (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd (change-filename filename :name nil :ext nil))
- (if (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+)
- (append (or exe-opts +lilypond-opts+) (list filename)) :wait t #|:output *standard-output*|#)
+ (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir
+ (change-filename filename :name nil :ext nil))
+ (if #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program
+ (or exe +lilypond-exe+)
+ (append (or exe-opts +lilypond-opts+) (list filename))
+ :wait t)
+ #+allegro (= (run-allegro-cmd (apply #'vector (cons (or exe +lilypond-exe+)
+ (cons (or exe +lilypond-exe+)
+ (append (or exe-opts +lilypond-opts+) (list filename)))))) 0)
(progn
(unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling"))
+ (ignore-errors (delete-file (change-filename filename :ext "log")))
+ (unless (string= (or out-ext +lilypond-out-ext+) "tex") (ignore-errors (delete-file (change-filename filename :ext "tex"))))
+ (unless (string= (or out-ext +lilypond-out-ext+) "dvi") (ignore-errors (delete-file (change-filename filename :ext "dvi"))))
+ (unless (string= (or out-ext +lilypond-out-ext+) "ps") (ignore-errors (delete-file (change-filename filename :ext "ps"))))
+ (unless (string= (or out-ext +lilypond-out-ext+) "pdf") (ignore-errors (delete-file (change-filename filename :ext "pdf"))))
(when view
- (unless (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (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+))))
- :wait nil #|:output *standard-output*|#)
- (er "viewing"))))
+ (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program
+ (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+))))
+ :wait nil)
+ #+allegro (= (run-allegro-cmd
+ (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)
+ (er "viewing"))))
(er "compiling")))
- #-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%"))))
+ #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%"))))
(defparameter *lilypond-version* t)
(defun lilypond-version (options)
(if (truep *lilypond-version*)
(setf *lilypond-version*
(destructuring-bind (&key exe &allow-other-keys) options
- (let ((os (make-string-output-stream)))
- (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))
- (let* ((out (get-output-stream-string os))
+ (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")))))
+ #+(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))
+ (let* ((out #+(or cmu sbcl openmcl) (get-output-stream-string os) #+allegro (read-line os))
(p (search "LilyPond " out)))
(when p (multiple-value-bind (n1 np) (parse-integer out :start (+ p 9) :junk-allowed t)
(+ (* n1 100) (parse-integer out :start (1+ np) :junk-allowed t))))))))
@@ -106,14 +132,6 @@
(defparameter +lilypond-num-reg+ (vector ",,," ",," "," "" "'" "''" "'''" "''''" "'''''"))
(defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . "")))
-;; sets and overrides
-;;(defparameter +lilypond-set-acc-style-default+ "#(set-accidental-style 'default)")
-;;(defparameter +lilypond-set-acc-style-forget+ "#(set-accidental-style 'forget)")
-;;(defparameter +lilypond-set-timesig-style-frac+ "\\override Staff.TimeSignature #'style = #'()")
-;;(defparameter +lilypond-set-tup-style-ratio+ "\\set tupletNumberFormatFunction = #fraction-tuplet-formatter")
-;;(defparameter +lilypond-set-instrument+ "\\set Staff.instrument = ~S")
-;;(defparameter +lilypond-set-instr+ "\\set Staff.instr = ~S")
-
(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")
@@ -168,12 +186,12 @@
(conc-strings
(svref +lilypond-num-note+ (mod wnum 12))
(svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2)))
- (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|#
+ (svref +lilypond-num-reg+ (1- (truncate wnum 12)))
(when caut "?"))
(conc-strings
(svref +lilypond-num-note+ (mod wnum 12))
(svref +lilypond-num-acc+ (+ acc1 2))
- (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|#
+ (svref +lilypond-num-reg+ (1- (truncate wnum 12)))
(when caut "?"))))
(lyname (p)
(incf de)
@@ -198,7 +216,7 @@
(when (or (null *timesig-style*) (eq *timesig-style* :fraction))
(if (> ns 1)
(loop for s from 1 to ns do
- (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|#))
+ (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s)))))
(format f " \\override Staff.TimeSignature #'style = #'()~%")))
(when (eq *tuplet-style* :ratio) (format f " \\set tupletNumberFormatFunction = #fraction-tuplet-formatter~%"))
(format f " \\autoBeamOff~%")
@@ -207,7 +225,7 @@
(format f " #(set-accidental-style 'forget)~%"))
(if (> ns 1)
(loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do
- (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|# (lyclef cl)))
+ (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) (lyclef cl)))
(format f " \\clef ~A~%" (lyclef (second (getprop p :clef)))))
(loop for e in lily-parthead do (format f " ~A~%" e))
(format f "~%")
@@ -228,20 +246,17 @@
(when (getmark e '(:starttext- 2)) (setf twrn t))
(format f "~A "
(conc-strings
-;; (if (list>1p (meas-events m))
- (let ((m (getmark e '(:voice :ord1324))))
- (if (and m (null (fourth m)))
- (case (third m)
- (1 (setf cdi :u) "\\voiceOne ")
- (2 (setf cdi :d) "\\voiceTwo ")
- (3 (setf cdi :u) "\\voiceThree ")
- (4 (setf cdi :d) "\\voiceFour ")
- (otherwise (setf cdi :u) "\\oneVoice "))
- ""))
-;; "")
+ (let ((m (getmark e '(:voice :ord1324))))
+ (if (and m (null (fourth m)))
+ (case (third m)
+ (1 (setf cdi :u) "\\voiceOne ")
+ (2 (setf cdi :d) "\\voiceTwo ")
+ (3 (setf cdi :u) "\\voiceThree ")
+ (4 (setf cdi :d) "\\voiceFour ")
+ (otherwise (setf cdi :u) "\\oneVoice "))
+ ""))
(let ((m (getmark e '(:staff :voice))))
- (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#)))
- #|(print (lystaff (third m)))|# ""))
+ (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m)))) ""))
(let ((c (getmark e :clef)))
(if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c)))
""))
@@ -255,9 +270,10 @@
collect (format nil "\\times ~A/~A {" (cdr r) (car r)))))
(let ((g (event-grace e)))
(if g
- (let ((g1 (getmark e :startgrace)))
- (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\\acciaccatura " "\\appoggiatura "))
- (g1 (if (< g 0) "\\acciaccatura {" "\\appoggiatura {"))))
+ (let ((g1 (getmark e :startgrace))
+ (gs (getmark e :startgraceslur-)))
+ (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>)) "\\> ")
@@ -299,7 +315,7 @@
(lynote (event-writtennote e) (event-acc e) (event-addacc e)
(getmark e (list :cautacc (event-note* e))))
(let ((ha (getmark e :harmonic)))
- (when ha (ecase (second ha) (:harmonic "\\harmonic") (:touched "^\\flageolet"))))))
+ (when ha (ecase (second ha) (:touched "\\harmonic") (:sounding "^\\flageolet"))))))
(if fm (if (event-inv e) "\\skip " "R") (if (event-inv e) "s" "r")))
(if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts))
(multiple-value-bind (wd ds) (let ((m (or (getmark e :tremolo)
Index: fomus/classes.lisp
diff -u fomus/classes.lisp:1.14 fomus/classes.lisp:1.15
--- fomus/classes.lisp:1.14 Fri Nov 11 16:49:35 2005
+++ fomus/classes.lisp Wed Jan 18 18:02:35 2006
@@ -44,7 +44,11 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:with-unlocked-packages ("COMMON-LISP")
(defclass rest (dur-base) ()))) ; only w/ xml in special cases--must not overlap a note-event!!!
-#-sbcl
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (excl:without-package-locks
+ (defclass rest (dur-base) ())))
+#-(or sbcl allegro)
(defclass rest (dur-base) ()) ; only w/ xml in special cases--must not overlap a note-event!!!
(defclass part (fomusobj-base)
@@ -67,7 +71,10 @@
(defprint timesig id (partid :partids) off time comp beat div repl props)
(defprint mark id partid off voice marks)
(defprint note id partid voice off dur note marks)
-(defprint rest id partid voice off dur marks)
+#+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
+ (excl:without-package-locks
+ (defprint rest id partid voice off dur marks)))
+#-allegro (defprint rest id partid voice off dur marks)
(defprint part id partid name abbrev instr events opts)
(defprint meas id off endoff timesig div events props)
Index: fomus/data.lisp
diff -u fomus/data.lisp:1.27 fomus/data.lisp:1.28
--- fomus/data.lisp:1.27 Sat Nov 12 14:42:46 2005
+++ fomus/data.lisp Wed Jan 18 18:02:35 2006
@@ -135,9 +135,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INSTRUMENTS
-(declaim (type list *percussion*))
-(defparameter *percussion* nil)
-
(defstruct (perc (:constructor make-perc-aux) (:copier nil) (:predicate percp))
(sym nil :type (or symbol real))
(staff 1 :type (integer 1))
Index: fomus/main.lisp
diff -u fomus/main.lisp:1.19 fomus/main.lisp:1.20
--- fomus/main.lisp:1.19 Sat Nov 12 14:42:46 2005
+++ fomus/main.lisp Wed Jan 18 18:02:35 2006
@@ -205,10 +205,3 @@
r (rest xx) (or process view) play view)))))
t)
-;; #+allegro (excl:current-directory)
-;; #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
-;; #+(or cmu scl) (ext:default-directory)
-;; #+sbcl (sb-unix:posix-getcwd/)
-;; #+cormanlisp (ccl:get-current-directory)
-;; #+lispworks (hcl:get-working-directory)
-;; #+mcl (ccl:mac-default-directory)
Index: fomus/marks.lisp
diff -u fomus/marks.lisp:1.12 fomus/marks.lisp:1.13
--- fomus/marks.lisp:1.12 Sat Oct 22 15:43:06 2005
+++ fomus/marks.lisp Wed Jan 18 18:02:35 2006
@@ -48,7 +48,7 @@
;; input level number only needs to be relative, with lower numbers = inner voices--mark arguments are mod then level
;; output level numbering starts at 1 (conforming to majority of output formats)
;; lower level is more inner
-;; this will translate the user input format to a more rigid format for the backends
+;; translate the user input format to a more well-defined format for the backends
(defun clean-spanners (pts spanners)
(loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners
do (loop for p of-type partex in pts do
Index: fomus/misc.lisp
diff -u fomus/misc.lisp:1.12 fomus/misc.lisp:1.13
--- fomus/misc.lisp:1.12 Wed Nov 30 17:51:37 2005
+++ fomus/misc.lisp Wed Jan 18 18:02:35 2006
@@ -135,6 +135,8 @@
(loop for e in initial-contents do (heap-ins e hp))
hp))
+
+
(declaim (inline list>1p list1p))
(defun list>1p (list)
(declare (type list list))
@@ -309,10 +311,10 @@
data score (val t :type boolean)) ; val = valid
;; (defconstant +a*-purgeat+ 1000)
-;; not necessarily used as A* algorithm
+;; BFS algorithm w/ limited heap
;; scorefun must always return optimistic value! (larger is better)--may return two values (second is remscore)
;; if heaplim = a number, limits heap size (ceases to be optimal)
-(defun a*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault)
+(defun bfs*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault)
(declare (type (function (t) t) scorefun solutfun) (type (function (t) list) expandfun)
(type (or null (integer 0)) heaplim) (type (function (t t) t) scoregreaterfun remscoregreaterfun))
(let ((*a*-id* -1)
Index: fomus/postproc.lisp
diff -u fomus/postproc.lisp:1.16 fomus/postproc.lisp:1.17
--- fomus/postproc.lisp:1.16 Sat Jan 7 20:58:43 2006
+++ fomus/postproc.lisp Wed Jan 18 18:02:35 2006
@@ -335,10 +335,11 @@
(setf fx t)
(car x))
e)))
- (let ((sy (first ma))) ; number of divisions, written durational value of tremolo marking
+ (let ((sy (first ma))
+ (dv (min (/ 1/8 w) (1+ (event-nbeams re (meas-timesig m)))))) ; number of divisions, written durational value of tremolo marking
(declare (type symbol sy))
(if (or (not (chordp re)) (eq sy :tremolo))
- (progn (push re ee) (addmark re (list :tremolo d w)))
+ (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv))))
(loop for n0 of-type rational in (event-notes* re)
and nn of-type (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) in (event-note re)
and lt of-type boolean in (event-tielt re)
@@ -370,7 +371,7 @@
(push e1 ee) (push e2 ee) (setf fx t)
(addmark e1 (list :starttremolo (/ d 2) w))
(addmark e2 (list :endtremolo (/ d 2) w))))
- (progn (push re ee) (addmark re (list :tremolo d w)))))))))))
+ (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv))))))))))))
(push e ee)))
finally (setf (meas-events m) (sort ee #'sort-offdur))))
(loop for g of-type cons in (split-into-groups (loop for x of-type meas in (part-meas p) append (meas-events x)) #'event-voice*) do
Index: fomus/staves.lisp
diff -u fomus/staves.lisp:1.10 fomus/staves.lisp:1.11
--- fomus/staves.lisp:1.10 Tue Sep 13 16:39:14 2005
+++ fomus/staves.lisp Wed Jan 18 18:02:35 2006
@@ -22,7 +22,7 @@
(declaim (type (real 0) *clef-force-clef-change-dist*))
(defparameter *clef-force-clef-change-dist* 2) ; can be nil
-(declaim (type (float 0 1) *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*))
+(declaim (type #-allegro (float 0 1) #+allegro float *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*))
(defparameter *clef-change-clef-penalty* (float 1))
(defparameter *clef-change-staff-penalty* (float 1/4)) ; should probably be less than change-clef-penalty
@@ -55,7 +55,7 @@
(defparameter *staff-engine-heap* 50)
(defstruct (clefnode (:copier nil) (:predicate clefnodep))
- (sc 0.0 :type (float 0))
+ (sc 0.0 :type #-allegro (float 0) #+allegro float)
(lo 0 :type (rational 0))
(lg 0 :type (rational 0))
(ics #() :type (vector symbol))
@@ -161,9 +161,9 @@
*clef-order-perbeat-penalty*))
(max (- o (clefnode-lo no)) (clefnode-lg no))))
(return (make-clefnode :sc sc :lo o :lg gd :ics ics :cs cs :lvs lvs :ret (nconc ret (clefnode-ret no)) :evs rs :o o :co nco))))))) ; ret is out of order
- (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2)))
+ (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2)))
(remscoregreaterfun (r1 r2)
- (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2))
+ (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2))
(if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2))))
(solutfun (no) (declare (type clefnode no)) (null (clefnode-evs no))))
(let ((*clef-list* (force-list (instr-clefs instr))))
@@ -199,7 +199,7 @@
(cddr (last-element re)) nil)
(return (values r re)))
(let ((n (or (let ((*staff-engine-heap* (max (roundint (* *staff-engine-heap* *quality*)) 1)))
- (a*-engine (list (make-clefnode :ics (make-array nst :initial-element nil)
+ (bfs*-engine (list (make-clefnode :ics (make-array nst :initial-element nil)
:cs (make-array nst :initial-element nil)
:lvs (make-array nst :initial-element nil)
:evs events))
Index: fomus/version.lisp
diff -u fomus/version.lisp:1.23 fomus/version.lisp:1.24
--- fomus/version.lisp:1.23 Sat Jan 7 20:58:43 2006
+++ fomus/version.lisp Wed Jan 18 18:02:35 2006
@@ -12,9 +12,9 @@
(declaim (type string +title+)
(type cons +version+ +banner+))
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 28))
+(defparameter +version+ '(0 1 29))
(defparameter +banner+
`("Lisp music notation formatter"
- "Copyright (c) 2005 David Psenicka, All Rights Reserved"
+ "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"
"See file \"COPYING\" for terms of use and distribution."))
Index: fomus/voices.lisp
diff -u fomus/voices.lisp:1.10 fomus/voices.lisp:1.11
--- fomus/voices.lisp:1.10 Wed Aug 31 16:18:00 2005
+++ fomus/voices.lisp Wed Jan 18 18:02:35 2006
@@ -13,19 +13,20 @@
;; user specifies a list of voices for voice parameter
;; algorithm decides which one to choose
-(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float
+ *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*))
(defparameter *voice-high/low-penalty* (float 1/3)) ; voice 1 is higher than voice 2
(defparameter *voice-simult-penalty* (float 1)) ; vertical chords are balanced between voices
(defparameter *voice-chord-score* (float 1/12)) ; incentive to group notes of same offset/dur into same voice
(defparameter *voice-leading-penalty* (float 1/4)) ; close-together notes are in same voice
(defparameter *voice-balance-penalty* (float 1/24)) ; notes are balanced/switched between voices over time
-(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-dist-score*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *voice-dist-score*))
(defparameter *voice-dist-score* (float 1/3))
-(declaim (type #-openmcl (float 0) #+openmcl float *voice-octave-dist*))
+(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-octave-dist*))
(defparameter *voice-octave-dist* (float 1))
-(declaim (type #-openmcl (float 0) #+openmcl float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*))
+(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*))
(defparameter *voice-high/low-beat-dist* (float 1/2))
(defparameter *voice-leading-beat-dist* (float 4))
(defparameter *voice-balance-beat-dist* (float 12)) ; effectively the "distance" for maintaining balance between voices
@@ -41,15 +42,16 @@
(declaim (inline auto-voices-fun))
(defun auto-voices-fun () (if (truep *auto-voices-mod*) :voices1 *auto-voices-mod*))
-(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*)
- (type #-openmcl (float 0) #+openmcl float *voice-full-beat-dist*))
+(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float
+ *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*)
+ (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-full-beat-dist*))
(declaim (special *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc*
*voice-octave-dist-sc* *voice-full-beat-dist* *voice-full-beat-dist-sc*)) ; adj is 1 + lowest (farthest) value
(defun voices-notedist-aux1 (note1 note2) ; by octave
(declare (type rational note1 note2))
(expt *voice-octave-dist-sc* (/ (diff note1 note2) 12.0)))
(defun voices-notedist-aux2 (off1 eoff1 off2 eoff2 beatdist sc) ; by offset
- (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-openmcl (float 0 1) #+openmcl float sc))
+ (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float sc))
(let ((d (max (- (float off2) (float eoff1)) (- (float off1) (float eoff2)) 0.0)))
(if (>= d (* *max-voice-beat-dist-mul* beatdist)) 0.0
(expt sc d))))
@@ -88,7 +90,7 @@
(defparameter *voice-engine-heap* 50)
(defstruct (voicenode (:copier nil) (:predicate voicenodep))
- (sc 0.0 :type (float 0))
+ (sc 0.0 :type #-allegro (float 0) #+allegro float)
(ret nil :type list)
(evs nil :type list)
(evc nil :type list)
@@ -102,7 +104,7 @@
(flet ((scorefun (no)
(declare (type voicenode no))
(cons (+ (voicenode-sc no)
- (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (voicenode-evd no) sum (car e)))
+ (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (voicenode-evd no) sum (car e)))
(voicenode-co no)))
(expandfun (no)
(declare (type voicenode no))
@@ -124,7 +126,7 @@
(s (voicenode-sc no)))
(let ((d (cons w
(loop ; keep only relevant notes that will need rescoring (endoff > - 8 beats)
- for e of-type (cons #-openmcl (float 0 1) #+openmcl float note) in (voicenode-evd no) ; e is (score . event)
+ for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float note) in (voicenode-evd no) ; e is (score . event)
if (>= (event-off (cdr e)) oo) ; endoff will = offset for grace notes!
collect (cdr e) ; collect just the events
else do (incf s (car e)))))
@@ -140,7 +142,8 @@
for e of-type noteex in d
collect (cons
(loop
- with su of-type #-openmcl (float 0) #+openmcl float = 0.0 and di of-type #-openmcl (float 0) #+openmcl float = 0.0
+ with su of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0
+ and di of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0
for e0 of-type noteex in c
unless (eq e e0)
do (let ((d0 (voices-notedist (event-note* e) (event-off e) (event-endoff e)
@@ -154,9 +157,9 @@
:ret (cons w (voicenode-ret no))
:evs lf :co nco))))
when xx collect xx)))
- (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2)))
+ (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2)))
(remscoregreaterfun (r1 r2)
- (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2))
+ (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2))
(if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2))))
(solutfun (no) (declare (type voicenode no)) (null (voicenode-evs no))))
(voicenode-ret
@@ -167,7 +170,7 @@
(*voice-leading-beat-dist-sc* (expt *voice-dist-score* (/ *voice-leading-beat-dist*)))
(*voice-full-beat-dist-sc* (expt *voice-dist-score* (/ *voice-full-beat-dist*)))
(*voice-octave-dist-sc* (expt *voice-dist-score* (/ *voice-octave-dist*))))
- (a*-engine (list (make-voicenode :evs events))
+ (bfs*-engine (list (make-voicenode :evs events))
#'scorefun
#'expandfun
#'solutfun
1
0
![](https://secure.gravatar.com/avatar/99f08d8522d913118b0e22104fcb9d1c.jpg?s=120&d=mm&r=g)
[fomus-cvs] CVS update: fomus/TODO fomus/backend_mid.lisp fomus/postproc.lisp fomus/version.lisp
by dpsenicka@common-lisp.net 08 Jan '06
by dpsenicka@common-lisp.net 08 Jan '06
08 Jan '06
Update of /project/fomus/cvsroot/fomus
In directory common-lisp.net:/tmp/cvs-serv21316
Modified Files:
TODO backend_mid.lisp postproc.lisp version.lisp
Log Message:
bug fix
Date: Sun Jan 8 03:58:43 2006
Author: dpsenicka
Index: fomus/TODO
diff -u fomus/TODO:1.26 fomus/TODO:1.27
--- fomus/TODO:1.26 Thu Dec 1 00:51:37 2005
+++ fomus/TODO Sun Jan 8 03:58:43 2006
@@ -6,6 +6,7 @@
Quantizing nested tuplets--occasional hangups
Many more...
Doc: list-instr-syms, list-perc-syms
+ Doc: separate MIDI files for different parts
Specifying percussion from MIDI info
Automatic percussion instrument changes
Splitting chords across staves (LilyPond)
Index: fomus/backend_mid.lisp
diff -u fomus/backend_mid.lisp:1.9 fomus/backend_mid.lisp:1.10
--- fomus/backend_mid.lisp:1.9 Thu Dec 1 00:51:37 2005
+++ fomus/backend_mid.lisp Sun Jan 8 03:58:43 2006
@@ -121,7 +121,7 @@
(defparameter *grace-dur-secs* 1/12)
(declaim (special *gracedur*))
(defparameter *min-amp* 1/10)
-(defparameter *trdur-secs* 1/12) ; trill notes per sec. (and unmeasured tremolos)
+(defparameter *trdur-secs* 1/16) ; trill notes per sec. (and unmeasured tremolos)
(declaim (special *trdur*))
(defparameter *tramp* 3/4)
(defparameter *fermata-mults* '(3/2 2 3))
@@ -248,10 +248,10 @@
do (setf (midi-dur* e) (min (+ (midi-dur e) *slur-adddur*) (* (midi-dur n) 3/2))))
ev))))
-(defun save-midi (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename)
+(defun save-midi-aux (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename)
(unless *cm-exists*
(format t ";; ERROR: Common Music required for MIDI output~%")
- (return-from save-midi))
+ (return-from save-midi-aux))
(when (>= *verbose* 1)
(if (typep play 'boolean) (out ";; Saving MIDI file ~S...~%" filename) (out ";; Scheduling MIDI playback...~%" filename)))
(destructuring-bind (&key (nports 1) instr-per-ch events-fun (pbend-width 2) cm-args
@@ -314,7 +314,7 @@
(progn
(format t ";; ERROR: Too many parts/instruments for ~S port(s)/~S channels (use NPORTS option, MIDI-CH option in parts or MIDIPRGCH-EX slot in instruments to fix)~%"
nports (* nports 16))
- (return-from save-midi)))))
+ (return-from save-midi-aux)))))
(unless (is-percussion p)
(loop for i in (chs (cdr c))
do (setf (svref (nth (car c) ps) i)
@@ -514,4 +514,18 @@
(setf xta (loop for e in (split-into-groups xta #'type-of) nconc (delete-duplicates e :key #'midi-ch)))
(if (typep play 'boolean)
(apply *cm-events* (sort (nconc xta evs) #'midi-sort) filename :tempo tempo :play play cm-args)
- (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args)))))
\ No newline at end of file
+ (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args)))))
+
+(defun save-midi (parts filename options play)
+ (flet ((ms (x y) (< (position x parts) (position y parts)))
+ (me (p) (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p)
+ (namestring (merge-pathnames midi-filename filename)))))
+ (loop for ps in (sort (mapcar (lambda (x) (sort x #'ms))
+ (split-into-groups (remove-if-not (lambda (p)
+ (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p)
+ midi-filename))
+ parts)
+ #'me :test 'equal))
+ #'ms :key #'first)
+ do (save-midi-aux ps (me (first ps)) options nil)))
+ (save-midi-aux parts filename options play))
\ No newline at end of file
Index: fomus/postproc.lisp
diff -u fomus/postproc.lisp:1.15 fomus/postproc.lisp:1.16
--- fomus/postproc.lisp:1.15 Fri Nov 11 23:03:16 2005
+++ fomus/postproc.lisp Sun Jan 8 03:58:43 2006
@@ -321,10 +321,10 @@
unless xf do (setf xf x)
do (push (third x) li)
finally (return xf)))))
- (if ma (let* ((d (second ma))
+ (if ma (let* ((d (second ma)) ; dur. of unit
(w (if d (let ((x (event-writtendur (copy-event e :dur d) (meas-timesig m))))
(loop-return-lastmin (diff i x) for i = 1/8 then (/ i 2)))
- 1/32)))
+ 1/32))) ; writ. trem. unit dur.
(let ((wd (event-writtendur e (meas-timesig m))))
(multiple-value-bind (d o) (floor wd w)
(let ((re (if (> o 0)
@@ -351,6 +351,8 @@
(let ((c1 (list>1p n1))
(c2 (list>1p n2))
(d2 (/ (event-dur* re) 2)))
+ (let ((x (event-tupfrac re)))
+ (when x (setf (car x) (/ (the rational (car x)) 2))))
(let ((e1 (copy-event re
:note (if c1 n1 (the (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))))
(first n1)))
Index: fomus/version.lisp
diff -u fomus/version.lisp:1.22 fomus/version.lisp:1.23
--- fomus/version.lisp:1.22 Thu Dec 1 00:51:37 2005
+++ fomus/version.lisp Sun Jan 8 03:58:43 2006
@@ -12,7 +12,7 @@
(declaim (type string +title+)
(type cons +version+ +banner+))
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 27))
+(defparameter +version+ '(0 1 28))
(defparameter +banner+
`("Lisp music notation formatter"
"Copyright (c) 2005 David Psenicka, All Rights Reserved"
1
0