[fomus-cvs] CVS update: fomus/README fomus/TODO fomus/backend_ly.lisp fomus/backends.lisp fomus/data.lisp fomus/main.lisp fomus/marks.lisp fomus/package.lisp fomus/postproc.lisp fomus/quantize.lisp fomus/split.lisp fomus/voices.lisp
David Psenicka
dpsenicka at common-lisp.net
Mon Jul 25 07:56:10 UTC 2005
Update of /project/fomus/cvsroot/fomus
In directory common-lisp.net:/tmp/cvs-serv10374
Modified Files:
README TODO backend_ly.lisp backends.lisp data.lisp main.lisp
marks.lisp package.lisp postproc.lisp quantize.lisp split.lisp
voices.lisp
Log Message:
Testing/bug fixes
Date: Mon Jul 25 09:56:03 2005
Author: dpsenicka
Index: fomus/README
diff -u fomus/README:1.1 fomus/README:1.2
--- fomus/README:1.1 Thu Jul 21 17:38:42 2005
+++ fomus/README Mon Jul 25 09:56:03 2005
@@ -2,12 +2,15 @@
Lisp music notation formatter
Fomus is alpha software, and still has a lot of testing and bug fixing to go
-before all of its features are useable.
+before all of its features are useable. Not all features that appear in the
+documentation are implemented yet. Also, some parts of the program are running
+slowly due to some settings being currently set to conservative values.
See the file "fomus.html" in the doc directory for instructions on how to use
the program. The following command loads FOMUS into lisp:
(load "path_to_fomus_directory/load.lisp")
+ (use-package fm)
The program is being developed in SBCL, but should also compile in CMUCL and
OpenMCL. It will eventually be supported in Allegro Common Lisp and CLISP.
Index: fomus/TODO
diff -u fomus/TODO:1.3 fomus/TODO:1.4
--- fomus/TODO:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/TODO Mon Jul 25 09:56:03 2005
@@ -3,12 +3,15 @@
IMMEDIATE
Testing and bug fixes
-BUG: :startslur- and :slur- marks
+Information on anonymous CVS downloading
BUG: error in beams in CMUCL
-DOC: dynamics marks can take order arguments (backend might not support it)
-DOC: make sure user knows to use the package
-DOC: make sure user knows about :default-beat setting
+DOC: dynamic marks can take order arguments (backend might not support it)
+DOC: other interface functions
+DOC: part properties
Adjust scores and penalties for decent results
+Breath marks (resolve before/after)
+Noteheads
+Fix fingering mark (no finger number argument)
@@ -24,6 +27,9 @@
Reorganize settings
MIDI input interface
Support for polymeters in backends
+Integrate user graceslur overrides
+Levels for single text marks
+Remove redundant dynamic marks
Index: fomus/backend_ly.lisp
diff -u fomus/backend_ly.lisp:1.3 fomus/backend_ly.lisp:1.4
--- fomus/backend_ly.lisp:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/backend_ly.lisp Mon Jul 25 09:56:03 2005
@@ -43,7 +43,7 @@
(defparameter +lilypond-out-ext+ "ps")
(defparameter +lilypond-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app"))
-(defun view-lilypond (filename options)
+(defun view-lilypond (filename options view)
(when (>= *verbose* 1) (out ";; Compiling/opening \"~A\" for viewing...~%" filename))
(destructuring-bind (xxx &key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options
(declare (ignore xxx))
@@ -58,10 +58,11 @@
(append (or exe-opts +lilypond-opts+) (list filename)) :wait t #|:output *standard-output*|#)
(progn
(unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling"))
- (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")))
+ (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"))))
(er "compiling")))
#-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%"))))
@@ -109,7 +110,7 @@
;; TODO: support texts, spanners and tremelos, remove dependency on ACCIDENTALYS
-(defun save-lilypond (parts filename options view)
+(defun save-lilypond (parts filename options process view)
(when (>= *verbose* 1) (out ";; Saving Lilypond file \"~A\"...~%" filename))
(with-open-file (f filename :direction :output :if-exists :supersede)
(destructuring-bind (xxx &key filehead scorehead &allow-other-keys) options
@@ -144,7 +145,7 @@
(loop
for p in parts
do (destructuring-bind (&key (lily-partname (lyname p))
- parthead ;; extra header information for part (list of strings)
+ lily-parthead ;; extra header information for part (list of strings)
&allow-other-keys) (part-opts p)
(let ((ns (instr-staves (part-instr p)))
(sa 1))
@@ -170,7 +171,7 @@
(loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do
(format f " ~A\\clef ~A~%" (lystaff s) (lyclef cl)))
(format f " \\clef ~A~%" (lyclef (second (getprop p :clef)))))
- (loop for e in parthead do (format f " ~A~%" e))
+ (loop for e in lily-parthead do (format f " ~A~%" e))
(format f "~%")
(loop
for m in (part-meas p) and mn from 1
@@ -336,5 +337,5 @@
for xxx in (getprops p :endgroup)
do (decf in 2) (format f "~A>>~%" (make-string in :initial-element #\space))))
(format f "}~%")))))
- (when view (view-lilypond filename options)))
+ (when process (view-lilypond filename options view)))
Index: fomus/backends.lisp
diff -u fomus/backends.lisp:1.1.1.1 fomus/backends.lisp:1.2
--- fomus/backends.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005
+++ fomus/backends.lisp Mon Jul 25 09:56:03 2005
@@ -21,9 +21,9 @@
(prin1 parts f)
(fresh-line f)))
-(defun backend (backend filename parts options view)
+(defun backend (backend filename parts options process view)
(case backend
(:data (save-data filename parts))
- (:lilypond (save-lilypond parts filename options view))
+ (:lilypond (save-lilypond parts filename options process view))
(otherwise (error "Unknown backend ~A" backend))))
Index: fomus/data.lisp
diff -u fomus/data.lisp:1.3 fomus/data.lisp:1.4
--- fomus/data.lisp:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/data.lisp Mon Jul 25 09:56:03 2005
@@ -31,7 +31,7 @@
(defparameter *min-tuplet-dur* 1/2) ; fraction of beat smallest tuplets should span at minimum (1/2 = half a beat, etc.)--can be nil
(defparameter *max-tuplet-dur* 4)
-(defparameter *default-beat* nil)
+(defparameter *default-beat* 1/4)
;; pitch quantizing
(declaim (special *note-precision*))
@@ -304,7 +304,7 @@
(:timesig-style (or* null (find* :fraction :common)) ":FRACTION or :COMMON")
(:tuplet-style (or* null (find* :ratio :single)) ":RATIO or :SINGLE")
- (:quantize-adjust-grace-durs boolean)
+ ;;(:quantize-adjust-grace-durs boolean)
(:default-grace-dur (rational (0))) (:default-grace-num integer) (:effective-grace-dur-mul (rational (0)))
(:min-auto-timesig-dur (rational (0))) (:default-timesig (type* +timesig-repl-type+) "TIMESIG object")
@@ -314,6 +314,7 @@
(:auto-ottavas boolean) (:auto-grace-slurs boolean) (:auto-voicing boolean) (:auto-beams boolean)
(:auto-quantize boolean) (:auto-multivoice-rests boolean) (:auto-multivoice-notes boolean)
(:auto-override-timesigs boolean)
+ (:auto-pizz/arco boolean)
(:split-fun symbol) (:auto-accs-fun symbol) (:auto-voices-fun symbol) (:auto-distr-rests-fun symbol)
(:auto-multivoice-comb-fun symbol) (:auto-ottavas-fun symbol) (:auto-beam-fun symbol) (:auto-quantize-fun symbol)
@@ -331,7 +332,7 @@
(:tuplet-dotted-rests boolean) (:double-dotted-notes boolean)
(:dotted-note-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG")
(:shortlongshort-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG")
- (:syncopated-notes-level (find* t :all :top :sig) "T, :ALL, :TOP or :SIG")
+ (:syncopated-notes-level boolean)
(:acc-engine-heap (integer 100)) (:acc-importance-score (real (0) 1)) (:acc-importance-steps (integer 1))
(:voice-engine-heap (integer 100)) (:voice-importance-score (real (0) 1)) (:voice-importance-steps (integer 1))
@@ -391,7 +392,7 @@
(or* (unique* sy :glissbefore x) (list* (unique* sy :glissbefore x))
(list* (unique* sy :glissbefore x) (eql* :before)) (list* (unique* sy :glissafter x) (eql* :after))))
(let* ((x (find* :breath)))
- (or* (unique* sy :breathbefore x) (list* (unique* sy :breathbefore x))
+ (or* (unique* sy :breathafter x) (list* (unique* sy :breathafter x))
(list* (unique* sy :breathbefore x) (eql* :before)) (list* (unique* sy :breathafter x) (eql* :after))))
(let* ((x (find* :harmonic)))
(or* (cons* (unique* sy :harmtouched x)
@@ -494,8 +495,10 @@
(defparameter +marks-all-ties+
'(:longtrill :tremolo :lefthandtremolo :righthandtremolo))
+(defparameter *auto-pizz/arco* t)
+
(defparameter +marks-on-off+
- '((:pizz . :arco)))
+ '((*auto-pizz/arco* . (:pizz . :arco))))
;; marks that prevent notes from combining into chords if they differ
(defparameter +marks-indiv-voices+
Index: fomus/main.lisp
diff -u fomus/main.lisp:1.3 fomus/main.lisp:1.4
--- fomus/main.lisp:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/main.lisp Mon Jul 25 09:56:03 2005
@@ -58,7 +58,7 @@
(multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp)
#-debug (declare (ignore rm))
#+debug (when rm (error "Error in FOMUS-PROC"))
- (multiple-value-bind (mks *events*) (split-list *events* #'markp)
+ (multiple-value-bind (*events* mks) (split-list *events* (lambda (x) (or (notep x) (restp x))))
(let ((pts (progn
(loop for p in *parts* and i from 0
do (multiple-value-bind (ti ke evs ma) (split-list (part-events p) #'timesigp #'keysigp
@@ -124,23 +124,20 @@
(reset-tempslots pts 0)
(distribute-marks pts mks)
(setf pts (sep-staves pts)) ; ********** STAVES SEPARATED
- (if *auto-quantize* (clean-quantize pts))
+ ;;(if *auto-quantize* (clean-quantize pts))
(when *auto-ottavas* ; (before clean-spanners)
(when (>= *verbose* 2) (out "~&; Ottavas..."))
(ottavas pts) #+debug (fomus-proc-check pts 'ottavas))
(when (>= *verbose* 2) (out "~&; Staff spanners..."))
(clean-spanners pts +marks-spanner-staves+) #+debug (fomus-proc-check pts 'spanners1)
- ;; (setf pts (sep-voices pts)) #+debug (fomus-proc-check pts 'sepvoices)
(setf pts (sep-voices (assemble-parts pts))) ; ********** STAVES TOGETHER, VOICES SEPARATED
(when (>= *verbose* 2) (out "~&; Voice spanners..."))
(expand-marks pts) #+debug (fomus-proc-check pts 'expandmarks)
(clean-spanners pts +marks-spanner-voices+) #+debug (fomus-proc-check pts 'spanners2)
- (when (and (>= *verbose* 2) (and *auto-grace-slurs* *auto-cautionary-accs*))
- (out "~&; Voice items..."))
+ (when (>= *verbose* 2) (out "~&; Miscellaneous items..."))
(preproc-cautaccs pts)
(when *auto-grace-slurs*
(grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs))
- ;; (setf pts (sep-voices (assemble-parts pts)))
(when (>= *verbose* 2) (out "~&; Measures..."))
(init-parts *timesigs* pts) ; ----- MEASURES
#+debug (fomus-proc-check pts 'measures)
@@ -184,7 +181,7 @@
(defun fomus-main ()
(let ((r (fomus-proc)))
(loop for x in (or (force-list2 *backend*) '((:data)))
- do (destructuring-bind (ba &key filename view &allow-other-keys) x
- (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x view))))
+ do (destructuring-bind (ba &key filename process view &allow-other-keys) x
+ (backend ba (or filename (change-filename *base-filename* :ext (lookup ba +backendexts+))) r x (or process view) view))))
t)
Index: fomus/marks.lisp
diff -u fomus/marks.lisp:1.3 fomus/marks.lisp:1.4
--- fomus/marks.lisp:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/marks.lisp Mon Jul 25 09:56:03 2005
@@ -17,13 +17,17 @@
(defun grace-slurs (pts)
(loop
for p in pts do
- (loop for e in (part-events p) do (rmmark e :startgraceslur-) (rmmark e :graceslur-) (rmmark e :endgraceslur-))
(loop
for e in (delete-if (lambda (x) (notany #'event-grace x)) (split-into-groups (part-events p) #'event-off))
- for s = (sort e #'sort-offdur)
- do
- (addmark (first s) :startgraceslur-)
- (addmark (find-if-not #'event-grace s) :endgraceslur-))
+ for s = (sort e (complement #'sort-offdur))
+ do (loop with sl and li
+ for x in s
+ when (or (getmark x :endgraceslur-) (getmark x :graceslur-))
+ do (if sl (error "Missing STARTGRACESLUR- mark in part ~A, offset ~A" (part-name p) (event-foff e)) (setf sl t)) (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-) (setf li nil))
+ unless sl do (push x li)
+ when (getmark x :startgraceslur-) do (if sl (setf sl nil) (error "Missing GRACESLUR-/ENDGRACESLUR- slur mark in part ~A, offset ~A" (part-name p) (event-foff e)))
+ finally
+ (when li (addmark (first li) :startgraceslur-) (addmark (last-element li) :endgraceslur-))))
(print-dot)))
;; must be in separate voices
@@ -134,7 +138,11 @@
(if (null vo) l (remove-if-not (lambda (e) (find (event-voice* e) vo)) l)))))
(if re r (remove-if #'restp r)))))
(let ((o (let ((q (getprop p :quant))) ; fix quantize error
- (if q (let ((x (find-if (lambda (x) (and (<= (car x) o0) (>= (cdr x) o0))) (rest q))))
+ (if q (let ((x (find-if (lambda (x) (and (funcall (caar x) o0)
+ (if (< (cdar x) (cdr x))
+ (< o0 (cdr x)) ; -->
+ (> o0 (cdr x))))) ; <--
+ (rest q))))
(if x (cdr x) o0))
o0))))
(if di
Index: fomus/package.lisp
diff -u fomus/package.lisp:1.3 fomus/package.lisp:1.4
--- fomus/package.lisp:1.3 Sat Jul 23 11:23:14 2005
+++ fomus/package.lisp Mon Jul 25 09:56:03 2005
@@ -53,7 +53,7 @@
(use-package "DBG" "FM")))
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 2))
+(defparameter +version+ '(0 1 3))
(defparameter +banner+
`("Lisp music notation formatter"
"Copyright (c) 2005 David Psenicka, All Rights Reserved"
Index: fomus/postproc.lisp
diff -u fomus/postproc.lisp:1.1.1.1 fomus/postproc.lisp:1.2
--- fomus/postproc.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005
+++ fomus/postproc.lisp Mon Jul 25 09:56:03 2005
@@ -241,7 +241,7 @@
(addprop m (list :barline :final)))) (print-dot)))
(defun postproc-marksonoff (pts)
- (loop for (a . b) in +marks-on-off+ do
+ (loop for (v . (a . b)) in +marks-on-off+ when (symbol-value v) do
(loop with o for p in pts do
(loop for m in (part-meas p) do
(loop for g in (meas-voices m) do
Index: fomus/quantize.lisp
diff -u fomus/quantize.lisp:1.2 fomus/quantize.lisp:1.3
--- fomus/quantize.lisp:1.2 Thu Jul 21 17:38:43 2005
+++ fomus/quantize.lisp Mon Jul 25 09:56:03 2005
@@ -80,7 +80,7 @@
collect (adj (dv o (loop for i in ep when (<= i os) collect i) e1 ts)
(dv os (loop for i in ep when (>= i os) collect i) e2 ts))))))))
(loop for p in parts
- for ph = (gethash p h)
+ for ph = (gethash p h) ; ph = timesigs for part
do (let* ((ee (sort (delete-duplicates (loop for e in (part-events p) collect (event-off e) collect (event-endoff e))) #'<))
(qs (sort
(delete-duplicates
@@ -102,38 +102,56 @@
(let ((o (event-off e)))
(loop while (and (list>1p qs) (< (second qs) o)) do (pop qs))
(let ((e1 (loop-return-firstmin (diff x o) for x in qs)))
- (if (event-grace e)
+ (flet ((aa (oo ee)
+ (cond ((< oo ee) (push (cons (cons #'>= oo) ee) ad)) ; -->
+ ((> oo ee) (push (cons (cons #'< oo) ; <--
+ (loop for (x1 x2) on qs until (or (null x2) (>= x2 ee))
+ finally (return x1)))
+ ad)))))
+ (if (event-grace e)
(progn
- (push (cons (event-off e) e1) ad)
+ (cond ((< (event-off e) e1) (push (cons (cons #'>= (event-off e)) e1) ad)) ; -->
+ ((> (event-off e) e1) (push (cons (cons #'<= (event-off e)) e1) ad))) ; <--
(setf (event-off e) e1
(event-dur* e) (let ((bd (/ (beat-division (loop for s in ph until (<= (timesig-off s) e1) finally (return s))))))
(let ((x (roundto (event-gracedur e) bd)))
(when (<= x 0) bd x)))))
(let ((e2 (let ((o (event-endoff e))) (loop-return-lastmin (diff x o) for x in qs))))
- (push (cons (event-off e) e1) ad)
+ (aa (event-off e) e1)
(setf (event-off e) e1)
(let ((x (- e2 e1)))
(if (<= x 0)
(progn
- (addmark e :grace)
+ (debugn "gr: ~A" e)
+ (aa (event-endoff e) e1)
+ ;; (addmark e :grace)
(setf (event-dur e)
- (cons (- (loop for i in qs until (> i e1) finally (return i)) e1)
+ (cons *default-grace-dur* #|(- (loop for i in qs until (> i e1) finally (return i)) e1)|#
(incf mg))))
(progn
- (push (cons (event-endoff e) e2) ad)
- (setf (event-dur* e) x))))))))
+ (aa (event-endoff e) e2)
+ (setf (event-dur* e) x)))))))))
finally
- (addprop p (cons :quant
- (merge-all ad (lambda (x y) (let ((x1 (car x)) (x2 (cdr x))
- (y1 (car y)) (y2 (cdr y)))
- (when (= x2 y2)
- (cons (if (< x1 x2)
- #+debug (if (<= y1 y2) (min x1 y1) (error "Error in QUANTIZE-BYFIT 3"))
- #-debug (min x1 y1)
- #+debug (if (>= y1 y2) (max x1 y1) (error "Error in QUANTIZE-BYFIT 4"))
- #-debug (max x1 y1))
- x2))))
- :call-rev nil))))))
+ (addprop p (cons :quant ; temporary prop: collection of all point movements
+ (merge-all ad (lambda (x y) (let ((x1 (cdar x)) (x2 (cdr x))
+ (y1 (cdar y)) (y2 (cdr y)))
+ (cond ((and (< x1 x2) (< y1 y2)) ; -->
+ (when (and (>= x2 y1) (>= y2 x1)) ; always #'>=
+ (cons (if (< x1 y1) (car x) (car y))
+ (max x2 y2))))
+ ((and (> x1 x2) (> y1 y2)) ; <--
+ (cond ((or (and (> x1 y2) (> y1 x2)) ; overlap
+ (and (= x1 y2) (eq (caar x) #'<=)) ; touching
+ (and (= y1 x2) (eq (caar y) #'<=)))
+ (cons (cond ((= x1 y1) (cons (if (or (eq (caar x) #'<=)
+ (eq (caar y) #'<=))
+ #'<= #'<)
+ x1))
+ ((> x1 y1) (car x))
+ (t (car y)))
+ (min x2 y2))))))))
+ :call-rev nil)))
+ (setf (part-events p) (sort (part-events p) #'sort-offdur)))))
(print-dot)))))
(defun quantize (timesigs parts)
@@ -141,24 +159,27 @@
(:quantize1 (quantize-byfit timesigs parts))
(otherwise (error "Unknown quantize function ~A" *auto-quantize-fun*))))
-(defparameter *quantize-adjust-grace-durs* t)
+;; (defparameter *quantize-adjust-grace-durs* t)
-(defun clean-quantize (parts)
- (loop for p in parts do
- (loop for v in (split-into-groups (part-events p) #'event-voice*) do
- (when *quantize-adjust-grace-durs*
- (loop with d
- for e in (sort (copy-list v) (complement #'sort-offdur))
- if (getmark e :grace)
- do (setf (event-dur* e) (if d (min d *default-grace-dur*) *default-grace-dur*))
- else if (event-grace e) do (setf d nil) else do (setf d (event-dur* e))))
- (loop with g and di = (>= *default-grace-num* 0) ; di = t if forward and default grace >= 0
- for e in (sort v (if di #'sort-offdur (complement #'sort-offdur)))
- if (popmark e :grace)
- do (setf (event-grace* e) (setf g (if g
- (if di (max (1+ g) *default-grace-num*) (min (1- g) *default-grace-num*))
- *default-grace-num*)))
- else if (event-grace e) do (setf g (event-grace e))))))
+;; (defun clean-quantize (parts)
+;; (when *quantize-adjust-grace-durs*
+;; (loop for p in parts do
+;; (loop for v in (split-into-groups (part-events p) #'event-voice*) do
+;; (loop with d and do
+;; for e in (sort (copy-list v) (complement #'sort-offdur))
+;; if (and d (getmark e :grace) (eql (event-off e) do))
+;; do (setf (event-dur* e) (let for x = *default-grace-dur* then (/ x 2) until (<= x d) finally (return x)))
+;; else if (notep e) do (setf d (event-dur* e))
+;; else do (setf d nil)
+;; do (setf do (event-off e))))
+;; ;; (loop with g and di = (>= *default-grace-num* 0) ; di = t if forward and default grace >= 0
+;; ;; for e in (sort v (if di #'sort-offdur (complement #'sort-offdur)))
+;; ;; if (popmark e :grace)
+;; ;; do (setf (event-grace* e) (setf g (if g
+;; ;; (if di (max (1+ g) *default-grace-num*) (min (1- g) *default-grace-num*))
+;; ;; *default-grace-num*)))
+;; ;; else if (event-grace e) do (setf g (event-grace e)))
+;; )))
(defun quantize-generic (parts)
(loop for p in parts do
Index: fomus/split.lisp
diff -u fomus/split.lisp:1.2 fomus/split.lisp:1.3
--- fomus/split.lisp:1.2 Sat Jul 23 11:23:14 2005
+++ fomus/split.lisp Mon Jul 25 09:56:03 2005
@@ -144,6 +144,14 @@
(setf gs (loop
for e in (split-into-groups gs (lambda (x) (cons (event-off x) (event-grace x))) :test 'equal) ; put vertical notes into chords (note = list of notes, combine all attributes)
if (list>1p e) collect (make-chord e) else collect (first e)))
+ (loop ; split places at grace note offsets
+ for g in gs
+ for i = (event-off g)
+ do (setf ns (loop
+ for e in ns
+ for (j . k) = (split-event e i)
+ when j collect j
+ when k collect k)))
(loop
for e in (nconc gs ns) ; separate notes belonging to next measure--notes after endoff already split
if (< (event-off e) endoff) collect e into v1
@@ -505,7 +513,7 @@
(let ((x (sort (copy-list li) (complement #'sort-offdur))))
(setf li (ex (second x) (first x) x))))))
li))
- (let ((lm (/ (* (beat-division timesig) 4))))
+ (let ((lm (/ (* (beat-division timesig) 65536))))
(flet ((scorefun (nd) ; score relative to ea. level
(if (splitnode-pts nd)
(loop
@@ -588,10 +596,10 @@
(mn (drst (loop for e in nds append (splitnode-evs e)) rl)))))))
(solutfun (nd) ; complete/valid?
(if (splitnode-pts nd)
- (let ((x (splitnode-rl nd)))
- (every (lambda (n) (or (truep n) (split-valid n off endoff x))) (splitnode-evs nd)))
- (or (truep (splitnode-evs nd))
- (split-valid (splitnode-evs nd) off endoff (splitnode-rl nd))))))
+ (let ((x (splitnode-rl nd)))
+ (every (lambda (n) (or (truep n) (split-valid n off endoff x))) (splitnode-evs nd)))
+ (or (truep (splitnode-evs nd))
+ (split-valid (splitnode-evs nd) off endoff (splitnode-rl nd))))))
(multiple-value-bind (evs grs)
(loop
for p in events
Index: fomus/voices.lisp
diff -u fomus/voices.lisp:1.1.1.1 fomus/voices.lisp:1.2
--- fomus/voices.lisp:1.1.1.1 Tue Jul 19 20:16:55 2005
+++ fomus/voices.lisp Mon Jul 25 09:56:03 2005
@@ -148,7 +148,7 @@
:heaplim *voice-engine-heap*
:scoregreaterfun #'scoregreaterfun
:remscoregreaterfun #'remscoregreaterfun)))
- (error "Cannot find voice distribution for part ~A" name))))))
+ (error "Cannot distribute voices for part ~A" name))))))
(defun voices-setvoice (events)
(loop for e in events when (listp (event-voice e)) do
More information about the Fomus-cvs
mailing list