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