I wrote some macros to help write analysis of musical pieces.
Here is an example file (on Bach's Invention I).
Structural analysis is (of course) performed by hand, and displayed on
a Lyrics structure on top of the music. (This part is only a set of
very simple macros).
Harmonic analysis is performed mostly by hand (I also have some code
that does harmonic analysis, but it works mostly on chorales; the code
here only detects octave-drop cadences) and displayed on a Lyrics
structure below the music.
The code also does a bit of motif analysis, which is done
automatically (motives are declared once by hand, then later
occurrences and inversions are identified automatically).
The enclosed files:
motif.scm contains most of the parentheses
bwv772.ly is the example for Invention I
TThe code compiles with both v2.18 (Debian stable; this is the only
version I have access to on some of my systems) and v2.19.
I am interested in any feedback you would have on this code!
--
Jérôme
; (music-fold-time order f data init music): f(data, leaf, X, pos)
; General utilities {{{1
(define (print . l) (map display l) (newline) #f)
(define (assert b . l) (or b (apply error l)))
;
https://stackoverflow.com/questions/108169/how-do-i-take-a-slice-of-a-list-a-sublist-in-scheme
(define (slice l start length) (take (drop l start) length))
(define (insert l position x)
(append (take l position) (cons x (drop l position))))
; returns interval [start, stop[ with given step
(define (interval-open start step stop) (if (>= start stop) '()
(cons start (interval-open (+ start step) step stop))))
; returns the last element of a closed list
(define (last l) (car (last-pair l)))
(define (anything->color c) (cond
((symbol? c) (x11-color c))
((and (number? c) (> c 1)) (map (lambda (x) (/ x 255.)) `(,c ,c ,c)))
((number? c) `(,c ,c ,c))
((and (list? c) (> (car c) 1) (map (lambda(x) (/ x 255.)) c)))
(else c)))
; Cosmetic functions {{{1
; Color variant {{{2
(define (color-comp-variant1 t x) (/ (* x t) (+ 1 (* (- t 1) x))))
(define (color-variant c n) (let* (;{{{
(n (modulo (* 4 n) 7))
(t `((0 0 1) (1 1 0) (0 1 1) (1 0 1) (0 1 0) (1 0 1) (0 0 0)))
(d (map (lambda (x) (list-ref `(1.3 .8) x)) (list-ref t n)))
)
; c = RGB color
; n = integer 0..6
(map color-comp-variant1 d c))
);}}}
(define (theme-color-variant c m);{{{
(color-variant c (ly:pitch-notename (first-note m))));}}}
; hsv->rgb {{{2
(define (hsv->rgb z) (let* (
(h (modulo (car z) 360)) (s (cadr z)) (v (caddr z))
(i (floor (/ h 60.)))
(c (* v s)) (t (/ h 60.)) (hmod2 (- t (* 2 (floor (/ t 2)))))
(absh (abs (- hmod2 1))) (x (* c (- 1 absh)))
) (map (lambda (y) (+ y (- v c))) (cond
((<= t 1) `(,c ,x 0))
((<= t 2) `(,x ,c 0))
((<= t 3) `(0 ,c ,x))
((<= t 4) `(0 ,x ,c))
((<= t 5) `(,x 0 ,c))
((<= t 6) `(,c 0 ,x))))));}}}
; with-background {{{2
; after http://lsr.di.unimi.it/LSR/Snippet?id=969
(define-markup-command (with-background layout props color arg) (color? markup?)
(let* ((stencil (interpret-markup layout props arg))
(X-ext (ly:stencil-extent stencil X))
(Y-ext (ly:stencil-extent stencil Y)))
(ly:stencil-add (ly:make-stencil
(list 'color color
(ly:stencil-expr (ly:round-filled-box X-ext Y-ext 0))
X-ext Y-ext)) stencil)))
(define mark-below (define-music-function (parser location label) (markup?)
(make-sequential-music (list
(prop-override '(Score RehearsalMark extra-offset) '(0 . -8.5) #t)
(prop-override '(Score RehearsalMark baseline-skip) 9 #t)
(make-music 'MarkEvent 'label label)))))
(define framed-mark (define-music-function (parser location text1) (markup?)
(make-sequential-music (list
(prop-override `(Bottom LyricText self-alignment-X) LEFT)
(make-music 'MarkEvent
'label (markup #:line (#:box #:fontsize -3 text1)))))))
(define corner-mark (define-music-function (parser location text2) (markup?)
(make-music 'MarkEvent 'label (markup #:fontsize -3
(#:combine (#:path .15 '((lineto 0 2) (lineto 3 2)))
#:line (" " text2))))))
; General utilities for music {{{1
; Naming convention:
; make-foobar: direct constructor for a foobar
; create-foobar: defines a function which returns a foobar
(define (pitch->int p)
(assert (ly:pitch? p) "pitch->int: must be a pitch: " p)
(if (ly:pitch? p)
(+ (* 7 (ly:pitch-octave p)) (ly:pitch-notename p))))
(define (pitch->semitone p)
(assert (ly:pitch? p) "pitch->semitone: must be a pitch: " p)
(if (ly:pitch? p)
(+ (* 12 (ly:pitch-octave p))
(list-ref `(0 2 4 5 7 9 11) (ly:pitch-notename p))
(* 2 (ly:pitch-alteration p)))))
; music-length: duration (as a rational) {{{2
(define moment->rational ly:moment-main)
(define (duration->rational dur) (ly:moment-main (ly:duration-length dur)))
(define (music-length m)
"Duration of m, as a rational"
(moment->rational (ly:music-length m)))
(define (rational->duration r)
(ly:make-duration 0 0 (numerator r) (denominator r)))
;}}}2
; prop-override / prop-revert {{{2
; (inspired by scm/ly-syntax-constructors.scm)
; (why is this not exported?)
; anyway, our version is easier to use
; 2.18 does not have ly:set-origin!
(if (< (cadr (ly:version)) 19)
(define ly:set-origin! identity))
(define* (prop-override path value #:optional once)
(ly:set-origin! (context-spec-music (ly:set-origin!
(make-music 'OverrideProperty
'symbol (cadr path)
'grob-property-path (cddr path)
'once once
'grob-value value
'pop-first #t))
(car path))))
(define (prop-revert path)
(ly:set-origin! (context-spec-music (ly:set-origin!
(make-music 'RevertProperty
'symbol (cadr path)
'grob-property-path (cddr path)))
(car path))))
; music-fold-time: fold music expression with user-supplied function {{{2
(define (music-fold-time order f data init music)
"Descend recursively in music.
On leaf nodes, call X ← f(data, leaf, X, pos),
where · data is the user data
· X is initialized as init
· pos is the current time position (rational)
Returns the value of X.
On non-leaf nodes, f(data, node, X, pos) is called
- before the descendants if order is 'pre,
- after the descendants if order is 'post,
- otherwise not at all.
"
(music-fold-time-rec order f data init music 0))
(define (music-fold-time-rec order f data init music start);{{{
"This is the function that does the work,
passing around $start = current time position (rational)"
(let* (
(prop (lambda* (n #:optional o) (ly:music-property music n o)))
(n (prop 'name))
(this-node (lambda (value return)
(if (eq? order value) (f data music return start) return)))
)(cond
((eq? n 'SequentialMusic)
(let* (
(return init)
(return (this-node 'pre return))
(return (car
; we fold using (X . time) ← g(music, (X . time))
; this means that:
; g(m, p) = (f(data, m, car p, cdr p), (cdr p)+length(m)
(fold (lambda (m p)
(cons (music-fold-time-rec order f data (car p) m (cdr p))
(+ (cdr p) (music-length m))))
(cons return start)
(prop 'elements '()))))
(return (this-node 'post return))
) return))
((member n '(EventChord SimultaneousMusic))
; we fold using X ← g(music, X)
; now g(m,X) = f(data, start, music, X)
(let* (
(return init)
(return (this-node 'pre return))
(return
(fold (lambda (m x) (music-fold-time-rec order f data x m start))
return
(prop 'elements '())))
(return (this-node 'post return))
) return))
((prop 'element #f)
(let* (
(return init)
(return (this-node 'pre return))
(return (music-fold-time-rec order f data return (prop 'element) start))
(return (this-node 'post return))
) return))
(else (f data music init start))
)));}}}
; music-map-time f data music {{{2
(define (music-map-time! f data music)
(music-map-time-rec! f data music 0))
(define (music-map-time-rec! f data music start)
(let* (
(prop (lambda* (n #:optional o) (ly:music-property music n o)))
(n (prop 'name))
)(cond
((eq? n 'SequentialMusic)
; we fold using (return' . time') ← g(music, return . time)
; so that g(m, p) = ((f(m) . (car p)), (cdr p) + (length m))
(ly:music-set-property! music 'elements
(car (fold (lambda (m p)
(cons
(append (car p)
(list (music-map-time-rec! f data m (cdr p))))
(+ (cdr p) (music-length m))))
(cons '() start) (prop 'elements '()))))
music)
((eq? n 'SimultaneousMusic)
(ly:music-set-property! music 'elements
(map (lambda (m) (music-map-time-rec! f data m start))
(prop 'elements '())))
music)
((prop 'element)
(ly:music-set-property! music 'element
(music-map-time-rec! f data (prop 'element) start))
music)
(else (f data music start))
)));}}}
; flatten-music: returns a list (time . (list of all pitches)) {{{2
; this list is sorted by time,
; and the value for each time is sorted by pitch (high to low)
; FIXME: find some way to incorporate rests in there
(define (flatten-music music)
(sort
; we first sort the pitches at each time,
(map (lambda (p)
(cons (car p)
(sort (cdr p) (lambda (p1 p2) (ly:pitch<? p2 p1)))))
(flatten-music-raw music))
; and then sort the whole list
(lambda (p1 p2) (< (car p1) (car p2)))
))
(define (flatten-music-raw music)
(music-fold-time #f
(lambda (data leaf return time) (let* (
(prop (lambda (n) (ly:music-property leaf n)))
(name (prop 'name))
(mark (lambda (x)
(assoc-set! return time
(cons x (or (assoc-ref return time) '())))))
) (cond
((eq? name 'NoteEvent) (mark (prop 'pitch)))
((eq? name 'RestEvent) (mark 'rest))
(else return))))
'() ; data
'() ; init
music))
; keeps only the top-sounding pitch
(define (flatten-music-top music)
(map (lambda (p) (cons (car p) (cadr p))) (flatten-music music)))
(define (flatten-music-bottom music)
(map (lambda (p) (cons (car p) (last (cdr p)))) (flatten-music music)))
; call-on-first-note: apply a user function on the first note {{{2
(define (call-on-first-note f data music)
"Call function (f data leaf) on first note of the music and return the value."
(let* (
(prop (lambda (n) (ly:music-property music n #f)))
(n (prop 'name))
)(cond
((prop 'elements)
(call-on-first-note f data (car (prop 'elements))))
((prop 'element)
(call-on-first-note f data (car (prop 'element))))
(else (f data music))
)))
; find-articulation-prop: search for a particular articulation {{{2
; (define (find-articulation-prop leaf name)
; "Finds the first articulation having a property with given name,
; and returns the value corresponding to this property."
; (find identity
; (map (lambda(x) (ly:music-property x name #f))
; (ly:music-property leaf 'articulations '()))))
; time-signature-changes: returns a (sorted) list of time sigs {{{2
(define (time-signature-changes . l)
"Returns a sorted list of all time signatures found in the music expressions,
together with their (rational) time position, as a list of
(time-position . (numerator . denominator))"
(sort (apply append (map time-signature-changes1 l))
(lambda (p q) (< (car p) (car q)))))
(define (time-signature-changes1 music)
"Same as time-signature-changes, but for only one music expression"
(music-fold-time #f
(lambda (data leaf X time)
(let* ((p (lambda(x) (ly:music-property leaf x))))
(if (eq? (p 'name) 'TimeSignatureMusic)
(append X `((,time . (,(p 'numerator) . ,(p 'denominator)))))
; (list (cons time (cons (p 'numerator) (p 'denominator)))))
X)))
'() '() music))
; music-splice: extract a part of a sequential music list {{{2
(define (music-splice mlist start stop)
"Assuming (music-splice) is a list of (sequential) music,
returns the sub-list of all elements at positions [start, stop["
(if (or (null? mlist) (<= stop 0)) '()
(let* (
(head (car mlist))
(tail (cdr mlist))
(dur (music-length head))
; (_ (begin (print "splice [" start ", " stop "[; head = " dur)
(display-scheme-music head)))
) (append
(if (<= start 0) (list head) '())
(music-splice (cdr mlist) (- start dur) (- stop dur))))))
; music-insert-before, music-insert-after {{{2
(define (music-list-insert-before pos mlist items)
(cond
((= pos 0) (append items mlist))
((> pos 0) (cons (car mlist) (music-list-insert-before
(- pos (music-length (car mlist)))
(cdr mlist) items)))
((and
(eq? (ly:music-property (car mlist) 'name) 'SequentialMusic)
(> (music-length (car mlist)) pos))
(music-insert-before! (car mlist) items)
mlist)
(else #f)))
(define (music-insert-before! pos music items)
"Insert items (music list) before position pos in music expression
music. Returns music if insertion was successful, otherwise #f.
Mutually recursive with music-list-insert-before (above)."
(let* (
(prop (lambda (x) (ly:music-property music x #f)))
(n (prop 'name))
) (cond
((eq? n 'SequentialMusic)
(print "in sequential: inserting @ " pos " in " (flatten-music music))
(let* (
(l (music-list-insert-before pos (prop 'elements) items))
) (and l (ly:music-set-property! music 'elements l))))
((eq? n 'SimultaneousMusic)
; we try to insert into each element
; the boolean b holds #f as long as insertion failed
(fold (lambda (m b) (b or (music-insert-before! pos m items)))
#f (prop 'elements)))
((prop 'element) (music-insert-before! pos (prop 'element) items))
(else #f)
)))
; Motivic analysis {{{1
; Utility functions {{{2
; this is needed for 2.18
; (define (make-articulation . l)
; (apply make-music (append `(ArticulationEvent articulation-type) l)))
; music->shape {{{2
; A shape is an alist of (position . movement),
; where a movement is either:
; - the symbol 'initial = the first note of the shape,
; - an integer (*diatonic* difference between pitches),
; - the symbol 'rest.
(define (pitch-movement ref new)
"Takes a reference pitch and a new pitch, and returns the pair
(new reference, pitch movement).
This is different from a subtraction when the new pitch is a rest."
; (assert (ly:pitch? ref) "pitch-movement: must be a Pitch: " ref)
(if (ly:pitch? ref)
(if (ly:pitch? new) (cons new (pitch->int (ly:pitch-diff new ref)))
(cons ref 'rest))
(if (ly:pitch? new) (cons new 'initial) (cons ref new))))
(define (flat->shape flat offset)
"Converts flat music into a shape.
offset is the offset since last strong beat.
The first entry returned will be (offset . 'initial).
The flat input always starts at 0, so we need to shift everything by +offset."
; we fold the flatten-music onto a pair L containing:
; (reference pitch . current shape)
; and p is the pair (new time, new pitch)
(if (null? flat) '()
(cdr (fold (lambda (p L) (let* (
(ref (car L)) ; reference pitch
(shape (cdr L)) ; current shape
(pos (car p)) ; time from start
(new-pitch (cdr p))
(move (pitch-movement ref new-pitch))
(new (cons (+ pos offset) (cdr move)))
) (cons (car move)
(append shape (list new)))))
`(,(cdar flat) . ((,(+ (caar flat) offset) . initial)))
(cdr flat)))))
(define (music->shape music offset)
"Converts music into a list of (time . movement), where a movement is
either: a pitch interval, 'initial, or 'rest; and moment is a rational.
offset is the offset since last strong beat;
the first entry returned should be (offset . 'initial)"
(flat->shape (flatten-music-top music) offset))
; strong-beats: {{{2
(define (strong-beats m)
(strong-beats-sigs (music-length m) (time-signature-changes m)))
(define (strong-beats-sigs l sigs)
(strong-beats-rec l sigs `(4 . 4) 0))
(define (strong-beats-rec l sigs r start)
(let* ((step (/ (if (even? (car r)) 2 (car r)) (cdr r))))
(if (null? sigs) (interval-open start step l)
(append (interval-open start step (caar sigs))
(strong-beats-rec l (cdr sigs) (cdar sigs) (caar sigs))
))))
(define (last-strong-beat-before s t)
"Returns the last strong beat in list l before time t"
(car (last-pair (take-while (lambda (x) (<= x t)) s))))
; shape-inversion
(define (invert-movement m) (if (number? m) (- m) m))
(define (invert-shape s)
(map (lambda (x) (cons (car x) (invert-movement (cdr x)))) s))
(define (invert-motif-name s) (string-append s "inv"))
; (markup s #:super "inv")
; flat-music-slice: extract an interval from flattened music {{{2
; flat music is a list (time . pitch)
; we return those events in [start, start + dur]
; with the time part offset by (-start)
(define (flat-music-drop start flat)
"Returns a list containing all events after start"
(cond
((null? flat) '())
((< start 0) flat)
(else (append (if (> start (caar flat)) '() (list (car flat)))
(flat-music-drop start (cdr flat))))))
(define (flat-music-take end flat)
"Returns a list containing all events before end"
(if (or (null? flat) (> (caar flat) end)) '()
(cons (car flat) (flat-music-take end (cdr flat)))))
(define (flat-music-slice start dur flat)
(flat-music-take (+ start dur) (flat-music-drop start flat)))
; motif colors {{{2
(define motif-colors '())
(define (set-motif-color! name color)
"Defines the color associated to the motif given by name."
(let* ((color (anything->color color)))
(set! motif-colors (assoc-set! motif-colors name color))
(set! motif-colors (assoc-set! motif-colors (invert-motif-name name) color))))
; XXX add a new color (as different from the previous ones as possible)
; if none exists (and of course add it to the alist)
(define (get-motif-color name)
(or (assoc-ref motif-colors name) `(.5 0. .5)))
; The motif definitions {{{2
; define-motif: returns a music-function which marks motives {{{3
; defA = #(define-motif 'A)
; then
; \relative { c' d e \defA { f g a } b c }
; and a recursive descend in this music can extract the motif
(define* (define-motif name #:optional color)
"Creates a music function used to mark the definition of a shape
in a music expression. These definitions are then extracted by
extract-motives (below)."
(cond
((string? color) (set-motif-color! name (get-motif-color color)))
(color (set-motif-color! name color))
)
(define-music-function (parser location music) (ly:music?)
(make-music 'SequentialMusic 'elements (list music)
'motif-define name)))
; extract-motives {{{3
(define (extract-motives music)
"Returns a list of shapes, of the form (name . shape).
This extracts the shapes marked with define-motif (above)."
; plist holds the strong beats of the music, so that we can start the
; motif relatively to the last one
(let* (
(s (strong-beats music))
(offset (lambda (x) (- x (last-strong-beat-before s x))))
) (music-fold-time 'pre
(lambda (data node shapes time)
(let* (
(a (ly:music-property node 'motif-define #f))
(e (ly:music-property node 'elements '()))
(s (if a (music->shape (car e) (offset time)) '()))
(ainv (if a (invert-motif-name a)))
(sinv (invert-shape s))
; (_ (if a (print "### a = " a "; offset(" time ") = " (offset
time))))
)
(if a `((,a . ,s) (,ainv . ,sinv) . ,shapes)
shapes)))
#f '() music)))
; Comparing shapes with the database {{{2
; compare-moves {{{3
(define (compare-moves m1 m2)
"Attributes a score for the comparison of movements m1 m2.
The lower the score, the better.
This is *not* symmetrical: m1 is the reference move.
"
(let* (
; (_ (print "compare moves " m1 " and " m2))
(d (and (number? m1) (number? m2) (- m2 m1)))
(p (cons m1 m2))
) (cond
; if everything matches, no penalty
((equal? m1 m2) 0)
; delayed entry has a slight penalty
((member p `((initial . #f) (#f . initial))) 1)
; ... even if the match is up to alterations
; same octave - no penalty; different octave - slight penalty
((and d (eq? (modulo d 7) 0)) 1)
; a non-zero interval may be offset by 1 (mutation) for a small cost
((and d
(not (zero? m1))
(eq? (abs d) 1))
2)
; if an extra note is added, small penalty
((and (not m1) (number? m2)) 2)
; if a note is missing, medium penalty
((and (number? m1) (not m2)) 3)
; if the direction is the same, medium penalty
((and (number? m1) (number? m2)
(> (* m1 m2) 0)) 3)
; else, large penalty
(else 8))))
; compare-shapes {{{3
(define (compare-shapes s1 s2)
"Returns a score for the comparison of shapes s1 and s2.
The lower the score, the better the match (0 = perfect match).
This *not* symmetrical: s1 is the reference shape."
(let* (
; (_ (print "comparing shapes...: " s1 " and " s2))
(t (delete-duplicates (sort (append (map car s1) (map car s2)) <)))
(moves-from (lambda (s) (map (lambda (x) (assoc-ref s x)) t)))
; (score (fold + 0 (map compare-moves (moves-from s1) (moves-from s2))))
)
(fold + 0 (map compare-moves (moves-from s1) (moves-from s2)))
))
; find-motives {{{3
; maximum allowed score, as a function of the number of notes in the
; motif
(define (max-score n) (+ 0 (* 1 n)))
(define (find-motives db music)
"Finds all occurrences of shapes from database db in music.
Returns a list of (time . shape-name)
XXX Now returns a list of (time . pitch . (motif index start)),
where index is the position in the given motif.
"
; FIXME: we should instead return a list of
; (name . ((time1 . pitch1) … (timen . pitchn)))
; (note: this is an alist-like, but with non-unique keys)
; this would ease a bit for marking the pitches later
; (replace nodes by sequential-music using music-map)
; this requires that flat-music-slice does *not* translate the pattern
(let* (
(plist (strong-beats music))
(flat (flatten-music-top music))
; we iterate over the database, with pairs (name . shape)
; this creates a list-of-lists-of-lists, which we flatten later
(tmp (map (lambda (x)
; (print "x = " x)
(let* (
; cdr x: shape of the motif
; cadr x: (offset . 'initial)
; caadr x: offset
(offset (caadr x))
(len (- (car (last (cdr x))) offset))
; (_ (print "trying motif " (car x) " offset = " offset " shape = "
(cdr x)))
) (map (lambda (t) (let* (
; t iterates over the strong beats of the music
; we first extract the notes from [t + offset, t + len + offset]
(start (+ t offset))
(ex (flat-music-slice start len flat))
; (_ (print " extract = " ex))
(candidate (flat->shape ex (- t)))
; (_ (print " Candidate at " t ", " start " = " candidate))
(score (compare-shapes (cdr x) candidate))
; (_ (print " score = " score))
; (_ (print " ex len= " (length ex) "; value " ex))
; (_ (if (< score (* 1 (length (cdr x)))) (print " +++ adding...")))
)
(if (< score (max-score (length (cdr x))))
; we return a list of ((time . pitch) . (motif . index))
; ex contains a list of (time . pitch)
; p is the pair (time . pitch), i is the index
(map (lambda (p i)
; (print "item " p ", " i)
`(,p . (,(car x) ,i ,(cdar ex)))
) ex (iota (length ex)) )
'()
)
)) plist))
) db))
)
; now we flatten the lolol
; using map(map) is easier on the eyes than fold(fold)...
; (print "folding...")
(fold append '() (fold append '() tmp))
))
; marking shapes {{{2
; motif-markup: the markup attached to the motif head {{{3
(define (motif-markup name)
"Returns the markup associated to a given motif name.
name is the name of the motif (string, but markup should also work)."
(motif-mark (get-motif-color name) name))
(define (motif-mark color name)
(markup #:with-color color #:center-column
(#:left-align #:fontsize -3 name #:vspace -.25
#:left-align #:fontsize 3 #:arrow-head 1 -1 #t))
)
; mark-motif-leaf: mark just one leaf with the motif colors {{{3
(define (mark-motif-leaf leaf name first trans) (let* (
(p (ly:music-property leaf 'pitch))
(color (color-variant (get-motif-color name) trans))
(grobs '(NoteHead Stem Dots Flag Script Accidental))
)
(if first
(ly:music-set-property! leaf 'articulations
(cons (make-music 'TextScriptEvent
'direction 1
'text (motif-markup name))
(ly:music-property leaf 'articulations))))
(make-sequential-music (append
(map (lambda (g) (prop-override `(Staff ,g color) color)) grobs)
(list leaf)
(map (lambda (g) (prop-revert `(Staff ,g color))) grobs)))
))
; mark-found-motives! {{{3
(define (mark-found-motives! found music)
; (print "marking " (length found) " motives in music...")
(music-map-time!
(lambda (data leaf time) (let* (
(prop (lambda (x) (ly:music-property leaf x)))
(n (prop 'name))
; (_ (begin (print "at time " time ": ") (display-scheme-music leaf)))
) (cond
((and (eq? n 'NoteEvent) (assoc-ref found (cons time (prop 'pitch))))
=> (lambda (p) (mark-motif-leaf leaf
(car p) (= 0 (cadr p)) (ly:pitch-notename (caddr p))
)))
(else leaf)
)
)) '() music))
; User API {{{2
(define (motif-analysis! . l) (let* (
(db (fold append '() (map extract-motives l)))
)
(map (lambda (x) (mark-found-motives! (find-motives db x) x)) l)
*unspecified*
))
; Harmonic analysis {{{1
; music-fold-time order f data init music -> f data leaf X time
; Convert pitch to color {{{2
(define* (pitch-if-minor p #:optional minor major)
"Returns 0 for major mode, 1 for minor mode"
(if (< (ly:pitch-octave p) -1) (or minor 1) (or major 0)))
(define (pitch->fifth p)
(modulo (* 7 (+ (modulo (pitch->semitone p) 12) (pitch-if-minor p 3))) 12))
(define (pitch->hue p)
(list-ref `(244 158 33 289 191 48 344) (modulo p 7)))
; (list-ref `(244 191 158 48 33 344 289) (modulo p 7))
; (list-ref `(244 48 289 158 344 191 33) (modulo p 7))
(define pitch-fg-table
(map (lambda (i) (hsv->rgb (list (pitch->hue i) .5 .4))) (iota 7)))
(define pitch-bg-table
(map (lambda (u)
(define minor (< u 7))
(define pitch (modulo u 7))
(hsv->rgb (list
; +2 for minor because of relative tonality
(pitch->hue (+ pitch (if minor 2 0)))
(if minor .25 .33)
(if minor 1. .75))))
(iota 14)))
; (define (pitch->bg p) (assoc-ref pitch-bg-table p))
(define (pitch->bg p)
(list-ref pitch-bg-table (modulo (pitch->int p) 14)))
(define (pitch->fg p) (list-ref pitch-fg-table (modulo p 7)))
; pitch to string {{{2
(define (pitch->string p)
(string-append
(symbol->string
(list-ref `(Do Ré Mi Fa Sol La Si do ré mi fa sol la si)
(+ (ly:pitch-notename p) (pitch-if-minor p 7))))
(list-ref `("♭" "" "♯") (+ 1 (* 2 (ly:pitch-alteration p))))))
; collect-metadata {{{2
(define (collect-metadata key music)
"Collects all harmony marks in music, and returns an alist of the form
(time . markup)"
(music-fold-time 'pre
(lambda (d node return time)
(add-metadata-mark return time
(ly:music-property node key #f)
(ly:music-property node 'origin)))
#f '() music))
(define (add-metadata-mark return time markup origin)
"Helper function for collect-metadata: ignores #f or adds markup."
; (if markup (begin
; (print "found markup at t = " time ":" markup)
; ))
(if markup (append return `((,time ,markup ,origin)) ) return))
; read-roman-degree {{{2
(define (prefix s n) (substring s 0 (min n (string-length s))))
(define (prefix-ci? s1 s2)
(and (>= (string-length s1) (string-length s2))
(string-ci=? s2 (substring s1 0 (string-length s2)))))
(define (degree-roman->int s)
"Returns a pair (value-of-roman-prefix . length-of-roman-prefix)"
(cond
((prefix-ci? s "V/")
((lambda (p) (cons (modulo (+ (car p) 4) 7) (+ (cdr p) 2)))
(degree-roman->int (substring s 2))))
((prefix-ci? s "VII") `(6 . 3))
((prefix-ci? s "VI") `(5 . 2))
((prefix-ci? s "V") `(4 . 1))
((prefix-ci? s "IV") `(3 . 2))
((prefix-ci? s "III") `(2 . 3))
((prefix-ci? s "II") `(1 . 2))
((prefix-ci? s "N") `(1 . 1))
((prefix-ci? s "I") `(0 . 1))
(else `(0 . 0))
))
(define (chord-markup y l)
(markup #:override `(baseline-skip . 1.8) (#:fontsize -3
#:raise y (make-column-markup l))))
(define (degree-tail-markup s)
"Returns the markup for the tail of the degree"
; FIXME: replace [digit]/ by slashed-digit
; then split into individual [sign?][alteration?][digit] patterns
(cond
((string-ci=? s "65") (chord-markup .8 `("6" "5")))
((string-ci=? s "+63") (chord-markup .8 `("+6" "3")))
((string-ci=? s "5/") (markup #:raise .6 #:fontsize -3 #:slashed-digit 5))
((string-ci=? s "7/") (markup #:raise .6 #:fontsize -3 #:slashed-digit 7))
(else (markup #:raise .6 #:fontsize -2 s))))
(define* (degree-markup s #:optional base)
"Returns markup for this degree"
(let* (
(p (degree-roman->int s))
(deg (car p))
(head (substring s 0 (cdr p)))
(tail (substring s (cdr p)))
)
(markup #:bold #:with-color (pitch->fg (+ deg (or base 0)))
#:concat (head (degree-tail-markup tail)))
))
; collect-octave-drops {{{2
(define (shape-octave-drops shape)
"Looks for octave-drop cadences in a shape
Returns a list of times."
(if (< (length shape) 3) '()
(append
(if (member (cons (cdadr shape) (cdaddr shape))
`((-7 . 3) (0 . 3) (-7 . -4) (0 . -4)))
`(,(caar shape)) '())
(shape-octave-drops (cdr shape)))))
(define (music-octave-drops music)
(shape-octave-drops
(filter (lambda (x) (number? (cdr x)))
(flat->shape (flatten-music-bottom music) 0))))
; harmonic-analysis {{{2
; FIXME: include \new Lyrics { } around this
(define harmonic-mark-duration 1/32)
(define (metadata-analysis key music)
"Takes music as in input (e.g. the bass voice), and returns a music
suitable for inclusion in a Lyrics context, containing the harmonic marks
attached to the music.
The key is a symbol identifying which metadata we collect."
; l is a pair (current duration . list of lyrics)
; w is a list (new time, new markup, location)
(make-music 'ContextSpeccedMusic 'create-new #t
'context-type 'Lyrics 'element
(make-sequential-music (cdr (fold
(lambda (w p)
; car w = position of the markup
; cadr w = markup
; caddr w = origin
; (print " w = " w ", p = " p)
(cons
(+ (car w) harmonic-mark-duration)
(append (cdr p) (list
(make-music 'SkipEvent
'duration (rational->duration (- (car w) (car p))))
(prop-override `(Bottom LyricText self-alignment-X) LEFT)
(make-music 'LyricEvent
'duration (rational->duration harmonic-mark-duration)
'origin (caddr w)
'text (cadr w))))))
`(0 . ())
(merge
(collect-metadata key music)
(map (lambda (x) (list x cadence-markup 'nothing)) (music-octave-drops
music))
(lambda (e1 e2) (< (car e1) (car e2))))
)))))
(define (harmonic-analysis music) (metadata-analysis 'harmony music))
; music-with-metadata: creates an empty music expression with metadata {{{2
(define (music-with-metadata origin . l)
(apply make-music `(Music void #t origin ,origin . ,l)))
(define (make-harmony-mark origin l)
(music-with-metadata origin 'harmony l))
(define (harmony-mark-bg bg text)
(define-music-function (parser location)()
(make-harmony-mark location
(markup #:with-background (anything->color bg) #:pad-markup .5 text))))
(define global-tonic 0)
(define modulation (define-music-function (parser location tonic) (ly:pitch?)
(set! global-tonic (ly:pitch-notename tonic))
(make-harmony-mark location
(markup #:with-background (pitch->bg tonic)
#:pad-markup .5 (pitch->string tonic)))))
(define degree (define-music-function (parser location deg) (string?)
(make-harmony-mark location (degree-markup deg global-tonic))))
; Structural analysis {{{1
(define structural-analysis-is-lyrics #f)
(define (structural-analysis music)
(if structural-analysis-is-lyrics
(metadata-analysis 'structure music)
(print "[ERROR] structural-analysis-is-lyrics positioned to #f.")))
(define (structural-framed origin text)
(if structural-analysis-is-lyrics
(music-with-metadata origin 'structure
(markup #:line (#:box #:fontsize -3 text)))
#{ \override RehearsalMark.padding = #4 \framed-mark $text #}))
(define (structural-corner origin text)
(if structural-analysis-is-lyrics
(music-with-metadata origin 'structure (markup #:fontsize -3
(#:combine (#:path .15 '((lineto 0 2) (lineto 3 2)))
#:line (" " text))))
#{ \corner-mark $text #}))
; this is only a bunch of macros that define marks above the score... {{{2
; (define exposition (define-music-function (parser location) ()
; #{ \override RehearsalMark.padding = #5 \framed-mark "Exposition" #}))
; (define step (define-music-function (parser location n) (number?)
; #{ \corner-mark #(string-append "" (number->string n) "." ) #}))
; }}}1
; defaults and user functions
(define exposition (define-music-function (parser location) ()
(structural-framed location "Exposition")))
(define counterexposition (define-music-function (parser location) ()
(structural-framed location "Counter-Exposition")))
(define step (define-music-function (parser location n) (number?)
(structural-corner location (string-append "" (number->string n) "."))))
; this is used by octave-drop detection:
(define cadence-markup
(markup #:with-background (anything->color .8) #:pad-markup .5 "Cadence"))
(define cadence (harmony-mark-bg .8 "Cadence"))
(define halfcadence (harmony-mark-bg .9 "½ Cad."))
(define deceptive (harmony-mark-bg .9 "Deceptive"))
(map (lambda (x) (set-motif-color! (car x) (cdr x))) `(
("A" . DodgerBlue4) ("B" . OrangeRed4) ("C" . (.1 .4 0))
("D" . DarkGoldenrod4)
))
(define defA (define-motif "A"))
(define defB (define-motif "B"))
(define defC (define-motif "C"))
(define defD (define-motif "D"))
(define defE (define-motif "E"))
\version "2.18"
#(define (print . l) (map display l) (newline) #f)
#(load "motif.scm")
defA = #(define-motif "A")
defB = #(define-motif "B")
defBi = #(define-motif "B'" 'DarkGoldenrod4)
defC = #(define-motif "C")
#(set! structural-analysis-is-lyrics #t)
\header { opus = "BWV 772" } %<<<1
voiceone = \relative c' {%<<<
\exposition
r16 \defA { c[ d e] f[ d e c] g'8[ } \defB { c b^\prall c]
d16[ } g, a b] c[ a b g] d'8[ \defBi { g f^\prall g]
e16[ } \step #1
a g f] e[ g f a] g[ \step #2 f e d] c[ e d f]
e[ \step #3 d c b] a[ c b d] c[ b a g] fis[ a g b]
a8[ d,] c'8.[^\mordent d16] b[ a g fis] e[ g fis a]
g[ b a c] b[ d c e] d[ b32 c d16 g] b,8[^\prall a16 g]
\exposition
g8 r r4 r16 g[ a b] c[ a b g]
fis8^\prall r r4 r16 a[ b c] d[ b c a]
b8 \step #1 r r4 r16\step #2 d[ c b] a[ c b d]
c8 \step #3 r r4 r16\step #4 e[ d c] b[ d cis e]
d8[ \step 1 cis d e] f[ \step 2 a, b! cis]
d[ \step 3 fis, gis a] b[ c] d4 ~
d16[ e, fis gis] a[ fis gis e] e'[ d c e] d[ c b d]
c[ a' gis b] a[ e f d] gis,[ f' e d] c8[ b16 a]
\exposition
a16[ a' g f] e[ g f a] g2 ~
g16[ e f g] a[ f g e] f2 ~
f16[ g f e] d[ f e g] f2 ~
f16[ d e f] g[ e f d] e2 ~
e16[ c d e] f[ d e c] d[ e f g] a[ f g e]
f[ g a b] c[ a b g] c8[ g] e[ d16 c]
c[ bes a g] f[ a g bes] a[ b c e,] d[ c' f, b]
<c g e>1^\fermata\arpeggio
\bar "|."
}%>>>
voicetwo = \relative c {%<<<
\clef "bass"
\textLengthOff
\modulation c \degree "I"
r2 r16 c[ d e] f[ d e c]
\degree "V"
g'8[g,] r4 r16 g'[ a b] c[ a \cadence b g]
c8[ \defC { b c d] e[ } g, a b]
\modulation g c[ e, fis g] a[b] \degree "V+4" c4 ~
c16[ d, e fis] g[ e \cadence fis d] \degree "I" g8[ b, c d]
e[fis g e] \degree "I6" b8.[ c16] d8[ d,]
r16 g[ a b] c[ a b g] d'8[ g fis \halfcadence g]
a16[ d, e fis] g[ e fis d] a'8[ d c \cadence d]
\modulation d,
g,16[ \clef "treble" g' f e] d[ f e g] f8[ e f d]
e16[ a g f] e[ g f a] g8[ f g \cadence e]
f16[ bes a g] f[ a g bes]
\modulation a,
a[ g f e] d[ f e g]
f[ e d c] b[ d c e] d[ c b a] gis[ b a c]
\clef "bass"
b8[e,] d'8.[^\mordent e16] c[ b a g!] fis[ a gis b]
a[c b d] c[ e d f] e8[ a, e' e,]
a8[ a,] r4 r16 e''16[ d c] b[ d cis e]
d2 ~ d16[ a b c] d[ b c a]
b2 ~ b16[ d c b] a[ c b d]
\modulation f
c2~ c16[ g a bes] c[ a bes g]
a8[ bes a g] f[ d' c bes]
a[f' e d] e16[ d, e f] g[ e f d]
e8[ c d e]
\modulation c
f16[ d e f] g8[ g,]
<c c,>1\arpeggio_\fermata
\bar "|."
}%>>>
#(motif-analysis! voiceone voicetwo)
\score {%<<<
\context PianoStaff <<
#(structural-analysis voiceone)
\set PianoStaff.connectArpeggios = ##t
\context Staff = "one" << \voiceone >>
\context Staff = "two" << \voicetwo >>
#(harmonic-analysis voicetwo)
>>
\layout { }
\midi { \context { \Score tempoWholesPerMinute = #(ly:make-moment 80 4) } }
}%>>>
% we can also do without the music and just keep the analysis:
\score {%<<<
\context PianoStaff <<
#(structural-analysis voiceone)
#(harmonic-analysis voicetwo)
>>
\layout { }
}%>>>
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
