[fomus-cvs] CVS update: fomus/backend_cmn.lisp fomus/backends.lisp fomus/data.lisp fomus/deps.lisp fomus/final.lisp fomus/fomus.asd fomus/load.lisp fomus/main.lisp fomus/other.lisp fomus/postproc.lisp fomus/version.lisp
David Psenicka
dpsenicka at common-lisp.net
Fri Nov 11 22:03:21 UTC 2005
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 , at ps)))
+ (:grandstaff `((system brace , at 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* , at +perc-keys+))))
+ (instr-percs (check* (or* null (list-of* (or* (type* +perc-type+) (cons* symbol (key-arg-pairs* , at +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"
More information about the Fomus-cvs
mailing list