Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv31832 Modified Files: backend_cmn.lisp backends.lisp data.lisp deps.lisp final.lisp fomus.asd load.lisp main.lisp other.lisp postproc.lisp version.lisp Log Message: more bug fixes Date: Fri Nov 11 23:03:17 2005 Author: dpsenicka Index: fomus/backend_cmn.lisp diff -u fomus/backend_cmn.lisp:1.1 fomus/backend_cmn.lisp:1.2 --- fomus/backend_cmn.lisp:1.1 Sat Oct 1 02:49:45 2005 +++ fomus/backend_cmn.lisp Fri Nov 11 23:03:16 2005 @@ -8,5 +8,29 @@ (in-package :fomus) (compile-settings) +(defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%") + (defun save-cmn (parts header filename options process view) - (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) \ No newline at end of file + ;; (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) + (write + `(cmn ,score-attr + ,@(labels ((pfn (pps &optional (grp 1)) + (loop for e = (pop pps) + 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 Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.11 fomus/backends.lisp:1.12 --- fomus/backends.lisp:1.11 Sat Oct 22 22:43:06 2005 +++ fomus/backends.lisp Fri Nov 11 23:03:16 2005 @@ -12,7 +12,7 @@ (declaim (type cons +backendexts+)) (defparameter +backendexts+ - '((:data . "fms") #|(:cmn . "cmn")|# (:lilypond . "ly") (:musicxml . "xml") (:midi . "mid") #|(:portmidi . "pm") (:midishare . "ms")|#)) + '((:data . "fms") (:cmn . "cmn") (:lilypond . "ly") (:musicxml . "xml") (:midi . "mid") #|(:portmidi . "pm") (:midishare . "ms")|#)) (declaim (type (or symbol list) *backend*)) (defparameter *backend* (list (first (first +backendexts+)))) @@ -37,7 +37,7 @@ (declare (type symbol backend) (type list parts) (type list options) (type boolean process) (type boolean view)) (case backend (:data (save-data filename parts)) -;; (:cmn (save-lilypond parts (format nil +cmn-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) + (:cmn (save-cmn parts (format nil +cmn-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (:lilypond (save-lilypond parts (format nil +lilypond-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options process view)) (:musicxml (save-xml parts (format nil +xml-comment+ +title+ (first +version+) (second +version+) (third +version+)) filename options)) (:midi (save-midi parts filename options play)) Index: fomus/data.lisp diff -u fomus/data.lisp:1.25 fomus/data.lisp:1.26 --- fomus/data.lisp:1.25 Sat Oct 22 22:43:06 2005 +++ fomus/data.lisp Fri Nov 11 23:03:16 2005 @@ -271,7 +271,7 @@ "Found ~S, expected (INTEGERS 1) or SYMBOLS in the form I, (I (S S I) ...) in CLEFLEGLS slot" t)) (instr-8uplegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected NIL, (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8UPLEGLS slot" t)) (instr-8dnlegls (check* (or* null (integer 1) (list* (integer 1) (integer 1))) "Found ~S, expected NIL, (INTEGER 1) or ((INTEGER 1) (INTEGER 1)) in 8DNLEGLS slot" t)) - (instr-percs (check* (or* null (list-of* (type* +perc-type+)) (list-of* (cons* symbol (key-arg-pairs* ,@+perc-keys+)))) + (instr-percs (check* (or* null (list-of* (or* (type* +perc-type+) (cons* symbol (key-arg-pairs* ,@+perc-keys+))))) "Found ~S, expected list of PERC objects or (SYMBOL/(INTEGER 0 127) KEYWORD/ARGUMENT-PAIRS...) in PERCS slot" t)) (instr-midiprgch-im (check* (or* null (integer 0 127) (list-of* (integer 0 127))) "Found ~S, expected NIL, (integer 0 127) or list of (integer 0 127) in MIDIPRGCH-IM slot" t)) Index: fomus/deps.lisp diff -u fomus/deps.lisp:1.7 fomus/deps.lisp:1.8 --- fomus/deps.lisp:1.7 Sat Oct 22 22:43:06 2005 +++ fomus/deps.lisp Fri Nov 11 23:03:16 2005 @@ -58,3 +58,14 @@ *cm-midipbend* (find-symbol "MIDI-PITCH-BEND" :cm) *cm-rts* (ignore-errors (symbol-function (find-symbol "RTS" :cm))) ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; COMMON MUSIC NOTATION + +(defparameter *cmn-exists* nil) + +(defun find-cmn () + (when (and (not *cmn-exists*) (find-package "CMN")) + (when (>= *verbose* 2) (format t ";; Common Music Notation package detected~%")) + (setf *cmn-exists* t + ))) \ No newline at end of file Index: fomus/final.lisp diff -u fomus/final.lisp:1.7 fomus/final.lisp:1.8 --- fomus/final.lisp:1.7 Sun Aug 21 21:17:40 2005 +++ fomus/final.lisp Fri Nov 11 23:03:16 2005 @@ -48,7 +48,7 @@ (conc-stringlist (loop for e in +banner+ collect (format nil ";; ~A~%" e)))))) (eval-when (:load-toplevel :execute) - (find-cm)) + (find-cm) (find-cmn)) (eval-when (:load-toplevel :execute) (load-initfile)) Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.16 fomus/fomus.asd:1.17 --- fomus/fomus.asd:1.16 Sat Oct 22 22:43:06 2005 +++ fomus/fomus.asd Fri Nov 11 23:03:16 2005 @@ -31,10 +31,11 @@ (:file "voices" :depends-on ("util")) (:file "quantize" :depends-on ("util" "splitrules")) + (:file "backend_cmn" :depends-on ("util")) (:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) (:file "backend_mid" :depends-on ("util")) - (:file "backends" :depends-on ("backend_ly" "backend_xml" "backend_mid" "version")) + (:file "backends" :depends-on ("backend_cmn" "backend_ly" "backend_xml" "backend_mid" "version")) (:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends")) Index: fomus/load.lisp diff -u fomus/load.lisp:1.7 fomus/load.lisp:1.8 --- fomus/load.lisp:1.7 Sat Oct 1 02:49:45 2005 +++ fomus/load.lisp Fri Nov 11 23:03:16 2005 @@ -2,7 +2,7 @@ ;; Load file for FOMUS (loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "splitrules" "accidentals" "beams" "marks" - "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" + "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_cmn" "backend_ly" "backend_xml" "backend_mid" "backends" "main" "interface" "final") and nw for na in fl Index: fomus/main.lisp diff -u fomus/main.lisp:1.17 fomus/main.lisp:1.18 --- fomus/main.lisp:1.17 Sat Oct 22 22:43:06 2005 +++ fomus/main.lisp Fri Nov 11 23:03:16 2005 @@ -52,7 +52,6 @@ ;; keysigs not implemented yet ;; returns data structure ready for output via backends (defun fomus-proc () - (find-cm) (when (and (numberp *verbose*) (>= *verbose* 1)) (out "~&;; Formatting music...")) (when *debug-filename* (save-debug)) (when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types...")) @@ -189,6 +188,8 @@ ;; MAIN (defun fomus-main () + (find-cm) + (when (find :cmn (force-list2some *backend*) :key #'first) (find-cmn)) (let ((r (fomus-proc))) (loop for x of-type (or symbol cons) in (force-list2some *backend*) do (let ((xx (force-list x))) Index: fomus/other.lisp diff -u fomus/other.lisp:1.10 fomus/other.lisp:1.11 --- fomus/other.lisp:1.10 Sat Oct 1 02:49:45 2005 +++ fomus/other.lisp Fri Nov 11 23:03:16 2005 @@ -17,19 +17,18 @@ (defun check-ranges (pts) (declare (type list pts)) (loop - with f for p of-type partex in pts unless (is-percussion p) - do (loop - with i = (part-instr p) - with mi = (when (instr-minp i) (+ (instr-minp i) (or (instr-tpose i) 0))) and ma = (when (instr-maxp i) (+ (instr-maxp i) (or (instr-tpose i) 0))) - for e of-type (or noteex restex) in (part-events p) - when (notep e) - do (let ((n (event-note* e))) - (when (or (and mi (< n mi)) (and ma (> n ma))) - (unless f (setf f t) (format t "~%; ")) - (format t "~&;; WARNING: Note ~S is out of range at offset ~S, part ~S" n (event-foff e) (part-name p)) - (return)))) (print-dot))) + do (loop with i = (part-instr p) + for mm in (list (when (instr-minp i) (+ (instr-minp i) (or (instr-tpose i) 0))) (when (instr-maxp i) (+ (instr-maxp i) (or (instr-tpose i) 0)))) + and co in (list #'< #'>) when mm do + (loop + for e of-type (or noteex restex) in (part-events p) + when (notep e) + do (let ((n (event-note* e))) + (when (funcall co n mm) + (format t "~&;; WARNING: Note ~S is out of range at offset ~S, part ~S" n (event-foff e) (part-name p)) + (return))))) (print-dot))) (defun transpose (pts) (declare (type list pts)) @@ -85,7 +84,8 @@ (loop with pm = (instr-percs (part-instr p)) for ev of-type (or noteex restex) in (part-events p) do (let ((n (event-note ev))) ; n = value of note slot - (unless (numberp n) + (if (numberp n) (unless (svref +note-to-white+ (mod n 12)) + (error "Invalid percussion note ~S in NOTE slot of note at offset ~S, part ~S" n (event-foff ev) (part-name p))) (let ((c (etypecase n ; c = percussion struct (symbol (find n *percussion* :key #'perc-sym) (find n pm :key #'perc-sym)) (perc n)))) @@ -95,7 +95,11 @@ (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))) - (when (and *auto-percussion-durs* (perc-autodur c) (not (event-grace ev))) (addmark ev :autodur))) + (when (and *auto-percussion-durs* (perc-autodur c) (not (event-grace ev)) + (notany (lambda (x) + (declare (type symbol x)) + (getmark ev x)) + '(:tremolo :tremolofirst :tremolosecond :longtrill))) (addmark ev :autodur))) (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))) @@ -122,10 +126,7 @@ for p of-type partex in parts do (loop with oo = mt for ev of-type (or noteex restex) in (reverse (part-events p)) - when (and (popmark ev :autodur) (notany (lambda (x) - (declare (type symbol x)) - (getmark ev x)) - '(:tremolo :tremolofirst :tremolosecond :longtrill))) + when (popmark ev :autodur) do (setf (event-autodur ev) t (event-dur ev) (if (= oo (event-off ev)) lb (- oo (event-off ev)))) when (and #|(notep ev)|# (< (event-off ev) oo)) do (setf oo (event-off ev))) (print-dot))) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.14 fomus/postproc.lisp:1.15 --- fomus/postproc.lisp:1.14 Sat Oct 22 22:43:06 2005 +++ fomus/postproc.lisp Fri Nov 11 23:03:16 2005 @@ -163,7 +163,9 @@ (if pc (addmark e (list m in)) ; just get rid of the accidental (let ((a (- (+ n in) wn))) (if (and (or (/= a 0) (/= (svref as wn) 0)) - (or (/= a 0) *acc-throughout-meas*)) (addmark e (list m in a)) (addmark e (list m in)))))) + (or (/= a 0) *acc-throughout-meas*)) + (addmark e (list m in a)) + (addmark e (list m in)))))) (loop for n of-type integer in (if (chordp e) (event-writtennotes e) (force-list (event-writtennote e))) and a of-type (integer -2 2) in (if (chordp e) (event-accs e) (force-list (event-acc e))) and aa of-type (rational -1/2 1/2) in (if (chordp e) (event-addaccs e) (force-list (event-addacc e))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.15 fomus/version.lisp:1.16 --- fomus/version.lisp:1.15 Sat Oct 22 22:43:06 2005 +++ fomus/version.lisp Fri Nov 11 23:03:16 2005 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 20)) +(defparameter +version+ '(0 1 21)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"