; (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"))