Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv8185
Modified Files: backend_ly.lisp backend_xml.lisp backends.lisp data.lisp fomus.asd main.lisp misc.lisp parts.lisp splitrules.lisp test.lisp util.lisp Log Message: bug fixes Date: Sun Aug 28 23:31:28 2005 Author: dpsenicka
Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.13 fomus/backend_ly.lisp:1.14 --- fomus/backend_ly.lisp:1.13 Sat Aug 27 20:13:21 2005 +++ fomus/backend_ly.lisp Sun Aug 28 23:31:27 2005 @@ -39,8 +39,7 @@
(defun view-lilypond (filename options view) (when (>= *verbose* 1) (out ";; Compiling/opening ~S for viewing...~%" filename)) - (destructuring-bind (xxx &key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options - (declare (ignore xxx)) + (destructuring-bind (&key exe view-exe exe-opts view-exe-opts out-ext &allow-other-keys) options (flet ((er (str) (format t ";; ERROR: Error ~A lilypond file~%" str) (return-from view-lilypond))) @@ -137,8 +136,7 @@ (defun save-lilypond (parts header filename options process view) (when (>= *verbose* 1) (out ";; Saving Lilypond file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) - (destructuring-bind (xxx &key filehead scorehead text-markup textdyn-markup texttempo-markup textnote-markup &allow-other-keys) options - (declare (ignore xxx)) + (destructuring-bind (&key filehead scorehead text-markup textdyn-markup texttempo-markup textnote-markup &allow-other-keys) options (format f "~A" header) (loop for e in +lilypond-head+ do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top (when filehead (loop for e in (force-list filehead) do (format f "~A~%" e) finally (format f "~%"))) ;; user header @@ -221,7 +219,7 @@ "")) "") (let ((m (getmark e '(:staff :voice)))) - (if m #|(and m (null (fourth m)))|# (format nil "\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) + (if (and m (> ns 1)) #|(and m (null (fourth m)))|# (format nil "\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) #|(print (lystaff (third m)))|# "")) (let ((c (getmark e :clef))) (if (and c (null (fourth c))) (format nil "\clef ~A " (lyclef (second c)))
Index: fomus/backend_xml.lisp diff -u fomus/backend_xml.lisp:1.2 fomus/backend_xml.lisp:1.3 --- fomus/backend_xml.lisp:1.2 Sun Aug 21 21:17:40 2005 +++ fomus/backend_xml.lisp Sun Aug 28 23:31:27 2005 @@ -45,7 +45,7 @@
(defun write-xml (cont str &optional (ind 0)) (destructuring-bind (ta ar0 &rest re) cont - (let ((ar (conc-stringlist (loop for (a va) in (force-list2 ar0) collect (format nil " ~A="~A"" a va))))) + (let ((ar (conc-stringlist (loop for (a va) in (force-list2all ar0) collect (format nil " ~A="~A"" a va))))) (if re (if (consp (first re)) (progn (format str "~V,0T<~A~A>~%" ind ta ar)
Index: fomus/backends.lisp diff -u fomus/backends.lisp:1.7 fomus/backends.lisp:1.8 --- fomus/backends.lisp:1.7 Sun Aug 21 21:17:40 2005 +++ fomus/backends.lisp Sun Aug 28 23:31:27 2005 @@ -29,10 +29,9 @@ (fresh-line f)))
(defun split-preproc-backends (pts) - (loop for x of-type (or symbol cons) in (or (force-list2 *backend*) '((:data))) - do (let ((ba (first (force-list x)))) - (case ba - (:lilypond (split-preproc-lilypond pts)))))) + (loop for x of-type (or symbol cons) in (force-list2some *backend*) + do (case (first (force-list x)) + (:lilypond (split-preproc-lilypond pts)))))
(defun backend (backend filename parts options process view) (declare (type symbol backend) (type list parts) (type list options) (type boolean process) (type boolean view))
Index: fomus/data.lisp diff -u fomus/data.lisp:1.15 fomus/data.lisp:1.16 --- fomus/data.lisp:1.15 Sun Aug 28 06:32:47 2005 +++ fomus/data.lisp Sun Aug 28 23:31:27 2005 @@ -465,7 +465,7 @@ (defparameter +settings+ '((:debug-filename (or null string)) (:verbose (integer 0 2)) (:use-cm boolean) (:cm-scale t) - (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (cons* symbol key-arg-pairs*))) + (:backend (or* symbol (cons* symbol key-arg-pairs*) (list-of* (or* symbol (cons* symbol key-arg-pairs*)))) "(SYMBOL KEYWORD/ARGUMENTS-PAIRS...) or list of (SYMBOL KEYWORD/ARGUMENTS-PAIRS...)") (:filename string) (:quality (real (0)))
Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.6 fomus/fomus.asd:1.7 --- fomus/fomus.asd:1.6 Sun Aug 28 06:32:47 2005 +++ fomus/fomus.asd Sun Aug 28 23:31:27 2005 @@ -33,7 +33,7 @@
(:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) - (:file "backends" :depends-on ("backend_ly" "version")) + (:file "backends" :depends-on ("backend_ly" "backend_xml" "version"))
(:file "main" :depends-on ("accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backends"))
Index: fomus/main.lisp diff -u fomus/main.lisp:1.12 fomus/main.lisp:1.13 --- fomus/main.lisp:1.12 Sat Aug 27 20:13:21 2005 +++ fomus/main.lisp Sun Aug 28 23:31:27 2005 @@ -186,17 +186,18 @@
(defun fomus-main () (let ((r (fomus-proc))) - (loop for x of-type (or symbol cons) in (or (force-list2 *backend*) '((:data))) - do (destructuring-bind (ba &key filename process view &allow-other-keys) (force-list x) - (declare (type symbol ba) (type boolean process view)) - (backend ba - (namestring - (merge-pathnames (or filename (change-filename *filename* :ext (lookup ba +backendexts+))) - #+cmu (ext:default-directory) - #+sbcl (sb-unix:posix-getcwd) - #+openmcl (ccl:mac-default-directory) - #+allegro (excl:current-directory))) - r x (or process view) view)))) + (loop for x of-type (or symbol cons) in (force-list2some *backend*) + do (let ((xx (force-list x))) + (destructuring-bind (ba &key filename process view &allow-other-keys) xx + (declare (type symbol ba) (type boolean process view)) + (backend ba + (namestring + (merge-pathnames (or filename (change-filename *filename* :ext (lookup ba +backendexts+))) + #+cmu (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd) + #+openmcl (ccl:mac-default-directory) + #+allegro (excl:current-directory))) + r (rest xx) (or process view) view))))) t)
;; #+allegro (excl:current-directory)
Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.7 fomus/misc.lisp:1.8 --- fomus/misc.lisp:1.7 Sun Aug 28 06:32:47 2005 +++ fomus/misc.lisp Sun Aug 28 23:31:27 2005 @@ -55,7 +55,11 @@ (if (listp list) list (list list))) (defun force-newlist (list) (if (listp list) (copy-list list) (list list))) -(defun force-list2 (list) +(defun force-list2some (list) + (let ((x (force-list list))) + (if (or (null x) (some #'listp x)) x + (list x)))) +(defun force-list2all (list) (let ((x (force-list list))) (if (or (null x) (every #'listp x)) x (list x))))
Index: fomus/parts.lisp diff -u fomus/parts.lisp:1.5 fomus/parts.lisp:1.6 --- fomus/parts.lisp:1.5 Sun Aug 21 21:17:41 2005 +++ fomus/parts.lisp Sun Aug 28 23:31:27 2005 @@ -55,7 +55,7 @@ (labels ((fl (l) (declare (type list l)) (loop for e of-type (or cons symbol) in l - if (consp e) nconc (fl (rest e)) else collect e))) ; listp + if (consp e) nconc (fl (rest e)) else collect e))) (let ((l (fl (instr-groups)))) (flet ((srt (x y) (let ((px (position (instr-sym (part-instr x)) l)) @@ -73,51 +73,106 @@ with fs = (unless (and tv (eq (the symbol (first sp)) :grandstaff)) (the symbol (first sp))) for s of-type (or cons symbol) in (rest sp) and j from 0 - if (consp s) ; listp + if (consp s) do (let ((l (nu in s tv j))) (when l (return (cons (cons i fs) l)))) else if (eq in s) do (return (list (cons i fs)))))) - (let ((gs nil)) ; was 0? - (flet ((en (p l ty) - (declare (type partex p) (type (integer 1) l) (type symbol ty)) - (if (and (getprop p (list :startgroup l)) (not gs)) - (rmprop p (list :startgroup l)) - (addprop p (list :endgroup l))) - (when (eq ty :grandstaff) (setf gs nil))) - (ad (p l ty) - (declare (type partex p) (type (integer 1) l) (type symbol ty)) - (addprop p (list :startgroup l ty)) - (when (eq ty :grandstaff) (setf gs t)))) + (flet ((en (p l ty) + (declare (type partex p) (type (integer 1) l) (type symbol ty)) + (if (and (getprop p (list :startgroup l)) (not (eq ty :grandstaff))) ; eliminate 1-staff braces + (rmprop p (list :startgroup l)) + (addprop p (list :endgroup l)))) + (ad (p l ty) + (declare (type partex p) (type (integer 1) l) (type symbol ty)) + (addprop p (list :startgroup l ty)))) + (loop + for (lp p) of-type ((or part null) part) on (cons nil pts) and ii downfrom -1 + and l = g + for g = (when p (or (rest (nu (instr-sym (part-instr p)) (cons nil (instr-groups)) (<= (instr-staves (part-instr p)) 1))) + (if (> (instr-staves (part-instr p)) 1) + (list (cons ii :grandstaff)) + (list (cons ii nil))))) + do + (loop + for ll on l and gg on g and i from 1 + while (equal (the (cons integer symbol) (first ll)) (the (cons integer symbol) (first gg))) + do (let ((x (cdr (the (cons * symbol) (first ll))))) (when (eq x :grandstaff) (en lp i x) (ad p i x))) + finally (loop - for (lp p) of-type ((or part null) part) on (cons nil pts) and ii downfrom -1 - and l = g - for g = (when p (or (rest (nu (instr-sym (part-instr p)) (cons nil (instr-groups)) (<= (instr-staves (part-instr p)) 1))) - (if (> (instr-staves (part-instr p)) 1) - (list (cons ii :grandstaff)) - (list (cons ii nil))))) + for l on ll and g on gg and j from i do + (let ((x (cdr (the (cons * symbol) (first l))))) (when x (en lp j x))) + (let ((x (cdr (the (cons * symbol) (first g))))) (when x (ad p j x))) + finally (loop - for ll on l and gg on g and i from 1 - while (equal (the (cons integer symbol) (first ll)) (the (cons integer symbol) (first gg))) - finally - (loop - for l on ll and g on gg and j from i - do - (let ((x (cdr (the (cons * symbol) (first l))))) (when (or x gs) (en lp j x))) - (let ((x (cdr (the (cons * symbol) (first g))))) (when x (ad p j x))) - finally - (loop - for ll on l and k from j - do (let ((x (cdr (the (cons * symbol) (first ll))))) (when (or x gs) (en lp k x)))) - (loop - for gg on g and k from j - do (let ((x (cdr (the (cons * symbol) (first gg))))) (when x (ad p k x)))))) - (print-dot)) - (let ((f (first pts)) - (l (last-element pts))) - (declare (type partex f l)) - (unless (and (getprop f '(:startgroup 1)) - (notany (lambda (p) (declare (type partex p)) (getprop p '(:startgroup 1))) (rest pts)) - (getprop l '(:endgroup 1))) - (addprop f '(:startgroup 0)) ; add a global group if there isn't one anyways - (addprop l '(:endgroup 0)))))))) + for ll on l and k from j + do (let ((x (cdr (the (cons * symbol) (first ll))))) (when x (en lp k x)))) + (loop + for gg on g and k from j + do (let ((x (cdr (the (cons * symbol) (first gg))))) (when x (ad p k x)))))) + (print-dot)) + (let ((f (first pts)) + (l (last-element pts))) + (declare (type partex f l)) + (unless (and (getprop f '(:startgroup 1)) + (notany (lambda (p) (declare (type partex p)) (getprop p '(:startgroup 1))) (rest pts)) + (getprop l '(:endgroup 1))) + (addprop f '(:startgroup 0)) ; add a global group if there isn't one + (addprop l '(:endgroup 0))))))) + +;; (defun group-parts (pts) +;; (declare (type list pts)) +;; (labels ((nu (in sp tv &optional i) +;; (declare (type symbol in) (type (cons symbol list) sp) (type boolean tv) (type (or (integer 0) null) i)) +;; (loop +;; with fs = (unless (and tv (eq (the symbol (first sp)) :grandstaff)) (the symbol (first sp))) +;; for s of-type (or cons symbol) in (rest sp) +;; and j from 0 +;; if (consp s) +;; do (let ((l (nu in s tv j))) +;; (when l (return (cons (cons i fs) l)))) +;; else if (eq in s) do (return (list (cons i fs)))))) +;; (let ((gs nil)) ; in the middle of grandstaff? +;; (flet ((en (p l ty) +;; (declare (type partex p) (type (integer 1) l) (type symbol ty)) +;; (if (and (getprop p (list :startgroup l)) (not gs)) ; eliminate 1-staff braces +;; (rmprop p (list :startgroup l)) +;; (addprop p (list :endgroup l))) +;; (when (eq ty :grandstaff) (setf gs nil))) +;; (ad (p l ty) +;; (declare (type partex p) (type (integer 1) l) (type symbol ty)) +;; (addprop p (list :startgroup l ty)) +;; (when (eq ty :grandstaff) (setf gs t)))) +;; (loop +;; for (lp p) of-type ((or part null) part) on (cons nil pts) and ii downfrom -1 +;; and l = g +;; for g = (when p (or (rest (nu (instr-sym (part-instr p)) (cons nil (instr-groups)) (<= (instr-staves (part-instr p)) 1))) +;; (if (> (instr-staves (part-instr p)) 1) +;; (list (cons ii :grandstaff)) +;; (list (cons ii nil))))) +;; do +;; (loop +;; for ll on l and gg on g and i from 1 +;; while (equal (the (cons integer symbol) (first ll)) (the (cons integer symbol) (first gg))) +;; finally +;; (loop +;; for l on ll and g on gg and j from i +;; do +;; (let ((x (cdr (the (cons * symbol) (first l))))) (when (or x gs) (en lp j x))) +;; (let ((x (cdr (the (cons * symbol) (first g))))) (when x (ad p j x))) +;; finally +;; (loop +;; for ll on l and k from j +;; do (let ((x (cdr (the (cons * symbol) (first ll))))) (when (or x gs) (en lp k x)))) +;; (loop +;; for gg on g and k from j +;; do (let ((x (cdr (the (cons * symbol) (first gg))))) (when x (ad p k x)))))) +;; (print-dot)) +;; (let ((f (first pts)) +;; (l (last-element pts))) +;; (declare (type partex f l)) +;; (unless (and (getprop f '(:startgroup 1)) +;; (notany (lambda (p) (declare (type partex p)) (getprop p '(:startgroup 1))) (rest pts)) +;; (getprop l '(:endgroup 1))) +;; (addprop f '(:startgroup 0)) ; add a global group if there isn't one +;; (addprop l '(:endgroup 0))))))))
Index: fomus/splitrules.lisp diff -u fomus/splitrules.lisp:1.1 fomus/splitrules.lisp:1.2 --- fomus/splitrules.lisp:1.1 Sun Aug 28 06:32:47 2005 +++ fomus/splitrules.lisp Sun Aug 28 23:31:27 2005 @@ -144,7 +144,7 @@ (make-unit :div 2 #|(if (rule-comp rule) 3 2)|# :tup nil :alt t :art t :irr (not ex) #|(or (rule-comp rule) (not ex))|# :comp (rule-comp rule))))))) (nconc (etypecase rule (initdiv (loop - for ee of-type cons in (force-list2 (rule-list rule)) + for ee of-type cons in (force-list2all (rule-list rule)) #+debug unless #+debug (= (apply #'+ ee) num) #+debug do #+debug (error "Error in SPLIT-RULES-BYLEVEL") collect (loop
Index: fomus/test.lisp diff -u fomus/test.lisp:1.6 fomus/test.lisp:1.7 --- fomus/test.lisp:1.6 Sun Aug 28 06:32:47 2005 +++ fomus/test.lisp Sun Aug 28 23:31:27 2005 @@ -128,6 +128,39 @@ :instr :tuba :events nil)))
+(fomus + :backend '((:data) (:lilypond :view t)) + :ensemble-type :orchestra + :parts (list + (make-part + :name "Piano 1" + :instr :piano + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Piano 2" + :instr :piano + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Flute 1" + :instr :flute + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Flute 2" + :instr :flute + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Clarinet 1" + :instr :bf-clarinet + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Clarinet 2" + :instr :bf-clarinet + :events (list (make-note :off 0 :dur 1 :note 60))) + (make-part + :name "Tuba" + :instr :tuba + :events (list (make-note :off 0 :dur 1 :note 36))))) + ;; Mark objects
(fomus
Index: fomus/util.lisp diff -u fomus/util.lisp:1.11 fomus/util.lisp:1.12 --- fomus/util.lisp:1.11 Sat Aug 27 20:13:21 2005 +++ fomus/util.lisp Sun Aug 28 23:31:27 2005 @@ -204,7 +204,7 @@
(defun timesig-div* (ts) (declare (type timesig-repl ts)) - (or (force-list2 (timesig-div ts)) + (or (force-list2all (timesig-div ts)) (when *use-default-meas-divs* (let ((nb (timesig-nbeats ts))) (or (lookup nb *default-meas-divs*) @@ -722,7 +722,7 @@ (defmethod make-timesigex* ((ts timesig)) (let ((nt (copy-timesig ts :off (roundto (timesig-off ts) (/ (beat-division ts))) - :div (force-list2 (timesig-div ts)) + :div (force-list2all (timesig-div ts)) :time (cons (first (timesig-time ts)) (second (timesig-time ts))) :repl (let ((x (mapcar #'make-timesigex* (force-list (timesig-repl ts))))) (if (list1p x) (first x) x))))) @@ -730,7 +730,7 @@ nt)) (defmethod make-timesigex* ((ts timesig-repl)) (let ((nt (copy-timesig-repl ts - :div (force-list2 (timesig-div ts)) + :div (force-list2all (timesig-div ts)) :time (cons (first (timesig-time ts)) (second (timesig-time ts)))))) (timesig-check nt) nt))