[fomus-cvs] CVS update: fomus/README fomus/TODO fomus/accidentals.lisp fomus/data.lisp fomus/main.lisp fomus/other.lisp fomus/util.lisp
David Psenicka
dpsenicka at common-lisp.net
Tue Jul 26 06:01:06 UTC 2005
Update of /project/fomus/cvsroot/fomus
In directory common-lisp.net:/tmp/cvs-serv32341
Modified Files:
README TODO accidentals.lisp data.lisp main.lisp other.lisp
util.lisp
Log Message:
Testing/bug fixes
Date: Tue Jul 26 08:00:59 2005
Author: dpsenicka
Index: fomus/README
diff -u fomus/README:1.3 fomus/README:1.4
--- fomus/README:1.3 Tue Jul 26 01:15:53 2005
+++ fomus/README Tue Jul 26 08:00:57 2005
@@ -20,8 +20,10 @@
(use-package :fm)
The program is being developed in SBCL, but should also compile in CMUCL and
-OpenMCL. It will eventually run in Allegro Common Lisp and CLISP.
+OpenMCL. It will eventually run in Allegro Common Lisp and CLISP. There are
+problems compiling it in SBCL v0.9.0 (and probably earlier versions) in Darwin
+(errors related to memory management).
If you wish to report a bug, make FOMUS generate a debug file (the default
-filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the
+filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the
DEBUG-FILENAME setting in the FOMUS documentation for more information.
Index: fomus/TODO
diff -u fomus/TODO:1.5 fomus/TODO:1.6
--- fomus/TODO:1.5 Tue Jul 26 01:15:53 2005
+++ fomus/TODO Tue Jul 26 08:00:57 2005
@@ -16,6 +16,7 @@
SHORT TERM
+Number of lines in staff
Global timesig-repl list
MINP and MAXP instrument ranges
MusicXML backend
Index: fomus/accidentals.lisp
diff -u fomus/accidentals.lisp:1.4 fomus/accidentals.lisp:1.5
--- fomus/accidentals.lisp:1.4 Tue Jul 26 01:15:53 2005
+++ fomus/accidentals.lisp Tue Jul 26 08:00:57 2005
@@ -154,7 +154,7 @@
(list x)))) ; e = lists of accs.
if (funcall spellfun o a) collect a)
(loop for a in (mapcar conv choices) if (funcall spellfun o a) collect a) ; ignore user's suggestion
- (error "No accidentals possible for note ~S, offset ~S, part ~S" (event-note f) (event-foff f) name))
+ (error "No accidentals possible for note ~S at offset ~S, part ~S" (event-note f) (event-foff f) name))
collect (let ((w (copy-event f :note (cons (event-note* f) e)))
(s (nokeynode-sc no)))
(let ((d (cons w
Index: fomus/data.lisp
diff -u fomus/data.lisp:1.5 fomus/data.lisp:1.6
--- fomus/data.lisp:1.5 Tue Jul 26 01:15:53 2005
+++ fomus/data.lisp Tue Jul 26 08:00:57 2005
@@ -42,20 +42,19 @@
(defparameter +notenum+ (vector 9 11 0 2 4 5 7))
(defun note-to-num (note)
- (if (keywordp note) note
- (roundto
- (if (and *cm-exists* *use-cm*)
- (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note))
- (if (symbolp note)
- (let* ((s (symbol-name note))
- (b (svref +notenum+ (- (char-int (aref s 0)) 65)))
- (a (case (aref s 1)
- ((#\+ #\S) (incf b) 2)
- ((#\- #\F) (decf b) 2)
- (otherwise 1))))
- (+ (* (parse-integer (subseq s a)) 12) b 12))
- note))
- *note-precision*)))
+ (roundto
+ (if (and *cm-exists* *use-cm*)
+ (if *cm-scale* (funcall *cm-keynumfun* note :in *cm-scale*) (funcall *cm-keynumfun* note))
+ (if (symbolp note)
+ (let* ((s (symbol-name note))
+ (b (svref +notenum+ (- (char-int (aref s 0)) 65)))
+ (a (case (aref s 1)
+ ((#\+ #\S) (incf b) 2)
+ ((#\- #\F) (decf b) 2)
+ (otherwise 1))))
+ (+ (* (parse-integer (subseq s a)) 12) b 12))
+ note))
+ *note-precision*))
(defun is-note (note)
(let ((*note-precision* 1)) (numberp (ignore-errors (note-to-num note)))))
(defun parse-usernote (no)
Index: fomus/main.lisp
diff -u fomus/main.lisp:1.5 fomus/main.lisp:1.6
--- fomus/main.lisp:1.5 Tue Jul 26 01:15:53 2005
+++ fomus/main.lisp Tue Jul 26 08:00:57 2005
@@ -55,119 +55,119 @@
(check-setting-types)
(find-cm)
(check-settings)
- (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 (*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
- (lambda (x) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks
- (flet ((gpi ()
- (or (part-partid p)
- (setf (part-partid p)
- (loop
- for s = (gensym)
- while (find s *parts* :key #'part-partid)
- finally (return s))))))
- (mapc (lambda (x)
- (unless (timesig-partids x)
- (setf (timesig-partids x) (gpi))))
- ti)
- (mapc (lambda (x)
- (unless (event-partid x)
- (setf (event-partid x) (gpi))))
- ma))
- (prenconc ti *timesigs*)
- (prenconc ke *keysigs*)
- (prenconc ma mks)
- (multiple-value-bind (eo ep) (split-list evs #'event-partid)
- (setf (part-events p) ep)
- (prenconc eo *events*))))
- (setf *timesigs* (mapcar #'make-timesigex* *timesigs*))
- (set-note-precision
+ (set-note-precision
+ (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 (*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
+ (lambda (x) (or (notep x) (restp x)))) ; separate timesigs/keysigs out of part tracks
+ (flet ((gpi ()
+ (or (part-partid p)
+ (setf (part-partid p)
+ (loop
+ for s = (gensym)
+ while (find s *parts* :key #'part-partid)
+ finally (return s))))))
+ (mapc (lambda (x)
+ (unless (timesig-partids x)
+ (setf (timesig-partids x) (gpi))))
+ ti)
+ (mapc (lambda (x)
+ (unless (event-partid x)
+ (setf (event-partid x) (gpi))))
+ ma))
+ (prenconc ti *timesigs*)
+ (prenconc ke *keysigs*)
+ (prenconc ma mks)
+ (multiple-value-bind (eo ep) (split-list evs #'event-partid)
+ (setf (part-events p) ep)
+ (prenconc eo *events*))))
+ (setf *timesigs* (mapcar #'make-timesigex* *timesigs*))
(loop
with h = (get-timesigs *timesigs* *parts*)
for i from 0 and e in *parts*
for (evs rm) on (split-list* *events* (mapcar #'part-partid *parts*) :key #'event-partid)
collect (make-partex* e i evs (gethash e h))
- finally (when rm (error "No matching part for event with partid ~S" (first *events*)))))))) ; make copied list of part-exs w/ sorted events
- #+debug (fomus-proc-check pts 'start)
- (track-progress +progress-int+
- (if *auto-quantize*
- (progn (when (>= *verbose* 2) (out "~&; Quantizing..."))
- (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize))
- (quantize-generic pts))
- (when *check-ranges*
- (when (>= *verbose* 2) (out "~&; Ranges..."))
- (check-ranges pts) #+debug (fomus-proc-check pts 'ranges))
- (preproc-harmonics pts)
- (when *transpose*
- (when (>= *verbose* 2) (out "~&; Transpositions..."))
- (transpose pts) #+debug (fomus-proc-check pts 'transpose))
- (if *auto-accidentals*
- (progn (when (>= *verbose* 2) (out "~&; Accidentals..."))
- (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs))
- (accidentals-generic pts))
- (reset-tempslots pts nil)
- (when (and (>= *verbose* 2) (find-if #'is-percussion pts))
- (out "~&; Percussion...") ; before voices & clefs
- (percussion pts))
- (if *auto-voicing*
- (progn (when (>= *verbose* 2) (out "~&; Voices..."))
- (voices pts) #+debug (fomus-proc-check pts 'voices))
- (voices-generic pts))
- (if *auto-staff/clef-changes*
- (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided
- (clefs pts) #+debug (fomus-proc-check pts 'clefs))
- (clefs-generic pts))
- (reset-tempslots pts 0)
- (distribute-marks pts mks)
- (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED
- ;;(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 (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 (>= *verbose* 2) (out "~&; Miscellaneous items..."))
- (preproc-cautaccs pts)
- (when *auto-grace-slurs*
- (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs))
- (when (>= *verbose* 2) (out "~&; Measures..."))
- (init-parts *timesigs* pts) ; ----- MEASURES
- #+debug (fomus-proc-check pts 'measures)
- #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x)))))
- (when *auto-cautionary-accs*
- (when (>= *verbose* 2) (out "~&; Cautionary accidentals..."))
- (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs))
- (when (>= *verbose* 2) (out "~&; Chords..."))
- (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS
- (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1)
- (when (>= *verbose* 2) (out "~&; Splits/ties/rests..."))
- (split pts) #+debug (fomus-proc-check pts 'ties)
- (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2)
- (when *auto-beams*
- (when (>= *verbose* 2) (out "~&; Beams..."))
- (beams pts) #+debug (fomus-proc-check pts 'beams))
- (when (>= *verbose* 2) (out "~&; Staff/voice layouts..."))
- (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER
- (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests)
- (when (or *auto-multivoice-rests* *auto-multivoice-notes*)
- (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes))
- (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs)
- (when (>= *verbose* 2) (out "~&; Post processing..."))
- (postaccs pts) #+debug (fomus-proc-check pts 'postaccs)
- (postproc pts) #+debug (fomus-proc-check pts 'postproc)
- (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts)
- (group-parts pts) #+debug (fomus-proc-check pts 'groupparts)
- (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops)
- (when (>= *verbose* 2) (format t "~&"))
- pts)))))
+ finally (when rm (error "No matching part for event with partid ~S" (first *events*))))))) ; make copied list of part-exs w/ sorted events
+ #+debug (fomus-proc-check pts 'start)
+ (track-progress +progress-int+
+ (if *auto-quantize*
+ (progn (when (>= *verbose* 2) (out "~&; Quantizing..."))
+ (quantize *timesigs* pts) #+debug (fomus-proc-check pts 'quantize))
+ (quantize-generic pts))
+ (when *check-ranges*
+ (when (>= *verbose* 2) (out "~&; Ranges..."))
+ (check-ranges pts) #+debug (fomus-proc-check pts 'ranges))
+ (preproc-harmonics pts)
+ (when *transpose*
+ (when (>= *verbose* 2) (out "~&; Transpositions..."))
+ (transpose pts) #+debug (fomus-proc-check pts 'transpose))
+ (if *auto-accidentals*
+ (progn (when (>= *verbose* 2) (out "~&; Accidentals..."))
+ (accidentals *keysigs* pts) #+debug (fomus-proc-check pts 'accs))
+ (accidentals-generic pts))
+ (reset-tempslots pts nil)
+ (when (and (>= *verbose* 2) (find-if #'is-percussion pts))
+ (out "~&; Percussion...") ; before voices & clefs
+ (percussion pts))
+ (if *auto-voicing*
+ (progn (when (>= *verbose* 2) (out "~&; Voices..."))
+ (voices pts) #+debug (fomus-proc-check pts 'voices))
+ (voices-generic pts))
+ (if *auto-staff/clef-changes*
+ (progn (when (>= *verbose* 2) (out "~&; Staves/clefs...")) ; staves/voices are now decided
+ (clefs pts) #+debug (fomus-proc-check pts 'clefs))
+ (clefs-generic pts))
+ (reset-tempslots pts 0)
+ (distribute-marks pts mks)
+ (setf pts (sep-staves pts)) ; ********** STAVES SEPARATED
+ ;;(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 (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 (>= *verbose* 2) (out "~&; Miscellaneous items..."))
+ (preproc-cautaccs pts)
+ (when *auto-grace-slurs*
+ (grace-slurs pts) #+debug (fomus-proc-check pts 'graceslurs))
+ (when (>= *verbose* 2) (out "~&; Measures..."))
+ (init-parts *timesigs* pts) ; ----- MEASURES
+ #+debug (fomus-proc-check pts 'measures)
+ #+debug (check-same pts "FOMUS-PROC (MEASURES)" :key (lambda (x) (meas-endoff (last-element (part-meas x)))))
+ (when *auto-cautionary-accs*
+ (when (>= *verbose* 2) (out "~&; Cautionary accidentals..."))
+ (cautaccs pts) #+debug (fomus-proc-check pts 'cautaccs))
+ (when (>= *verbose* 2) (out "~&; Chords..."))
+ (preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS
+ (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1)
+ (when (>= *verbose* 2) (out "~&; Splits/ties/rests..."))
+ (split pts) #+debug (fomus-proc-check pts 'ties)
+ (clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2)
+ (when *auto-beams*
+ (when (>= *verbose* 2) (out "~&; Beams..."))
+ (beams pts) #+debug (fomus-proc-check pts 'beams))
+ (when (>= *verbose* 2) (out "~&; Staff/voice layouts..."))
+ (setf pts (assemble-parts pts)) #+debug (fomus-proc-check pts 'assvoices) ; ********** VOICES TOGETHER
+ (distr-rests pts) #+debug (fomus-proc-check pts 'distrrests)
+ (when (or *auto-multivoice-rests* *auto-multivoice-notes*)
+ (comb-notes pts) #+debug (fomus-proc-check pts 'combnotes))
+ (clean-clefs pts) #+debug (fomus-proc-check pts 'cleanclefs)
+ (when (>= *verbose* 2) (out "~&; Post processing..."))
+ (postaccs pts) #+debug (fomus-proc-check pts 'postaccs)
+ (postproc pts) #+debug (fomus-proc-check pts 'postproc)
+ (setf pts (sort-parts pts)) #+debug (fomus-proc-check pts 'sortparts)
+ (group-parts pts) #+debug (fomus-proc-check pts 'groupparts)
+ (postpostproc-sortprops pts) #+debug (fomus-proc-check pts 'sortprops)
+ (when (>= *verbose* 2) (format t "~&"))
+ pts))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAIN
Index: fomus/other.lisp
diff -u fomus/other.lisp:1.2 fomus/other.lisp:1.3
--- fomus/other.lisp:1.2 Tue Jul 26 01:15:53 2005
+++ fomus/other.lisp Tue Jul 26 08:00:57 2005
@@ -64,13 +64,18 @@
when (is-percussion p) do
(loop with pm = (instr-percs (part-instr p))
for ev in (part-events p) do
- (let ((n (event-note ev)))
+ (let ((n (event-note ev))) ; n = value of note slot
(unless (numberp n)
- (let ((c (etypecase n
+ (let ((c (etypecase n ; c = percussion struct
(symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym))
(perc n))))
- (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1))
- (setf (event-staff* ev) (perc-staff c)))
- (when (perc-voice c) (setf (event-voice* ev) (perc-voice c)))))))
+ (if c
+ (progn
+ (when (and (perc-staff c) (> (instr-staves (part-instr p)) 1))
+ (setf (event-staff* ev) (perc-staff c)))
+ (when (perc-voice c) (setf (event-voice* ev) (perc-voice c)))
+ (setf (event-note ev) (note-to-num (perc-note c))))
+ (if (is-note n) (setf (event-note ev) (note-to-num n))
+ (error "Unknown percussion specifier ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p))))))))
(print-dot)))
Index: fomus/util.lisp
diff -u fomus/util.lisp:1.4 fomus/util.lisp:1.5
--- fomus/util.lisp:1.4 Tue Jul 26 01:15:53 2005
+++ fomus/util.lisp Tue Jul 26 08:00:57 2005
@@ -501,15 +501,13 @@
:dur (get-dur ev ts)
:marks (event-marks ev)
:voice (event-voice ev)
- :note (let ((n (event-note ev)))
- (if (is-percussion pa)
- (unless (numberp n)
- (perc-note (etypecase n
- (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym)
- (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa))))
- (perc n)))
- n)
- (parse-usernote n)))))
+ :note (if (is-percussion pa) (event-note ev)
+ ;; (if (numberp n) n
+ ;; (perc-note (etypecase n
+ ;; (symbol (or (find n *percussion* :key #'perc-sym) (find n (instr-percs (part-instr pa)) :key #'perc-sym)
+ ;; (error "Unknown percussion note/instrument ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name pa))))
+ ;; (perc n))))
+ (parse-usernote (event-note ev)))))
(defmethod make-eventex* ((ev rest) ts pa)
(declare (ignore pa))
(make-restex
More information about the Fomus-cvs
mailing list