%%% Create an engraver that colors note heads depending on the 
%%% intervals between successive pitches

%% Interval definitions alist
%%
%% Key:
%% number determines the interval type, 1=prime, 2=second, 3=third ...
%% plus and minus signs determine variant, no sign=perfect interval, +=major,
%% ++=augmented, -=minor, --=diminished
%% This naming scheme is arbitrary, it is possible to label the interval-types
%% differently, like
%%
%% '(("A1" . (0 . 1))
%%   ("P1" . (0 . 0))
%%   ("m2" . (1 . 1)) etc.
%%
%% if an argument list using the same labels is passed to the engraver.
%%
%% Value:
%% the car represents the diatonic, the cdr the semitonic steps.
%% Only positive values are specified, negative values for
%% intervals downwards are generated in the engraver.
%% This list may be extended or completely overwritten
%% Usage: #(display (assoc-get "4--" intervaldefs))

#(define intervaldefs
   '(("1++" . (0 . 1))
     ("1" . (0 . 0))
     ("2-" . (1 . 1))
     ("2--" . (1 . 0))
     ("2+" . (1 . 2))
     ("2++" . (1 . 3))
     ("3-" . (2 . 3))
     ("3--" . (2 . 2))
     ("3+" . (2 . 4))
     ("3++" . (2 . 5))
     ("4--" . (3 . 4))
     ("4++" . (3 . 6))
     ("4" . (3 . 5))
     ("5--" . (4 . 6))
     ("5++" . (4 . 8))
     ("5" . (4 . 7))
     ("6-" . (5 . 8))
     ("6--" . (5 . 7))
     ("6+" . (5 . 9))
     ("6++" . (5 . 10))
     ("7-" . (6 . 10))
     ("7--" . (6 . 9))
     ("7+" . (6 . 11))
     ("7++" . (6 . 12))
     ("8--" . (7 . 11))
     ("8++" . (7 . 13))
     ("8" . (7 . 12))
     ("9-" . (8 . 13))
     ("9--" . (8 . 12))
     ("9+" . (8 . 14))
     ("9++" . (8 . 15))
     ("10-" . (9 . 15))
     ("10--" . (9 . 14))
     ("10+" . (9 . 16))
     ("10++" . (9 . 17))
     ("11--" . (10 . 16))
     ("11++" . (10 . 18))
     ("11" . (10 . 17))
     ("12--" . (11 . 18))
     ("12" . (11 . 19))))

