[fomus-cvs] CVS update: fomus/splitrules.lisp fomus/README fomus/classes.lisp fomus/data.lisp fomus/fomus.asd fomus/load.lisp fomus/misc.lisp fomus/split.lisp fomus/staves.lisp fomus/test.lisp
David Psenicka
dpsenicka at common-lisp.net
Sun Aug 28 04:32:51 UTC 2005
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 , at args))
-(defmacro make-sig (&rest args) `(make-instance 'sig , at args))
-(defmacro make-unit (&rest args) `(make-instance 'unit , at args))
-(defmacro make-sig-nodiv (&rest args) `(make-instance 'sig-nodiv , at args))
-(defmacro make-unit-nodiv (&rest args) `(make-instance 'unit-nodiv , at 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
More information about the Fomus-cvs
mailing list