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"