%% Create an engraver that compares the intervals between sequential pitches
%% of a voice with a given list of intervals.
%% If a specified interval is found, the heads of both notes encompassing
%% the interval are colored.
%%
%% Mode of operation:
%% Intervals are defined by two integers representing the diatonic
%% resp. semitonic distance between two pitches.
%% It is necessary to take both distances into account to distinguish
%% between enharmonically identical intervals, e.g. a major third
%% and a diminished fourth.
%% Example:
%% d -> f# : diatonic distance = 2 steps (f# is derived from f natural),
%% semitonic distance = 4 steps
%% d -> gb: diatonic distance = 3 steps (gb is derived from g natural),
%% semitonic distance = 4 steps
%%
%% The engraver consists of two parts:
%%
%% color_interval_engraver: checks, whether the given parameters are valid,
%% looks up the interval in the interval definitions alist and hands
%% the determined interval distances together with the other unchanged
%% parameters over to the actual engraver color-interval-engraver-core.
%%
%% color-interval-engraver-core: creates a scheme-engraver which
%% acknowledges note head grobs and stores the last and
%% current grob locally. Then the pitches are extracted and the interval between
%% the last and current pitch is compared to the specified interval.
%%
%% Usage:
%% \color_interval_engraver #intervaldefs #debug? intervals-given
%%
%% intervaldefs: alist containing information about semitonical distances for
%% certain intervals, diatonical distance is calculated in the engraver using
%% `string-diatonic-semi-tonic-list`, relying on the key.
%%
%% debug?: (optional) boolean, if true, output information about the processed
%% pitches
%%
%% intervals-given: list of the form
%%   #`((interval1 ,dir1 enh1 ,color1)
%%      (interval2 ,dir2 enh2 ,color2)
%%      ...
%%      (intervalN ,dirN enhN ,colorN))
%% with
%% intervalN: string - specifying the interval to search after
%% dirN: integer - UP (=1) DOWN (=-1) or 0 (up and down)
%% enhN: boolean - search for enharmonically equivalent intervals, too?
%% colorN: lilypond color value, see NR A.7.
%%
%% Constructing the argument list with `(= quasiquote) provides
%% an elegant shorthand for (list (list interval1 dir1 enh1 color1)
%%                                (list interval2 dir2 enh2 color2))
%% This would not work with '(= quote), because this special form does
%% not allow to unquote certain list elements with the comma ,
%% The directions UP and DOWN and the color values, however, need
%% to be evaluated to the corresponding integer values resp.
%% RGB values.
%%
%% \layout {
%%   \context {
%%     \Voice
%%     \consists \color_interval_engraver #intervaldefs
%%       `(("2--" ,UP #f ,green)
%%         ("3+" ,DOWN #t ,blue))
%%   }
%% }

color_interval_engraver =
#(define-scheme-function (interval-defs debug? intervals-given)
   (list? (boolean?) list?) ;; debug? is optional, defaults to #f

   (let* ((msg-header "Color_interval_engraver:")
          ;; 2.18.2 does not accept an empty list as engraver, unlike 2.19.x
          (empty-engraver
           (make-engraver ((initialize translator) '())))
          (type-check-interval
           (lambda (interval)
             ;; basic check for amount of args
             (if (not (= 4 (length interval)))
                 (begin
                  (ly:warning
                   "~a Interval ~a must have 4 entries" msg-header interval)
                  #f)
                 ;; check every entry for type, additionally the first entry
                 ;; whether it's a key in intervaldefs
                 (let ((name (car interval))
                       (dir (second interval))
                       (enh? (third interval))
                       (color (fourth interval)))
                   (and
                    ;; check first entry for string? and
                    ;; whether it's in intervaldefs
                    (if (and (string? name) (assoc-get name intervaldefs))
                        #t
                        (begin
                         (ly:warning
"~a In interval ~a, ~a not found in interval definitions"
                          msg-header
                          interval
                          (car interval))
                         #f))
                    ;; check second entry for ly:dir?
                    ;; As opposed to the normal meaning of 0 (=CENTER),
                    ;; 0 means up >and< down here
                    (if (ly:dir? dir)
                        #t
                        (begin
                         (ly:warning
"~a In interval ~a, wrong type argument: ~a, needs to be a direction."
                          msg-header
                          interval
                          dir)
                         #f))
                    ;; check third entry for boolean?
                    (if (boolean? enh?)
                        #t
                        (begin
                         (ly:warning
"~a In interval ~a, wrong type argument: ~a, needs to be a boolean."
                          msg-header
                          interval
                          enh?)
                         #f))
                    ;; check fourth entry for color?
                    (if (color? color)
                        #t
                        (begin
                         (ly:warning
"~a In interval ~a, wrong type argument: ~a, needs to be a color."
                          msg-header
                          interval
                          color)
                         #f)))))))
          (cleaned-intervals-given
           (filter type-check-interval intervals-given))
          (search-intervals
           (map
            (lambda (interval)
              (let ((diatonic-semitonic-pair
                     (assoc-get (car interval) interval-defs)))
                (cons diatonic-semitonic-pair (cdr interval))))
            cleaned-intervals-given)))

     (if debug?
         (begin
          (ly:message "~a Preprocessed intervals:\n" msg-header)
          (for-each
           (lambda (search-interval)
             (format (current-error-port)
               "Distances (DT/ST):~a, direction:~a, enharmonic:~a, color:~a\n"
               (car search-interval)
               (second search-interval)
               (third search-interval)
               (fourth search-interval)))
           search-intervals)))

     (if (null? search-intervals)
         (begin
          (ly:warning
           "~a No valid interval found. Returning empty engraver" msg-header)
          empty-engraver)
         ;; Instantiate actual engraver
         (color-interval-engraver-core search-intervals debug?))))


#(define (color-interval-engraver-core search-intervals debug?)
   (lambda (context)
     ;; Context type: Staff, Voice, etc.
     ;; Context id: arbitrary string
     ;; \new <context-type> = <context-id> \music
     ;; \new Voice = "soprano" \music
     (let ((engraver-name "Color_interval_engraver")
           (context-type (ly:context-name context))
           (context-id (let ((id (ly:context-id context)))
                         (if (string-null? id)
                             "N/A"
                             id)))
           ;; Later we want to extract the current bar number from there
           (score-context (ly:context-find context 'Score))
           (noteheads-to-process '())
           (ready-to-process? #f)
           (last-noteheads-color #f)
           (last-interval #f))
       (make-engraver
        ((initialize translator)
         ;; Output a warning if the engraver has been added to a Staff context
         ;; If the Staff consists of more than one Voice, the engraver cannot
         ;; distinguish the different voices and will mix them up
         (if (eq? context-type 'Staff)
             (ly:warning
              (string-append
               "Adding color_interval_engraver to a Staff context may lead "
               "to unexpected results if the Staff contains more than one "
               "voice."))))
        ;; This engraver does not listen to events, thus it does not
        ;; define listeners. It does only acknowledge grobs,
        ;; specifically note heads created by other engravers.
        (acknowledgers
         ((note-head-interface engraver grob source-engraver)
          (if ready-to-process?
              ;; if we have two note heads already, push the old one out
              (set! noteheads-to-process (list grob (car noteheads-to-process)))
              ;; We need two note heads to compare the underlying pitches
              ;; -> store note heads until we have two
              (begin
               (set! noteheads-to-process (cons grob noteheads-to-process))
               (if (= (length noteheads-to-process) 2)
                   (set! ready-to-process? #t))))

          ;; Check for grobs in the queue, before continuing
          (if ready-to-process?
              ;; Note head grobs store a reference to the
              ;; event that caused their generation
              ;; Thus we can extract the pitch
              (let* ((current-bar-number
                      (ly:context-property score-context 'currentBarNumber))
                     (current-moment (ly:context-current-moment context))
                     (grob-causes (map (lambda (grob)
                                         (ly:grob-property grob 'cause))
                                    noteheads-to-process))
                     (pitches (map (lambda (cause)
                                     (ly:event-property cause 'pitch))
                                grob-causes))
                     ;; Calculate interval distances, diatonic and semitonic
                     (current-interval-dist-diatonic
                      (apply - (map ly:pitch-steps pitches)))
                     (current-interval-dist-semitonic
                      (apply - (map ly:pitch-semitones pitches)))
                     ;; Check if a given interval matches the current interval
                     (interval-match?
                      (lambda (search-interval)
                        (let* ((search-interval-dist (car search-interval))
                               (search-interval-dir (second search-interval))
                               (search-interval-enh? (third search-interval))
                               (search-interval-dist-diatonic
                                (car search-interval-dist))
                               (search-interval-dist-semitonic
                                (cdr search-interval-dist)))
                          ;; if search-interval-enh? was set to true for
                          ;; the current interval, compare only the semitonic
                          ;; distances, e.g. c#-f would also match a major 3rd,
                          ;; not only a diminished 4th
                          ;;
                          ;; search-interval-dir can only be -1, 0, 1
                          ;; other values are excluded by typechecking,
                          ;; thus 0 needs special casing,
                          ;; for other cases multiplying relevant value with
                          ;; search-interval-dir is enough
                          ;;   -- harm
                          (if (zero? search-interval-dir)
                              (and
                               ;; if direction does not matter, compare
                               ;; with absolute values
                               (= search-interval-dist-semitonic
                                  (abs current-interval-dist-semitonic))
                               (if (not search-interval-enh?)
                                   (= search-interval-dist-diatonic
                                      (abs current-interval-dist-diatonic))
                                   #t))
                              (and
                               (= search-interval-dist-semitonic
                                  (* search-interval-dir
                                    current-interval-dist-semitonic))
                               (if (not search-interval-enh?)
                                   (= search-interval-dist-diatonic
                                      (* search-interval-dir
                                        current-interval-dist-diatonic))
                                   #t))))))
                     ;; Get first occurrence of a matching interval
                     (matching-interval (find interval-match? search-intervals))
                     ;; Extract color from matching interval
                     (search-interval-color (if matching-interval
                                                (fourth matching-interval)
                                                #f)))

                (if debug?
                    (let* ((cep (current-error-port)))
                      (format cep
                        "\n*** This is ~a from ~a ~a ***\n"
                        engraver-name context-type context-id)
                      (format cep "\nBar number ~a, moment ~a\n"
                        current-bar-number current-moment)
                      (format cep "\nPitches (last/current): ~a/~a\n"
                        (second pitches)
                        (first pitches))
                      (format cep "\nDistance (diatonic/semitonic): ~a/~a\n"
                        current-interval-dist-diatonic
                        current-interval-dist-semitonic)
                      (if matching-interval
                          (begin
                           (format cep "\nMatch! Found interval ~a, coloring ~a\n"
                             matching-interval search-interval-color)
                           (if last-noteheads-color
                               (format cep
                                 "\nRecoloring - Last note heads color: ~a\n"
                                 last-noteheads-color))))
                      (display "\n---------------------\n" cep)))

                (if search-interval-color
                    (begin
                     ;; Check if the note heads directly preceding were
                     ;; colored, too. If true, the last note head belongs
                     ;; to two distinct intervals
                     ;;
                     ;; <noteheads-to-process>
                     ;; (grobB grobA)
                     ;; interval grobB<->grobA matches -> color!
                     ;; (grobB_colored grobA_colored)
                     ;; <next iteration>
                     ;; (grobC grobB_colored)
                     ;; interval grobC<->grobB matches -> color!
                     ;; (grobC_colored grobB_colored_colored (!))
                     ;; -> information about interval grobA<->grobB gets lost
                     ;; In this case, print a warning
                     (if last-noteheads-color
                         (ly:warning
                          (string-append
                           "~a: Recoloring note head in ~a ~a, bar number ~a\n"
                           "~a belongs to intervals ~a and ~a")
                          engraver-name
                          context-type
                          context-id
                          current-bar-number
                          (second pitches)
                          last-interval
                          matching-interval))
                     ;; Color current and last note head grob
                     (for-each
                      (lambda (grob)
                        (ly:grob-set-property!
                         grob
                         'color
                         search-interval-color))
                      noteheads-to-process)))
                ;; Preserve the current color (if any) for recoloring check
                ;; (see above)
                (set! last-noteheads-color search-interval-color)
                (set! last-interval matching-interval)))))))))


\markup \column {
  \line {
    "Diminished second," \with-color #green "up" "and" \with-color #blue "down"
  }
  \line {
    "Minor second," \with-color #yellow "up" "and" \with-color #cyan "down"
  }
  \line {
    "Major second," \with-color #red "up" "and" \with-color #darkgreen "down"
  }
  \line {
    "Augmented second," \with-color #darkcyan "up"
    "and" \with-color #darkyellow "down"
  }
}

\score {
  \new Voice
  \relative c'' {
    fis4 g e d as gis cis bes f g cis des des, e g fis
  }
  \layout {
    \context {
      \Voice
      \consists
      \color_interval_engraver #intervaldefs
      #`(("2--" ,UP #f ,green)
         ("2--" ,DOWN #f ,blue)
         ("2-" ,UP #f ,yellow)
         ("2-" ,DOWN #f ,cyan)
         ("2+" ,UP #f ,red)
         ("2+" ,DOWN #f ,darkgreen)
         ("2++" ,UP #f ,darkcyan)
         ("2++" ,DOWN #f ,darkyellow)
         ;; Not specified interval
         ;("2+++" ,DOWN #f ,darkyellow)
         ;; Direction not suitable
         ;("2++" 2 #f ,darkyellow)
         ;; Wrong type argument for 'searching enharmonically equivalent, too?'
         ;("2++" ,DOWN foo ,darkyellow)
         ;; Wrong type for color
         ;("2++" ,DOWN #f (1 2 3 4 5))
         ;; Wrong amount of entries
         ;("2++" ,DOWN #f)
         )
    }
  }
}

\markup \column {
  "Color intervals regardless of direction"
  \with-color #green "Diminished third"
  \with-color #yellow "Minor third"
  \with-color #red "Major third"
  \with-color #darkcyan "Augmented third"
}

\score {
  \new Staff \relative c' { d4 f e cis gis' e f a d bis cis as e ges des fis }
  \layout {
    \context {
      \Voice
      \consists \color_interval_engraver #intervaldefs
      #`(("3--" 0 #f ,green)
         ("3-" 0 #f ,yellow)
         ("3+" 0 #f ,red)
         ("3++" 0 #f ,darkcyan))
    }
  }
}

\markup \column {
  "Color enharmonically equivalent intervals, too"
  \with-color #green "Augmented second, minor third"
}

\score {
  \new Staff \relative c' { d4 f e a ges }
  \layout {
    \context {
      \Voice
      \consists \color_interval_engraver #intervaldefs #`(("3-" 0 #t ,green))
    }
  }
}

\markup \column {
  "Output warning, if note belongs to two intervals"
  \line { \with-color #green "Minor third" and
          \with-color #red "perfect fourth" }
}

\score {
  \new Staff \relative c' { c4 es bes des }
  \layout {
    \context {
      \Voice
      \consists \color_interval_engraver #intervaldefs
      #`(("3-" ,UP #f ,green)
         ("4" ,DOWN #f ,red))
    }
  }
}

\markup \column {
  "Output debug information"
  \line { \with-color #green "Minor second" and
          \with-color #red "perfect fourth" }
}

\score {
  <<
    \new Voice = "Soprano" \relative c' {
      \key b \minor
      \partial 2 fis2
      e2. fis4
      b2 a4 r
      cis fis, b a
      gis2 fis4 r
    }
    \new Voice = "Alto" \relative c' {
      \key b \minor
      \partial 2 d2
      cis2. d4
      d (e) fis r
      fis (fis) eis fis
      fis eis fis r
    }
  >>
  \layout {
    \context {
      \Voice
      \consists \color_interval_engraver #intervaldefs ##t
      #`(("2-" ,DOWN #f ,green)
         ("4" ,UP #f ,red))
    }
  }
}

\markup \column {
  "Output warning, if engraver has been added to staff instead of voice context"
  \line { \with-color #green "Minor second" and
          \with-color #red "perfect fourth" }
}

\score {
  \new Staff <<
    \new Voice = "Soprano" \relative c' {
      \voiceOne
      \key b \minor
      \partial 2 fis2
      e2. fis4
      b2 a4 r
      cis fis, b a
      gis2 fis4 r
    }
    \new Voice = "Alto" \relative c' {
      \voiceTwo
      \key b \minor
      \partial 2 d2
      cis2. d4
      d (e) fis r
      fis (fis) eis fis
      fis eis fis r
    }
  >>
  \layout {
    \context {
      \Staff
      \consists \color_interval_engraver #intervaldefs
      #`(("4" ,UP #f ,red)
         ("2-" ,DOWN #f ,green))
    }
  }
}

\paper { tagline = ##f }