February 2006 - fomus-cvs@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