- fomus-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[fomus-cvs] CVS fomus
by dpsenicka 19 Feb '06

19 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv3818 Modified Files: accidentals.lisp backend_cmn.lisp backend_ly.lisp classes.lisp data.lisp load.lisp main.lisp misc.lisp package.lisp test.lisp util.lisp version.lisp voices.lisp Log Message: bugs/lispworks --- /project/fomus/cvsroot/fomus/accidentals.lisp 2006/02/11 22:39:40 1.17 +++ /project/fomus/cvsroot/fomus/accidentals.lisp 2006/02/19 04:20:41 1.18 @@ -119,7 +119,7 @@ ;; depth-first search branching down only top score group (same scores) ;; DESTRUCTIVE (defstruct (nokeynode (:copier nil) (:predicate nokeynodep)) - (sc 0.0 :type #-allegro (float 0) #+allegro float) + (sc 0.0 :type #-(or allegro lispworks) (float 0) #+(or allegro lispworks) float) (ret nil :type list) (re 0 :type (integer 0)) (evs nil :type list) --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/18 22:51:43 1.10 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/19 04:20:41 1.11 @@ -111,22 +111,29 @@ (format t ";; ERROR: Error ~A CMN file~%" str) (return-from view-cmn))) (ignore-errors (delete-file (change-filename filename :ext (or out-ext +cmn-out-ext+)))) - (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir + (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir #+lispworks hcl:change-directory (change-filename filename :name nil :ext nil)) (if (ignore-errors (load filename)) (progn (unless (probe-file (change-filename filename :ext (or out-ext +cmn-out-ext+))) (er "compiling")) (when view - (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program - (or view-exe +cmn-view-exe+) - (append (or view-exe-opts +cmn-view-opts+) - (list (change-filename filename :ext (or out-ext +cmn-out-ext+)))) - :wait nil) - #+allegro (= (run-allegro-cmd - (apply #'vector (cons (or view-exe +cmn-view-exe+) - (cons (or view-exe +cmn-view-exe+) + (unless #+(or cmu sbcl openmcl) (ignore-errors + (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or view-exe +cmn-view-exe+) + (append (or view-exe-opts +cmn-view-opts+) + (list (change-filename filename :ext (or out-ext +cmn-out-ext+)))) + :wait nil)) + #+lispworks (ignore-errors + (system:call-system (format nil "~A~{ ~A~}" (or view-exe +cmn-view-exe+) (append (or view-exe-opts +cmn-view-opts+) - (list (change-filename filename :ext (or out-ext +cmn-out-ext+))))))) nil nil) 0) + (list (change-filename filename :ext (or out-ext +cmn-out-ext+)))) + :wait nil))) + #+allegro (eql (run-allegro-cmd + (apply #'vector (cons (or view-exe +cmn-view-exe+) + (cons (or view-exe +cmn-view-exe+) + (append (or view-exe-opts +cmn-view-opts+) + (list (change-filename filename :ext (or out-ext +cmn-out-ext+))))))) nil nil) + 0) (er "viewing")))) (er "compiling"))))) --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/18 22:51:43 1.29 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/19 04:20:41 1.30 @@ -16,15 +16,15 @@ (eval-when (:load-toplevel :execute) (defparameter +lilypond-exe+ (or #+darwin (find-exe "lilypond.sh") - #+mswindows (find-exe "lilypond.exe") - #-mswindows (find-exe "lilypond") + #+(or mswindows win32) (find-exe "lilypond.exe") + #-(or mswindows win32) (find-exe "lilypond") #+darwin "lilypond.sh" - #+mswindows "lilypond.exe" - #-mswindows "lilypond")) - (defparameter +lilypond-view-exe+ #-mswindows +ghostview-exe+ #+mswindows +acroread-exe+)) + #+(or mswindows win32) "lilypond.exe" + #-(or mswindows win32) "lilypond")) + (defparameter +lilypond-view-exe+ #-(or mswindows win32) +ghostview-exe+ #+(or mswindows win32) +acroread-exe+)) -(defparameter +lilypond-opts+ #-(or darwin mswindows) '("--ps") #+(or darwin mswindows) '("--pdf")) -(defparameter +lilypond-out-ext+ #-(or darwin mswindows) "ps" #+(or darwin mswindows) "pdf") +(defparameter +lilypond-opts+ #-(or darwin mswindows win32) '("--ps") #+(or darwin mswindows win32) '("--pdf")) +(defparameter +lilypond-out-ext+ #-(or darwin mswindows win32) "ps" #+(or darwin mswindows win32) "pdf") (defparameter +lilypond-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app")) (defun view-lilypond (filename options view) @@ -34,15 +34,21 @@ (format t ";; ERROR: Error ~A lilypond file~%" str) (return-from view-lilypond))) (ignore-errors (delete-file (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir + (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir #+lispworks hcl:change-directory (change-filename filename :name nil :ext nil)) - (if #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program - (or exe +lilypond-exe+) - (append (or exe-opts +lilypond-opts+) (list filename)) - :wait t) - #+allegro (= (run-allegro-cmd (apply #'vector (cons (or exe +lilypond-exe+) - (cons (or exe +lilypond-exe+) - (append (or exe-opts +lilypond-opts+) (list filename)))))) 0) + (if #+(or cmu sbcl openmcl) (ignore-errors + (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)) + :wait t)) + #+lispworks (ignore-errors + (system:call-system (format nil "~A~{ ~A~}" + (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)) + :wait t))) + #+allegro (eql (run-allegro-cmd (apply #'vector (cons (or exe +lilypond-exe+) + (cons (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)))))) 0) (progn (unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling")) (ignore-errors (delete-file (change-filename filename :ext "log"))) @@ -51,16 +57,24 @@ (unless (string= (or out-ext +lilypond-out-ext+) "ps") (ignore-errors (delete-file (change-filename filename :ext "ps")))) (unless (string= (or out-ext +lilypond-out-ext+) "pdf") (ignore-errors (delete-file (change-filename filename :ext "pdf")))) (when view - (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program - (or view-exe +lilypond-view-exe+) - (append (or view-exe-opts +lilypond-view-opts+) - (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - :wait nil) - #+allegro (= (run-allegro-cmd - (apply #'vector (cons (or view-exe +lilypond-view-exe+) - (cons (or view-exe +lilypond-view-exe+) + (unless #+(or cmu sbcl openmcl) (ignore-errors + (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) + :wait nil)) + #+lispworks (ignore-errors + (system:call-system (format nil "~A~{ ~A~}" + (or view-exe +lilypond-view-exe+) (append (or view-exe-opts +lilypond-view-opts+) - (list (change-filename filename :ext (or out-ext +lilypond-out-ext+))))))) nil nil) 0) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) + :wait nil))) + #+allegro (eql (run-allegro-cmd + (apply #'vector (cons (or view-exe +lilypond-view-exe+) + (cons (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+))))))) nil nil) + 0) (er "viewing")))) (er "compiling"))))) @@ -69,12 +83,17 @@ (if (truep *lilypond-version*) (setf *lilypond-version* (destructuring-bind (&key exe &allow-other-keys) options - (let ((os #+(or cmu sbcl openmcl) (make-string-output-stream) - #+allegro (ignore-errors (nth-value 1 (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v")))))) + (let ((os #+(or cmu sbcl openmcl lispworks) (make-string-output-stream) + #+allegro (nth-value 1 (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v"))))) #+(or cmu sbcl openmcl) (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) (list "-v") :wait t :output os)) - (let* ((out #+(or cmu sbcl openmcl) (get-output-stream-string os) #+allegro (read-line os)) + #+lispworks (ignore-errors + (system:call-system (format nil "~A~{ ~A~}" + (or exe +lilypond-exe+) + (list "-v") + :wait t))) + (let* ((out #+(or cmu sbcl openmcl lispworks) (get-output-stream-string os) #+allegro (read-line os)) (p (search "LilyPond " out))) (if p (multiple-value-bind (n1 np) (parse-integer out :start (+ p 9) :junk-allowed t) (+ (* n1 100) (parse-integer out :start (1+ np) :junk-allowed t))) @@ -228,7 +247,7 @@ (list (make-restex :inv t :off (meas-off m) :dur (- (meas-endoff m) (meas-off m)) :marks '(:measrest))))) while e do (let ((fm (getmark e :measrest)) - (trf (and (>= (nth-value 1 (event-writtendur* e ts)) 2) (< (lilypond-version options) 205)))) + (trf (and (>= (nth-value 1 (event-writtendur* e ts)) 2) (< (lilypond-version options) 207)))) (when (getmark e '(:starttext- 2)) (setf twrn t)) (format f "~A " (conc-strings --- /project/fomus/cvsroot/fomus/classes.lisp 2006/02/18 22:51:43 1.17 +++ /project/fomus/cvsroot/fomus/classes.lisp 2006/02/19 04:20:41 1.18 @@ -48,7 +48,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (excl:without-package-locks (defclass rest (dur-base) ()))) -#-(or sbcl allegro) +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((lispworks:*handle-warn-on-redefinition* nil)) + (defclass rest (dur-base) ()))) +#-(or sbcl allegro lispworks) (defclass rest (dur-base) ()) ; only w/ xml in special cases--must not overlap a note-event!!! (defclass part (fomusobj-base) @@ -74,7 +78,10 @@ #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (excl:without-package-locks (defprint rest id partid voice off dur marks))) -#-allegro (defprint rest id partid voice off dur marks) +#+lispworks (eval-when (:compile-toplevel :load-toplevel :execute) + (let ((lispworks:*handle-warn-on-redefinition* nil)) + (defprint rest id partid voice off dur marks))) +#-(or allegro lispworks) (defprint rest id partid voice off dur marks) (defprint part id partid name abbrev instr events opts) (defprint meas id off endoff timesig div events props) @@ -374,6 +381,38 @@ (declare (type meas me) (type timesig-repl timesig) (type (rational 0) off) (type (rational 0) endoff) (type list events props div)) (make-meas :id id :timesig timesig :off off :endoff endoff :events events :props props :div div)) +;; MAKE-INSTR + +(defun make-instrex* (instr part) + (declare (type instr instr)) + (copy-instr instr + :8uplegls (if (consp (instr-8uplegls instr)) (cons (first (instr-8uplegls instr)) (second (instr-8uplegls instr))) (instr-8uplegls instr)) + :8dnlegls (if (consp (instr-8dnlegls instr)) (cons (first (instr-8dnlegls instr)) (second (instr-8dnlegls instr))) (instr-8dnlegls instr)) + :percs (loop for e in (instr-percs instr) collect + (flet ((er (s) (error "Invalid percussion instrument ~S in part ~S" s (part-name part)))) + (flet ((gi (s) + (declare (type (or symbol (integer 0 127)) s)) + (if (symbolp s) + (or (find s *percussion* :key #'perc-sym) + (find s +percussion+ :key #'perc-sym) + (er s)) + (or (find s *percussion* :test (lambda (k i) + (declare (type (integer 0 127) k) (type perc i)) + (find k (force-list (perc-midinote-im i))))) + (find s +percussion+ :test (lambda (k i) + (declare (type (integer 0 127) k) (type perc i)) + (find k (force-list (perc-midinote-im i))))) + (er s))))) + (let ((z (typecase e + (perc (copy-perc e)) + ((or symbol number) (copy-perc (gi e))) + (list (let ((z (apply #'copy-perc (gi (first e)) (rest e)))) + (check-type* z +perc-type+) + z)) + (otherwise (er e))))) + (when (perc-note z) (setf (perc-note z) (note-to-num (perc-note z)))) + z)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INPUT TYPE CHECKS --- /project/fomus/cvsroot/fomus/data.lisp 2006/02/18 22:51:43 1.33 +++ /project/fomus/cvsroot/fomus/data.lisp 2006/02/19 04:20:41 1.34 @@ -12,7 +12,7 @@ ;; GLOBAL FOR BACKENDS #+(or linux darwin unix) (defparameter +tmp-path+ "/tmp/") -#+mswindows (defparameter +tmp-path+ "\\") +#+(or mswindows win32) (defparameter +tmp-path+ "/") (declaim (type boolean *acc-throughout-meas*)) (defparameter *acc-throughout-meas* t) @@ -453,36 +453,6 @@ finally (return (nconc (mapcar #'car (sort i #'> :key #'cdr)) p (list (cons :choirgroup v)) (list (cons :choirgroup c)) k)))))) -(defun make-instrex* (instr part) - (declare (type instr instr)) - (copy-instr instr - :8uplegls (if (consp (instr-8uplegls instr)) (cons (first (instr-8uplegls instr)) (second (instr-8uplegls instr))) (instr-8uplegls instr)) - :8dnlegls (if (consp (instr-8dnlegls instr)) (cons (first (instr-8dnlegls instr)) (second (instr-8dnlegls instr))) (instr-8dnlegls instr)) - :percs (loop for e in (instr-percs instr) collect - (flet ((er (s) (error "Invalid percussion instrument ~S in part ~S" s (part-name part)))) - (flet ((gi (s) - (declare (type (or symbol (integer 0 127)) s)) - (if (symbolp s) - (or (find s *percussion* :key #'perc-sym) - (find s +percussion+ :key #'perc-sym) - (er s)) - (or (find s *percussion* :test (lambda (k i) - (declare (type (integer 0 127) k) (type perc i)) - (find k (force-list (perc-midinote-im i))))) - (find s +percussion+ :test (lambda (k i) - (declare (type (integer 0 127) k) (type perc i)) - (find k (force-list (perc-midinote-im i))))) - (er s))))) - (let ((z (typecase e - (perc (copy-perc e)) - ((or symbol number) (copy-perc (gi e))) - (list (let ((z (apply #'copy-perc (gi (first e)) (rest e)))) - (check-type* z +perc-type+) - z)) - (otherwise (er e))))) - (when (perc-note z) (setf (perc-note z) (note-to-num (perc-note z)))) - z)))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DEFAULT DIVISIONS --- /project/fomus/cvsroot/fomus/load.lisp 2005/11/11 22:03:16 1.8 +++ /project/fomus/cvsroot/fomus/load.lisp 2006/02/19 04:20:41 1.9 @@ -1,16 +1,21 @@ ;; -*-lisp-*- ;; 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_cmn" "backend_ly" - "backend_xml" "backend_mid" "backends" "main" "interface" "final") +(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" + "splitrules" + ("accidentals" "beams" "marks" "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 - for cl = (merge-pathnames na *load-pathname*) - for cn = (compile-file-pathname cl) do - (when (or nw - (not (probe-file cn)) - (>= (file-write-date cl) (file-write-date cn))) - (compile-file cl) - (setf nw t)) - (load cn)) \ No newline at end of file + for cl = (if (listp na) (mapcar (lambda (x) (merge-pathnames x *load-pathname*)) na) (list (merge-pathnames na *load-pathname*))) + for cn = (mapcar (lambda (x) (compile-file-pathname x)) cl) + do (loop with nw0 + for cn0 in cn + and cl0 in cl + when (or nw + (not (probe-file cn0)) + (>= (file-write-date cl0) (file-write-date cn0))) + do (compile-file cl0) (setf nw0 t) + finally (setf nw nw0)) + (map nil (lambda (x) (load x)) cn)) \ No newline at end of file --- /project/fomus/cvsroot/fomus/main.lisp 2006/02/18 22:51:43 1.22 +++ /project/fomus/cvsroot/fomus/main.lisp 2006/02/19 04:20:41 1.23 @@ -202,7 +202,8 @@ #+cmu (ext:default-directory) #+sbcl (sb-unix:posix-getcwd) #+openmcl (ccl:mac-default-directory) - #+allegro (excl:current-directory))) + #+allegro (excl:current-directory) + #+lispworks (hcl:get-working-directory))) r (rest xx) (or process view) play view))))) t) --- /project/fomus/cvsroot/fomus/misc.lisp 2006/02/03 07:17:18 1.17 +++ /project/fomus/cvsroot/fomus/misc.lisp 2006/02/19 04:20:41 1.18 @@ -14,7 +14,11 @@ (declaim (inline change-filename)) (defun change-filename (filename &key (dir (pathname-directory filename)) (name (pathname-name filename)) (ext (pathname-type filename))) (declare (type (or pathname string null) filename name ext) (type (or pathname string list) dir)) - (namestring (make-pathname :device (pathname-device filename) :directory dir :name name :type ext))) + (namestring (make-pathname :device (pathname-device filename) :directory #-(and (or mswindows win32) lispworks) + dir #+(and (or mswindows win32) lispworks) (if (or (stringp dir) (pathnamep dir)) + (pathname-directory dir) + dir) + :name name :type ext))) (declaim (inline conc-strings conc-stringlist)) (defun conc-strings (&rest strings) @@ -72,13 +76,14 @@ #+allegro (defun run-allegro-cmd (cmd &optional (wait t) (hide t)) - (multiple-value-bind (ostr istr p) (excl:run-shell-command - #-mswindows cmd - #+mswindows (if (typep cmd 'string) cmd - (conc-stringlist (loop for e across cmd and i = nil then t when i collect e and collect " "))) - :input :stream :output :stream :error-output :stream :wait nil :show-window (if hide :hide :normal)) - (declare (ignore istr)) - (values (if wait (sys:os-wait nil p) 0) ostr))) + (ignore-errors + (multiple-value-bind (ostr istr p) (excl:run-shell-command + #-(or mswindows win32) cmd + #+(or mswindows win32) (if (typep cmd 'string) cmd + (conc-stringlist (loop for e across cmd and i = nil then t when i collect e and collect " "))) + :input :stream :output :stream :error-output :stream :wait nil :show-window (if hide :hide :normal)) + (declare (ignore istr)) + (values (if wait (sys:os-wait nil p) 0) ostr)))) (defun find-exe (filename) (namestring* @@ -87,13 +92,13 @@ #+darwin (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Applications/*/*" #+openmcl :directories #+openmcl t))) #+darwin (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Applications/*/*/*" #+openmcl :directories #+openmcl t))) #+darwin (probe-file (change-filename filename :dir "/sw/bin")) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*" #+openmcl :directories #+openmcl t))) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*" #+openmcl :directories #+openmcl t))) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*\\*" #+openmcl :directories #+openmcl t))) - #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\usr\\local\\bin")) - #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\usr\\bin")) - #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\bin")) - #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\usr\\X11R6\\bin")) + #+(or mswindows win32) (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Program Files/*" #+openmcl :directories #+openmcl t))) + #+(or mswindows win32) (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Program Files/*/*" #+openmcl :directories #+openmcl t))) + #+(or mswindows win32) (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Program Files/*/*/*" #+openmcl :directories #+openmcl t))) + #+(or mswindows win32) (probe-file (change-filename filename :dir "/cygwin/usr/local/bin")) + #+(or mswindows win32) (probe-file (change-filename filename :dir "/cygwin/usr/bin")) + #+(or mswindows win32) (probe-file (change-filename filename :dir "/cygwin/bin")) + #+(or mswindows win32) (probe-file (change-filename filename :dir "/cygwin/usr/X11R6/bin")) #+(or linux darwin unix) (probe-file (change-filename filename :dir "/usr/local/bin")) #+(or linux darwin unix) (probe-file (change-filename filename :dir "/usr/bin")) #+(or linux darwin unix) (probe-file (change-filename filename :dir "/bin")) --- /project/fomus/cvsroot/fomus/package.lisp 2005/11/30 23:51:37 1.13 +++ /project/fomus/cvsroot/fomus/package.lisp 2006/02/19 04:20:41 1.14 @@ -46,6 +46,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; GLOBAL +;; :ALLEGRO-V7.0 +;; :LISPWORKS4 + (defmacro compile-settings () '(eval-when (:compile-toplevel) #+debug (declaim (optimize (safety 3) (debug 3))) --- /project/fomus/cvsroot/fomus/test.lisp 2006/02/18 22:51:43 1.25 +++ /project/fomus/cvsroot/fomus/test.lisp 2006/02/19 04:20:41 1.26 @@ -267,7 +267,7 @@ collect (make-note :off off :dur dur :note (+ 60 (random 25))))))) (fomus - :backend '((:data) :musicxml (:lilypond :view t) #|(:cmn :view t)|# #|(:midi :tempo 60 :delay 1)|#) + :backend '((:data) (:lilypond :view t) #|(:cmn :view t)|# #|(:midi :tempo 60 :delay 1)|#) :ensemble-type :orchestra :parts (list --- /project/fomus/cvsroot/fomus/util.lisp 2006/02/18 22:51:43 1.23 +++ /project/fomus/cvsroot/fomus/util.lisp 2006/02/19 04:20:41 1.24 @@ -36,11 +36,11 @@ (defparameter +ghostview-exe+ #+darwin (find-exe "open") #+(and (or linux unix) (not darwin)) (or (find-exe "ggv") (find-exe "kgv") (find-exe "gv") (find-exe "ghostview") "gv") - #+mswindows (or (find-exe "gsview32.exe") (find-exe "gv.exe") "gsview.exe")) + #+(or mswindows win32) (or (find-exe "gsview32.exe") (find-exe "gv.exe") "gsview.exe")) (defparameter +acroread-exe+ #+darwin (find-exe "open") #+(and (or linux unix) (not darwin)) (or (find-exe "acroread") (find-exe "gpdf") "acroread") - #+mswindows (or (find-exe "AcroRd32.exe") "AcroRd32.exe"))) + #+(or mswindows win32) (or (find-exe "AcroRd32.exe") "AcroRd32.exe"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PROGRESS DOTS, IMMEDIATE OUTPUT --- /project/fomus/cvsroot/fomus/version.lisp 2006/02/18 22:51:43 1.33 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/19 04:20:41 1.34 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 38)) +(defparameter +version+ '(0 1 39)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved" --- /project/fomus/cvsroot/fomus/voices.lisp 2006/01/19 00:02:35 1.11 +++ /project/fomus/cvsroot/fomus/voices.lisp 2006/02/19 04:20:41 1.12 @@ -90,7 +90,7 @@ (defparameter *voice-engine-heap* 50) (defstruct (voicenode (:copier nil) (:predicate voicenodep)) - (sc 0.0 :type #-allegro (float 0) #+allegro float) + (sc 0.0 :type #-(or allegro lispworks) (float 0) #+(or allegro lispworks) float) (ret nil :type list) (evs nil :type list) (evc nil :type list)

1 0

[fomus-cvs] CVS fomus
by dpsenicka 16 Feb '06

16 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv20946 Modified Files: fomus.asd Log Message: asdf fix --- /project/fomus/cvsroot/fomus/fomus.asd 2005/11/11 22:03:16 1.17 +++ /project/fomus/cvsroot/fomus/fomus.asd 2006/02/16 07:16:06 1.18 @@ -17,7 +17,7 @@ (:file "classes" :depends-on ("data")) (:file "util" :depends-on ("classes")) - (:file "splitrules" :depends-on ("misc")) + (:file "splitrules" :depends-on ("data")) (:file "accidentals" :depends-on ("util")) (:file "beams" :depends-on ("util"))

1 0

[fomus-cvs] CVS fomus
by dpsenicka 13 Feb '06

13 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv27315 Modified Files: backend_cmn.lisp split.lisp splitrules.lisp version.lisp Log Message: irreg. measure split bug --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/11 22:39:40 1.8 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/13 19:51:27 1.9 @@ -5,11 +5,6 @@ ;; backend_cmn.lisp ;;************************************************************************************************** -; Unused lexical variable HA, in SAVE-CMN. -; Unused lexical variable HS, in SAVE-CMN. -; Unused lexical variable XXX (6 references), in SAVE-CMN. -; Unused lexical variable TU, in SAVE-CMN. - (in-package :fomus) (compile-settings) @@ -203,7 +198,7 @@ for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m)) and l = (and (notep e) (> (event-beamlt e) 0)) and r = (and (notep e) (> (event-beamrt e) 0)) - and tu = (getmark e :starttup) + ;;and tu = (getmark e :starttup) do (setf st (or (third (getmark e '(:staff :voice))) st)) when (and r (not l)) do (when ee (setf (car ee) '-beam ee nil)) ;;(event-off e) @@ -228,8 +223,8 @@ and w in (event-writtennotes e) and a in (event-accs e) and a2 in (event-addaccs e) - for ha = (getmark e (list :harmonic :touched n)) - and hs = (getmark e (list :harmonic :sounding n)) + ;;for ha = (getmark e (list :harmonic :touched n)) + ;;and hs = (getmark e (list :harmonic :sounding n)) collect (cmnnote w a a2 nil (getmark e (list :hideacc n)) (getmark e (list :showacc n)) --- /project/fomus/cvsroot/fomus/split.lisp 2005/09/21 16:54:31 1.17 +++ /project/fomus/cvsroot/fomus/split.lisp 2006/02/13 19:51:28 1.18 @@ -353,7 +353,7 @@ (let ((x (sort (copy-list li) (complement #'sort-offdur)))) (setf li (ex (second x) (first x) x)))))) li)) - (let ((lm (/ (* (beat-division timesig) 8 #|65536|#)))) + (let ((lm (/ (* (beat-division timesig) 8)))) (flet ((scorefun (nd) ; score relative to ea. level (declare (type splitnode nd)) (let ((sis (if (unitp (splitnode-rl nd)) (rule-sis (splitnode-rl nd)) 0))) @@ -473,12 +473,7 @@ (loop with g = (delete-duplicates (mapcar #'event-off gr)) for e of-type (or noteex restex) in li when (restp e) do (setf (event-nomerge e) g))) (let ((re (or (itdepfirst*-engine - (make-splitnode :rl #|(if (timesig-div* timesig) - (make-initdiv :time (timesig-time timesig) :comp (timesig-comp timesig) :beat (timesig-beat* timesig) - :list (timesig-div* timesig) :tsoff (timesig-off timesig) :comp (timesig-comp timesig)) - (make-sig :time (timesig-time timesig) :comp (timesig-comp timesig) :beat (timesig-beat* timesig) - :alt t :art t :top t :comp (timesig-comp timesig)))|# - (first-splitrule timesig) + (make-splitnode :rl (first-splitrule timesig) :evs evs :of1 off :of2 endoff) #'scorefun #'expandfun #'assemfun #'solutfun --- /project/fomus/cvsroot/fomus/splitrules.lisp 2005/09/21 16:54:31 1.5 +++ /project/fomus/cvsroot/fomus/splitrules.lisp 2006/02/13 19:51:28 1.6 @@ -109,11 +109,7 @@ (loop for (e1 e2) of-type ((rational 0 1) (or (rational 0 1) null)) on (cons 0 (append x '(1))) while e2 for ii in (if (listp i) i (list i (- tup i))) and tt = (- e2 e1) and a1 = t then a2 for a2 = (or (= e2 1) (and (expof2 e2) (expof2 (- tup e2)))) collect - (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii)) -;; (if (and (<= ii 1) (if (unitp rule) (rule-sim rule) t)) -;; (make-unit-nodiv :tup (cons tt tu) :comp (rule-comp rule) :dmu dmu :tlt t :trt t) -;; (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii))) - ))))))) + (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii))))))))) (sort (etypecase rule ((or initdiv sig) (let* ((num (/ (rule-num rule) (* (rule-den rule) (rule-beat rule)))) ; 3/8 is treated like 1/4, etc. @@ -122,45 +118,47 @@ (declare (type (member t :all :top :sig) sy)) (or (find sy '(t :all :sig)) (and (eq sy :top) (or (initdivp rule) (rule-top rule))))) - (in (n al ar in) ; n = division ratio + (in (n al ar in &optional ir) ; n = division ratio, ir = if rule is irregular & 2/3 duration is expof2 (declare (type (rational (0) (1)) n) (type boolean al ar) (type list in)) (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) :alt al :art ar :init in :irr (not ex) :comp (rule-comp rule)) - (make-unit :div (if (rule-comp rule) 3 2) :tup nil :alt t :art t :init in :irr (not ex) :comp (rule-comp rule)))) + (make-unit :div (if (or (rule-comp rule) ir) 3 2) ;; (if (rule-comp rule) 3 2) + :tup nil :alt t :art t :init in :irr (not ex) :comp (rule-comp rule)))) (snd (n tl tr) (declare (type (rational (0) (1)) n) (type boolean tl tr)) (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# (make-sig-nodiv :comp (rule-comp rule) :tlt tl :trt tr :comp (rule-comp rule)) (make-unit-nodiv :tup nil :tlt tl :trt tr :comp (rule-comp rule))))) - (flet ((si (n wh al ar) ; n = division ratio, >1/4 or >3/8 comp. is designated with :sig, smaller durations become units + (flet ((si (n wh al ar &optional ir) ; n = division ratio, >1/4 or >3/8 comp. is designated with :sig, smaller durations become units (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar)) (etypecase rule - (initdiv (in n al ar nil)) + (initdiv (in n al ar nil ir)) (sig (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) :alt (if (eq wh :l) (and (rule-alt rule) al) (and (rule-alt rule) (rule-art rule) al)) :art (if (eq wh :r) (and (rule-art rule) ar) (and (rule-alt rule) (rule-art rule) ar)) :irr (not ex) :comp (rule-comp rule)) - (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))))))) + (make-unit :div (if ir 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-list2all (rule-list rule)) - #+debug unless #+debug (= (apply #'+ ee) num) + for ee0 of-type cons in (force-list2all (rule-list rule)) + #+debug unless #+debug (= (apply #'+ ee0) num) #+debug do #+debug (error "Error in SPLIT-RULES-BYLEVEL") collect (loop - for (e en) of-type ((rational (0)) (or (rational (0)) null)) on ee + for (e en) of-type ((rational (0)) (or (rational (0)) null)) on ee0 sum e into s collect (/ e num) into ee ; split durs when en collect (/ s num) into ll ; split points finally (return (cons (if (list>1p ll) ll (car ll)) (loop for (i n) of-type ((rational (0)) (or (rational (0)) null)) on ee + and ii of-type (rational (0)) in ee0 and x of-type (rational (0) 1) in (append ll '(1)) and la = t then aa for aa = (let ((xx (* x num))) (and (expof2 xx) (or (= num xx) (expof2 (- num xx))))) - collect (in i la (or (null n) aa) ee))))))) + collect (in i la (or (null n) aa) ee (expof2 (* ii 2/3))))))))) ;; 2/13/06 (sig (loop for nn of-type (integer 2) in (or (lowmult (numerator num)) (if (rule-comp rule) '(3) '(2))) nconc (loop @@ -171,7 +169,9 @@ (expof2 xx) (expof2 (- num xx))) collect (let ((aa (or (and co (expof2 (* xx 3/2)) (expof2 (* (- num xx) 3/2))) (and (expof2 xx) (expof2 (- num xx)))))) - (list x (si x :l t aa) (si (- 1 x) :r aa t))))))) + (list x + (si x :l t aa (and (rule-irr rule) (expof2 (* xx 2/3)))) ;; 2/13/06 + (si (- 1 x) :r aa t (and (rule-irr rule) (expof2 (* x 2/3)))))))))) ;; 2/13/06 (when (and (al *dotted-note-level*) (or (initdivp rule) (rule-alt rule)) ex (not (rule-comp rule))) (nconc (list (list 3/4 (snd 3/4 t nil) (si 1/4 :r t t))) ; dotted notes (when *double-dotted-notes* @@ -212,7 +212,7 @@ (declare (type (rational (0) (1)) n)) (when (rule-tup rule) (cons (* (the (rational (0)) (first (rule-tup rule))) n) (rest (rule-tup rule)))))) - (flet ((un (n wh al ar &optional d) + (flet ((un (n wh al ar &optional d) ; d is fraction of total number of divs (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar) (type (or (integer 1) null) d)) (if (and (rule-sim rule) (<= (* (rule-sim rule) n) 1)) (make-unit-nodiv :tup (tu n) :dmu (rule-dmu rule) :tlt t :trt t :comp (rule-comp rule) :rst t) --- /project/fomus/cvsroot/fomus/version.lisp 2006/02/11 22:39:40 1.31 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/13 19:51:28 1.32 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 36)) +(defparameter +version+ '(0 1 37)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS fomus
by dpsenicka 11 Feb '06

11 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv2217 Modified Files: accidentals.lisp backend_cmn.lisp classes.lisp data.lisp main.lisp marks.lisp other.lisp test.lisp util.lisp version.lisp Log Message: bugs/cmn --- /project/fomus/cvsroot/fomus/accidentals.lisp 2006/01/31 08:19:57 1.16 +++ /project/fomus/cvsroot/fomus/accidentals.lisp 2006/02/11 22:39:40 1.17 @@ -21,45 +21,6 @@ (defparameter *auto-cautionary-accs* nil) ;; NOKEY! - -(declaim (type (vector boolean) +nokey-quality+)) -(defparameter +nokey-quality+ (vector nil t t nil nil t t)) - -;; return a white note or nil if not possible -(defun nokey-spell (note acc) ; acc = -2/-1/0/1/2 - (declare (type rational note) (type (integer -2 2) acc)) - (multiple-value-bind (o n) (floor (- note acc) 12) - (let ((x (svref +note-to-white+ n))) - (when x (values x o))))) -(defun nokeyq-spell (note acc) ; acc = -2/-1/0/1/2 - (declare (type rational note) (type (cons (integer -2 2) (rational -1/2 1/2)) acc)) - (multiple-value-bind (o n) (floor (- note (car acc) (cdr acc)) 12) - (let ((x (when (integerp n) (svref +note-to-white+ n)))) - (when x (values x o))))) - -;; return values: int-value (0 - 6), int-quality (0 = perfect, -1/1 = min./maj., -2/2... = dim./aug., nil = ???) -(defun nokey-int (note1 acc1 note2 acc2) - (declare (type rational note1 note2) (type (integer -2 2) acc1 acc2)) - (multiple-value-bind (s1 o1) (nokey-spell note1 acc1) - (multiple-value-bind (s2 o2) (nokey-spell note2 acc2) - (multiple-value-bind (sp1 sp2 n1 n2) - (let ((p1 (+ s1 (* o1 7))) - (p2 (+ s2 (* o2 7)))) - (if (= p1 p2) - (if (< note1 note2) - (values p1 p2 note1 note2) - (values p2 p1 note2 note1)) - (if (< p1 p2) - (values p1 p2 note1 note2) - (values p2 p1 note2 note1)))) - (let ((b (mod (- sp2 sp1) 7))) - (values b - (let ((x (- (- n2 n1) (svref +white-to-note+ b) (* (floor (- sp2 sp1) 7) 12)))) - (if (svref +nokey-quality+ b) - (if (>= x 0) (1+ x) x) ; maj./min. - (cond ((> x 0) (1+ x)) ; aud./dim. - ((< x 0) (1- x)) - (t 0)))))))))) ;; (declaim (inline nokeyq-int)) ;; (defun nokeyq-int (note1 acc1 accq1 note2 acc2 accq2) ;; (nokeyint (- note1 accq1) acc1 (- note2 accq2) acc2)) @@ -103,12 +64,12 @@ (defun nokey-notepen (n a) (declare (type rational n) (type (or (integer -2 2) (integer -2 2)) a)) (* (loop - for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (nokey-spell n a))) + for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (notespelling n a))) minimize (diff a e)) *acc-spelling-penalty*)) (defun nokeyq-notepen (n a) (declare (type rational n) (type (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) a)) (* (loop - for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (nokeyq-spell n a))) + for e of-type (integer -1 1) in (cons 0 (svref +nokey-penalty+ (qnotespelling n a))) minimize (diff (car a) e)) *acc-spelling-penalty*)) ;; scores of 1 are perfect @@ -124,7 +85,7 @@ (values note1 acc1 off1 eoff1 note2 acc2 off2 eoff2) (values note2 acc2 off2 eoff2 note1 acc1 off1 eoff1))) (declare (ignorable o1 eo1 o2 eo2)) - (multiple-value-bind (i q) (nokey-int n1 a1 n2 a2) + (multiple-value-bind (i q) (interval n1 a1 n2 a2) (let ((v (- (cond ((and tie (/= i (svref +nokey-harmints+ (mod (diff n1 n2) 12))) #|(or (and (< acc1 0) (> acc2 0)) (and (> acc1 0) (< acc2 0)))|#) 0.0) ((find q (svref +nokey-niceints1+ i)) *acc-diatonic-int-score*) ((and (= i 0) ; unisons special case @@ -148,7 +109,7 @@ (min (max (if (or (and (> a1 0) (< a2 0)) (and (< a1 0) (> a2 0))) (if tie 0.0 (let ((m (if (and (/= qa1 0) (/= qa2 0)) *acc-similar-qtone-score* (/ *acc-similar-qtone-score* 2.0)))) - (if (= (nokeyq-spell note1 acc1) (nokeyq-spell note2 acc2)) (+ s m) (- s m)))) ; penalize different accs on different written notes + (if (= (qnotespelling note1 acc1) (qnotespelling note2 acc2)) (+ s m) (- s m)))) ; penalize different accs on different written notes s) 0.0) 1.0)))))) @@ -275,16 +236,6 @@ (declaim (type boolean *use-double-accs*)) (defparameter *use-double-accs* nil) -(declaim (type cons +acc-single+ +acc-double+ +acc-qtones-single+ +acc-qtones-double+)) -(defparameter +acc-single+ '(-1 0 1)) -(defparameter +acc-double+ '(-2 -1 0 1 2)) -(defparameter +acc-qtones-single+ '(-1 0 1 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2))) -(defparameter +acc-qtones-double+ '(-2 -1 0 1 2 (-1 . -1/2) (0 . -1/2) #|(1 . -1/2) (-1 . 1/2)|# (0 . 1/2) (1 . 1/2))) - -(defun nokey-convert-qtone (x) - (declare (type (or (cons (integer -2 2) (rational -1/2 1/2)) (integer -2 2)) x)) - (if (consp x) x (cons x 0))) - ;; Processed before chords exist and before voices are separated ;; events in parts are sorted--function must return them sorted (defun accidentals (keysigs parts) @@ -298,9 +249,9 @@ (case (auto-accs-fun) (:nokey1 (if *quartertones* (acc-nokey evs (if *use-double-accs* +acc-qtones-double+ +acc-qtones-single+) - #'nokeyq-spell #'nokeyq-notepen #'nokeyq-intscore (part-name e) #'nokey-convert-qtone) + #'qnotespelling #'nokeyq-notepen #'nokeyq-intscore (part-name e) #'convert-qtone) (acc-nokey evs (if *use-double-accs* +acc-double+ +acc-single+) - #'nokey-spell #'nokey-notepen #'nokey-intscore (part-name e) #'identity))) + #'notespelling #'nokey-notepen #'nokey-intscore (part-name e) #'identity))) (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*)))) #'sort-offdur))))) @@ -312,26 +263,25 @@ ,@forms)) (defun accidentals-generic (parts) - (loop for p of-type partex in parts - unless (is-percussion p) - do (loop with cho = (if *quartertones* - (mapcar #'nokey-convert-qtone +acc-qtones-double+) - +acc-double+) - for e of-type (or noteex restex) in (part-events p) - for n = (event-note* e) ;;and a of-type (integer -2 2) = (event-acc e) and q of-type (rational -1/2 1/2) = (event-addacc e) - for ua = (let ((u (event-useracc e))) - (if (list1p u) (if (consp (first u)) (first u) (cons (first u) 0)) - (if u (error "Only one accidental allowed when :AUTO-ACCIDENTALS is NIL in note at offset ~S, part ~S" (event-foff e) (part-name p)) - (cons 0 0)))) - unless (and (if *quartertones* - (find ua cho :test #'equal) - (find (car ua) cho)) - (nokeyq-spell n ua)) - do (error "Invalid note spelling ~S at offset ~S, part ~S" (cond ((/= (cdr ua) 0) (list n (car ua) (cdr ua))) - ((/= (car ua) 0) (list n (car ua))) - (t (list n))) - (event-foff e) (part-name p)) - do (setf (event-note e) (cons n ua))))) + (flet ((so (d) + (lambda (x y) + (let ((ax (if (consp x) (car x) x)) + (ay (if (consp y) (car y) y))) + (if (= (abs ax) (abs ay)) + (funcall d ax ay) + (< (abs ax) (abs ay))))))) + (loop with cho = (if *quartertones* + (mapcar #'convert-qtone +acc-qtones-double+) + +acc-double+) + with chof = (stable-sort (copy-list cho) (so #'<)) + and chos = (stable-sort (copy-list cho) (so #'>)) + for p of-type partex in parts + unless (is-percussion p) + do (loop for e of-type (or noteex restex) in (part-events p) + do (let ((n (event-note* e))) + (setf (event-note e) + (cons n (find-if (lambda (a) (if (consp a) (qnotespelling n a) (notespelling n a))) + (append (event-useracc e) (let ((m (mod n 12))) (if (and (>= m 9/2) (<= m 7)) chos chof))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CAUTIONARY ACCIDENTALS --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/05 04:57:33 1.7 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/11 22:39:40 1.8 @@ -5,6 +5,11 @@ ;; backend_cmn.lisp ;;************************************************************************************************** +; Unused lexical variable HA, in SAVE-CMN. +; Unused lexical variable HS, in SAVE-CMN. +; Unused lexical variable XXX (6 references), in SAVE-CMN. +; Unused lexical variable TU, in SAVE-CMN. + (in-package :fomus) (compile-settings) @@ -55,8 +60,9 @@ (:percussion . percussion))) (defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style) - (automatic-beams nil) (automatic-octave-signs nil))) -(defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24))) + (automatic-beams nil) (automatic-octave-signs nil) (automatic-ties nil) (automatic-bars nil) + (automatic-beat-subdivision-numbers nil))) +(defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24) (text-connecting-pattern '(5 10)))) ;; left out: (:leftheel . ...) (:rightheel . ...) (:lefttoe . ...) (:righttoe . ...)| (defparameter +cmn-marks+ @@ -67,9 +73,21 @@ ;; (:arpeggio . ...) (:pizz . ...) (:arco . ...) ;; ((:glissando :after) . ...) ((:portamento :after) . ...) <-- begin/end marks, use setf gliss- and -gliss +(defparameter +cmn-dynamics+ + '((:pppppp . (dynamic "pppppp")) (:ppppp . (dynamic "ppppp")) (:pppp . pppp) (:ppp . ppp) (:pp . pp) (:p . p) (:mp . mp) + (:ffffff . (dynamic "ffffff")) (:fffff . (dynamic "fffff")) (:ffff . ffff) (:fff . fff) (:ff . ff) (:f . f) (:mf . mf) + (:sff . sff) (:spp . spp) (:sf . sf) (:sp . sp) (:fp . fp) (:rfz . rfz) (:sfz . sfz))) + (defparameter +cmn-trmarks+ '((:prall . inverted-mordent) (:trill . trill) (:mordent . mordent) (:startlongtrill- . trill))) +(defparameter +cmn-textstyle+ '((font-name "Times-Italic"))) +(defparameter +cmn-textnotestyle+ '((font-name "Times-Italic"))) +(defparameter +cmn-texttempostyle+ '((font-name "Times-Bold") (font-scaler 2))) + +(defparameter +cmn-up+ '(y (lambda (ma no sc &optional ju) (declare (ignore ma sc ju)) (- (staff-y0 no) 1)))) +(defparameter +cmn-down+ '(y (lambda (ma no sc &optional ju) (declare (ignore ma sc ju)) (+ (staff-y0 no) 1)))) + (defun internalize (x) (typecase x (keyword x) @@ -137,7 +155,7 @@ collect (string x)))) "-" (string (code-char (+ 64 de))))))) - (let* ((bv -1) (gv -1) (pv -1) (sv -1) + (let* ((bv -1) (gv -1) (pv -1) (sv -1) (ouv -1) (odv -1) (w<v -1) (w>v -1) (tv -1) (rv -1) (cmp (loop for p in parts nconc (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) @@ -145,6 +163,12 @@ and ggg = (make-hash-table :test 'eq) and ppp = (make-hash-table :test 'eq) and sss = (make-hash-table :test 'eq) + and ouuu = (make-hash-table :test 'eq) + and oddd = (make-hash-table :test 'eq) + and w<<< = (make-hash-table :test 'eq) + and w>>> = (make-hash-table :test 'eq) + and ttt = (make-hash-table :test 'eq) + and rrr = (make-hash-table :test 'eq) for vi from 0 below nvce nconc ; loop through voices (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) and ns = (instr-staves (part-instr p)) ; number of staves @@ -166,7 +190,8 @@ (format nil "~A1~D" pna si) (format nil "~A1" pna)))))) ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) - ,@(loop with o = 0 and st = 1 and gg and pg and sg and wvy + ,@(loop with o = 0 and st = 1 and gg and pg and sg = (make-hash-table) and wvy and oug and odg + and w>g = (make-hash-table) and w<g = (make-hash-table) and tg = (make-hash-table) and rg for m in (part-meas p) and stoff = 0 then (+ stoff lmdur) for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) @@ -185,7 +210,12 @@ (setf bb e) when (getmark e '(:glissando :after)) do (setf gg e) when (getmark e '(:portamento :after)) do (setf pg e) - when (and wvy (getmark e :endlongtrill-)) do (setf (second wvy) co) + when (getmark e :start8up) do (setf oug e) + when (getmark e :start8down) do (setf odg e) + when (and wvy (getmark e :endlongtrill-)) do (setf (second wvy) co) + do (loop for (xxx lvl) in (getmarks e :startslur-) do (setf (gethash lvl sg) e)) + do (loop for (xxx lvl) in (getmarks e :startwedge<) do (setf (gethash lvl w<g) e)) + do (loop for (xxx lvl) in (getmarks e :startwedge>) do (setf (gethash lvl w>g) e)) when (= st si) collect (let ((cd (cmndur (event-dur* e) m))) (nconc (if (restp e) @@ -257,23 +287,64 @@ ,@(when (eq (car i) :startlongtrill-) (list '(wavy-line t) (setf wvy (list 'wavy-time nil)))))) - ;; ottavas + (when (or (getmark e :start8up) (getmark e :end8up)) + (let ((h (gethash oug ouuu))) + (list (if h + `(begin-octave-up (svref ouvect ,h)) + `(setf (svref ouvect ,(setf (gethash oug ouuu) (incf ouv))) (end-octave-up)))))) + (when (or (getmark e :start8down) (getmark e :end8down)) + (let ((h (gethash odg oddd))) + (list (if h + `(begin-octave-down (svref odvect ,h)) + `(setf (svref odvect ,(setf (gethash odg oddd) (incf odv))) (begin-octave-down)))))) (let ((x (getmark e :tremolo))) (when x (list `(tremolo (tremolo-slashes ,(- (roundint (log (third x) 1/2)) 2)))))) - ;;; start/end tremolos + (let ((x (or (getmark e :endtremolo) (getmark e :starttremolo)))) + (when x (let* ((tb (- (roundint (log (third x) 1/2)) 2)) + (bm (max (min (- (roundint (log (event-writtendur* e (meas-timesig m)) 1/2)) 2) tb) 0))) + (list (let ((h (gethash rg rrr))) + (list (if h + `(begin-tremolo (svref rvect ,h) (tremolo-slashes ,(- tb bm)) (tremolo-beams ,bm)) + `(setf (svref rvect ,(setf (gethash rg rrr) (incf rv))) + (end-tremolo (tremolo-slashes ,(- tb bm)) (tremolo-beams ,bm)))))))))) (cond ((getmark e '(:arpeggio :up)) (list '(arpeggio arrow-up))) ((getmark e '(:arpeggio :down)) (list '(arpeggio arrow-down))) ((getmark e :arpeggio) (list 'arpeggio))) - ;;; dynamics - ;;; wedges - ;;; text - ;;; slur svect + (loop for i in + (loop for a in +cmn-dynamics+ nconc (mapcar #'force-list (getmarks e (car a)))) + collect (lookup (first i) +cmn-dynamics+)) + (loop + for (xxx lvl) in (nconc (getmarks e :startwedge>) (getmarks e :endwedge>)) + collect (let ((h (gethash (gethash lvl w>g) w>>>))) + (list (if h + `(-diminuendo (svref wvect> ,h)) + `(setf (svref wvect> ,(setf (gethash (gethash lvl w>g) w>>>) (incf w>v))) (diminuendo-)))))) + (loop + for (xxx lvl) in (nconc (getmarks e :startwedge<) (getmarks e :endwedge<)) + collect (let ((h (gethash (gethash lvl w<g) w<<<))) + (list (if h + `(-crescendo (svref wvect< ,h)) + `(setf (svref wvect< ,(setf (gethash (gethash lvl w<g) w<<<) (incf w<v))) (crescendo-)))))) + (loop for x in (nconc (getmarks e :text) (getmarks e :textdyn) (getmarks e :textnote) (getmarks e :texttempo)) collect + (if (eq (first x) :textdyn) + `(dynamic ,(third x)) + `(text ,(third x) + ,@(case (first x) (:text +cmn-textstyle+) (:textnote +cmn-textnotestyle+) (:texttempo +cmn-texttempostyle+)) + ,(ecase (second x) (:up +cmn-up+) (:down +cmn-down+))))) + (loop for (m lvl dir txt) in (nconc (getmarks e :starttext-) (getmarks e :endtext-)) collect + (let ((h (gethash (gethash lvl tg) ttt))) + (list (if h + `(-text (svref tvect ,h) ,(when (eq m :starttext-) (list txt)) + ,(ecase dir (:up +cmn-up+) (:down +cmn-down+))) + `(setf (svref tvect ,(setf (gethash (gethash lvl tg) ttt) (incf tv))) + (text- ,(when (eq m :starttext-) (list txt)) + ,(ecase dir (:up +cmn-up+) (:down +cmn-down+)))))))) (loop - for xxx in (nconc (getmarks e :startslur-) (getmarks e :endslur-)) - collect (let ((h (gethash sg sss))) + for (xxx lvl) in (nconc (getmarks e :startslur-) (getmarks e :endslur-)) + collect (let ((h (gethash (gethash lvl sg) sss))) (list (if h `(-slur (svref svect ,h)) - `(setf (svref svect ,(setf (gethash sg sss) (incf sv))) (slur-)))))) + `(setf (svref svect ,(setf (gethash (gethash lvl sg) sss) (incf sv))) (slur-)))))) (when (getmark e :glissando) (let ((h (gethash gg ggg))) (list (if h @@ -299,10 +370,16 @@ (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) :key (lambda (x) (if (consp x) (first x) x)) :from-end t) (let* ,(nconc - (if (> bv 0) (list `(bvect (make-array ,(1+ bv))))) - (if (> gv 0) (list `(gvect (make-array ,(1+ gv))))) - (if (> pv 0) (list `(pvect (make-array ,(1+ pv))))) - (if (> sv 0) (list `(svect (make-array ,(1+ sv))))) + (if (>= bv 0) (list `(bvect (make-array ,(1+ bv))))) + (if (>= gv 0) (list `(gvect (make-array ,(1+ gv))))) + (if (>= pv 0) (list `(pvect (make-array ,(1+ pv))))) + (if (>= sv 0) (list `(svect (make-array ,(1+ sv))))) + (if (>= ouv 0) (list `(ouvect (make-array ,(1+ ouv))))) + (if (>= odv 0) (list `(odvect (make-array ,(1+ odv))))) + (if (>= tv 0) (list `(tvect (make-array ,(1+ tv))))) + (if (>= rv 0) (list `(rvect (make-array ,(1+ rv))))) + (if (>= w<v 0) (list `(wvect< (make-array ,(1+ w<v))))) + (if (>= w>v 0) (list `(wvect> (make-array ,(1+ w>v))))) cmp) ,@(labels ((pfn (pps &optional (grp 1)) (loop for e = (pop pps) ; e = part --- /project/fomus/cvsroot/fomus/classes.lisp 2006/01/19 00:02:35 1.15 +++ /project/fomus/cvsroot/fomus/classes.lisp 2006/02/11 22:39:40 1.16 @@ -427,7 +427,7 @@ (type* +dur-base-type+) (class* note (note (check* (type* +notesym-type+) - "Found ~S, expected REALS or valid note/accidental symbols in the form X, (X X ...) or (X (X X) ...) in NOTE slot" t)) + "Found ~S, expected REAL or valid note/accidental symbols in the form X, (X X ...) or (X (X X) ...) in NOTE slot" t)) (marks (or* null (with-error* ("~~A in MARKS slot") (type* +notemarks-type+)))))))) (defparameter +rest-type+ --- /project/fomus/cvsroot/fomus/data.lisp 2006/02/03 07:17:18 1.31 +++ /project/fomus/cvsroot/fomus/data.lisp 2006/02/11 22:39:40 1.32 @@ -89,8 +89,8 @@ (let ((a (when (consp no) (rest no))) (no (note-to-num (if (consp no) (first no) no)))) (if a - (cons no (mapcar (lambda (x) (if (and (listp x) (list>1p x)) - (cons (acc-to-num (first x) 1) (acc-to-num (second x) 1/2)) + (cons no (mapcar (lambda (x) (if (listp x) + (if (list>1p x) (cons (acc-to-num (first x) 1) (acc-to-num (second x) 1/2)) (acc-to-num (first x) 1)) (acc-to-num x 1))) a)) no))) @@ -102,7 +102,7 @@ (if (symbolp acc) (lookup (symbol-name acc) +accnum+ :test #'string=) (roundto acc prec))) (defun is-acc (acc) - (typecase acc (real acc) (symbol (find (symbol-name acc) +accnum+ :key #'car :test #'string=)))) + (typecase acc (integer (<= (abs acc) 2)) (symbol (find (symbol-name acc) +accnum+ :key #'car :test #'string=)))) (defun dur-to-num (dur bt) (if (and *cm-rhythmfun* *use-cm* (symbolp dur)) @@ -116,7 +116,7 @@ (defparameter +notesym-type+ '(or* real symbol (cons* (satisfies is-note) - (list-of* (or* (satisfies is-acc) (list* (satisfies is-acc) (satisfies is-acc))))))) + (or* null (list-of* (or* (satisfies is-acc) (list* (satisfies is-acc)) (list* (satisfies is-acc) (member -1/2 0 1/2)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CLEFS @@ -343,7 +343,7 @@ (make-instr :ef-trumpet :clefs :treble :tpose 3 :minp 57 :maxp 87 :midiprgch-ex 56) (make-instr :d-trumpet :clefs :treble :tpose 2 :minp 56 :maxp 86 :midiprgch-ex 56) (make-instr :c-trumpet :clefs :treble :minp 52 :maxp 84 :midiprgch-ex 56) - (make-instr :bf-trumpet :clefs :treble :tpose -2 :minp 50 :maxp 82 :midiprgch-im '(56 59) :midiprgch-ex 56) + (make-instr :bf-trumpet :clefs :treble :tpose -2 :minp 52 :maxp 82 :midiprgch-im '(56 59) :midiprgch-ex 56) (make-instr :flugelhorn :clefs :treble :tpose -2 :minp 52 :maxp 82 :midiprgch-ex 56) (make-instr :ef-bass-trumpet :clefs :treble :tpose -26 :minp 33 :maxp 63 :midiprgch-ex 56) (make-instr :bf-bass-trumpet :clefs :treble :tpose -26 :minp 28 :maxp 58 :midiprgch-ex 56) --- /project/fomus/cvsroot/fomus/main.lisp 2006/01/19 00:02:35 1.20 +++ /project/fomus/cvsroot/fomus/main.lisp 2006/02/11 22:39:40 1.21 @@ -114,6 +114,7 @@ (check-ranges pts) #+debug (fomus-proc-check pts 'ranges)) (preproc-noteheads pts) (check-mark-accs pts) + (check-useraccs pts) (when *transpose* (when (>= *verbose* 2) (out "~&; Transpositions...")) (transpose pts) #+debug (fomus-proc-check pts 'transpose)) --- /project/fomus/cvsroot/fomus/marks.lisp 2006/02/03 07:17:18 1.16 +++ /project/fomus/cvsroot/fomus/marks.lisp 2006/02/11 22:39:40 1.17 @@ -53,7 +53,7 @@ (loop for (startsym contsym endsym xxx symlvl) of-type (symbol symbol symbol t (or symbol (integer 1))) in spanners do (loop for p of-type partex in pts do (loop - with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta and mor of-type list + with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta and staa and mor of-type list for (e nxe) of-type ((or noteex restex) (or noteex restex null)) on (reverse (part-events p)) do ; go backwards, find endsyms (setf mor nil) (loop @@ -89,10 +89,12 @@ (decf nu)) (error "Levels for marks ~S, ~S and ~S are out of order at offset ~S, part ~S" startsym contsym endsym (event-foff e) (part-name p))) (progn - (loop for (a b) of-type ((or noteex restex) (or noteex restex null)) on sta + (loop for (a b) of-type ((or noteex restex) (or noteex restex null)) on (or (lookup n sta) staa) if b do (addmark a (list contsym 1)) else do (addmark a (list endsym 1)) (addmark e (nconc (list startsym 1) (when a3 (list a3)) (when a2 (list a2)) - (when (and a1 symlvl) (list a1)))))))))) + (when (and a1 symlvl) (list a1))))) + (let ((x (assoc n sta))) + (if x (setf (cdr x) nil) (push (cons n nil) sta)))))))) (loop for lv of-type (integer 1) in mor do (unless (gethash lv ss) (setf (gethash lv ss) (incf nu)) @@ -100,7 +102,8 @@ (loop for l of-type (integer 1) being each hash-value in ss if nxe do (unless (getmark e (list endsym l)) (addmark e (list contsym l))) else do (addmark e (list startsym l))) - (push e sta)) + (map nil (lambda (x) (push e (cdr x))) sta) + (push e staa)) (print-dot)))) (defun expand-marks (pts) --- /project/fomus/cvsroot/fomus/other.lisp 2005/11/30 23:51:37 1.12 +++ /project/fomus/cvsroot/fomus/other.lisp 2006/02/11 22:39:40 1.13 @@ -30,13 +30,50 @@ (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 check-useraccs (pts) + (declare (type list pts)) + (loop for p of-type partex in pts + unless (is-percussion p) + do (loop with cha + for e of-type (or noteex restex) in (part-events p) + when (notep e) do (when (event-useracc e) + (loop with n = (event-note* e) and ch + for a of-type (or cons (integer -2 2)) in (event-useracc e) + if (if (and *quartertones* (consp a)) + (qnotespelling n a) + (and (numberp a) (notespelling n a))) collect a into re else do (setf ch t cha t) + finally (when ch (setf (event-note e) (cons n re))))) + finally (when cha (format t "~&;; WARNING: Bad note spellings removed in part ~S" (part-name p)))) + (print-dot))) + (defun transpose (pts) (declare (type list pts)) (loop for p of-type partex in pts unless (is-percussion p) do (let ((r (or (instr-tpose (part-instr p)) 0))) (when r (loop for e of-type (or noteex restex) in (part-events p) - when (notep e) do (decf (event-note* e) r)))) (print-dot))) + when (notep e) do + (if (event-useracc e) + (let* ((n (event-note* e)) + (n2 (- n r))) + (setf (event-note e) + (cons n2 + (delete-duplicates + (loop for a0 of-type (or cons (integer -2 2)) in (event-useracc e) + for a = (if (consp a0) (car a0) a0) + and aa = (when *quartertones* (if (consp a0) (cdr a0) 0)) + nconc (if *quartertones* + (loop for (a2 . aa2) of-type ((integer -2 2) . (rational -1/2 1/2)) in + (mapcar #'convert-qtone +acc-qtones-double+) + when (and (qnotespelling n2 (cons a2 aa2)) + (< (abs (nth-value 1 (interval (+ n aa) a (+ n2 aa2) a2))) 2)) + collect (if (= aa2 0) a2 (cons a2 aa2))) + (loop for a2 of-type (integer -2 2) in +acc-double+ + when (and (notespelling n2 a2) (< (abs (nth-value 1 (interval n a n2 a2))) 2)) + collect a2))) + :test #'equal)))) + (decf (event-note* e) r))))) + (print-dot))) (defun preproc-noteheads (parts) (declare (type list parts)) --- /project/fomus/cvsroot/fomus/test.lisp 2006/02/03 07:17:18 1.23 +++ /project/fomus/cvsroot/fomus/test.lisp 2006/02/11 22:39:40 1.24 @@ -1,11 +1,10 @@ ;; EXAMPLES ;; The majority of these will eventually be part of the documentation as usage examples -;; It's also a list of what works or almost works ;; Example 1 (fomus - :backend '((:data) (:lilypond :view t) (:cmn :view t) (:midi :tempo 120 :delay 1 :play nil)) + :backend '((:data) (:lilypond :view t) #|(:cmn :view t) (:midi :tempo 120 :delay 1 :play nil)|#) :ensemble-type :orchestra :parts (list @@ -18,8 +17,8 @@ collect (make-note :off off :dur (if (< off 10) 1/2 1) :note (+ 48 (random 25)) - :marks (when (= (mod off 1) 0) - '(:ppp*))))))) + :marks (when (= (random 3) 0) + '(:staccato))))))) (fomus :backend '((:data) (:lilypond :view t) :musicxml) @@ -729,7 +728,7 @@ (fomus ; :auto-ottavas :backend '((:data) (:lilypond :view t)) :ensemble-type :orchestra - :auto-ottavas nil + :auto-ottavas t :parts (list (make-part --- /project/fomus/cvsroot/fomus/util.lisp 2006/01/31 08:19:57 1.21 +++ /project/fomus/cvsroot/fomus/util.lisp 2006/02/11 22:39:40 1.22 @@ -62,6 +62,12 @@ (defparameter +note-to-white+ (vector 0 nil 1 nil 2 3 nil 4 nil 5 nil 6)) (defparameter +white-to-note+ (vector 0 2 4 5 7 9 11)) +(declaim (type cons +acc-single+ +acc-double+ +acc-qtones-single+ +acc-qtones-double+)) +(defparameter +acc-single+ '(0 -1 1)) +(defparameter +acc-double+ '(0 -1 1 -2 2)) +(defparameter +acc-qtones-single+ '(0 -1 1 (0 . -1/2) (0 . 1/2) (-1 . -1/2) (1 . 1/2))) +(defparameter +acc-qtones-double+ '(0 -1 1 -2 2 (0 . -1/2) (0 . 1/2) (-1 . -1/2) (1 . 1/2))) + (defun notetowhite (p) (declare (type integer p)) (multiple-value-bind (o n) (floor p 12) @@ -71,6 +77,49 @@ (multiple-value-bind (o n) (floor w 7) (+ (* o 12) (svref +white-to-note+ n)))) +(declaim (type (vector boolean) +nokey-quality+)) +(defparameter +interval-quality+ (vector nil t t nil nil t t)) + +;; return a white note or nil if not possible +(defun notespelling (note acc) ; acc = -2/-1/0/1/2 + (declare (type rational note) (type (integer -2 2) acc)) + (multiple-value-bind (o n) (floor (- note acc) 12) + (let ((x (svref +note-to-white+ n))) + (when x (values x o))))) +(defun qnotespelling (note acc) ; acc = -2/-1/0/1/2 + (declare (type rational note) (type (cons (integer -2 2) (rational -1/2 1/2)) acc)) + (multiple-value-bind (o n) (floor (- note (car acc) (cdr acc)) 12) + (let ((x (when (integerp n) (svref +note-to-white+ n)))) + (when x (values x o))))) + +(defun convert-qtone (x) + (declare (type (or (cons (integer -2 2) (rational -1/2 1/2)) (integer -2 2)) x)) + (if (consp x) x (cons x 0))) + +;; return values: int-value (0 - 6), int-quality (0 = perfect, -1/1 = min./maj., -2/2... = dim./aug., nil = ???) +(defun interval (note1 acc1 note2 acc2) + (declare (type rational note1 note2) (type (integer -2 2) acc1 acc2)) + (multiple-value-bind (s1 o1) (notespelling note1 acc1) + (multiple-value-bind (s2 o2) (notespelling note2 acc2) + (multiple-value-bind (sp1 sp2 n1 n2) + (let ((p1 (+ s1 (* o1 7))) + (p2 (+ s2 (* o2 7)))) + (if (= p1 p2) + (if (< note1 note2) + (values p1 p2 note1 note2) + (values p2 p1 note2 note1)) + (if (< p1 p2) + (values p1 p2 note1 note2) + (values p2 p1 note2 note1)))) + (let ((b (mod (- sp2 sp1) 7))) + (values b + (let ((x (- (- n2 n1) (svref +white-to-note+ b) (* (floor (- sp2 sp1) 7) 12)))) + (if (svref +interval-quality+ b) + (if (>= x 0) (1+ x) x) ; maj./min. + (cond ((> x 0) (1+ x)) ; aud./dim. + ((< x 0) (1- x)) + (t 0)))))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; UTILITY --- /project/fomus/cvsroot/fomus/version.lisp 2006/02/05 04:57:33 1.30 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/11 22:39:40 1.31 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 35)) +(defparameter +version+ '(0 1 36)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS fomus
by dpsenicka 05 Feb '06

05 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv28667 Modified Files: TODO backend_cmn.lisp backend_ly.lisp backend_xml.lisp version.lisp Log Message: bugs/cmn --- /project/fomus/cvsroot/fomus/TODO 2006/02/03 07:17:18 1.28 +++ /project/fomus/cvsroot/fomus/TODO 2006/02/05 04:57:33 1.29 @@ -17,11 +17,16 @@ Aesthetic tweaks: avoid staff changes when notes move in other direction re-evaluate initial clef decision in measure 1 + Some more marks: + pedal on/off + double/triple tongue + bartok pizz. Short Term: Combine separate sections with different settings into one score Proportional notation + Automatic percussion instrument changes Durations that fill to next/previous note Part properties: override settings for individual parts Number of lines in staff --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/31 08:19:57 1.6 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/02/05 04:57:33 1.7 @@ -58,6 +58,18 @@ (automatic-beams nil) (automatic-octave-signs nil))) (defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24))) +;; left out: (:leftheel . ...) (:rightheel . ...) (:lefttoe . ...) (:righttoe . ...)| +(defparameter +cmn-marks+ + '((:accent . accent) (:marcato . marcato) (:staccatissimo . staccato) (:staccato . staccato) (:tenuto . tenuto) + (:portato . (detache (staccato (dy -1/8)))) (:upbow . up-bow) (:downbow . down-bow) + (:thumb . thumb) (:open . open-note) (:stopped . stopped-note) ((:breath :after) . breath-mark) (:fermata . fermata))) + +;; (:arpeggio . ...) (:pizz . ...) (:arco . ...) +;; ((:glissando :after) . ...) ((:portamento :after) . ...) <-- begin/end marks, use setf gliss- and -gliss + +(defparameter +cmn-trmarks+ + '((:prall . inverted-mordent) (:trill . trill) (:mordent . mordent) (:startlongtrill- . trill))) + (defun internalize (x) (typecase x (keyword x) @@ -96,6 +108,7 @@ (er "viewing")))) (er "compiling"))))) +;; multinote trems??? (defun save-cmn (parts header filename options process view) (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) @@ -103,11 +116,13 @@ (format f "~A" header) (let ((de 0) (phash (make-hash-table :test 'equal))) (flet ((cmndur (val m) (* val (timesig-beat* (meas-timesig m)) 4)) - (cmnnote (wnum acc1 acc2 dur hide show caut harmt harms) ;; wdur is actual dur * beat * 4 + (cmnnote (wnum acc1 acc2 dur hide show caut grace #|harmt harms|#) ;; wdur is actual dur * beat * 4 (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) (when caut (setf acc (list acc 'in-parentheses))) (when (and (equal acc 'natural) (not show)) (setf acc nil)) - (nconc (list (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) + (nconc (when (< grace 0) (list 'grace-note)) + (when (>= grace 0) (list 'appoggiatura)) + (list (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) (format nil "~D" (1- (truncate wnum 12)))))) (when dur (list (or (lookup dur +cmn-durations+) (list 'rq dur)))) @@ -122,11 +137,14 @@ collect (string x)))) "-" (string (code-char (+ 64 de))))))) - (let* ((bv -1) + (let* ((bv -1) (gv -1) (pv -1) (sv -1) (cmp (loop for p in parts nconc (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) and bbb = (make-hash-table :test 'eq) + and ggg = (make-hash-table :test 'eq) + and ppp = (make-hash-table :test 'eq) + and sss = (make-hash-table :test 'eq) for vi from 0 below nvce nconc ; loop through voices (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) and ns = (instr-staves (part-instr p)) ; number of staves @@ -148,7 +166,7 @@ (format nil "~A1~D" pna si) (format nil "~A1" pna)))))) ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) - ,@(loop with o = 0 and st = 1 + ,@(loop with o = 0 and st = 1 and gg and pg and sg and wvy for m in (part-meas p) and stoff = 0 then (+ stoff lmdur) for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) @@ -163,42 +181,109 @@ and tu = (getmark e :starttup) do (setf st (or (third (getmark e '(:staff :voice))) st)) when (and r (not l)) do - (when ee (setf (car ee) '-beam ee nil)) - (event-off e) + (when ee (setf (car ee) '-beam ee nil)) ;;(event-off e) (setf bb e) + when (getmark e '(:glissando :after)) do (setf gg e) + when (getmark e '(:portamento :after)) do (setf pg e) + when (and wvy (getmark e :endlongtrill-)) do (setf (second wvy) co) when (= st si) collect - (let* ((cd (cmndur (event-dur* e) m)) - (y (if (restp e) ; y must be nconcable - (or (lookup cd +cmn-restdurs+) (list 'rest `(rq ,cd))) - (if (chordp e) - (cons 'chord - (nconc - (loop - for n in (event-writtennotes e) - and w in (event-writtennotes e) - and a in (event-accs e) - and a2 in (event-addaccs e) - for ha = (getmark e (list :harmonic :touched n)) - and hs = (getmark e (list :harmonic :sounding n)) - collect (cmnnote w a a2 nil - (getmark e (list :hideacc n)) - (getmark e (list :showacc n)) - (getmark e (list :cautacc n)) - (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n)))) - (list (or (lookup cd +cmn-restdurs+) `(rq ,cd))))) - (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) cd - (getmark e (list :hideacc (event-writtennote e))) - (getmark e (list :showacc (event-writtennote e))) - (getmark e (list :cautacc (event-writtennote e))) - (getmark e (list :harmonic :touched (event-writtennote e))) - (getmark e (list :harmonic :sounding (event-writtennote e)))))))) - (when (or l r) - (let ((h (gethash bb bbb))) - (nconc y (list (if h - (setf ee (list '-beam- `(svref bvect ,h))) - `(setf (svref bvect ,(setf (gethash bb bbb) (incf bv))) (beam-))))))) - (if (> co o) (nconc y (list `(onset ,co))) y)) + (let ((cd (cmndur (event-dur* e) m))) + (nconc (if (restp e) + (or (lookup cd +cmn-restdurs+) (list 'rest `(rq ,cd))) + (if (chordp e) + (cons 'chord + (nconc + (loop + for n in (event-writtennotes e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + for ha = (getmark e (list :harmonic :touched n)) + and hs = (getmark e (list :harmonic :sounding n)) + collect (cmnnote w a a2 nil + (getmark e (list :hideacc n)) + (getmark e (list :showacc n)) + (getmark e (list :cautacc n)) + (event-grace e) + #|(getmark e (list :harmonic :touched n))|# + #|(getmark e (list :harmonic :sounding n))|#)) + (list (or (lookup cd +cmn-restdurs+) `(rq ,cd))))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) cd + (getmark e (list :hideacc (event-writtennote e))) + (getmark e (list :showacc (event-writtennote e))) + (getmark e (list :cautacc (event-writtennote e))) + (event-grace e) + #|(getmark e (list :harmonic :touched (event-writtennote e)))|# + #|(getmark e (list :harmonic :sounding (event-writtennote e)))|#))) + (when (> co o) (list `(onset ,co))) + (when (or l r) + (let ((h (gethash bb bbb))) + (list (if h + (setf ee (list '-beam- `(svref bvect ,h))) ;; -beam- will be resetfed + `(setf (svref bvect ,(setf (gethash bb bbb) (incf bv))) (beam-)))))) + (loop for i in + (sort (delete-duplicates + (loop for (a1 . a2) in +cmn-marks+ + nconc (mapcar (lambda (x) (cons a2 (force-list x))) (getmarks e a1))) + :key #'cdr :test #'equal) + (lambda (x y) (cond + ((find (cadr x) +marks-withacc+) nil) + ((find (cadr y) +marks-withacc+) t) + (t (let ((x2 (caddr x)) (y2 (caddr y))) + (cond ((and (numberp x2) (numberp y2)) (< x2 y2)) + (x2 t))))))) + collect (car i)) + (loop for i in + (delete-duplicates + (loop for (a1 . a2) in +cmn-trmarks+ + nconc (mapcar (lambda (x) (let ((f (force-list x))) + (cons a2 (if (eq (first f) :startlongtrill-) (fifth f) (third f))))) + (getmarks e a1))) + :key #'cdr :test #'equal) + collect + `(,(car i) ,@(when (cdr i) + (list `(ornament-sign + ,(ecase (cdr i) + (-2 'double-flat) + (-3/2 'flat-down) + (-1 'flat) + (-1/2 'natural-down) + (0 'natural) + (1/2 'natural-up) + (1 'sharp) + (3/2 'sharp-up) + (2 'double-sharp)) + (scale 1/2 1/2)))) + ,@(when (eq (car i) :startlongtrill-) + (list '(wavy-line t) + (setf wvy (list 'wavy-time nil)))))) + ;; ottavas + (let ((x (getmark e :tremolo))) + (when x (list `(tremolo (tremolo-slashes ,(- (roundint (log (third x) 1/2)) 2)))))) + ;;; start/end tremolos + (cond ((getmark e '(:arpeggio :up)) (list '(arpeggio arrow-up))) + ((getmark e '(:arpeggio :down)) (list '(arpeggio arrow-down))) + ((getmark e :arpeggio) (list 'arpeggio))) + ;;; dynamics + ;;; wedges + ;;; text + ;;; slur svect + (loop + for xxx in (nconc (getmarks e :startslur-) (getmarks e :endslur-)) + collect (let ((h (gethash sg sss))) + (list (if h + `(-slur (svref svect ,h)) + `(setf (svref svect ,(setf (gethash sg sss) (incf sv))) (slur-)))))) + (when (getmark e :glissando) + (let ((h (gethash gg ggg))) + (list (if h + `(-glissando (svref gvect ,h)) + `(setf (svref gvect ,(setf (gethash gg ggg) (incf gv))) (glissando-)))))) + (when (getmark e :portamento) + (let ((h (gethash pg ppp))) + (list (if h + `(-portamento (svref pvect ,h)) + `(setf (svref pvect ,(setf (gethash pg ppp) (incf pv))) (portamento-)))))))) and do (setf o (+ co (cmndur (event-dur* e) m))) finally (when ee (setf (car ee) '-beam))) collect (let ((b (getprop m :barline))) @@ -213,7 +298,12 @@ `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr +cmn-changeableopts+ (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) :key (lambda (x) (if (consp x) (first x) x)) :from-end t) - (let* ,(if (> bv 0) (cons `(bvect (make-array ,(1+ bv))) cmp) cmp) + (let* ,(nconc + (if (> bv 0) (list `(bvect (make-array ,(1+ bv))))) + (if (> gv 0) (list `(gvect (make-array ,(1+ gv))))) + (if (> pv 0) (list `(pvect (make-array ,(1+ pv))))) + (if (> sv 0) (list `(svect (make-array ,(1+ sv))))) + cmp) ,@(labels ((pfn (pps &optional (grp 1)) (loop for e = (pop pps) ; e = part while e --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/03 07:17:18 1.27 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/05 04:57:33 1.28 @@ -117,7 +117,7 @@ (defparameter +lilypond-marks+ '((:accent . "->") (:marcato . "-^") (:staccatissimo . "-|") (:staccato . "-.") (:tenuto . "--") (:portato . "-_") (:upbow . "\\upbow") (:downbow . "\\downbow") (:thumb . "\\thumb") (:leftheel . "\\lheel") (:rightheel . "\\rheel") (:lefttoe . "\\ltoe") (:righttoe . "\\rtoe") (:open . "\\open") - (:stopped . "-+") #|(:turn . "\\turn") (:reverseturn . "\\reverseturn")|# (:arpeggio . "\\arpeggio") (:pizz . "^\"pizz.\"") (:arco . "^\"arco\"") + (:stopped . "-+") #|(:turn . "\\turn") (:reverseturn . "\\reverseturn")|# #|(:arpeggio . "\\arpeggio")|# (:pizz . "^\"pizz.\"") (:arco . "^\"arco\"") ((:breath :after) . " \\breathe") ((:glissando :after) . "\\glissando") ((:portamento :after) . "\\glissando") ((:fermata :short) . "\\shortfermata") (:fermata . "\\fermata") ((:fermata :long) . "\\longfermata") ((:fermata :verylong) . "\\verylongfermata"))) --- /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/02/03 07:17:18 1.8 +++ /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/02/05 04:57:33 1.9 @@ -95,12 +95,14 @@ (defparameter +xml-1note-tremolo-kludge+ t) (defparameter +xml-multinote-tremolo-kludge+ t) (defparameter +xml-harmonic-kludge+ t) +(defparameter +xml-partgroups-kludge+ nil) (defun save-xml (parts header filename options #|process view|#) (when (>= *verbose* 1) (out ";; Saving MusicXML file ~S...~%" filename)) (destructuring-bind (&key (xml-1note-tremolo-kludge +xml-1note-tremolo-kludge+) (xml-multinote-tremolo-kludge +xml-multinote-tremolo-kludge+) - (xml-harmonic-kludge +xml-harmonic-kludge+) &allow-other-keys) options + (xml-harmonic-kludge +xml-harmonic-kludge+) + (xml-partgroups-kludge +xml-partgroups-kludge+)&allow-other-keys) options (with-open-file (f filename :direction :output :if-exists :supersede) (loop for e in +xml-head+ do (format f "~A~%" e)) (format f "~%" header) @@ -137,17 +139,18 @@ ,.(loop for p in parts and pn from 1 for s = (getprops p :startgroup) and e = (getprops p :endgroup) - when s nconc (loop for x in (sort s #'< :key #'second) when (> (second x) 0) collect - `("part-group" (("type" "start") ("number" ,(second x))) - ,@(case (third x) - (:group '(("group-symbol" nil "bracket"))) - (:grandstaff '(("group-symbol" nil "brace")))) - ("group-barline" nil "yes"))) + when (and s (not xml-partgroups-kludge)) + nconc (loop for x in (sort s #'< :key #'second) when (> (second x) 0) collect + `("part-group" (("type" "start") ("number" ,(second x))) + ,@(case (third x) + (:group '(("group-symbol" nil "bracket"))) + (:grandstaff '(("group-symbol" nil "brace")))) + ("group-barline" nil "yes"))) collect `("score-part" ("id" ,(format nil "P~A" pn)) ("part-name" nil ,(or (part-name p) "")) ,@(when (part-abbrev p) `(("part-abbreviation" nil ,(part-abbrev p))))) - when e nconc (loop for x in (sort e #'> :key #'second) when (> (second x) 0) collect - `("part-group" (("type" "stop") ("number" ,(second x))))))) + when (and e (not xml-partgroups-kludge)) nconc (loop for x in (sort e #'> :key #'second) when (> (second x) 0) collect + `("part-group" (("type" "stop") ("number" ,(second x))))))) ,.(loop for p in parts and pn from 1 for pc = (is-percussion p) and ns = (instr-staves (part-instr p)) collect `("part" ("id" ,(format nil "P~A" pn)) ,.(loop with slrlvl = (cons nil nil) and wlvl = (cons nil nil) and olvl = (cons nil nil) and tlvl = (cons nil nil) @@ -242,7 +245,7 @@ ("direction-type" nil ("words" ,+xml-textnotestyle+ ,i)) ,@(when (> ns 1) `(("staff" nil ,(event-staff e)))))))))) - nconc (when (and fi xml-1note-tremolo-kludge) + nconc (when fi (loop for x in (nconc (getmarks e :text) (getmarks e :textdyn) (getmarks e :textnote) (getmarks e :texttempo)) collect `("direction" ("placement" ,(ecase (second x) (:up "above") (:down "below"))) ("direction-type" nil --- /project/fomus/cvsroot/fomus/version.lisp 2006/02/03 07:17:18 1.29 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/05 04:57:33 1.30 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 34)) +(defparameter +version+ '(0 1 35)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS fomus
by dpsenicka 01 Feb '06

01 Feb '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv25447 Modified Files: backend_ly.lisp backend_xml.lisp misc.lisp version.lisp Log Message: bugs/musicxml --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/31 08:19:57 1.25 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/02/01 23:59:06 1.26 @@ -17,14 +17,14 @@ (defparameter +lilypond-exe+ (or #+darwin (find-exe "lilypond.sh") #+mswindows (find-exe "lilypond.exe") - #-(or darwin mswindows) (find-exe "lilypond") + #-mswindows (find-exe "lilypond") #+darwin "lilypond.sh" #+mswindows "lilypond.exe" - #-(or darwin mswindows) "lilypond")) + #-mswindows "lilypond")) (defparameter +lilypond-view-exe+ #-mswindows +ghostview-exe+ #+mswindows +acroread-exe+)) -(defparameter +lilypond-opts+ #-mswindows '("--ps") #+mswindows '("--pdf")) -(defparameter +lilypond-out-ext+ #-mswindows "ps" #+mswindows "pdf") +(defparameter +lilypond-opts+ #-(or darwin mswindows) '("--ps") #+(or darwin mswindows) '("--pdf")) +(defparameter +lilypond-out-ext+ #-(or darwin mswindows) "ps" #+(or darwin mswindows) "pdf") (defparameter +lilypond-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app")) (defun view-lilypond (filename options view) --- /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/01/31 08:19:57 1.6 +++ /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/02/01 23:59:06 1.7 @@ -187,11 +187,11 @@ `("direction" ("placement" ,(if (eq (third x) :up) "above" "below")) ("direction-type" nil ("wedge" (("type" "stop") ("number" ,(remnum (cons (second x) (event-voice* e)) wlvl)))))))) - nconc (when fi (loop for x in (getmarks e :end8up-) collect + nconc (when fi (loop for xxx in (getmarks e :end8up-) collect `("direction" nil ("direction-type" nil ("octave-shift" (("type" "stop") ("number" ,(remnum (event-staff e) olvl)))))))) - nconc (when fi (loop for x in (getmarks e :end8down-) collect + nconc (when fi (loop for xxx in (getmarks e :end8down-) collect `("direction" nil ("direction-type" nil ("octave-shift" (("type" "stop") ("number" ,(remnum (event-staff e) olvl)))))))) @@ -209,11 +209,11 @@ ("direction-type" nil ("wedge" (("type" "crescendo") ("number" ,(getnum (cons (second x) (event-voice* e)) wlvl))))) ,@(when (> ns 1) `(("staff" nil ,(event-staff e))))))) - nconc (when fi (loop for x in (getmarks e :start8up-) collect + nconc (when fi (loop for xxx in (getmarks e :start8up-) collect `("direction" nil ("direction-type" nil ("octave-shift" (("type" "up") ("number" ,(getnum (event-staff e) olvl)))))))) - nconc (when fi (loop for x in (getmarks e :start8down-) collect + nconc (when fi (loop for xxx in (getmarks e :start8down-) collect `("direction" nil ("direction-type" nil ("octave-shift" (("type" "down") ("number" ,(getnum (event-staff e) olvl)))))))) @@ -223,7 +223,7 @@ collect `("direction" ("placement" ,(if (eq (third x) :up) "above" "below")) ("direction-type" nil - ("dashes" (("type" "start") ("number" ,(remnum (cons (second x) (event-voice* e)) tlvl)))))))) + ("dashes" (("type" "start") ("number" ,(getnum (cons (second x) (event-voice* e)) tlvl)))))))) nconc (when fi (loop for (m . i) in +xml-words+ when (getmark e m) collect (cons i m) into re finally (when re (return (loop for i in @@ -237,12 +237,12 @@ ("words" ,+xml-textnotestyle+ ,i)) ,@(when (> ns 1) `(("staff" nil ,(event-staff e)))))))))) nconc (when fi (loop for x in (nconc (getmarks e :text) (getmarks e :textdyn) (getmarks e :textnote) (getmarks e :texttempo)) collect - `("direction" ("placement" ,(ecase (third x) (:up "above") (:down "below"))) + `("direction" ("placement" ,(ecase (second x) (:up "above") (:down "below"))) ("direction-type" nil ("words" ,(ecase (first x) (:text +xml-textstyle+) (:textdyn +xml-dyntextstyle+) (:textnote +xml-textnotestyle+) (:texttempo +xml-texttempostyle+)) - ,(fourth x)))))) + ,(third x)))))) collect `("note" nil ,@(when (event-grace e) `(("grace" ("slash" ,(if (< (event-grace e) 0) "yes" "no"))))) ,@(unless fi `(("chord" nil))) --- /project/fomus/cvsroot/fomus/misc.lisp 2006/01/31 08:19:57 1.15 +++ /project/fomus/cvsroot/fomus/misc.lisp 2006/02/01 23:59:06 1.16 @@ -83,11 +83,11 @@ (defun find-exe (filename) (namestring* (or #+darwin (probe-file (change-filename filename :dir "/Applications")) - #+darwin (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Applications/*.app"))) + #+darwin (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "/Applications/*.app" #+openmcl :directories #+openmcl t))) #+darwin (probe-file (change-filename filename :dir "/sw/bin")) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*"))) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*"))) - #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*\\*"))) + #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*" #+openmcl :directories #+openmcl t))) + #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*" #+openmcl :directories #+openmcl t))) + #+mswindows (find-if (lambda (x) (probe-file x)) (mapcar (lambda (x) (change-filename filename :dir (namestring x))) (directory "\\Program Files\\*\\*\\*" #+openmcl :directories #+openmcl t))) #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\usr\\local\\bin")) #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\usr\\bin")) #+mswindows (probe-file (change-filename filename :dir "\\cygwin\\bin")) --- /project/fomus/cvsroot/fomus/version.lisp 2006/01/31 08:19:57 1.27 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/02/01 23:59:06 1.28 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 32)) +(defparameter +version+ '(0 1 33)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS fomus
by dpsenicka 28 Jan '06

28 Jan '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv9366 Modified Files: accidentals.lisp backend_cmn.lisp backend_ly.lisp backend_xml.lisp data.lisp marks.lisp misc.lisp postproc.lisp test.lisp util.lisp version.lisp Log Message: bug fixes --- /project/fomus/cvsroot/fomus/accidentals.lisp 2006/01/19 00:02:35 1.14 +++ /project/fomus/cvsroot/fomus/accidentals.lisp 2006/01/28 20:31:19 1.15 @@ -409,41 +409,42 @@ ;; rests are removed already, after chords & ties ;; events are events in 1 measure (defun acc-nokey-postaccs (events) - (when *acc-throughout-meas* - (let ((as (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil)) - (ac (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil))) - (flet ((fixacc (e n a a2 tl) - (declare (type noteex e) (type rational n) (type (integer -2 2) a) (type (rational -1/2 1/2) a2) (type boolean tl)) - (let ((w (- n a a2))) - (if tl - (setf (svref as w) (unless (and (= a 0) (= a2 0)) (cons a a2)) (svref ac w) t) - (if (and (= a 0) (= a2 0)) - (when (svref as w) ; show the natural - (setf (svref as w) nil) - (rmmark e (list :cautacc w)) - (addmark e (list (if (svref ac w) :cautacc :showacc) w))) - (if (equal (svref as w) (cons a a2)) - (addmark e (list :hideacc w)) - (setf (svref as w) (cons a a2) (svref ac w) nil))))))) - (loop - for e of-type noteex in events - if (chordp e) - do (loop - for n of-type rational in (event-notes* e) - and a of-type (integer -2 2) in (event-accs e) - and a2 of-type (rational -1/2 1/2) in (event-addaccs e) - and tl of-type boolean in (event-tielt e) - do (fixacc e n a a2 tl)) - else do (fixacc e (event-note* e) (event-acc e) (event-addacc e) (event-tielt e)))))) + (let ((as (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil)) + (ac (make-array 128 :element-type '(or null (cons (integer -2 2) (rational -1/2 1/2))) :initial-element nil))) + (flet ((fixacc (e n a a2 tl) + (declare (type noteex e) (type rational n) (type (integer -2 2) a) (type (rational -1/2 1/2) a2) (type boolean tl)) + (let ((w (- n a a2))) + (if tl + (setf (svref as w) (unless (and (= a 0) (= a2 0)) (cons a a2)) (svref ac w) t) + (if (and (= a 0) (= a2 0)) + (when (svref as w) ; show the natural + (setf (svref as w) nil) + (rmmark e (list :cautacc w)) + (addmark e (list (if (svref ac w) :cautacc :showacc) w))) + (if (equal (svref as w) (cons a a2)) + (addmark e (list :hideacc w)) + (setf (svref as w) (cons a a2) (svref ac w) nil))))))) + (loop + for e of-type noteex in events + if (chordp e) + do (loop + for n of-type rational in (event-notes* e) + and a of-type (integer -2 2) in (event-accs e) + and a2 of-type (rational -1/2 1/2) in (event-addaccs e) + and tl of-type boolean in (event-tielt e) + do (fixacc e n a a2 tl)) + else do (fixacc e (event-note* e) (event-acc e) (event-addacc e) (event-tielt e))))) (print-dot)) ;; post processing (defun postaccs (parts) - (loop for p of-type partex in parts unless (is-percussion p) do - (loop for m of-type meas in (part-meas p) do - (multiple-value-bind (evs rs) (split-list (meas-events m) #'notep) - (case (auto-accs-fun) - (:nokey1 (acc-nokey-postaccs evs)) - (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*))) - (setf (meas-events m) (sort (nconc rs evs) #'sort-offdur)))))) + (when *acc-throughout-meas* + (loop for p of-type partex in parts unless (is-percussion p) do + (loop for m of-type meas in (part-meas p) do + (multiple-value-bind (evs rs) (split-list (meas-events m) #'notep) + (loop for ev of-type cons in (split-into-groups evs #'event-staff) do + (case (auto-accs-fun) + (:nokey1 (acc-nokey-postaccs (copy-list (sort ev #'sort-offdur)))) + (otherwise (error "Unknown accidental assignment function ~S" *auto-accs-mod*)))) + (setf (meas-events m) (sort (nconc rs evs) #'sort-offdur))))))) --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/26 05:48:21 1.4 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/28 20:31:19 1.5 @@ -8,6 +8,10 @@ (in-package :fomus) (compile-settings) +(eval-when (:load-toplevel :execute) + (defparameter +cmn-view-exe+ +ghostview-exe+)) +(defparameter +cmn-view-opts+ #-darwin nil #+darwin '("/Applications/Preview.app")) + (defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%") (defparameter +cmn-num-note+ (vector "C" nil "D" nil "E" "F" nil "G" nil "A" nil "B")) @@ -22,9 +26,13 @@ (defparameter +cmn-durations+ '((1/16 . 64th) (3/32 . 64th.) (1/8 . 32nd) (3/16 . 32nd.) (1/4 . s) (3/8 . s.) (7/16 . s..) + (1/6 . ts) (1/2 . e) (3/4 . e.) (7/8 . e..) + (1/3 . te) (1 . q) (3/2 . q.) (7/4 . q..) + (2/3 . tq) (2 . h) (3 . h.) (7/2 . h..) + (4/3 . th) (4 . w) (6 . w.) (8 . dw))) (defparameter +cmn-restdurs+ '((1/32 . one-twenty-eighth-rest) @@ -37,10 +45,6 @@ (4 . whole-rest) (6 . dotted-whole-rest) (8 . double-whole-rest))) -;; french-violin treble tenor-treble soprano mezzo-soprano alto tenor baritone baritone-c -;; baritone-f bass sub-bass double-bass -;; percussion quad-bass double-treble quad-treble - (defparameter +cmn-clefs+ '((:subbass-8dn . sub-bass) (:bass-8dn . double-bass) (:c-baritone-8dn . baritone-c) (:f-baritone-8dn . baritone-f) (:tenor-8dn . tenor) (:subbass . sub-bass) (:alto-8dn . alto) (:bass . bass) (:mezzosoprano-8dn . mezzo-soprano) (:c-baritone . baritone-c) (:f-baritone . baritone-f) (:soprano-8dn . soprano) (:tenor . tenor) (:subbass-8up . sub-bass) (:treble-8dn . tenor-treble) (:alto . alto) (:bass-8up . bass) @@ -48,7 +52,9 @@ (:treble . treble) (:alto-8up . alto) (:mezzosoprano-8up . mezzo-soprano) (:soprano-8up . soprano) (:treble-8up . double-treble) (:percussion . percussion))) -(defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style))) +(defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style) + (automatic-beams nil) (automatic-octave-signs nil))) +(defparameter +cmn-changeableopts+ '((all-output-in-one-file t) (size 24))) (defun internalize (x) (typecase x @@ -57,30 +63,55 @@ (list (mapcar #'internalize x)) (otherwise x))) -;; (defparameter +cmn-writeflags+ '(:escape t)) - (defparameter +cmn-out-ext+ "eps") -;; (defun save-cmn (parts header filename options process view) nil) +(defun view-cmn (filename options view) + (when (not *cmn-exists*) ;; for viewing only + (format t ";; ERROR: Common Music Notation required for CMN output~%") + (return-from view-cmn)) + (when (>= *verbose* 1) (out ";; Compiling/opening ~S for viewing...~%" filename)) + (destructuring-bind (&key view-exe view-exe-opts out-ext &allow-other-keys) options + (flet ((er (str) + (format t ";; ERROR: Error ~A CMN file~%" str) + (return-from view-cmn))) + #+(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) + (progn + (ignore-errors (delete-file (change-filename filename :ext (or out-ext +cmn-out-ext+)))) + (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir + (change-filename filename :name nil :ext nil)) + (if (ignore-errors (load filename)) + (progn + (unless (probe-file (change-filename filename :ext (or out-ext +cmn-out-ext+))) (er "compiling")) + (when view + (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or view-exe +cmn-view-exe+) + (append (or view-exe-opts +cmn-view-opts+) + (list (change-filename filename :ext (or out-ext +cmn-out-ext+)))) + :wait nil) + #+allegro (= (run-allegro-cmd + (apply #'vector (cons (or view-exe +cmn-view-exe+) + (cons (or view-exe +cmn-view-exe+) + (append (or view-exe-opts +cmn-view-opts+) + (list (change-filename filename :ext (or out-ext +cmn-out-ext+))))))) nil) 0) + (er "viewing")))) + (er "compiling"))) + #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view CMN file~%")))) (defun save-cmn (parts header filename options process view) - (when (and (not *cmn-exists*) (or process view)) ;; for viewing only - (format t ";; ERROR: Common Music Notation required for CMN output~%") - (return-from save-cmn)) (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) (destructuring-bind (&key score-attr out-ext &allow-other-keys) options (format f "~A" header) (let ((de 0) (phash (make-hash-table :test 'equal))) (flet ((cmndur (val m) (* val (timesig-beat* (meas-timesig m)) 4)) - (cmnnote (wnum acc1 acc2 dur hide show caut harmt harms) ;; wdur is actual dur * beat * 4 + (cmnnote (wnum acc1 acc2 dur hide show caut harmt harms) ;; wdur is actual dur * beat * 4 (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) (when caut (setf acc (list acc 'in-parentheses))) (when (and (equal acc 'natural) (not show)) (setf acc nil)) (nconc (list (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) - (format nil "~D" (1- (truncate wnum 12))))) - (or (lookup dur +cmn-durations+) (list 'rq dur))) + (format nil "~D" (1- (truncate wnum 12)))))) + (when dur (list (or (lookup dur +cmn-durations+) (list 'rq dur)))) (unless (member acc '(nil flat natural sharp)) (list acc))))) (cmnname (p) (incf de) @@ -92,79 +123,98 @@ collect (string x)))) "-" (string (code-char (+ 64 de))))))) - (let ((cmp (loop for p in parts nconc - (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) - (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) - for vi from 0 below nvce nconc ; loop through voices - (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) - and ns = (instr-staves (part-instr p)) ; number of staves - for si from 1 to ns - for ipna = (intern (if (> ns 1) - (if (> nvce 0) - (format nil "~A~D~D" pna (1+ vi) si) - (format nil "~A1~D" pna si)) - (if (> nvce 0) - (format nil "~A~D" pna (1+ vi)) - pna))) - do (setf (gethash p phash) (nconc (gethash p phash) (list ipna))) - collect - `(,ipna - (staff bar - ,@(when (and (<= si 1) (part-name p)) (list (list 'staff-name (part-name p)))) - ,@(when (> vi 0) - (list (list 'tied-to (intern (if (> ns 1) - (format nil "~A1~D" pna si) - (format nil "~A1" pna)))))) - ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) - ,@(loop with o = 0 and st = 1 - for m in (part-meas p) - and stoff = 0 then (+ stoff lmdur) - for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) - when (getprop m :startsig) collect (list 'meter (timesig-num (meas-timesig m)) (timesig-den (meas-timesig m))) - nconc - (loop for e in (nth vi (meas-events m)) - for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m)) - do (setf st (or (third (getmark e '(:staff :voice))) st)) - when (= st si) collect - (let ((y (if (restp e) - (or (lookup (cmndur (event-dur* e) m) +cmn-restdurs+) (error "Finish me")) - (if (chordp e) - (cons 'chord - (loop - for n in (event-writtennotes e) - and w in (event-writtennotes e) - and a in (event-accs e) - and a2 in (event-addaccs e) - for ha = (getmark e (list :harmonic :touched n)) - and hs = (getmark e (list :harmonic :sounding n)) - collect (cmnnote w a a2 - (cmndur (event-dur* e) m) - (getmark e (list :hideacc n)) - (getmark e (list :showacc n)) - (getmark e (list :cautacc n)) - (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n))))) - (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) - (cmndur (event-dur* e) m) - (getmark e (list :hideacc (event-writtennote e))) - (getmark e (list :showacc (event-writtennote e))) - (getmark e (list :cautacc (event-writtennote e))) - (getmark e (list :harmonic :touched (event-writtennote e))) - (getmark e (list :harmonic :sounding (event-writtennote e)))))))) - (if (> co o) (nconc y (list (list 'onset co))) y)) - and do (setf o (+ co (cmndur (event-dur e) m)))) - collect (let ((b (getprop m :barline))) - (if (>= o (+ stoff lmdur)) - (lookup (second b) +cmn-barlines+) - (list (lookup (second b) +cmn-barlines+) - (list 'onset (setf o (+ stoff lmdur))))))))))))))) + (let* ((bv -1) + (cmp (loop for p in parts nconc + (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) + (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) + and bbb = (make-hash-table :test 'eq) + for vi from 0 below nvce nconc ; loop through voices + (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) + and ns = (instr-staves (part-instr p)) ; number of staves + for si from 1 to ns + for ipna = (intern (if (> ns 1) + (if (> nvce 0) + (format nil "~A~D~D" pna (1+ vi) si) + (format nil "~A1~D" pna si)) + (if (> nvce 0) + (format nil "~A~D" pna (1+ vi)) + pna))) + do (setf (gethash p phash) (nconc (gethash p phash) (list ipna))) + collect + `(,ipna + (staff bar + ,@(when (and (<= si 1) (part-name p)) (list (list 'staff-name (part-name p)))) + ,@(when (> vi 0) + (list (list 'tied-to (intern (if (> ns 1) + (format nil "~A1~D" pna si) + (format nil "~A1" pna)))))) + ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) + ,@(loop with o = 0 and st = 1 + for m in (part-meas p) + and stoff = 0 then (+ stoff lmdur) + for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) + when (getprop m :startsig) collect `(meter ,(timesig-num (meas-timesig m)) ,(timesig-den (meas-timesig m))) + nconc + (loop + with bb and ee ;;for (pre e nxe) on (cons nil (nth vi (meas-events m))) ;;while e + for e in (nth vi (meas-events m)) + for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m)) + and l = (and (notep e) (> (event-beamlt e) 0)) + and r = (and (notep e) (> (event-beamrt e) 0)) + and tu = (getmark e :starttup) + do (setf st (or (third (getmark e '(:staff :voice))) st)) + when (and r (not l)) do + (when ee (setf (car ee) '-beam ee nil)) + (event-off e) + (setf bb e) + when (= st si) collect + (let* ((cd (cmndur (event-dur* e) m)) + (y (if (restp e) ; y must be nconcable + (or (lookup cd +cmn-restdurs+) (list 'rest `(rq ,cd))) + (if (chordp e) + (cons 'chord + (nconc + (loop + for n in (event-writtennotes e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + for ha = (getmark e (list :harmonic :touched n)) + and hs = (getmark e (list :harmonic :sounding n)) + collect (cmnnote w a a2 nil + (getmark e (list :hideacc n)) + (getmark e (list :showacc n)) + (getmark e (list :cautacc n)) + (getmark e (list :harmonic :touched n)) + (getmark e (list :harmonic :sounding n)))) + (list (or (lookup cd +cmn-restdurs+) `(rq ,cd))))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) cd + (getmark e (list :hideacc (event-writtennote e))) + (getmark e (list :showacc (event-writtennote e))) + (getmark e (list :cautacc (event-writtennote e))) + (getmark e (list :harmonic :touched (event-writtennote e))) + (getmark e (list :harmonic :sounding (event-writtennote e)))))))) + (when (or l r) + (let ((h (gethash bb bbb))) + (nconc y (list (if h + (setf ee (list '-beam- `(svref bvect ,h))) + `(setf (svref bvect ,(setf (gethash bb bbb) (incf bv))) (beam-))))))) + (if (> co o) (nconc y (list `(onset ,co))) y)) + and do (setf o (+ co (cmndur (event-dur* e) m))) + finally (when ee (setf (car ee) '-beam))) + collect (let ((b (getprop m :barline))) + (if (>= o (+ stoff lmdur)) + (lookup (second b) +cmn-barlines+) + (list (lookup (second b) +cmn-barlines+) + `(onset ,(setf o (+ stoff lmdur))))))))))))))) (prin1 (internalize '(in-package cmn)) f) (fresh-line f) (prin1 (internalize - `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) + `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr +cmn-changeableopts+ + (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) :key (lambda (x) (if (consp x) (first x) x)) :from-end t) - (let* ,cmp + (let* ,(if (> bv 0) (cons `(bvect (make-array ,(1+ bv))) cmp) cmp) ,@(labels ((pfn (pps &optional (grp 1)) (loop for e = (pop pps) ; e = part while e @@ -179,4 +229,5 @@ else nconc (gethash e phash)))) (pfn parts))))) f) - (fresh-line f))))))) + (fresh-line f)))))) + (when process (view-cmn filename options view))) --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/26 05:48:21 1.23 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/28 20:31:19 1.24 @@ -13,31 +13,12 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix)) -#+allegro -(defun run-allegro-cmd (cmd &optional (wait t)) - (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) - (declare (ignore istr)) - (values (if wait (sys:os-wait nil p) 0) ostr))) - -#+(or linux darwin unix) -(defun find-exe (filename) - (namestring* - (or #+darwin (probe-file (change-filename filename :dir "/Applications")) - #+darwin (probe-file (change-filename filename :dir "/Applications/Lilypond.app")) - #+darwin (probe-file (change-filename filename :dir "/sw/bin")) - (probe-file (change-filename filename :dir "/usr/local/bin")) - (probe-file (change-filename filename :dir "/usr/bin")) - (probe-file (change-filename filename :dir "/bin"))))) - (eval-when (:load-toplevel :execute) (defparameter +lilypond-exe+ (or #+darwin (find-exe "lilypond.sh") (find-exe "lilypond") #-darwin "lilypond" #+darwin "lilypond.sh")) - (defparameter +lilypond-view-exe+ - #+darwin (find-exe "open") - #+(and (or linux unix) (not darwin)) (or (find-exe "ggv") (find-exe "kgv") (find-exe "gv") (find-exe "ghostview") "gv") - #-(or linux darwin unix) "gv")) + (defparameter +lilypond-view-exe+ +ghostview-exe+)) (defparameter +lilypond-opts+ '("--ps")) (defparameter +lilypond-out-ext+ "ps") --- /project/fomus/cvsroot/fomus/backend_xml.lisp 2005/10/01 00:49:45 1.4 +++ /project/fomus/cvsroot/fomus/backend_xml.lisp 2006/01/28 20:31:19 1.5 @@ -124,11 +124,12 @@ ("sign" nil ,s) ,@(when l `(("line" nil ,l))) ,@(when o `(("clef-octave-change" nil ,o))))))))) - ,.(loop with nv = (length (meas-voices m)) + ,.(loop with nv = (length (meas-voices m)) and ts = (meas-timesig m) for v in (meas-voices m) - for b = (getprop m :barline) + for b = (getprop m :barline) and fi = nil then t + when fi collect `("backup" nil ("duration" nil ,(* (- (meas-endoff m) (meas-off m)) (timesig-beat* ts) dv))) nconc (loop - with tv and ts = (meas-timesig m) + with tv for e in v nconc (loop with ch = (chordp e) for fi = t then nil @@ -155,15 +156,16 @@ ("display-step" nil ,(svref +xml-num-perc-note+ (mod no 12))) ("display-octave" nil ,(floor (1- no) 12))))) ,@(when (restp e) '(("rest" nil))) +;; ,@(when tl '(("tie" ("type" "stop")))) +;; ,@(when tr '(("tie" ("type" "start")))) ,@(unless (event-grace e) `(("duration" nil ,(* (event-writtendur e ts) dv)))) ,@(when (> nv 1) `(("voice" nil ,(event-voice* e)))) - ,@(when tr '(("tie" ("type" "end")))) - ,@(when tl '(("tie" ("type" "start")))) ("type" nil ,(lookup (event-writtendur* e ts) +xml-num-durtype+)) ,.(loop repeat (nth-value 1 (event-writtendur* e ts)) collect '("dot" nil)) - ,@(let ((ca (getmark e (list :cautacc o)))) - (when (and (notep e) (not pc) - (or (/= ac 0) (/= aac 0) ca)) + ,@(let ((ca (getmark e (list :cautacc no)))) + (when (and (notep e) (not pc) (not tl) + (not (getmark e (list :hideacc no))) + (or (getmark e (list :showacc no)) (/= ac 0) (/= aac 0) ca)) `(("accidental" ,(when ca '("cautionary" "yes")) ,(svref (svref +xml-num-acctype+ (+ ac 2)) (1+ (* aac 2))))))) ,@(when (event-tup e) @@ -187,7 +189,10 @@ (loop for i from 1 to bc collect `("beam" ("number" ,i) "continue")) (loop for i from (1+ bc) to (event-beamlt e) collect `("beam" ("number" ,i) "end")) (loop for i from (1+ bc) to (event-beamrt e) collect `("beam" ("number" ,i) "begin"))))) - ;; notations + ,@(let ((ntr (when tr '(("tied" ("type" "start"))))) + (ntl (when tl '(("tied" ("type" "stop")))))) + (when (or ntr ntl) + `(("notations" nil ,@ntl ,@ntr)))) ) do (let ((ns (mapcar #'rest (getmarks e '(:endtup))))) (setf tv (delete-if (lambda (x) (find (first x) ns)) tv))))) --- /project/fomus/cvsroot/fomus/data.lisp 2006/01/19 00:02:35 1.28 +++ /project/fomus/cvsroot/fomus/data.lisp 2006/01/28 20:31:19 1.29 @@ -794,11 +794,11 @@ '((:startslur- :slur- :endslur- nil) (:startgraceslur- :graceslur- :endgraceslur- nil) (:starttext- :text- :endtext- :text) - (:startwedge< :wedge< :endwedge< t) - (:startwedge> :wedge> :endwedge> t) - (:startwedge*< :wedge*< :endwedge*< t) - (:startwedge*> :wedge*> :endwedge*> t) - (:startlongtrill- :longtrill- :endlongtrill- t))) + (:startwedge< :wedge< :endwedge< nil) + (:startwedge> :wedge> :endwedge> nil) + (:startwedge*< :wedge*< :endwedge*< nil) + (:startwedge*> :wedge*> :endwedge*> nil) + (:startlongtrill- :longtrill- :endlongtrill- nil))) (defparameter +marks-spanner-staves+ '((:start8up- :8up- :end8up- :8up) (:start8down- :8down- :end8down- :8down))) --- /project/fomus/cvsroot/fomus/marks.lisp 2006/01/26 05:48:21 1.14 +++ /project/fomus/cvsroot/fomus/marks.lisp 2006/01/28 20:31:19 1.15 @@ -53,17 +53,19 @@ (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners do (loop for p of-type partex in pts do (loop - with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta + with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta and mor of-type list for (e nxe) of-type ((or noteex restex) (or noteex restex null)) on (reverse (part-events p)) do ; go backwards, find endsyms + (setf mor nil) (loop for (xxx a1) of-type (t (or (integer 1) null)) in (sort (nconc (when contsym (loop for x = (popmark e contsym) while x collect (force-list x))) ; a1 is level (loop for x = (popmark e endsym) while x collect (force-list x))) #'< :key (lambda (x) (or (second x) 1))) do (let ((lv (or a1 1))) - (unless (gethash lv ss) - (setf (gethash lv ss) (incf nu)) - (addmark e (list endsym nu))))) + (if (gethash lv ss) + (push lv mor) + (progn (setf (gethash lv ss) (incf nu)) + (addmark e (list endsym nu)))))) (loop ; find startsyms for rr0 of-type cons in (sort (loop for x = (popmark e startsym) @@ -85,11 +87,17 @@ (addmark e (nconc (list startsym n) (when a3 (list a3)) (when a2 (list a2)))) ; fixed order now--level is mandatory 1st argument, string is second if text, modifier is last and optional (decf nu)) (error "Levels for marks ~S, ~S and ~S are out of order at offset ~S, part ~S" startsym contsym endsym (event-foff e) (part-name p))) - (progn + (progn (loop for (a b) of-type ((or noteex restex) (or noteex restex null)) on sta if b do (addmark a (list contsym 1)) else do (addmark a (list endsym 1)) (addmark e (nconc (list startsym 1) (when a3 (list a3)) (when a2 (list a2)))))))))) - (loop for l being each hash-value in ss do (addmark e (list (if nxe contsym startsym) l))) + (loop for lv of-type (integer 1) in mor do + (unless (gethash lv ss) + (setf (gethash lv ss) (incf nu)) + (addmark e (list endsym nu)))) + (loop for l of-type (integer 1) being each hash-value in ss + if nxe do (unless (getmark e (list endsym l)) (addmark e (list contsym l))) + else do (addmark e (list startsym l))) (push e sta)) (print-dot)))) --- /project/fomus/cvsroot/fomus/misc.lisp 2006/01/19 00:02:35 1.13 +++ /project/fomus/cvsroot/fomus/misc.lisp 2006/01/28 20:31:19 1.14 @@ -67,6 +67,25 @@ (defmacro cons-list (objs places) `(mapcar #'cons ,objs ,places)) +(declaim (inline namestring*)) +(defun namestring* (filename) (when filename (namestring filename))) + +#+allegro +(defun run-allegro-cmd (cmd &optional (wait t)) + (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) + (declare (ignore istr)) + (values (if wait (sys:os-wait nil p) 0) ostr))) + +#+(or linux darwin unix) +(defun find-exe (filename) + (namestring* + (or #+darwin (probe-file (change-filename filename :dir "/Applications")) + #+darwin (probe-file (change-filename filename :dir "/Applications/Lilypond.app")) + #+darwin (probe-file (change-filename filename :dir "/sw/bin")) + (probe-file (change-filename filename :dir "/usr/local/bin")) + (probe-file (change-filename filename :dir "/usr/bin")) + (probe-file (change-filename filename :dir "/bin"))))) + (defstruct (heap (:constructor make-heap-aux) (:predicate heapp)) (fun #'+ :type (function (t t) t)) (arr #() :type (array t))) --- /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/26 05:48:21 1.18 +++ /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/28 20:31:19 1.19 @@ -255,19 +255,23 @@ ;; leave middle marks (defun postproc-spanners (pts) (declare (type list pts)) - (loop + (loop for (startsym xxx endsym replsym) of-type (symbol symbol symbol symbol) in (append +marks-spanner-voices+ +marks-spanner-staves+) ;; fix any notes with starts/ends on same note - unless (truep replsym) do (loop for p of-type partex in pts - do (loop for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (meas-events x)) do - (loop - for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) - for lv = (second ma) - when (getmark e (if lv (list endsym lv) endsym)) - do - (rmmark e (if lv (list startsym lv) startsym)) - (rmmark e (if lv (list endsym lv) endsym)) - when replsym do (addmark e (nconc (list replsym lv) (cddr ma))))) + do (loop for v from 0 below (loop for x of-type meas in (part-meas p) maximize (length (meas-voices x))) do + (loop with h = (make-hash-table) + for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (nth v (meas-voices x))) do + (loop + for ma of-type cons in (mapcar #'force-list (getmarks e endsym)) + for lv = (second ma) do + (unless (gethash lv h) + (rmmark e (if lv (list startsym lv) startsym)) + (rmmark e (if lv (list endsym lv) endsym)) + (when replsym (addmark e (nconc (list replsym lv) (cddr ma))))) + (remhash lv h)) + (loop + for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) + do (setf (gethash (second ma) h) t)))) (print-dot)))) (defun postproc-barlines (pts) @@ -476,10 +480,10 @@ (defun postproc (pts) (postproc-tremolos pts) (postproc-timesigs pts) - (postproc-spanners pts) (postproc-markaccs pts) (postproc-midimarks pts) (postproc-voices pts) ;; voices now separated into lists + (postproc-spanners pts) (postproc-clefs pts) (postproc-staves pts) (postproc-measrests pts) --- /project/fomus/cvsroot/fomus/test.lisp 2006/01/26 05:48:21 1.21 +++ /project/fomus/cvsroot/fomus/test.lisp 2006/01/28 20:31:19 1.22 @@ -5,7 +5,7 @@ ;; Example 1 (fomus - :backend '((:data) (:lilypond :view t) (:midi :tempo 120 :delay 1 :play nil)) + :backend '((:data) (:lilypond :view t) (:cmn :view t) (:midi :tempo 120 :delay 1 :play nil)) :ensemble-type :orchestra :parts (list --- /project/fomus/cvsroot/fomus/util.lisp 2005/10/22 20:43:06 1.19 +++ /project/fomus/cvsroot/fomus/util.lisp 2006/01/28 20:31:19 1.20 @@ -30,6 +30,15 @@ (or (= (loop for i in '() maximize i) 0) (error "Failed LOOP test in \"util.lisp\""))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FIND GHOSTVIEW + +(eval-when (:load-toplevel :execute) + (defparameter +ghostview-exe+ + #+darwin (find-exe "open") + #+(and (or linux unix) (not darwin)) (or (find-exe "ggv") (find-exe "kgv") (find-exe "gv") (find-exe "ghostview") "gv") + #-(or linux darwin unix) "gv")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PROGRESS DOTS, IMMEDIATE OUTPUT (declaim (type (integer 0) +progress-int+)) @@ -102,9 +111,6 @@ finally (return (if (< o o2) (nconc r (list (cons o o2))) r)))) -(declaim (inline namestring*)) -(defun namestring* (filename) (when filename (namestring filename))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PROPERTIES/MARKS --- /project/fomus/cvsroot/fomus/version.lisp 2006/01/26 05:48:21 1.25 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/01/28 20:31:19 1.26 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 30)) +(defparameter +version+ '(0 1 31)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS fomus
by dpsenicka 26 Jan '06

26 Jan '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv8816 Modified Files: backend_cmn.lisp backend_ly.lisp marks.lisp postproc.lisp test.lisp version.lisp Log Message: bug fixes --- /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/19 00:02:35 1.3 +++ /project/fomus/cvsroot/fomus/backend_cmn.lisp 2006/01/26 05:48:21 1.4 @@ -19,39 +19,69 @@ (:repeatleft . end-repeat-bar) (:repeatright . begin-repeat-bar) (:repeatleftright . begin-and-end-repeat-bar) (:invisible . (bar invisible)))) +(defparameter +cmn-durations+ '((1/16 . 64th) (3/32 . 64th.) + (1/8 . 32nd) (3/16 . 32nd.) + (1/4 . s) (3/8 . s.) (7/16 . s..) + (1/2 . e) (3/4 . e.) (7/8 . e..) + (1 . q) (3/2 . q.) (7/4 . q..) + (2 . h) (3 . h.) (7/2 . h..) + (4 . w) (6 . w.) + (8 . dw))) +(defparameter +cmn-restdurs+ '((1/32 . one-twenty-eighth-rest) + (1/16 . sixty-fourth-rest) + (1/8 . thirty-second-rest) + (1/4 . sixteenth-rest) (3/8 . dotted-sixteenth-rest) + (1/2 . eighth-rest) (3/4 . dotted-eighth-rest) + (1 . quarter-rest) (3/2 . dotted-quarter-rest) + (2 . half-rest) (3 . dotted-half-rest) + (4 . whole-rest) (6 . dotted-whole-rest) + (8 . double-whole-rest))) + +;; french-violin treble tenor-treble soprano mezzo-soprano alto tenor baritone baritone-c +;; baritone-f bass sub-bass double-bass +;; percussion quad-bass double-treble quad-treble + +(defparameter +cmn-clefs+ '((:subbass-8dn . sub-bass) (:bass-8dn . double-bass) (:c-baritone-8dn . baritone-c) (:f-baritone-8dn . baritone-f) (:tenor-8dn . tenor) + (:subbass . sub-bass) (:alto-8dn . alto) (:bass . bass) (:mezzosoprano-8dn . mezzo-soprano) (:c-baritone . baritone-c) (:f-baritone . baritone-f) + (:soprano-8dn . soprano) (:tenor . tenor) (:subbass-8up . sub-bass) (:treble-8dn . tenor-treble) (:alto . alto) (:bass-8up . bass) + (:mezzosoprano . mezzo-soprano) (:c-baritone-8up . baritone-c) (:f-baritone-8up . baritone-f) (:soprano . soprano) (:tenor-8up . tenor) + (:treble . treble) (:alto-8up . alto) (:mezzosoprano-8up . mezzo-soprano) (:soprano-8up . soprano) (:treble-8up . double-treble) + (:percussion . percussion))) + +(defparameter +cmn-options+ '((automatic-rests nil) (implicit-accidental-duration 1) (implicit-accidental-style :new-style))) + +(defun internalize (x) + (typecase x + (keyword x) + (symbol (intern (symbol-name x))) + (list (mapcar #'internalize x)) + (otherwise x))) + +;; (defparameter +cmn-writeflags+ '(:escape t)) + +(defparameter +cmn-out-ext+ "eps") + +;; (defun save-cmn (parts header filename options process view) nil) + (defun save-cmn (parts header filename options process view) - ;; (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 (and (not *cmn-exists*) (or process view)) ;; for viewing only + (format t ";; ERROR: Common Music Notation required for CMN output~%") + (return-from save-cmn)) (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 + (destructuring-bind (&key score-attr out-ext &allow-other-keys) options (format f "~A" header) - (let ((de 0) (phash (make-hash-table :test 'eq))) - (flet ((cmnnote (wnum acc1 acc2 wdur hide caut harmt harms) + (let ((de 0) (phash (make-hash-table :test 'equal))) + (flet ((cmndur (val m) (* val (timesig-beat* (meas-timesig m)) 4)) + (cmnnote (wnum acc1 acc2 dur hide show caut harmt harms) ;; wdur is actual dur * beat * 4 (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) - (when (and acc caut) (setf acc (list acc 'in-parentheses))) - (list 'note - (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) - (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) - (format nil "~D" (truncate wnum 12)))) - (svref wdur - - - - (if *quartertones* - (conc-strings - (svref +cmn-num-note+ (mod wnum 12)) - (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) - (svref +cmn-num-reg+ (1- (truncate wnum 12))) - (when caut "?")) - (conc-strings - (svref +cmn-num-note+ (mod wnum 12)) - (svref +cmn-num-acc+ (+ acc1 2)) - (svref +cmn-num-reg+ (1- (truncate wnum 12))) - (when caut "?")))) + (when caut (setf acc (list acc 'in-parentheses))) + (when (and (equal acc 'natural) (not show)) (setf acc nil)) + (nconc (list (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) + (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) + (format nil "~D" (1- (truncate wnum 12))))) + (or (lookup dur +cmn-durations+) (list 'rq dur))) + (unless (member acc '(nil flat natural sharp)) (list acc))))) (cmnname (p) (incf de) (intern @@ -64,58 +94,89 @@ (string (code-char (+ 64 de))))))) (let ((cmp (loop for p in parts nconc (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) - (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) - for v in voices and vi from 1 ... - for pna = (format nil "~A~D" cmn-partname vi) nconc - (loop with ns = (instr-staves (part-instr p)) - and o = 0 - for s in ns and si from 1 collect - (setf (maphash p phash) - `(,(if (> ns 1) (format nil "~A~D" pna si) pna0) - (staff - ,@(when (part-name p) (staff-name (part-name p))) - ,@(when (> ns 1) (tied-to (format nil "~A1" pna))) - ,@(loop for m in (part-meas p) nconc - (loop for e in (meas-events m) collect - (let ((nch (if (chordp e) + (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) + for vi from 0 below nvce nconc ; loop through voices + (loop with pna = (if (> nvce 1) (format nil "~A~D" cmn-partname (1+ vi)) cmn-partname) + and ns = (instr-staves (part-instr p)) ; number of staves + for si from 1 to ns + for ipna = (intern (if (> ns 1) + (if (> nvce 0) + (format nil "~A~D~D" pna (1+ vi) si) + (format nil "~A1~D" pna si)) + (if (> nvce 0) + (format nil "~A~D" pna (1+ vi)) + pna))) + do (setf (gethash p phash) (nconc (gethash p phash) (list ipna))) + collect + `(,ipna + (staff bar + ,@(when (and (<= si 1) (part-name p)) (list (list 'staff-name (part-name p)))) + ,@(when (> vi 0) + (list (list 'tied-to (intern (if (> ns 1) + (format nil "~A1~D" pna si) + (format nil "~A1" pna)))))) + ,(lookup (second (find si (getprops p :clef) :key #'third)) +cmn-clefs+) + ,@(loop with o = 0 and st = 1 + for m in (part-meas p) + and stoff = 0 then (+ stoff lmdur) + for lmdur = (cmndur (- (meas-endoff m) (meas-off m)) m) + when (getprop m :startsig) collect (list 'meter (timesig-num (meas-timesig m)) (timesig-den (meas-timesig m))) + nconc + (loop for e in (nth vi (meas-events m)) + for co = (+ stoff (cmndur (- (event-off e) (meas-off m)) m)) + do (setf st (or (third (getmark e '(:staff :voice))) st)) + when (= st si) collect + (let ((y (if (restp e) + (or (lookup (cmndur (event-dur* e) m) +cmn-restdurs+) (error "Finish me")) + (if (chordp e) + (cons 'chord (loop - for (n nn) on (event-notes* e) + for n in (event-writtennotes e) and w in (event-writtennotes e) and a in (event-accs e) and a2 in (event-addaccs e) for ha = (getmark e (list :harmonic :touched n)) and hs = (getmark e (list :harmonic :sounding n)) collect (cmnnote w a a2 + (cmndur (event-dur* e) m) + (getmark e (list :hideacc n)) + (getmark e (list :showacc n)) (getmark e (list :cautacc n)) (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n)))) - (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) - (getmark e (list :cautacc (event-note* e))) - (getmark e (list :harmonic :touched n)) - (getmark e (list :harmonic :sounding n)))))))) - collect (let ((b (getprop m :barline))) (lookup (second b) +cmn-barlines+)) - - - - - (write - `(cmn ,score-attr - (let , - - - - - - ,@(labels ((pfn (pps &optional (grp 1)) - (loop for e = (pop pps) ; e = part - 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 + (getmark e (list :harmonic :sounding n))))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) + (cmndur (event-dur* e) m) + (getmark e (list :hideacc (event-writtennote e))) + (getmark e (list :showacc (event-writtennote e))) + (getmark e (list :cautacc (event-writtennote e))) + (getmark e (list :harmonic :touched (event-writtennote e))) + (getmark e (list :harmonic :sounding (event-writtennote e)))))))) + (if (> co o) (nconc y (list (list 'onset co))) y)) + and do (setf o (+ co (cmndur (event-dur e) m)))) + collect (let ((b (getprop m :barline))) + (if (>= o (+ stoff lmdur)) + (lookup (second b) +cmn-barlines+) + (list (lookup (second b) +cmn-barlines+) + (list 'onset (setf o (+ stoff lmdur))))))))))))))) + (prin1 (internalize '(in-package cmn)) f) + (fresh-line f) + (prin1 + (internalize + `(cmn ,@(remove-duplicates (append +cmn-options+ score-attr (list (list 'output-file (change-filename filename :ext (or out-ext +cmn-out-ext+))))) + :key (lambda (x) (if (consp x) (first x) x)) :from-end t) + (let* ,cmp + ,@(labels ((pfn (pps &optional (grp 1)) + (loop for e = (pop pps) ; e = part + while e + for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) ; startgroups = grp or greater + if gr nconc (let* ((gg (first (sort gr #'< :key #'second))) + (gl (second gg)) ; gl = level + (ps (pfn (loop for i = e then (pop pps) collect i until (getprop e (list :endgroup gl))) (1+ gl)))) + (case (third gg) + ((:group :choirgroup) (list (append '(system bracket) ps))) + (:grandstaff (list (append '(system brace) ps))) + (otherwise (list (append '(system) ps))))) + else nconc (gethash e phash)))) + (pfn parts))))) + f) + (fresh-line f))))))) --- /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/19 00:02:35 1.22 +++ /project/fomus/cvsroot/fomus/backend_ly.lisp 2006/01/26 05:48:21 1.23 @@ -14,10 +14,10 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix)) #+allegro -(defun run-allegro-cmd (cmd) +(defun run-allegro-cmd (cmd &optional (wait t)) (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) - (sys:os-wait nil p) - ostr)) + (declare (ignore istr)) + (values (if wait (sys:os-wait nil p) 0) ostr))) #+(or linux darwin unix) (defun find-exe (filename) @@ -78,7 +78,7 @@ (apply #'vector (cons (or view-exe +lilypond-view-exe+) (cons (or view-exe +lilypond-view-exe+) (append (or view-exe-opts +lilypond-view-opts+) - (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))))))) 0) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+))))))) nil) 0) (er "viewing")))) (er "compiling"))) #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) @@ -89,7 +89,7 @@ (setf *lilypond-version* (destructuring-bind (&key exe &allow-other-keys) options (let ((os #+(or cmu sbcl openmcl) (make-string-output-stream) - #+allegro (ignore-errors (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v"))))) + #+allegro (ignore-errors (nth-value 1 (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v")))))) #+(or cmu sbcl openmcl) (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) (list "-v") :wait t :output os)) @@ -275,9 +275,9 @@ (cond ((and g1 (getmark e :endgrace)) (if gs (if (< g 0) "\\acciaccatura " "\\appoggiatura ") "\\grace ")) (g1 (if gs (if (< g 0) "\\acciaccatura {" "\\appoggiatura {") "\\grace {")))) "")) - (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\\< ") - ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\\> ") - (t "")) +;; (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\\< ") +;; ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\\> ") +;; (t "")) (cond ((getmark e '(:arpeggio :up)) "\\arpeggioUp ") ((getmark e '(:arpeggio :down)) "\\arpeggioDown ") ((getmark e :arpeggio) "\\arpeggioNeutral ") @@ -385,16 +385,19 @@ (2 "\\doublesharp"))) when (eq cdi :d) collect "_" and collect (car i))) (cond ((or (getmark e :endwedge<) (getmark e :endwedge>)) "\\!") - ((getmark e :startwedge<) "\\<") - ((getmark e :startwedge>) "\\>") +;; ((getmark e :startwedge<) "\\<") +;; ((getmark e :startwedge>) "\\>") (t "")) (conc-stringlist (loop for i in (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a)))) collect (lookup (first i) +lilypond-dyns+))) - (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\\<") - ((and (getmark e :startwedge>) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\\>") - (t "")) + (cond ((getmark e :startwedge<) "\\< ") + ((getmark e :startwedge>) "\\> ") + (t "")) +;; (cond ((and (getmark e :startwedge<) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\\<") +;; ((and (getmark e :startwedge>) (not (getmark e :endwedge<)) (not (getmark e :endwedge>))) "\\>") +;; (t "")) (conc-stringlist (loop for x in '(:text :textdyn :texttempo :textnote) and m in (list (or text-markup +lilypond-text+) --- /project/fomus/cvsroot/fomus/marks.lisp 2006/01/19 00:02:35 1.13 +++ /project/fomus/cvsroot/fomus/marks.lisp 2006/01/26 05:48:21 1.14 @@ -53,9 +53,8 @@ (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners do (loop for p of-type partex in pts do (loop - with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 - for e of-type (or noteex restex) in (reverse (part-events p)) ; go backwards, find endsyms - do + with ss = (make-hash-table :test 'eql) and nu of-type (integer 0) = 0 and sta + for (e nxe) of-type ((or noteex restex) (or noteex restex null)) on (reverse (part-events p)) do ; go backwards, find endsyms (loop for (xxx a1) of-type (t (or (integer 1) null)) in (sort (nconc (when contsym (loop for x = (popmark e contsym) while x collect (force-list x))) ; a1 is level @@ -64,7 +63,7 @@ do (let ((lv (or a1 1))) (unless (gethash lv ss) (setf (gethash lv ss) (incf nu)) - (addmark e (list endsym nu))))) + (addmark e (list endsym nu))))) (loop ; find startsyms for rr0 of-type cons in (sort (loop for x = (popmark e startsym) @@ -86,9 +85,12 @@ (addmark e (nconc (list startsym n) (when a3 (list a3)) (when a2 (list a2)))) ; fixed order now--level is mandatory 1st argument, string is second if text, modifier is last and optional (decf nu)) (error "Levels for marks ~S, ~S and ~S are out of order at offset ~S, part ~S" startsym contsym endsym (event-foff e) (part-name p))) - #|(error "Missing end mark ~S or ~S for start mark ~S at offset ~S, part ~S" contsym endsym startsym (event-foff e) (part-name p))|#)))) - (loop for l being each hash-value in ss do (addmark e (list contsym l))) - #|finally (or (= nu 0) (error "Missing start mark ~S in part ~S" startsym (part-name p)))|#) + (progn + (loop for (a b) of-type ((or noteex restex) (or noteex restex null)) on sta + if b do (addmark a (list contsym 1)) else do (addmark a (list endsym 1)) + (addmark e (nconc (list startsym 1) (when a3 (list a3)) (when a2 (list a2)))))))))) + (loop for l being each hash-value in ss do (addmark e (list (if nxe contsym startsym) l))) + (push e sta)) (print-dot)))) (defun expand-marks (pts) --- /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/19 00:02:35 1.17 +++ /project/fomus/cvsroot/fomus/postproc.lisp 2006/01/26 05:48:21 1.18 @@ -252,22 +252,22 @@ when (and (list1p g) (restp (first g))) do (addmark (first g) :measrest))) (print-dot))) +;; leave middle marks (defun postproc-spanners (pts) (declare (type list pts)) (loop - for (startsym xxx endsym replsym) of-type (symbol t symbol symbol) in (append +marks-spanner-voices+ +marks-spanner-staves+) ;; fix any notes with starts/ends on same note + for (startsym xxx endsym replsym) of-type (symbol symbol symbol symbol) in (append +marks-spanner-voices+ +marks-spanner-staves+) ;; fix any notes with starts/ends on same note unless (truep replsym) do (loop for p of-type partex in pts - do (loop for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (meas-events x)) - do (loop - for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) - for lv = (second ma) - when (getmark e (if lv (list endsym lv) endsym)) - do - (rmmark e (if lv (list startsym lv) startsym)) - (rmmark e (if lv (list endsym lv) endsym)) - (when replsym (addmark e (let ((x (cddr ma))) - (if x (cons replsym x) replsym)))))) + do (loop for e of-type (or noteex restex) in (loop for x of-type meas in (part-meas p) append (meas-events x)) do + (loop + for ma of-type cons in (mapcar #'force-list (getmarks e startsym)) + for lv = (second ma) + when (getmark e (if lv (list endsym lv) endsym)) + do + (rmmark e (if lv (list startsym lv) startsym)) + (rmmark e (if lv (list endsym lv) endsym)) + when replsym do (addmark e (nconc (list replsym lv) (cddr ma))))) (print-dot)))) (defun postproc-barlines (pts) --- /project/fomus/cvsroot/fomus/test.lisp 2005/11/12 20:42:46 1.20 +++ /project/fomus/cvsroot/fomus/test.lisp 2006/01/26 05:48:21 1.21 @@ -5,7 +5,7 @@ ;; Example 1 (fomus - :backend '((:data) (:lilypond :view nil) (:midi :tempo 120 :delay 1 :play nil)) + :backend '((:data) (:lilypond :view t) (:midi :tempo 120 :delay 1 :play nil)) :ensemble-type :orchestra :parts (list @@ -237,6 +237,7 @@ (fomus :backend '((:data) (:lilypond :view t) (:midi :tempo 80 :delay 1)) :ensemble-type :orchestra + :auto-grace-slurs nil :parts (list (make-part --- /project/fomus/cvsroot/fomus/version.lisp 2006/01/19 00:02:35 1.24 +++ /project/fomus/cvsroot/fomus/version.lisp 2006/01/26 05:48:21 1.25 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 29)) +(defparameter +version+ '(0 1 30)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved"

1 0

[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_cmn.lisp fomus/backend_ly.lisp fomus/classes.lisp fomus/data.lisp fomus/main.lisp fomus/marks.lisp fomus/misc.lisp fomus/postproc.lisp fomus/staves.lisp fomus/version.lisp fomus/voices.lisp
by dpsenicka＠common-lisp.net 19 Jan '06

19 Jan '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv29848 Modified Files: accidentals.lisp backend_cmn.lisp backend_ly.lisp classes.lisp data.lisp main.lisp marks.lisp misc.lisp postproc.lisp staves.lisp version.lisp voices.lisp Log Message: more fixes Date: Wed Jan 18 18:02:35 2006 Author: dpsenicka Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.13 fomus/accidentals.lisp:1.14 --- fomus/accidentals.lisp:1.13 Tue Nov 15 19:26:30 2005 +++ fomus/accidentals.lisp Wed Jan 18 18:02:35 2006 @@ -67,15 +67,15 @@ ;; numbers to determine importance of accidentals (declaim (type (real 1) *max-acc-beat-dist-mul*)) (defparameter *max-acc-beat-dist-mul* 2) ; number of beats of rest before not caring about interval spelling -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-dist-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-dist-score*)) (defparameter *acc-dist-score* (float 1/3)) -(declaim (type #-openmcl (float (0)) #+openmcl float *acc-beat-dist* *acc-octave-dist*)) +(declaim (type #-(or openmcl allegro) (float (0)) #+(or openmcl allegro) float *acc-beat-dist* *acc-octave-dist*)) (defparameter *acc-beat-dist* (float 3/2)) ; number of beats where beat distance score = acc-dist-score (defparameter *acc-octave-dist* (float 2)) ; number of octaves where octave distance score = acc-dist-score (default is 1.0 octaves = 2 beats = 2/3 of total score) ;; don't need to check if beat distance is past max -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-beat-dist-sc* *acc-octave-dist-sc*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-beat-dist-sc* *acc-octave-dist-sc*)) (declaim (special *acc-beat-dist-sc* *acc-octave-dist-sc*)) (defun nokey-notedist (tie note1 off1 eoff1 note2 off2 eoff2) (declare (type boolean tie) (type rational note1 note2) (type (real 0) off1 eoff1 off2 eoff2)) @@ -91,7 +91,8 @@ (defparameter +nokey-penalty+ (vector '(1) '(-1 1) '(-1) '(1) '(-1 1) '(-1 1) '(-1))) (defparameter +nokey-harmints+ (vector 0 1 1 2 2 3 4 4 5 5 6 6)) -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*)) (defparameter *acc-diatonic-int-score* (float 7/8)) (defparameter *acc-aug-dim-int-score* (float 1/2)) (defparameter *acc-spelling-penalty* (float 1/4)) @@ -157,7 +158,7 @@ ;; depth-first search branching down only top score group (same scores) ;; DESTRUCTIVE (defstruct (nokeynode (:copier nil) (:predicate nokeynodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (ret nil :type list) (re 0 :type (integer 0)) (evs nil :type list) @@ -170,7 +171,7 @@ (type (function (rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (values (or (integer 0 6) null) (or integer null))) spellfun) (type (function (boolean rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0) rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0)) - #-openmcl (float 0 1) #+openmcl float) intscorefun) + #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float) intscorefun) (type (or string null) name) (type (function ((or (cons (integer -2 2) (rational -1/2 1/2)) (integer -2 2))) cons) conv)) (let ((co 0) (mxd (* *acc-beat-dist* *max-acc-beat-dist-mul*)) @@ -179,7 +180,7 @@ (flet ((scorefun (no) ; optimistic score (declare (type nokeynode no)) (cons (+ (nokeynode-sc no) - (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (nokeynode-evd no) sum (car e)) + (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (nokeynode-evd no) sum (car e)) (nokeynode-re no)) ; unexplored accidentals all scores of 1 (nokeynode-co no))) (expandfun (no) @@ -205,14 +206,14 @@ (s (nokeynode-sc no))) (let ((d (cons w (or (loop ; keep only relevant notes that will need rescoring (endoff > - ? beats) - for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) ; e is (score . event) + for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) ; e is (score . event) if (> (event-endoff (cdr e)) oo) ; endoff will = offset for grace notes! collect (cdr e) ; collect just the events else do (incf s (car e))) - (let ((mx (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + (let ((mx (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) maximize (event-endoff (cdr e))))) (setf s (nokeynode-sc no)) - (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) if (>= (event-endoff (cdr e)) mx) collect (cdr e) else do (incf s (car e))))))) @@ -229,7 +230,7 @@ (let* ((eua (event-useracc e)) (ne (event-note* e)) (su (- 1.0 (funcall penfun ne eua))) (di 1.0)) - (declare (type #-openmcl (float 0) #+openmcl float su di)) + (declare (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float su di)) (loop ; plus optimistic 1 scores for rest in range for e0 of-type noteex in lf while (<= (event-off e0) (event-off e)) @@ -252,9 +253,9 @@ e)) :re (1- (nokeynode-re no)) :ret (cons w (nokeynode-ret no)) :evs lf))))) - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (> (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (> (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (< (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type nokeynode no)) (null (nokeynode-evs no)))) (nokeynode-ret @@ -262,13 +263,13 @@ (*acc-engine-heap* (max (roundint (* *acc-engine-heap* *quality*)) 1)) (*acc-beat-dist-sc* (expt *acc-dist-score* (/ *acc-beat-dist*))) (*acc-octave-dist-sc* (expt *acc-dist-score* (/ *acc-octave-dist*)))) - (a*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already - #'scorefun - #'expandfun - #'solutfun - :heaplim *acc-engine-heap* - :scoregreaterfun #'scoregreaterfun - :remscoregreaterfun #'remscoregreaterfun)) + (bfs*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already + #'scorefun + #'expandfun + #'solutfun + :heaplim *acc-engine-heap* + :scoregreaterfun #'scoregreaterfun + :remscoregreaterfun #'remscoregreaterfun)) (error "Cannot find valid note spellings for part ~S" name)))))) ; return events sorted (declaim (type boolean *use-double-accs*)) @@ -405,8 +406,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; POST PROCESSING -;; (defparameter *acc-throughout-meas* t) - ;; rests are removed already, after chords & ties ;; events are events in 1 measure (defun acc-nokey-postaccs (events) Index: fomus/backend_cmn.lisp diff -u fomus/backend_cmn.lisp:1.2 fomus/backend_cmn.lisp:1.3 --- fomus/backend_cmn.lisp:1.2 Fri Nov 11 16:03:16 2005 +++ fomus/backend_cmn.lisp Wed Jan 18 18:02:35 2006 @@ -10,20 +10,105 @@ (defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%") +(defparameter +cmn-num-note+ (vector "C" nil "D" nil "E" "F" nil "G" nil "A" nil "B")) +(defparameter +cmn-num-acc+ (vector 'double-flat 'flat 'natural 'sharp 'double-sharp)) +(defparameter +cmn-num-accq+ (vector (vector nil 'double-flat) (vector 'flat-down 'flat 'natural-down) (vector 'natural-down 'natural 'natural-up) + (vector 'natural-up 'sharp 'sharp-up) (vector nil 'double-sharp))) + +(defparameter +cmn-barlines+ '((nil . bar) (:single . bar) (:double . interior-double-bar) (:final . double-bar) + (:repeatleft . end-repeat-bar) (:repeatright . begin-repeat-bar) (:repeatleftright . begin-and-end-repeat-bar) + (:invisible . (bar invisible)))) + (defun save-cmn (parts header filename options process view) ;; (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) + (let ((de 0) (phash (make-hash-table :test 'eq))) + (flet ((cmnnote (wnum acc1 acc2 wdur hide caut harmt harms) + (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) + (when (and acc caut) (setf acc (list acc 'in-parentheses))) + (list 'note + (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) + (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) + (format nil "~D" (truncate wnum 12)))) + (svref wdur + + + + (if *quartertones* + (conc-strings + (svref +cmn-num-note+ (mod wnum 12)) + (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) + (svref +cmn-num-reg+ (1- (truncate wnum 12))) + (when caut "?")) + (conc-strings + (svref +cmn-num-note+ (mod wnum 12)) + (svref +cmn-num-acc+ (+ acc1 2)) + (svref +cmn-num-reg+ (1- (truncate wnum 12))) + (when caut "?")))) + (cmnname (p) + (incf de) + (intern + (conc-strings + (string-upcase + (conc-stringlist (loop for x across (part-name p) + when (alpha-char-p x) + collect (string x)))) + "-" + (string (code-char (+ 64 de))))))) + (let ((cmp (loop for p in parts nconc + (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) + (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) + for v in voices and vi from 1 ... + for pna = (format nil "~A~D" cmn-partname vi) nconc + (loop with ns = (instr-staves (part-instr p)) + and o = 0 + for s in ns and si from 1 collect + (setf (maphash p phash) + `(,(if (> ns 1) (format nil "~A~D" pna si) pna0) + (staff + ,@(when (part-name p) (staff-name (part-name p))) + ,@(when (> ns 1) (tied-to (format nil "~A1" pna))) + ,@(loop for m in (part-meas p) nconc + (loop for e in (meas-events m) collect + (let ((nch (if (chordp e) + (loop + for (n nn) on (event-notes* e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + for ha = (getmark e (list :harmonic :touched n)) + and hs = (getmark e (list :harmonic :sounding n)) + collect (cmnnote w a a2 + (getmark e (list :cautacc n)) + (getmark e (list :harmonic :touched n)) + (getmark e (list :harmonic :sounding n)))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) + (getmark e (list :cautacc (event-note* e))) + (getmark e (list :harmonic :touched n)) + (getmark e (list :harmonic :sounding n)))))))) + collect (let ((b (getprop m :barline))) (lookup (second b) +cmn-barlines+)) + + + + (write `(cmn ,score-attr + (let , + + + + + ,@(labels ((pfn (pps &optional (grp 1)) - (loop for e = (pop pps) - for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) + (loop for e = (pop pps) ; e = part + 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) @@ -33,4 +118,4 @@ (loop )))) (pfn parts))) :stream f - :escape nil)))) \ No newline at end of file + :escape nil)))|#) \ No newline at end of file Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.21 fomus/backend_ly.lisp:1.22 --- fomus/backend_ly.lisp:1.21 Sat Nov 12 14:42:46 2005 +++ fomus/backend_ly.lisp Wed Jan 18 18:02:35 2006 @@ -13,6 +13,12 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix)) +#+allegro +(defun run-allegro-cmd (cmd) + (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) + (sys:os-wait nil p) + ostr)) + #+(or linux darwin unix) (defun find-exe (filename) (namestring* @@ -43,31 +49,51 @@ (flet ((er (str) (format t ";; ERROR: Error ~A lilypond file~%" str) (return-from view-lilypond))) - #+(and (or cmu sbcl openmcl) (or linux darwin unix)) + #+(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (progn (ignore-errors (delete-file (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd (change-filename filename :name nil :ext nil)) - (if (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) - (append (or exe-opts +lilypond-opts+) (list filename)) :wait t #|:output *standard-output*|#) + (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir + (change-filename filename :name nil :ext nil)) + (if #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)) + :wait t) + #+allegro (= (run-allegro-cmd (apply #'vector (cons (or exe +lilypond-exe+) + (cons (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)))))) 0) (progn (unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling")) + (ignore-errors (delete-file (change-filename filename :ext "log"))) + (unless (string= (or out-ext +lilypond-out-ext+) "tex") (ignore-errors (delete-file (change-filename filename :ext "tex")))) + (unless (string= (or out-ext +lilypond-out-ext+) "dvi") (ignore-errors (delete-file (change-filename filename :ext "dvi")))) + (unless (string= (or out-ext +lilypond-out-ext+) "ps") (ignore-errors (delete-file (change-filename filename :ext "ps")))) + (unless (string= (or out-ext +lilypond-out-ext+) "pdf") (ignore-errors (delete-file (change-filename filename :ext "pdf")))) (when view - (unless (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or view-exe +lilypond-view-exe+) - (append (or view-exe-opts +lilypond-view-opts+) (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - :wait nil #|:output *standard-output*|#) - (er "viewing")))) + (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) + :wait nil) + #+allegro (= (run-allegro-cmd + (apply #'vector (cons (or view-exe +lilypond-view-exe+) + (cons (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))))))) 0) + (er "viewing")))) (er "compiling"))) - #-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) + #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) (defparameter *lilypond-version* t) (defun lilypond-version (options) (if (truep *lilypond-version*) (setf *lilypond-version* (destructuring-bind (&key exe &allow-other-keys) options - (let ((os (make-string-output-stream))) - (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) - (list "-v") :wait t :output os)) - (let* ((out (get-output-stream-string os)) + (let ((os #+(or cmu sbcl openmcl) (make-string-output-stream) + #+allegro (ignore-errors (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v"))))) + #+(or cmu sbcl openmcl) (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or exe +lilypond-exe+) + (list "-v") :wait t :output os)) + (let* ((out #+(or cmu sbcl openmcl) (get-output-stream-string os) #+allegro (read-line os)) (p (search "LilyPond " out))) (when p (multiple-value-bind (n1 np) (parse-integer out :start (+ p 9) :junk-allowed t) (+ (* n1 100) (parse-integer out :start (1+ np) :junk-allowed t)))))))) @@ -106,14 +132,6 @@ (defparameter +lilypond-num-reg+ (vector ",,," ",," "," "" "'" "''" "'''" "''''" "'''''")) (defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . ""))) -;; sets and overrides -;;(defparameter +lilypond-set-acc-style-default+ "#(set-accidental-style 'default)") -;;(defparameter +lilypond-set-acc-style-forget+ "#(set-accidental-style 'forget)") -;;(defparameter +lilypond-set-timesig-style-frac+ "\\override Staff.TimeSignature #'style = #'()") -;;(defparameter +lilypond-set-tup-style-ratio+ "\\set tupletNumberFormatFunction = #fraction-tuplet-formatter") -;;(defparameter +lilypond-set-instrument+ "\\set Staff.instrument = ~S") -;;(defparameter +lilypond-set-instr+ "\\set Staff.instr = ~S") - (defparameter +lilypond-marks+ '((:accent . "->") (:marcato . "-^") (:staccatissimo . "-|") (:staccato . "-.") (:tenuto . "--") (:portato . "-_") (:upbow . "\\upbow") (:downbow . "\\downbow") (:thumb . "\\thumb") (:leftheel . "\\lheel") (:rightheel . "\\rheel") (:lefttoe . "\\ltoe") (:righttoe . "\\rtoe") (:open . "\\open") @@ -168,12 +186,12 @@ (conc-strings (svref +lilypond-num-note+ (mod wnum 12)) (svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) (when caut "?")) (conc-strings (svref +lilypond-num-note+ (mod wnum 12)) (svref +lilypond-num-acc+ (+ acc1 2)) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) (when caut "?")))) (lyname (p) (incf de) @@ -198,7 +216,7 @@ (when (or (null *timesig-style*) (eq *timesig-style* :fraction)) (if (> ns 1) (loop for s from 1 to ns do - (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|#)) + (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))))) (format f " \\override Staff.TimeSignature #'style = #'()~%"))) (when (eq *tuplet-style* :ratio) (format f " \\set tupletNumberFormatFunction = #fraction-tuplet-formatter~%")) (format f " \\autoBeamOff~%") @@ -207,7 +225,7 @@ (format f " #(set-accidental-style 'forget)~%")) (if (> ns 1) (loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do - (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|# (lyclef cl))) + (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) (lyclef cl))) (format f " \\clef ~A~%" (lyclef (second (getprop p :clef))))) (loop for e in lily-parthead do (format f " ~A~%" e)) (format f "~%") @@ -228,20 +246,17 @@ (when (getmark e '(:starttext- 2)) (setf twrn t)) (format f "~A " (conc-strings -;; (if (list>1p (meas-events m)) - (let ((m (getmark e '(:voice :ord1324)))) - (if (and m (null (fourth m))) - (case (third m) - (1 (setf cdi :u) "\\voiceOne ") - (2 (setf cdi :d) "\\voiceTwo ") - (3 (setf cdi :u) "\\voiceThree ") - (4 (setf cdi :d) "\\voiceFour ") - (otherwise (setf cdi :u) "\\oneVoice ")) - "")) -;; "") + (let ((m (getmark e '(:voice :ord1324)))) + (if (and m (null (fourth m))) + (case (third m) + (1 (setf cdi :u) "\\voiceOne ") + (2 (setf cdi :d) "\\voiceTwo ") + (3 (setf cdi :u) "\\voiceThree ") + (4 (setf cdi :d) "\\voiceFour ") + (otherwise (setf cdi :u) "\\oneVoice ")) + "")) (let ((m (getmark e '(:staff :voice)))) - (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) - #|(print (lystaff (third m)))|# "")) + (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m)))) "")) (let ((c (getmark e :clef))) (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c))) "")) @@ -255,9 +270,10 @@ collect (format nil "\\times ~A/~A {" (cdr r) (car r))))) (let ((g (event-grace e))) (if g - (let ((g1 (getmark e :startgrace))) - (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\\acciaccatura " "\\appoggiatura ")) - (g1 (if (< g 0) "\\acciaccatura {" "\\appoggiatura {")))) + (let ((g1 (getmark e :startgrace)) + (gs (getmark e :startgraceslur-))) + (cond ((and g1 (getmark e :endgrace)) (if gs (if (< g 0) "\\acciaccatura " "\\appoggiatura ") "\\grace ")) + (g1 (if gs (if (< g 0) "\\acciaccatura {" "\\appoggiatura {") "\\grace {")))) "")) (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\\< ") ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\\> ") @@ -299,7 +315,7 @@ (lynote (event-writtennote e) (event-acc e) (event-addacc e) (getmark e (list :cautacc (event-note* e)))) (let ((ha (getmark e :harmonic))) - (when ha (ecase (second ha) (:harmonic "\\harmonic") (:touched "^\\flageolet")))))) + (when ha (ecase (second ha) (:touched "\\harmonic") (:sounding "^\\flageolet")))))) (if fm (if (event-inv e) "\\skip " "R") (if (event-inv e) "s" "r"))) (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) (multiple-value-bind (wd ds) (let ((m (or (getmark e :tremolo) Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.14 fomus/classes.lisp:1.15 --- fomus/classes.lisp:1.14 Fri Nov 11 16:49:35 2005 +++ fomus/classes.lisp Wed Jan 18 18:02:35 2006 @@ -44,7 +44,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (sb-ext:with-unlocked-packages ("COMMON-LISP") (defclass rest (dur-base) ()))) ; only w/ xml in special cases--must not overlap a note-event!!! -#-sbcl +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (excl:without-package-locks + (defclass rest (dur-base) ()))) +#-(or sbcl allegro) (defclass rest (dur-base) ()) ; only w/ xml in special cases--must not overlap a note-event!!! (defclass part (fomusobj-base) @@ -67,7 +71,10 @@ (defprint timesig id (partid :partids) off time comp beat div repl props) (defprint mark id partid off voice marks) (defprint note id partid voice off dur note marks) -(defprint rest id partid voice off dur marks) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) + (excl:without-package-locks + (defprint rest id partid voice off dur marks))) +#-allegro (defprint rest id partid voice off dur marks) (defprint part id partid name abbrev instr events opts) (defprint meas id off endoff timesig div events props) Index: fomus/data.lisp diff -u fomus/data.lisp:1.27 fomus/data.lisp:1.28 --- fomus/data.lisp:1.27 Sat Nov 12 14:42:46 2005 +++ fomus/data.lisp Wed Jan 18 18:02:35 2006 @@ -135,9 +135,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INSTRUMENTS -(declaim (type list *percussion*)) -(defparameter *percussion* nil) - (defstruct (perc (:constructor make-perc-aux) (:copier nil) (:predicate percp)) (sym nil :type (or symbol real)) (staff 1 :type (integer 1)) Index: fomus/main.lisp diff -u fomus/main.lisp:1.19 fomus/main.lisp:1.20 --- fomus/main.lisp:1.19 Sat Nov 12 14:42:46 2005 +++ fomus/main.lisp Wed Jan 18 18:02:35 2006 @@ -205,10 +205,3 @@ r (rest xx) (or process view) play view))))) t) -;; #+allegro (excl:current-directory) -;; #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) -;; #+(or cmu scl) (ext:default-directory) -;; #+sbcl (sb-unix:posix-getcwd/) -;; #+cormanlisp (ccl:get-current-directory) -;; #+lispworks (hcl:get-working-directory) -;; #+mcl (ccl:mac-default-directory) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.12 fomus/marks.lisp:1.13 --- fomus/marks.lisp:1.12 Sat Oct 22 15:43:06 2005 +++ fomus/marks.lisp Wed Jan 18 18:02:35 2006 @@ -48,7 +48,7 @@ ;; input level number only needs to be relative, with lower numbers = inner voices--mark arguments are mod then level ;; output level numbering starts at 1 (conforming to majority of output formats) ;; lower level is more inner -;; this will translate the user input format to a more rigid format for the backends +;; translate the user input format to a more well-defined format for the backends (defun clean-spanners (pts spanners) (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners do (loop for p of-type partex in pts do Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.12 fomus/misc.lisp:1.13 --- fomus/misc.lisp:1.12 Wed Nov 30 17:51:37 2005 +++ fomus/misc.lisp Wed Jan 18 18:02:35 2006 @@ -135,6 +135,8 @@ (loop for e in initial-contents do (heap-ins e hp)) hp)) + + (declaim (inline list>1p list1p)) (defun list>1p (list) (declare (type list list)) @@ -309,10 +311,10 @@ data score (val t :type boolean)) ; val = valid ;; (defconstant +a*-purgeat+ 1000) -;; not necessarily used as A* algorithm +;; BFS algorithm w/ limited heap ;; scorefun must always return optimistic value! (larger is better)--may return two values (second is remscore) ;; if heaplim = a number, limits heap size (ceases to be optimal) -(defun a*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault) +(defun bfs*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault) (declare (type (function (t) t) scorefun solutfun) (type (function (t) list) expandfun) (type (or null (integer 0)) heaplim) (type (function (t t) t) scoregreaterfun remscoregreaterfun)) (let ((*a*-id* -1) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.16 fomus/postproc.lisp:1.17 --- fomus/postproc.lisp:1.16 Sat Jan 7 20:58:43 2006 +++ fomus/postproc.lisp Wed Jan 18 18:02:35 2006 @@ -335,10 +335,11 @@ (setf fx t) (car x)) e))) - (let ((sy (first ma))) ; number of divisions, written durational value of tremolo marking + (let ((sy (first ma)) + (dv (min (/ 1/8 w) (1+ (event-nbeams re (meas-timesig m)))))) ; number of divisions, written durational value of tremolo marking (declare (type symbol sy)) (if (or (not (chordp re)) (eq sy :tremolo)) - (progn (push re ee) (addmark re (list :tremolo d w))) + (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv)))) (loop for n0 of-type rational in (event-notes* re) and nn of-type (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) in (event-note re) and lt of-type boolean in (event-tielt re) @@ -370,7 +371,7 @@ (push e1 ee) (push e2 ee) (setf fx t) (addmark e1 (list :starttremolo (/ d 2) w)) (addmark e2 (list :endtremolo (/ d 2) w)))) - (progn (push re ee) (addmark re (list :tremolo d w))))))))))) + (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv)))))))))))) (push e ee))) finally (setf (meas-events m) (sort ee #'sort-offdur)))) (loop for g of-type cons in (split-into-groups (loop for x of-type meas in (part-meas p) append (meas-events x)) #'event-voice*) do Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.10 fomus/staves.lisp:1.11 --- fomus/staves.lisp:1.10 Tue Sep 13 16:39:14 2005 +++ fomus/staves.lisp Wed Jan 18 18:02:35 2006 @@ -22,7 +22,7 @@ (declaim (type (real 0) *clef-force-clef-change-dist*)) (defparameter *clef-force-clef-change-dist* 2) ; can be nil -(declaim (type (float 0 1) *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*)) +(declaim (type #-allegro (float 0 1) #+allegro float *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*)) (defparameter *clef-change-clef-penalty* (float 1)) (defparameter *clef-change-staff-penalty* (float 1/4)) ; should probably be less than change-clef-penalty @@ -55,7 +55,7 @@ (defparameter *staff-engine-heap* 50) (defstruct (clefnode (:copier nil) (:predicate clefnodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (lo 0 :type (rational 0)) (lg 0 :type (rational 0)) (ics #() :type (vector symbol)) @@ -161,9 +161,9 @@ *clef-order-perbeat-penalty*)) (max (- o (clefnode-lo no)) (clefnode-lg no)))) (return (make-clefnode :sc sc :lo o :lg gd :ics ics :cs cs :lvs lvs :ret (nconc ret (clefnode-ret no)) :evs rs :o o :co nco))))))) ; ret is out of order - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type clefnode no)) (null (clefnode-evs no)))) (let ((*clef-list* (force-list (instr-clefs instr)))) @@ -199,7 +199,7 @@ (cddr (last-element re)) nil) (return (values r re))) (let ((n (or (let ((*staff-engine-heap* (max (roundint (* *staff-engine-heap* *quality*)) 1))) - (a*-engine (list (make-clefnode :ics (make-array nst :initial-element nil) + (bfs*-engine (list (make-clefnode :ics (make-array nst :initial-element nil) :cs (make-array nst :initial-element nil) :lvs (make-array nst :initial-element nil) :evs events)) Index: fomus/version.lisp diff -u fomus/version.lisp:1.23 fomus/version.lisp:1.24 --- fomus/version.lisp:1.23 Sat Jan 7 20:58:43 2006 +++ fomus/version.lisp Wed Jan 18 18:02:35 2006 @@ -12,9 +12,9 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 28)) +(defparameter +version+ '(0 1 29)) (defparameter +banner+ `("Lisp music notation formatter" - "Copyright (c) 2005 David Psenicka, All Rights Reserved" + "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved" "See file \"COPYING\" for terms of use and distribution.")) Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.10 fomus/voices.lisp:1.11 --- fomus/voices.lisp:1.10 Wed Aug 31 16:18:00 2005 +++ fomus/voices.lisp Wed Jan 18 18:02:35 2006 @@ -13,19 +13,20 @@ ;; user specifies a list of voices for voice parameter ;; algorithm decides which one to choose -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*)) (defparameter *voice-high/low-penalty* (float 1/3)) ; voice 1 is higher than voice 2 (defparameter *voice-simult-penalty* (float 1)) ; vertical chords are balanced between voices (defparameter *voice-chord-score* (float 1/12)) ; incentive to group notes of same offset/dur into same voice (defparameter *voice-leading-penalty* (float 1/4)) ; close-together notes are in same voice (defparameter *voice-balance-penalty* (float 1/24)) ; notes are balanced/switched between voices over time -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-dist-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *voice-dist-score*)) (defparameter *voice-dist-score* (float 1/3)) -(declaim (type #-openmcl (float 0) #+openmcl float *voice-octave-dist*)) +(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-octave-dist*)) (defparameter *voice-octave-dist* (float 1)) -(declaim (type #-openmcl (float 0) #+openmcl float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*)) +(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*)) (defparameter *voice-high/low-beat-dist* (float 1/2)) (defparameter *voice-leading-beat-dist* (float 4)) (defparameter *voice-balance-beat-dist* (float 12)) ; effectively the "distance" for maintaining balance between voices @@ -41,15 +42,16 @@ (declaim (inline auto-voices-fun)) (defun auto-voices-fun () (if (truep *auto-voices-mod*) :voices1 *auto-voices-mod*)) -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*) - (type #-openmcl (float 0) #+openmcl float *voice-full-beat-dist*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*) + (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-full-beat-dist*)) (declaim (special *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist* *voice-full-beat-dist-sc*)) ; adj is 1 + lowest (farthest) value (defun voices-notedist-aux1 (note1 note2) ; by octave (declare (type rational note1 note2)) (expt *voice-octave-dist-sc* (/ (diff note1 note2) 12.0))) (defun voices-notedist-aux2 (off1 eoff1 off2 eoff2 beatdist sc) ; by offset - (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-openmcl (float 0 1) #+openmcl float sc)) + (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float sc)) (let ((d (max (- (float off2) (float eoff1)) (- (float off1) (float eoff2)) 0.0))) (if (>= d (* *max-voice-beat-dist-mul* beatdist)) 0.0 (expt sc d)))) @@ -88,7 +90,7 @@ (defparameter *voice-engine-heap* 50) (defstruct (voicenode (:copier nil) (:predicate voicenodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (ret nil :type list) (evs nil :type list) (evc nil :type list) @@ -102,7 +104,7 @@ (flet ((scorefun (no) (declare (type voicenode no)) (cons (+ (voicenode-sc no) - (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (voicenode-evd no) sum (car e))) + (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (voicenode-evd no) sum (car e))) (voicenode-co no))) (expandfun (no) (declare (type voicenode no)) @@ -124,7 +126,7 @@ (s (voicenode-sc no))) (let ((d (cons w (loop ; keep only relevant notes that will need rescoring (endoff > - 8 beats) - for e of-type (cons #-openmcl (float 0 1) #+openmcl float note) in (voicenode-evd no) ; e is (score . event) + for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float note) in (voicenode-evd no) ; e is (score . event) if (>= (event-off (cdr e)) oo) ; endoff will = offset for grace notes! collect (cdr e) ; collect just the events else do (incf s (car e))))) @@ -140,7 +142,8 @@ for e of-type noteex in d collect (cons (loop - with su of-type #-openmcl (float 0) #+openmcl float = 0.0 and di of-type #-openmcl (float 0) #+openmcl float = 0.0 + with su of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0 + and di of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0 for e0 of-type noteex in c unless (eq e e0) do (let ((d0 (voices-notedist (event-note* e) (event-off e) (event-endoff e) @@ -154,9 +157,9 @@ :ret (cons w (voicenode-ret no)) :evs lf :co nco)))) when xx collect xx))) - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type voicenode no)) (null (voicenode-evs no)))) (voicenode-ret @@ -167,7 +170,7 @@ (*voice-leading-beat-dist-sc* (expt *voice-dist-score* (/ *voice-leading-beat-dist*))) (*voice-full-beat-dist-sc* (expt *voice-dist-score* (/ *voice-full-beat-dist*))) (*voice-octave-dist-sc* (expt *voice-dist-score* (/ *voice-octave-dist*)))) - (a*-engine (list (make-voicenode :evs events)) + (bfs*-engine (list (make-voicenode :evs events)) #'scorefun #'expandfun #'solutfun

1 0

[fomus-cvs] CVS update: fomus/TODO fomus/backend_mid.lisp fomus/postproc.lisp fomus/version.lisp
by dpsenicka＠common-lisp.net 08 Jan '06

08 Jan '06

Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv21316 Modified Files: TODO backend_mid.lisp postproc.lisp version.lisp Log Message: bug fix Date: Sun Jan 8 03:58:43 2006 Author: dpsenicka Index: fomus/TODO diff -u fomus/TODO:1.26 fomus/TODO:1.27 --- fomus/TODO:1.26 Thu Dec 1 00:51:37 2005 +++ fomus/TODO Sun Jan 8 03:58:43 2006 @@ -6,6 +6,7 @@ Quantizing nested tuplets--occasional hangups Many more... Doc: list-instr-syms, list-perc-syms + Doc: separate MIDI files for different parts Specifying percussion from MIDI info Automatic percussion instrument changes Splitting chords across staves (LilyPond) Index: fomus/backend_mid.lisp diff -u fomus/backend_mid.lisp:1.9 fomus/backend_mid.lisp:1.10 --- fomus/backend_mid.lisp:1.9 Thu Dec 1 00:51:37 2005 +++ fomus/backend_mid.lisp Sun Jan 8 03:58:43 2006 @@ -121,7 +121,7 @@ (defparameter *grace-dur-secs* 1/12) (declaim (special *gracedur*)) (defparameter *min-amp* 1/10) -(defparameter *trdur-secs* 1/12) ; trill notes per sec. (and unmeasured tremolos) +(defparameter *trdur-secs* 1/16) ; trill notes per sec. (and unmeasured tremolos) (declaim (special *trdur*)) (defparameter *tramp* 3/4) (defparameter *fermata-mults* '(3/2 2 3)) @@ -248,10 +248,10 @@ do (setf (midi-dur* e) (min (+ (midi-dur e) *slur-adddur*) (* (midi-dur n) 3/2)))) ev)))) -(defun save-midi (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename) +(defun save-midi-aux (parts filename options play) ; if play is open stream, then uses rts realtime (ignores filename) (unless *cm-exists* (format t ";; ERROR: Common Music required for MIDI output~%") - (return-from save-midi)) + (return-from save-midi-aux)) (when (>= *verbose* 1) (if (typep play 'boolean) (out ";; Saving MIDI file ~S...~%" filename) (out ";; Scheduling MIDI playback...~%" filename))) (destructuring-bind (&key (nports 1) instr-per-ch events-fun (pbend-width 2) cm-args @@ -314,7 +314,7 @@ (progn (format t ";; ERROR: Too many parts/instruments for ~S port(s)/~S channels (use NPORTS option, MIDI-CH option in parts or MIDIPRGCH-EX slot in instruments to fix)~%" nports (* nports 16)) - (return-from save-midi))))) + (return-from save-midi-aux))))) (unless (is-percussion p) (loop for i in (chs (cdr c)) do (setf (svref (nth (car c) ps) i) @@ -514,4 +514,18 @@ (setf xta (loop for e in (split-into-groups xta #'type-of) nconc (delete-duplicates e :key #'midi-ch))) (if (typep play 'boolean) (apply *cm-events* (sort (nconc xta evs) #'midi-sort) filename :tempo tempo :play play cm-args) - (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args))))) \ No newline at end of file + (apply *cm-rts* (sort (nconc xta evs) #'midi-sort) play :tempo tempo cm-args))))) + +(defun save-midi (parts filename options play) + (flet ((ms (x y) (< (position x parts) (position y parts))) + (me (p) (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p) + (namestring (merge-pathnames midi-filename filename))))) + (loop for ps in (sort (mapcar (lambda (x) (sort x #'ms)) + (split-into-groups (remove-if-not (lambda (p) + (destructuring-bind (&key midi-filename &allow-other-keys) (part-opts p) + midi-filename)) + parts) + #'me :test 'equal)) + #'ms :key #'first) + do (save-midi-aux ps (me (first ps)) options nil))) + (save-midi-aux parts filename options play)) \ No newline at end of file Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.15 fomus/postproc.lisp:1.16 --- fomus/postproc.lisp:1.15 Fri Nov 11 23:03:16 2005 +++ fomus/postproc.lisp Sun Jan 8 03:58:43 2006 @@ -321,10 +321,10 @@ unless xf do (setf xf x) do (push (third x) li) finally (return xf))))) - (if ma (let* ((d (second ma)) + (if ma (let* ((d (second ma)) ; dur. of unit (w (if d (let ((x (event-writtendur (copy-event e :dur d) (meas-timesig m)))) (loop-return-lastmin (diff i x) for i = 1/8 then (/ i 2))) - 1/32))) + 1/32))) ; writ. trem. unit dur. (let ((wd (event-writtendur e (meas-timesig m)))) (multiple-value-bind (d o) (floor wd w) (let ((re (if (> o 0) @@ -351,6 +351,8 @@ (let ((c1 (list>1p n1)) (c2 (list>1p n2)) (d2 (/ (event-dur* re) 2))) + (let ((x (event-tupfrac re))) + (when x (setf (car x) (/ (the rational (car x)) 2)))) (let ((e1 (copy-event re :note (if c1 n1 (the (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (first n1))) Index: fomus/version.lisp diff -u fomus/version.lisp:1.22 fomus/version.lisp:1.23 --- fomus/version.lisp:1.22 Thu Dec 1 00:51:37 2005 +++ fomus/version.lisp Sun Jan 8 03:58:43 2006 @@ -12,7 +12,7 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 27)) +(defparameter +version+ '(0 1 28)) (defparameter +banner+ `("Lisp music notation formatter" "Copyright (c) 2005 David Psenicka, All Rights Reserved"

1 0