January 2006 - fomus-cvs@common-lisp.net - mailman3.common-lisp.net

[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 25 Jan '06

25 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 18 Jan '06

18 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 07 Jan '06

07 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