Update of /project/fomus/cvsroot/fomus In directory common-lisp.net:/tmp/cvs-serv4326 Modified Files: README classes.lisp data.lisp fomus.asd load.lisp misc.lisp split.lisp staves.lisp test.lisp Added Files: splitrules.lisp Log Message: bug fixes Date: Sun Aug 28 06:32:47 2005 Author: dpsenicka Index: fomus/README diff -u fomus/README:1.6 fomus/README:1.7 --- fomus/README:1.6 Sat Aug 27 21:22:43 2005 +++ fomus/README Sun Aug 28 06:32:47 2005 @@ -29,4 +29,3 @@ If you wish to report a bug, make FOMUS generate a debug file (the default filename is "/tmp/fomus.dbg") and send it to dpsenick(at)uiuc(dot)edu. See the DEBUG-FILENAME setting in the FOMUS documentation for more information. -! \ No newline at end of file Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.9 fomus/classes.lisp:1.10 --- fomus/classes.lisp:1.9 Sat Aug 27 20:13:21 2005 +++ fomus/classes.lisp Sun Aug 28 06:32:47 2005 @@ -13,9 +13,9 @@ (defclass fomusobj-base () ((id :accessor obj-id :initform nil :initarg :id))) ; fomus doesn't use this! -(defclass event-base (fomusobj-base) ; an event in fomus is an object with an offset--also confusingly refers to a note or rest +(defclass event-base (fomusobj-base) ((off :type (real 0) :accessor event-off :initform nil :initarg :off) - (partid :type (or symbol real null) :accessor event-partid :initform nil :initarg :partid))) ; offsets are in beats + (partid :type (or symbol real null) :accessor event-partid :initform nil :initarg :partid))) (defclass timesig-repl (fomusobj-base) ((time :type cons :accessor timesig-time :initform '(4 4) :initarg :time) Index: fomus/data.lisp diff -u fomus/data.lisp:1.14 fomus/data.lisp:1.15 --- fomus/data.lisp:1.14 Sat Aug 27 20:13:21 2005 +++ fomus/data.lisp Sun Aug 28 06:32:47 2005 @@ -625,6 +625,7 @@ *checktype-markserr* t) (type* +notemarks-type+))) +;; include :staff but not :clef (defparameter +marks-rests+ '(:fermata :breath :notehead :textnote :texttempo :textdyn :text ;;:texttempo- :endtexttempo- :textdyn- :endtextdyn- :text- :endtext- #|:starttexttempo- :starttextdyn-|# :starttext-)) @@ -636,18 +637,13 @@ (declaim (type boolean *auto-pizz/arco*)) (defparameter *auto-pizz/arco* t) -;; ordering for accidentals is specified w/ second parameter slot in list (might not be relevant, depends on backend), ex.: (:staccato 1) (:fermata 2) -;; exceptions: (:finger 4 5), (:tremolo 1/4-dur-in-beats) (:righthandtremolo 1/8) (:lefthandtremolo t-unmeasured) -;; format of slurs is (:startslur- :dotted 1), (:slur- 1), (:endslur- :dotted)--order of 2nd and 3rd arguments don't matter -;; format of running-trills after processing is :startrunningtrill- and :endrunningtrill- (USER SHOULD JUST USE :RUNNINGTRILL) -;; format of texts is (:textnote "sul A") ;; marks only at beginning or end of tied notes (declaim (type cons +marks-first-tie+ +marks-last-tie+ +marks-all-ties+ +marks-on-off+ +marks-before-after+ +marks-indiv-voices+ +marks-spanner-voices+ +marks-spanner-staves+ +marks-expand+ +marks-defaultup+)) (defparameter +marks-first-tie+ '(:startslur- :startgraceslur- :start8up- :start8down- :starttext- #|:starttextdyn- :starttexttempo-|# :startwedge< :startwedge> :endgraceslur- :ppppp :pppp :ppp :pp :p :mp :mf :f :ff :fff :ffff :fffff :fp :sf :sff :sp :spp :sfz :rfz - :text :textdyn :textnote :texttempo ; up, down and dyn are italicized, tempo is slightly larger and above + :text :textdyn :textnote :texttempo ; up, down and dyn are italicized, tempo is larger and above :accent :marcato :tenuto :portato :upbow :downbow :flageolet :thumb :leftheel :rightheel :lefttoe :righttoe :turn :reverseturn :trill :prall :mordent :prallprall :prallmordent :upprall :downprall :upmordent :downmordent :pralldown :prallup :lineprall Index: fomus/fomus.asd diff -u fomus/fomus.asd:1.5 fomus/fomus.asd:1.6 --- fomus/fomus.asd:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/fomus.asd Sun Aug 28 06:32:47 2005 @@ -16,6 +16,8 @@ (:file "data" :depends-on ("misc" "deps")) (:file "classes" :depends-on ("data")) (:file "util" :depends-on ("classes")) + + (:file "splitrules" :depends-on ("misc")) (:file "accidentals" :depends-on ("util")) (:file "beams" :depends-on ("util")) @@ -24,10 +26,10 @@ (:file "ottavas" :depends-on ("util")) (:file "parts" :depends-on ("util")) (:file "postproc" :depends-on ("util")) - (:file "split" :depends-on ("util")) + (:file "split" :depends-on ("util" "splitrules")) (:file "staves" :depends-on ("util")) (:file "voices" :depends-on ("util")) - (:file "quantize" :depends-on ("util" "accidentals")) + (:file "quantize" :depends-on ("util" "splitrules")) (:file "backend_ly" :depends-on ("util")) (:file "backend_xml" :depends-on ("util")) Index: fomus/load.lisp diff -u fomus/load.lisp:1.5 fomus/load.lisp:1.6 --- fomus/load.lisp:1.5 Mon Aug 15 21:46:10 2005 +++ fomus/load.lisp Sun Aug 28 06:32:47 2005 @@ -1,7 +1,7 @@ ;; -*-lisp-*- ;; Load file for FOMUS -(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "accidentals" "beams" "marks" +(loop with fl = '("package" "version" "misc" "deps" "data" "classes" "util" "splitrules" "accidentals" "beams" "marks" "other" "ottavas" "parts" "postproc" "split" "staves" "voices" "quantize" "backend_ly" "backend_xml" "backends" "main" "interface" "final") and nw Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.6 fomus/misc.lisp:1.7 --- fomus/misc.lisp:1.6 Sat Aug 27 20:13:21 2005 +++ fomus/misc.lisp Sun Aug 28 06:32:47 2005 @@ -57,7 +57,7 @@ (if (listp list) (copy-list list) (list list))) (defun force-list2 (list) (let ((x (force-list list))) - (if (or (null x) (some #'listp x)) x + (if (or (null x) (every #'listp x)) x (list x)))) (defmacro cons-list (objs places) Index: fomus/split.lisp diff -u fomus/split.lisp:1.14 fomus/split.lisp:1.15 --- fomus/split.lisp:1.14 Sat Aug 27 20:13:21 2005 +++ fomus/split.lisp Sun Aug 28 06:32:47 2005 @@ -207,254 +207,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SPLITTER -;; tup in place of div -(defun split-tupdurmult (tup div) - (declare (type (integer 2) tup) (type (rational 1) div)) - (/ tup (loop-return-firstmin (diff d tup) for d = (loop for x1 = div then x2 for x2 = (/ x1 2) while (integerp x2) finally (return x1)) then (* d 2)))) - -;; returns list of new rules for given rule: (number-or-list-of-divs newrule1 newrule2...) -;; structures for easy debugging and tweeking -(defclass baserule () nil) -(defclass basesplit () - ((alt :type boolean :accessor rule-alt :initform nil :initarg :alt) ; alt/art = attached/anchored left/right (at a div-2 boundary) - (art :type boolean :accessor rule-art :initform nil :initarg :art) - (init :type list :accessor rule-init :initform nil :initarg :init) - (irr :type boolean :accessor rule-irr :initform nil :initarg :irr))) ; t if parent is irregular (not expof2) -(defclass basenodiv () - ((tlt :type boolean :accessor rule-tlt :initform nil :initarg :tlt) ; tlt/trt = t if tie allowed on that side, nil if not allowed - (trt :type boolean :accessor rule-trt :initform nil :initarg :trt))) -(defclass basecomp () - ((comp :type boolean :accessor rule-comp :initform nil :initarg :comp))) -(defclass baseunit () - ((tup :type list :accessor rule-tup :initform nil :initarg :tup) ; tup members multiplied together gives the actual fraction - (dmu :type list :accessor rule-dmu :initform nil :initarg :dmu))) -(defclass baseinit () - ((time :type (cons (integer 1) (integer 1)) :accessor rule-time :initform '(1 1) :initarg :time) - (beat :type (rational (0)) :accessor rule-beat :initform 1 :initarg :beat))) - -(defclass initdiv (baserule baseinit basecomp) - ((list :type list :accessor rule-list :initform nil :initarg :list) - (tsoff :type (rational 0) :accessor rule-tsoff :initform 0 :initarg :tsoff))) -(defclass sig (baserule basesplit baseinit basecomp) - ((top :type boolean :accessor rule-top :initform nil :initarg :top))) -(defclass unit (baserule basesplit baseunit basecomp) - ((div :type (integer 2) :accessor rule-div :initform 1 :initarg :div) ; 2? - (sim :type (or null (rational (0))) :accessor rule-sim :initform nil :initarg :sim) - (sis :type (integer 0 1) :accessor rule-sis :initform 0 :initarg :sis))) -(defclass sig-nodiv (baserule basenodiv basecomp) ()) -(defclass unit-nodiv (baserule basenodiv baseunit basecomp) - ((rst :type boolean :accessor rule-rst :initform nil :initarg :rst))) - -(defprint initdiv time comp beat list tsoff) -(defprint sig time comp beat alt art irr init top) -(defprint unit div comp alt art irr init tup dmu sim sis) -(defprint sig-nodiv comp tlt trt) -(defprint unit-nodiv tup comp dmu tlt trt rst) - -;;(declaim (inline basesplitp basenodivp basecompp baseunitp baseinitp initdivp sigp unitp sig-nodiv-p unit-nodiv-p)) -(defun basesplitp (o) (typep o 'basesplit)) -(defun basenodivp (o) (typep o 'basenodiv)) -(defun basecompp (o) (typep o 'basecomp)) -(defun baseunitp (o) (typep o 'baseunit)) -(defun baseinitp (o) (typep o 'baseinit)) -(defun initdivp (o) (typep o 'initdiv)) -(defun sigp (o) (typep o 'sig)) -(defun unitp (o) (typep o 'unit)) -(defun sig-nodiv-p (o) (typep o 'sig-nodiv)) -(defun unit-nodiv-p (o) (typep o 'unit-nodiv)) - -(defmacro make-initdiv (&rest args) `(make-instance 'initdiv ,@args)) -(defmacro make-sig (&rest args) `(make-instance 'sig ,@args)) -(defmacro make-unit (&rest args) `(make-instance 'unit ,@args)) -(defmacro make-sig-nodiv (&rest args) `(make-instance 'sig-nodiv ,@args)) -(defmacro make-unit-nodiv (&rest args) `(make-instance 'unit-nodiv ,@args)) - -;;(declaim (inline rule-num rule-den)) -(defun rule-num (r) (declare (type baseinit r)) (the (integer 1) (car (rule-time r)))) -(defun rule-den (r) (declare (type baseinit r)) (the (integer 1) (cdr (rule-time r)))) - -(declaim (type (member t :all :top :sig) *dotted-note-level*) - (type (member t :all :top :sig) *shortlongshort-notes-level*) - (type boolean *syncopated-notes-level*)) -(defparameter *dotted-note-level* t) ; can = (t or :all), :top or :sig for levels where dotted notes are allowed, nil = no dotted notes -(defparameter *shortlongshort-notes-level* t) ; = (same as above) if special rhythmic patterns allowed (tied syncopations) -(defparameter *syncopated-notes-level* t) ; b bah.. bah.. bah.. b - -(declaim (type boolean *double-dotted-notes* *tuplet-dotted-rests*)) -(defparameter *double-dotted-notes* t) ; = t if can use double dotted notes -(defparameter *tuplet-dotted-rests* t) - -(defun split-rules-bylevel (rule tups) ; tups = tuplets are allowed, :s = simple - (declare (type baserule rule) (type (member nil t :s) tups)) - (let ((mt (first (if (baseunitp rule) - (loop for e on *max-tuplet* for xxx in (rule-tup rule) finally (return e)) - *max-tuplet*))) ; max tuplet for next nesting level - #|(mn (length mt))|#) ; max nesting depth - (flet ((dv2 (n) - (declare (type (integer 1) n)) - (loop for n2 = (/ n 2) while (integerp n2) do (setf n n2)) - (max n 2))) - (flet ((divs (tup div &optional ntup ndmu) - (declare (type (integer 2) tup) (type (rational 1) div) (type list ntup ndmu)) - (let ((tu (force-list ntup)) - (dmu (cons (split-tupdurmult tup div) ndmu)) - (ir (when *tuplet-dotted-rests* (not (expof2 tup))))) - (loop - for i of-type (or cons (integer 1)) in (tuplet-division tup) - collect - (let ((x (if (listp i) (loop with x = 0 for y of-type (integer 1) in (butlast i) collect (/ (incf x y) tup)) (list (/ i tup))))) - (cons (if (list>1p x) x (first x)) - (loop for (e1 e2) of-type ((rational 0 1) (or (rational 0 1) null)) on (cons 0 (append x '(1))) while e2 - for ii in (if (listp i) i (list i (- tup i))) and tt = (- e2 e1) and a1 = t then a2 - for a2 = (and (expof2 e2) (expof2 (- tup e2))) collect - (if (and (<= ii 1) (if (unitp rule) (rule-sim rule) t)) - (make-unit-nodiv :tup (cons tt tu) :comp (rule-comp rule) :dmu dmu :tlt t :trt t) - (make-unit :div (dv2 ii) :tup (cons tt tu) :dmu dmu :alt a1 :art a2 :irr ir :comp (rule-comp rule) :sim (when (eq tups :s) ii)))))))))) - (sort (etypecase rule - ((or initdiv sig) - (let* ((num (/ (rule-num rule) (* (rule-den rule) (rule-beat rule)))) ; 3/8 is treated like 1/4, etc. - (ex (expof2 num))) ; in compound meter, num = 1 for 3/8 - (flet ((al (sy) - (declare (type (member t :all :top :sig) sy)) - (or (find sy '(t :all :sig)) - (and (eq sy :top) (or (initdivp rule) (rule-top rule))))) - (in (n al ar in) ; n = division ratio - (declare (type (rational (0) (1)) n) (type boolean al ar) (type list in)) - (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) - (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) - :alt al :art ar :init in :irr (not ex) :comp (rule-comp rule)) - (make-unit :div (if (rule-comp rule) 3 2) :tup nil :alt t :art t :init in :irr (not ex) :comp (rule-comp rule)))) - (snd (n tl tr) - (declare (type (rational (0) (1)) n) (type boolean tl tr)) - (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# - (make-sig-nodiv :comp (rule-comp rule) :tlt tl :trt tr :comp (rule-comp rule)) - (make-unit-nodiv :tup nil :tlt tl :trt tr :comp (rule-comp rule))))) - (flet ((si (n wh al ar) ; n = division ratio, >1/4 or >3/8 comp. is designated with :sig, smaller durations become units - (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar)) - (etypecase rule - (initdiv (in n al ar nil)) - (sig (if (if (rule-comp rule) (>= num (/ n)) (> num (/ n))) #|(> num (/ n))|# - (make-sig :time (cons (* (rule-num rule) n) (rule-den rule)) :comp (rule-comp rule) :beat (rule-beat rule) - :alt (if (eq wh :l) (and (rule-alt rule) al) (and (rule-alt rule) (rule-art rule) al)) - :art (if (eq wh :r) (and (rule-art rule) ar) (and (rule-alt rule) (rule-art rule) ar)) - :irr (not ex) :comp (rule-comp rule)) - (make-unit :div 2 #|(if (rule-comp rule) 3 2)|# :tup nil :alt t :art t :irr (not ex) #|(or (rule-comp rule) (not ex))|# :comp (rule-comp rule))))))) - (nconc (etypecase rule - (initdiv (loop - for ee of-type cons in (force-list2 (rule-list rule)) - #+debug unless #+debug (= (apply #'+ ee) num) - #+debug do #+debug (error "Error in SPLIT-RULES-BYLEVEL") - collect (loop - for (e en) of-type ((rational (0)) (or (rational (0)) null)) on ee - sum e into s - collect (/ e num) into ee ; split durs - when en collect (/ s num) into ll ; split points - finally (return (cons (if (list>1p ll) ll (car ll)) - (loop - for (i n) of-type ((rational (0)) (or (rational (0)) null)) on ee - and x of-type (rational (0) 1) in (append ll '(1)) - and la = t then aa - for aa = (let ((xx (* x num))) - (and (expof2 xx) (or (= num xx) (expof2 (- num xx))))) - collect (in i la (or (null n) aa) ee))))))) - (sig (loop - for nn of-type (integer 2) in (or (lowmult (numerator num)) (if (rule-comp rule) '(3) '(2))) - nconc (loop - for j from 1 below nn - for x of-type (rational (0) (1)) = (/ j nn) ; x is the ratio - for xx = (* x num) and co = (and (rule-comp rule) (<= num 1)) - when (or (and co (expof2 (* xx 3/2))) - (expof2 xx) (expof2 (- num xx))) - collect (let ((aa (or (and co (expof2 (* xx 3/2)) (expof2 (* (- num xx) 3/2))) - (and (expof2 xx) (expof2 (- num xx)))))) - (list x (si x :l t aa) (si (- 1 x) :r aa t))))))) - (when (and (al *dotted-note-level*) (or (initdivp rule) (rule-alt rule)) ex (not (rule-comp rule))) - (nconc (list (list 3/4 (snd 3/4 t nil) (si 1/4 :r t t))) ; dotted notes - (when *double-dotted-notes* - (list (list 7/8 (snd 7/8 t nil) (si 1/8 :r t t)))))) - (when (and (al *dotted-note-level*) (or (initdivp rule) (rule-art rule)) ex (not (rule-comp rule))) - (nconc (list (list 1/4 (si 1/4 :l t t) (snd 3/4 nil t)) ) - (when *double-dotted-notes* - (list (list 1/8 (si 1/8 :l t t) (snd 7/8 nil t)))))) - (when (and (al *shortlongshort-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) - ex (or (not (rule-comp rule)) (>= num 4))) - (list (list '(1/4 3/4) (si 1/4 :l t t) (snd 1/2 t t) (si 1/4 :r t t)))) ; longer note in middle - (when (and *syncopated-notes-level* (al :top) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3)) - (not (rule-comp rule))) - (cond ((integerp num) - (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation - (snd (/ 1/2 num) t nil)) - (make-list (1- num) :initial-element (snd (/ num) nil nil)) - (list (snd (/ 1/2 num) nil t))))) - ((= (denominator num) 2) - (nconc (list (nconc (list (loop for i from 1 below num collect (/ i num))) ; regular off beat syncopation - (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)) - (list (snd (/ 1/2 num) nil t)))) - (list (nconc (list (loop for i from 1/2 below num collect (/ i num)) ; regular off beat syncopation - (snd (/ 1/2 num) t nil)) - (make-list (- num 1/2) :initial-element (snd (/ num) nil nil)))))))) - (when (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) - (loop - with nu = (if (rule-comp rule) (* num 3/2) num) - for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division - unless (expof2 (/ nu j)) - nconc (divs j nu)))))))) - (unit ; unit is at divide-by-2 level - (let ((ex (expof2 (rule-div rule)))) - (flet ((al (sy) - (declare (type (member t :all :top :sig) sy)) - (find sy '(t :all))) - (tu (n) - (declare (type (rational (0) (1)) n)) - (when (rule-tup rule) - (cons (* (the (rational (0)) (first (rule-tup rule))) n) (rest (rule-tup rule)))))) - (flet ((un (n wh al ar &optional d) - (declare (type (rational (0) (1)) n) (type (member :l :r) wh) (type boolean al ar) (type (or (integer 1) null) d)) - (if (and (rule-sim rule) (<= (* (rule-sim rule) n) 1)) - (make-unit-nodiv :tup (tu n) :dmu (rule-dmu rule) :tlt t :trt t :comp (rule-comp rule) :rst t) - (make-unit :div (if d (dv2 d) 2) :tup (tu n) :dmu (rule-dmu rule) - :alt (if (eq wh :l) (and (rule-alt rule) al) (and (rule-alt rule) (rule-art rule) al)) - :art (if (eq wh :r) (and (rule-art rule) ar) (and (rule-alt rule) (rule-art rule) ar)) - :irr (not ex) :comp (rule-comp rule) :sim (when (rule-sim rule) (* (rule-sim rule) n))))) - (und (n tl tr) (make-unit-nodiv :tup (tu n) :dmu (rule-dmu rule) :tlt tl :trt tr :comp (rule-comp rule)))) - (nconc (loop for nn of-type (integer 2) in (or (lowmult (rule-div rule)) '(2)) - nconc (loop for j from 1 below nn collect - (let ((x (/ j nn)) - (aa (and (expof2 j) (expof2 (- nn j))))) - (list x (un x :l t aa j) (un (- 1 x) :r aa t (- nn j)))))) - (when (and (al *dotted-note-level*) (rule-alt rule) ex) - (nconc (list (list 3/4 (und 3/4 t nil) (un 1/4 :r t t))) ; dotted notes - (when *double-dotted-notes* - (list (list 7/8 (und 7/8 t nil) (un 1/8 :r t t)))))) - (when (and (al *dotted-note-level*) (rule-art rule) ex) - (nconc (list (list 1/4 (un 1/4 :l t t) (und 3/4 nil t))) - (when *double-dotted-notes* - (list (list 1/8 (un 1/8 :l t t) (und 7/8 nil t)))))) - (when (and (al *shortlongshort-notes-level*) (rule-alt rule) (rule-art rule) ex) - (list (list '(1/4 3/4) (un 1/4 :l t t) (und 1/2 t t) (un 1/4 :r t t)))) ; longer note in middle - (when #|(debugn-if (>= (length (rule-tup rule)) 1) "~A ~A ~A ~A" - tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)) - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))))|# - (and tups mt (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule))) - (loop - for j of-type (integer 2) in (primes2 mt) ; only primes--number isn't actual tuplet, just division - unless (expof2 (/ (rule-div rule) j)) - nconc (divs j (rule-div rule) (rule-tup rule) (rule-dmu rule)))))))))) - (lambda (x0 y0) - (declare (type (cons (or cons (rational (0) (1))) *) x0 y0)) - (let ((x (car x0)) (y (car y0))) - (declare (type (or cons (rational (0) (1))) x y)) - (let ((xm (if (listp x) (the (rational (0) (1)) (ave-list x)) x)) - (ym (if (listp y) (the (rational (0) (1)) (ave-list y)) y))) - (let ((xd (diff xm 1/2)) - (yd (diff ym 1/2))) - (if (= xd yd) - (if (= xm ym) - (cond ((listp x) t) - ((listp y) nil)) - (> xm ym)) - (< xd yd))))))))))) - (declaim (type (real (0)) *min-split-all-parts-dur*)) (defparameter *min-split-all-parts-dur* 3/2) Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.7 fomus/staves.lisp:1.8 --- fomus/staves.lisp:1.7 Sun Aug 21 21:17:41 2005 +++ fomus/staves.lisp Sun Aug 28 06:32:47 2005 @@ -227,12 +227,12 @@ (loop for e of-type (or noteex restex) in (part-events p) do (rmmark e :clef)) ;;(addprop p (list :clef :percussion)) else do + (get-usermarks (part-events p) :staff :startstaff- :staff- :endstaff- + (lambda (e s) + (declare (type (or noteex restex) e) (type list s)) + (if (notep e) (setf (event-userstaff e) (force-list (first s))) (addmark e (list :userstaff (first s))))) + (part-name p)) (multiple-value-bind (no re) (split-list (part-events p) #'notep) - (get-usermarks no :staff :startstaff- :staff- :endstaff- - (lambda (e s) - (declare (type (or noteex restex) e) (type list s)) - (setf (event-userstaff e) (force-list (first s)))) - (part-name p)) (get-usermarks no :clef :startclef- :clef- :endclef- (lambda (e c) (declare (type (or noteex restex) e) (type list c)) @@ -249,12 +249,13 @@ do (loop with s of-type (or list (integer 1)) for e of-type (or noteex restex) in (sort g #'sort-offdur) - if (and (restp e) (null (event-userstaff e))) do (if (listp s) (push e s) (setf (event-staff* e) s)) + if (and (restp e) (null (getmark e :userstaff))) do (if (listp s) (push e s) (setf (event-staff* e) s)) else do - (let ((v (if (restp e) (event-userstaff e) (event-staff e)))) - (if (listp s) + (let ((v (if (restp e) (second (popmark e :userstaff)) (event-staff e)))) + (when v + (when (listp s) (mapc (lambda (x) (declare (type restex x)) (setf (event-staff* x) v)) s)) - (setf s v)))))) + (setf s v))))))) (defun clefs-generic (parts) (loop for p of-type partex in parts Index: fomus/test.lisp diff -u fomus/test.lisp:1.5 fomus/test.lisp:1.6 --- fomus/test.lisp:1.5 Sat Aug 27 20:13:21 2005 +++ fomus/test.lisp Sun Aug 28 06:32:47 2005 @@ -527,6 +527,26 @@ (1 :snaredrum))))))) ;; User Rests + +(fomus + :backend '((:data) (:lilypond :view t)) + :verbose 2 + :ensemble-type :orchestra + :parts + (list + (make-part + :name "Piano" + :instr :piano + :events + (cons (make-rest :off 19/2 :dur 2 :marks '(:fermata)) + (loop + for off from 0 below 19/2 by 1/2 + collect (make-note :off off + :dur 1/2 + :note (+ 48 (random 25)) + :marks (when (<= (random 3) 0) + '(:staccato)))))))) + ;; Auto On/Offs ;; User Overrides ;; Auto Pizz/Arco