Update of /project/fomus/cvsroot/fomus
In directory common-lisp.net:/tmp/cvs-serv20942
Modified Files:
TODO accidentals.lisp backend_ly.lisp classes.lisp data.lisp
interface.lisp main.lisp marks.lisp misc.lisp package.lisp
split.lisp util.lisp
Log Message:
Testing/bug fixes
Date: Sat Jul 23 11:23:14 2005
Author: dpsenicka
Index: fomus/TODO
diff -u fomus/TODO:1.2 fomus/TODO:1.3
--- fomus/TODO:1.2 Thu Jul 21 17:38:42 2005
+++ fomus/TODO Sat Jul 23 11:23:14 2005
@@ -3,6 +3,12 @@
IMMEDIATE
Testing and bug fixes
+BUG: :startslur- and :slur- marks
+BUG: error in beams in CMUCL
+DOC: dynamics marks can take order arguments (backend might not support it)
+DOC: make sure user knows to use the package
+DOC: make sure user knows about :default-beat setting
+Adjust scores and penalties for decent results
@@ -17,6 +23,7 @@
Reorganize code, update comments
Reorganize settings
MIDI input interface
+Support for polymeters in backends
@@ -24,4 +31,4 @@
Features for proportional notation (generate hidden rests of constant duration?)
Key signatures (key detection algorithm)
-Combine sections with different settings into one score
+Combine separately notated sections with different settings into one score (concatenate multiple .fms files?)
Index: fomus/accidentals.lisp
diff -u fomus/accidentals.lisp:1.2 fomus/accidentals.lisp:1.3
--- fomus/accidentals.lisp:1.2 Thu Jul 21 17:38:42 2005
+++ fomus/accidentals.lisp Sat Jul 23 11:23:14 2005
@@ -114,7 +114,7 @@
(aa n2 a2))))
(if qt v (max v 0)))))))
(defun nokeyq-intscore (tie note1 acc1 off1 eoff1 note2 acc2 off2 eoff2)
- (let ((s (nokey-intscore (- note1 (cdr acc1)) (car acc1) off1 eoff1 (- note2 (cdr acc2)) (car acc2) off2 eoff2 t)))
+ (let ((s (nokey-intscore tie (- note1 (cdr acc1)) (car acc1) off1 eoff1 (- note2 (cdr acc2)) (car acc2) off2 eoff2 t)))
(if (and (= (cdr acc1) 0) (= (cdr acc2) 0)) (max s 0)
(let ((a1 (if (= (cdr acc1) 0) (car acc1) (cdr acc1)))
(a2 (if (= (cdr acc2) 0) (car acc2) (cdr acc2))))
Index: fomus/backend_ly.lisp
diff -u fomus/backend_ly.lisp:1.2 fomus/backend_ly.lisp:1.3
--- fomus/backend_ly.lisp:1.2 Thu Jul 21 17:38:42 2005
+++ fomus/backend_ly.lisp Sat Jul 23 11:23:14 2005
@@ -69,9 +69,6 @@
;; LILYPOND BACKEND
(defparameter +lilypond-head+
- '("\\version \"2.4.2\""
- "\\include \"english.ly\""))
-(defparameter +lilypond-headq+ ;; quarter tones aren't supported in english
'("\\version \"2.4.2\""))
(defparameter +lilypond-defs+
'("octUp = #(set-octavation 1)"
@@ -83,8 +80,8 @@
))
(defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b"))
-(defparameter +lilypond-num-acc+ (vector "ff" "f" "" "s" "ss"))
-(defparameter +lilypond-num-accq+ (vector (vector nil "eseh") (vector "eseh" "es" "eh") (vector "eh" "" "ih") (vector "ih" "is" "isih") (vector nil "isis")))
+(defparameter +lilypond-num-acc+ (vector "eses" "es" "" "is" "isis"))
+(defparameter +lilypond-num-accq+ (vector (vector nil "eses") (vector "eseh" "es" "eh") (vector "eh" "" "ih") (vector "ih" "is" "isih") (vector nil "isis")))
(defparameter +lilypond-num-reg+ (vector ",,," ",," "," "" "'" "''" "'''" "''''" "'''''"))
(defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . "")))
@@ -118,7 +115,7 @@
(destructuring-bind (xxx &key filehead scorehead &allow-other-keys) options
(declare (ignore xxx))
(format f "% ~A v~A.~A.~A~%~%" +title+ (first +version+) (second +version+) (third +version+))
- (loop for e in (if *quartertones* +lilypond-headq+ +lilypond-head+) do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top
+ (loop for e in +lilypond-head+ do (format f "~A~%" e) finally (format f "~%")) ;; stuff at top
(when filehead (loop for e in filehead do (format f "~A~%" e) finally (format f "~%"))) ;; user header
(loop for e in +lilypond-defs+ do (format f "~A~%" e) finally (format f "~%")) ;; definitions
(let ((de 0) (nms nil))
@@ -252,11 +249,11 @@
(t "")))
and ar = (conc-stringlist
(loop for i in
- (sort (loop for a in +lilypond-marks+ nconc (getmarks e (car a)))
+ (sort (loop for a in +lilypond-marks+ nconc (mapcar #'force-list (getmarks e (car a))))
(lambda (x y) (let ((x2 (second x)) (y2 (second y)))
(cond ((and (numberp x2) (numberp y2)) (< x2 y2))
(x2 t)))))
- collect (lookup i +lilypond-marks+)))
+ collect (lookup (first i) +lilypond-marks+)))
;and txt = ...
and we0 = (cond ((and (getmark e :startwedge<) (getmark e :endwedge-)) "\\< ")
((and (getmark e :startwedge>) (getmark e :endwedge-)) "\\> ")
@@ -270,26 +267,23 @@
(t ""))
and dyn = (conc-stringlist
(loop for i in
- (sort (loop for a in +lilypond-dyns+ nconc (getmarks e (car a)))
- (lambda (x y) (let ((x2 (second x)) (y2 (second y)))
- (cond ((and (numberp x2) (numberp y2)) (< x2 y2))
- (x2 t)))))
- collect (lookup i +lilypond-marks+)))
+ (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a))))
+ collect (lookup (first i) +lilypond-dyns+)))
and s1 = (conc-stringlist
(loop
- for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :startslur-))
+ for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-))
collect "("))
and s2 = (conc-stringlist
(loop
- for xxx in (remove-if (lambda (x) (/= (third x) 1)) (getmarks e :endslur-))
+ for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-))
collect ")"))
and sl1 = (conc-stringlist
(loop
- for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :startslur-))
+ for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-))
collect "("))
and sl2 = (conc-stringlist
(loop
- for xxx in (remove-if (lambda (x) (/= (third x) 2)) (getmarks e :endslur-))
+ for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-))
collect ")"))
do (format f "~A " (conc-strings st vo cl ot1 tu1 gr1 we0 bnu ba du sl1 s1 s2 sl2 be1 be2 ti ar we1 dyn #|txt|# we2 gr2 tu2 ot2)))
when een do (format f s2))
Index: fomus/classes.lisp
diff -u fomus/classes.lisp:1.2 fomus/classes.lisp:1.3
--- fomus/classes.lisp:1.2 Thu Jul 21 17:38:42 2005
+++ fomus/classes.lisp Sat Jul 23 11:23:14 2005
@@ -120,7 +120,7 @@
(declaim (inline timesig-num timesig-den))
(defun timesig-num (ts) (car (timesig-time ts)))
(defun timesig-den (ts) (cdr (timesig-time ts)))
-(defun timesig-beat* (ts) (if (timesig-comp ts) (/ 3 (timesig-den ts)) (or (timesig-beat ts) (/ (timesig-den ts)))))
+(defun timesig-beat* (ts) (if (timesig-comp ts) (/ 3 (timesig-den ts)) (or (timesig-beat ts) *default-beat* (/ (timesig-den ts)))))
(declaim (inline obj-partid))
(defgeneric obj-partid (x))
Index: fomus/data.lisp
diff -u fomus/data.lisp:1.2 fomus/data.lisp:1.3
--- fomus/data.lisp:1.2 Thu Jul 21 17:38:42 2005
+++ fomus/data.lisp Sat Jul 23 11:23:14 2005
@@ -31,6 +31,8 @@
(defparameter *min-tuplet-dur* 1/2) ; fraction of beat smallest tuplets should span at minimum (1/2 = half a beat, etc.)--can be nil
(defparameter *max-tuplet-dur* 4)
+(defparameter *default-beat* nil)
+
;; pitch quantizing
(declaim (special *note-precision*))
(defparameter *quartertones* nil)
@@ -321,7 +323,8 @@
(:default-meas-divs (or* null (list-of* (cons* (rational 0) (list-of* (list-of* (rational 0)))))) "list of ((RATIONAL (0)) (((RATIONAL (0)) ...) ...))")
(:use-default-tuplet-divs boolean)
(:default-tuplet-divs (or* null (list-of* (cons* (integer 1) (list-of* (list-of* (integer 1)))))) "list of ((INTEGER 1) (((INTEGER 1) ...) ...))")
-
+
+ (:default-beat (or null (rational (0))))
(:beat-division (or* (integer 1) (and (list* (integer 1) (integer 1)) (length* = 2))) "(INTEGER 1) or ((INTEGER 1) (INTEGER 1))")
(:min-tuplet-dur (real (0))) (:max-tuplet-dur (real (0))) (:min-simple-tuplet-dur (real (0)))
(:max-tuplet (or* (integer 2) (list-of* (integer 2))) "(INTEGER 2) or list of (INTEGER 2)")
@@ -377,9 +380,9 @@
:startwedge> :startwedge< :wedge- :endwedge-
:startgraceslur- :graceslur- :endgraceslur-
:clef- :endclef-
- :rfz :sfz :spp :sp :sff :sf :fp :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp
- :cautacc))))
- x (list* x)) ; spanners w/ only 1 level, non-articulations
+ :cautacc
+ :rfz :sfz :spp :sp :sff :sf :fp :fffff :ffff :fff :ff :f :mf :mp :p :pp :ppp :pppp :ppppp))))
+ (or* x (list* x))) ; spanners w/ only 1 level, non-articulations
(let* ((x (unique* sy (find* :fermata))))
(or* x (list* x) (list* x (find* :short :long :verylong))))
(let* ((x (unique* sy (find* :arpeggio))))
@@ -399,7 +402,7 @@
:lineprall :prallup :pralldown :downmordent :upmordent :downprall :upprall :prallmordent
:prallprall :mordent :prall :trill :reverseturn :turn :righttoe :lefttoe :rightheel :leftheel
:thumb :flageolet :downbow :upbow :portato :tenuto :marcato :accent))))
- (or* x (list* x) (list* x integer))) ; articulations, some spanners
+ (or* x (list* x) (list* x integer))) ; articulations, dynamics, some spanners
(let* ((x (unique* sy :clef (find* :clef :startclef-))))
(list* x (function* is-clef)))
(let* ((x (unique* sy (find* :notehead))))
@@ -412,7 +415,7 @@
(unique* si 1 (eql* :dotted))
(list* (unique* si integer) (eql* :dotted))
(list* (eql* :dotted) (unique* si integer)))))) ; startslur-
- (let* ((x (unique* sy (find* :slur- :endslur-))))
+ (let* ((x (find* :slur- :endslur-)))
(or* (unique* si 1 x) (unique* si 1 (list* x)) (list* x (unique* si integer))))
(let* ((x (find* :textnote :texttempo :textdyn :text)))
(list* x string)) ; text
@@ -435,21 +438,30 @@
(list* string (unique* tx integer))
(list* (unique* tx integer) string))))))
+(defparameter *checktype-markerr* "Found ~A, expected valid/unique mark")
+(defparameter *checktype-markserr* "Found ~A, expected list of valid marks")
+
(defparameter +notemarks-type+
- '(with-unique* (sy si tt td tx)
- (list-of*
- (check* (type* +notemark-type+) "Found ~A, expected valid mark" t))))
+ '(check*
+ (with-unique* (sy si tt td tx)
+ (list-of*
+ (check* (type* +notemark-type+) *checktype-markerr* t)))
+ *checktype-markserr* t))
(defparameter +markmarks-type+
- '(with-unique* (sy si tt td tx)
- (list-of*
- (check* (or* (type* +notemark-type+)
- (cons (eql* :mark) (cons (or* (real 0) (list* real)) (and* list (type* +notemark-type+)))))
- "Found ~A, expected valid mark" t))))
+ '(check*
+ (with-unique* (sy si tt td tx)
+ (list-of*
+ (check* (or* (type* +notemark-type+)
+ (cons (eql* :mark) (cons (or* (real 0) (list* real)) (and* list (type* +notemark-type+)))))
+ *checktype-markerr* t)))
+ *checktype-markserr* t))
(defparameter +restmarks-type+
'(and*
- (list-of* (check* (or* (satisfies is-restmarksym) (cons* (satisfies is-restmarksym) list)) "Found ~A, expected valid mark" t))
+ (check*
+ (list-of* (check* (or* (satisfies is-restmarksym) (cons* (satisfies is-restmarksym) list)) *checktype-markerr* t))
+ *checktype-markserr* t)
(type* +notemarks-type+)))
(defparameter +marks-rests+
Index: fomus/interface.lisp
diff -u fomus/interface.lisp:1.1.1.1 fomus/interface.lisp:1.2
--- fomus/interface.lisp:1.1.1.1 Tue Jul 19 20:16:59 2005
+++ fomus/interface.lisp Sat Jul 23 11:23:14 2005
@@ -72,6 +72,10 @@
(let ((re (apply #'make-instance 'rest :partid partid args)))
(push re *fomus-events*)
t))
+(defun fomus-newmark (partid &rest args)
+ (let ((re (apply #'make-instance 'mark :partid partid args)))
+ (push re *fomus-events*)
+ t))
;;(declaim (inline fomus-part))
(defun fomus-part (sym)
@@ -81,9 +85,9 @@
(defun fomus-exec (&rest args)
(unwind-protect
(apply #'fomus
- :global *fomus-global*
- :parts (nreverse *fomus-parts*)
- :events *fomus-events*
+ :global (append *global* *fomus-global*)
+ :parts (append *parts* (nreverse *fomus-parts*))
+ :events (append *events* *fomus-events*)
(append args *fomus-args*))
(fomus-init)))
Index: fomus/main.lisp
diff -u fomus/main.lisp:1.2 fomus/main.lisp:1.3
--- fomus/main.lisp:1.2 Thu Jul 21 17:38:43 2005
+++ fomus/main.lisp Sat Jul 23 11:23:14 2005
@@ -52,7 +52,7 @@
(when (and (numberp *verbose*) (>= *verbose* 1)) (out ";; Formatting music..."))
(when *debug-filename* (save-debug))
(when (and (numberp *verbose*) (>= *verbose* 2)) (out "~&; Checking types..."))
- (check-settings-types)
+ (check-setting-types)
(find-cm)
(check-settings)
(multiple-value-bind (*timesigs* *keysigs* rm) (split-list *global* #'timesigp #'keysigp)
@@ -151,7 +151,7 @@
(when (>= *verbose* 2) (out "~&; Chords..."))
(preproc pts) #+debug (fomus-proc-check pts 'preproc) ; ----- CHORDS, RESTS
(clean-ties pts) #+debug (fomus-proc-check pts 'cleanties1)
- (when (>= *verbose* 2) (out "~&; Splits/ties/rests..."))
+ (when (>= *verbose* 2) (out "~&; Splits/ties/rests..."))
(split pts) #+debug (fomus-proc-check pts 'ties)
(clean-ties pts) #+debug (fomus-proc-check pts 'cleanties2)
(when *auto-beams*
Index: fomus/marks.lisp
diff -u fomus/marks.lisp:1.2 fomus/marks.lisp:1.3
--- fomus/marks.lisp:1.2 Thu Jul 21 17:38:43 2005
+++ fomus/marks.lisp Sat Jul 23 11:23:14 2005
@@ -63,7 +63,7 @@
(addmark e (if a2 (list startsym n a2) (list startsym n))) ; fixed order now--level is mandatory 1st argument, modifier is optional
(decf nu))
(error "Levels for marks ~A, ~A and ~A are out of order at offset ~A, part ~A" startsym contsym endsym (event-foff e) (part-name p)))
- (error "Missing ending marks ~A or ~A for starting mark ~A at offset ~A, part ~A" contsym endsym startsym (event-foff e) (part-name p))))))
+ (error "Missing ending mark ~A or ~A for starting mark ~A at offset ~A, part ~A" contsym endsym startsym (event-foff e) (part-name p))))))
finally (or (= nu 0) (error "Missing starting mark ~A in part ~A" startsym (part-name p)))) (print-dot))))
(defun expand-marks (pts)
Index: fomus/misc.lisp
diff -u fomus/misc.lisp:1.1.1.1 fomus/misc.lisp:1.2
--- fomus/misc.lisp:1.1.1.1 Tue Jul 19 20:16:56 2005
+++ fomus/misc.lisp Sat Jul 23 11:23:14 2005
@@ -301,7 +301,7 @@
;; slightly more complicated type checking
(defun check-type* (obj type &optional er un lt)
(flet ((get-error (x)
- (apply #'format nil (first x)
+ (apply #'format nil (typecase (first x) (symbol (symbol-value (first x))) (otherwise (first x)))
(mapcar (lambda (z)
(if (truep z) obj
(cond ((functionp z) (funcall z obj))
@@ -341,7 +341,7 @@
(o (if th se obj)))
(unless (find o (cdr x) :test #'equal)
(push o (cdr x))
- (check-type* obj se er un lt))))
+ (check-type* obj (or th se) er un lt))))
(let* (mapcar (lambda (x) (push (cons (first x) (second x)) lt)) fi) (check-type* obj se er un lt))
(error* (let ((x (get-error ty))) (if er (error er x) (error x))))
(with-error* (if (or (stringp (first fi)) (check-type* obj (first fi) er un lt))
Index: fomus/package.lisp
diff -u fomus/package.lisp:1.2 fomus/package.lisp:1.3
--- fomus/package.lisp:1.2 Thu Jul 21 17:38:43 2005
+++ fomus/package.lisp Sat Jul 23 11:23:14 2005
@@ -8,10 +8,6 @@
(eval-when (:compile-toplevel)
(declaim (optimize (safety 3) (debug 3))))
-;; debug feature flag
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (pushnew :debug *features*))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PACKAGE
@@ -57,7 +53,7 @@
(use-package "DBG" "FM")))
(defparameter +title+ "FOMUS")
-(defparameter +version+ '(0 1 1))
+(defparameter +version+ '(0 1 2))
(defparameter +banner+
`("Lisp music notation formatter"
"Copyright (c) 2005 David Psenicka, All Rights Reserved"
Index: fomus/split.lisp
diff -u fomus/split.lisp:1.1.1.1 fomus/split.lisp:1.2
--- fomus/split.lisp:1.1.1.1 Tue Jul 19 20:16:57 2005
+++ fomus/split.lisp Sat Jul 23 11:23:14 2005
@@ -233,7 +233,7 @@
(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* :top) ; b bah.. bah.. bah.. b
+(defparameter *syncopated-notes-level* t) ; b bah.. bah.. bah.. b
(defparameter *double-dotted-notes* t) ; = t if can use double dotted notes
(defparameter *tuplet-dotted-rests* t)
@@ -274,18 +274,18 @@
(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) (if #|(> num (/ n))|# (if (rule-comp rule) (>= 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)))))
+ (snd (n 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
(etypecase rule
(initdiv (in n al ar nil))
- (sig (if #|(> num (/ n))|# (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 (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)))))))
+ (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 in (force-list2 (rule-list rule))
@@ -304,7 +304,7 @@
(and (expof2 xx) (or (= num xx) (expof2 (- num xx)))))
collect (in i la (or (null n) aa) ee)))))))
(sig (loop
- for nn in (or (lowmult num) (if (rule-comp rule) '(3) '(2)))
+ for nn in (or (lowmult (numerator num)) (if (rule-comp rule) '(3) '(2)))
nconc (loop
for j from 1 below nn
for x = (/ j nn) ; x is the ratio
@@ -324,13 +324,21 @@
(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 (al *syncopated-notes-level*) (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule) (>= num 3))
+ (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)))
- (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)))))
+ (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 (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)))
(loop
with nu = (if (rule-comp rule) (* num 3/2) num)
@@ -366,7 +374,7 @@
(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
+ (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 (and tups (or (initdivp rule) (rule-alt rule)) (or (initdivp rule) (rule-art rule)))
(let ((l (length (force-list (rule-tup rule)))))
(when (< l mn)
Index: fomus/util.lisp
diff -u fomus/util.lisp:1.2 fomus/util.lisp:1.3
--- fomus/util.lisp:1.2 Thu Jul 21 17:38:43 2005
+++ fomus/util.lisp Sat Jul 23 11:23:14 2005
@@ -183,7 +183,7 @@
for x = (let ((bb (* nb d)))
(or (lookup bb *default-meas-divs*)
(lookup bb +default-meas-divs+)))
- when x do (return (mapcar (lambda (y) (/ y d)) x))))))))
+ when x do (return (loop for y in x collect (mapcar (lambda (z) (/ z d)) y)))))))))
(defparameter *effective-grace-dur-mul* 1/2) ; multiplier for effective duration of grace notes--use this in any algorithm that needs a small durational value for grace notes
@@ -475,7 +475,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CHECK SETTINGS
-(defun check-settings-types ()
+(defun check-setting-types ()
(loop for (sy ty er) in +settings+ do
(let ((v (symbol-value (find-symbol (conc-strings "*" (symbol-name sy) "*") :fomus))))
(or (check-type* v ty) (error "Found ~A, expected ~A in setting ~A" v (or er ty) sy)))))
