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"
