\version "2.18.2"

%% 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
%% Value:
%% the cdr represents the semitonic steps.
%% diatonic steps are calculated relying on the key in the engraver
%% 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++" . 1)
     ("1" . 0)
     ("2-" . 1)
     ("2--" . 0)
     ("2+" . 2)
     ("2++" . 3)
     ("3-" . 3)
     ("3--" . 2)
     ("3+" . 4)
     ("3++" . 5)
     ("4--" . 4)
     ("4++" . 6)
     ("4" . 5)
     ("5--" . 6)
     ("5++" . 8)
     ("5" . 7)
     ("6-" . 8)
     ("6--" . 7)
     ("6+" . 9)
     ("6++" . 10)
     ("7-" . 10)
     ("7--" . 9)
     ("7+" . 11)
     ("7++" . 12)
     ("8--" . 11)
     ("8++" . 13)
     ("8" . 12)
     ("9-" . 13)
     ("9--" . 12)
     ("9+" . 14)
     ("9++" . 15)
     ("10-" . 15)
     ("10--" . 14)
     ("10+" . 16)
     ("10++" . 17)
     ("11--" . 16)
     ("11++" . 18)
     ("11" . 17)
     ("12--" . 18)
     ("12" . 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))
%%   }
%% }
#(use-modules (ice-9 pretty-print))
color_interval_engraver =
#(define-scheme-function (parser location intervaldefs debug? intervals-given)
   (list? (boolean?) list?) ;; debug? is optional, defaults to #f
   
  (define (string-diatonic-semi-tonic-list string-semi-tonic-list)
   (map 
     (lambda (e)
       (let* ((interval-string 
                (string-trim-both 
                  (car e) 
                  (lambda (c) (or (eqv? c #\+) (eqv? c #\-)))))
              (interval-diatonic
                (string->number interval-string)))
         (cons (car e) (cons (1- interval-diatonic) (cdr e)))))
     string-semi-tonic-list))
     
  (define (type-check-intervals-given msg-header)
    (lambda (interval) 
      ;; basic check for amount of args
      (if (= 4 (length interval))
          #t
          (begin 
            (ly:error 
              "~a Interval ~a must have 4 entries" msg-header interval)
            #f))
      ;; check every entry for type, additonally 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?
          (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))))))
   
   (let* ((msg-header "Color_interval_engraver:")
          (interval-defs-list (string-diatonic-semi-tonic-list intervaldefs))
          (cleaned-intervals-given
            (filter (type-check-intervals-given msg-header) intervals-given))
          (search-intervals 
            ;; mmh, not sure if `reverse` is really needed
            (reverse 
              (map
                (lambda (interval)
                  (let ((diatonic-semitonic-pair 
                          (assoc-get (car interval) interval-defs-list)))
                    (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)
          '())
         ;; Instantiate actual engraver
         (color-interval-engraver-core search-intervals debug?))))


#(define (color-interval-engraver-core search-intervals debug?)
   (lambda (context)
     (let ((last-grob #f)
           (current-grob #f))
       (make-engraver
        ;; 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)
          ;; Store current and last note head grob
          (set! last-grob current-grob)
          (set! current-grob grob)
          
          ;; Check for grobs in the queue, before continuing
          (if (and last-grob current-grob)
              ;; Note head grobs store a reference to the
              ;; event that caused their generation
              ;; Thus we can extract the pitch
              (let* ((current-grob-cause
                       (ly:grob-property current-grob 'cause))
                     (current-pitch
                       (ly:event-property current-grob-cause 'pitch))
                     (last-grob-cause (ly:grob-property last-grob 'cause))
                     (last-pitch (ly:event-property last-grob-cause 'pitch))
                     ;; Calculate interval distances, diatonic and semitonic
                     (current-interval-dist-diatonic
                      (- (ly:pitch-steps current-pitch)
                         (ly:pitch-steps last-pitch)))
                     (current-interval-dist-semitonic
                      (- (ly:pitch-semitones current-pitch)
                         (ly:pitch-semitones last-pitch)))
                     ;; 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)))
                      (newline)
                      (format cep "Previous pitch: ~a\n" last-pitch)
                      (format cep "Current pitch: ~a\n" current-pitch)
                      (format cep "Diatonic diff: ~a\n"
                        current-interval-dist-diatonic)
                      (format cep "Semitonic diff: ~a\n"
                        current-interval-dist-semitonic)
                      (format cep "Matching interval: ~a\n" matching-interval)
                      (format cep "Grob color: ~a\n" search-interval-color)
                      (display "**********\n" cep)))
                      
                (if search-interval-color
                    (begin
                     ;; Color current and last note head grob
                     (set! (ly:grob-property current-grob 'color)
                           search-interval-color)
                     (set! (ly:grob-property last-grob 'color)
                           search-interval-color)))))))))))
 

\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 Staff
    \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))
    }
  }
}

\score {
  \new Staff \relative c' { c4 d }
  \layout {
    \context {
      \Voice
      \consists \color_interval_engraver #intervaldefs #`(("30-" 0 #t ,green))
    }
  }
}