[fomus-cvs] CVS update: fomus/backend_ly.lisp fomus/backend_xml.lisp fomus/backends.lisp fomus/data.lisp fomus/fomus.asd fomus/main.lisp fomus/misc.lisp fomus/parts.lisp fomus/splitrules.lisp fomus/test.lisp fomus/util.lisp
David Psenicka
dpsenicka at common-lisp.net
Sun Aug 28 21:31:34 UTC 2005
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))
More information about the Fomus-cvs
mailing list