\version "2.19.15"

#(define (remove-step x ps)
  "Copy PS, but leave out the Xth step."
  (if (null? ps)
      '()
      (let* ((t (remove-step x (cdr ps))))
        (if (= (- x 1) (ly:pitch-steps (car ps)))
            t
            (cons (car ps) t)))))

#(define (natural-chord-alteration p)
  "Return the natural alteration for step P."
  (if (= (ly:pitch-steps p) 6)
      FLAT
      0))

#(define (pitch-step p)
  "Musicological notation for an interval.  Eg. C to D is 2."
  (+ 1 (ly:pitch-steps p)))

#(define (split-at-predicate pred lst)
  "Split LST into two lists at the first element that returns #f for
  (PRED previous_element element).  Return the two parts as a pair.
  Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
  (let ((i (and (pair? lst)
                (list-index (lambda (x y) (not (pred x y)))
                            lst
                            (cdr lst)))))
    (if i
        (call-with-values
            (lambda () (split-at lst (1+ i)))
          cons)
        (list lst))))

#(define (get-step x ps)
  "Does PS have the X step? Return that step if it does."
  (if (null? ps)
      #f
      (if (= (- x 1) (ly:pitch-steps (car ps)))
          (car ps)
          (get-step x (cdr ps)))))

#(define (conditional-string-downcase str condition)
  (if condition
      (string-downcase str)
      str))

#(define-public (accidental->string alteration)
   (cond ((= alteration FLAT) "♭")         ;; or "b"
         ((= alteration DOUBLE-FLAT) "𝄫")  ;; or "bb"
         ((= alteration SHARP) "♯")        ;; or "#"
         ((= alteration DOUBLE-SHARP) "𝄪") ;; or "##"
         (else "")))

#(define-public (note-name->string pitch lowercase?)
  "Return pitch as string for @var{pitch}."
    (string-append
       (conditional-string-downcase
        (vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename pitch))
        lowercase?)
        (accidental->string (ly:pitch-alteration pitch))))  
    
%% What a shit :((
%% Works, though
#(define (look-for-string lst strg)
   (if (null? (cdr lst))
       (let ((arg (if (list? (car lst)) 
                      (last (car lst)) 
                      (car lst))))
         (string-append 
           strg
           (if (string? arg)
               arg
               "")))
       (cond ((string? (car lst))
              (string-append (car lst) strg)
              (look-for-string (cdr lst) strg)
              )
             ((list? (car lst))
              (string-append
                (string-concatenate (filter! string? (car lst)))
                strg)
              (look-for-string (cdr lst) strg)
              )
             ((list? (cadr lst))
              (look-for-string (cadr lst) strg)
              )
             (else (string-append "?" strg))
       )))
       
%#(newline)
%#(display-scheme-music ignatzekExceptions)

#(define transformed-ignatzek-exceptions
  (map
    (lambda (e)
      (list (car e) (look-for-string (cdr e) "")))
    ignatzekExceptions))
    
  
chord-note-namer = #'()
minor-chord-modifier = #"m"
major-seven-symbol = #"7+"
chord-name-separator = #" "
slash-chord-separator = #"/"
additional-pitch-prefix = #""
chord-prefix-spacer = #0
chord-name-lowercase-minor = ##f
chord-name-exceptions = #transformed-ignatzek-exceptions

#(define-public (simple-chord-names in-pitches bass inversion)
                
  (define (remove-uptil-step x ps)
    "Copy PS, but leave out everything below the Xth step."
    (if (null? ps)
        '()
        (if (< (ly:pitch-steps (car ps)) (- x 1))
            (remove-uptil-step x (cdr ps))
            ps)))

  (define name-root note-name->string)
  (define name-note
      (if (null? chord-note-namer)
          note-name->string
          chord-note-namer))

  (define (is-natural-alteration? p)
    (= (natural-chord-alteration p) (ly:pitch-alteration p)))

  (define (ignatzek-format-chord-name
           root
           prefix-modifiers
           main-name
           alteration-pitches
           addition-pitches
           suffix-modifiers
           bass-pitch
           lowercase-root?)

    "Format for the given (lists of) pitches.  This is actually more
work than classifying the pitches."

    (define (filter-main-name p)
      "The main name: don't print anything for natural 5 or 3."
      (if
       (or (not (ly:pitch? p))
           (and (is-natural-alteration? p)
                (or (= (pitch-step p) 5)
                    (= (pitch-step p) 3))))
       '()
       (list (name-step p))))

    (define (glue-word-to-step word x)
      (string-append word (name-step x)))

    (define (suffix-modifier->markup mod)
      (if (or (= 4 (pitch-step mod))
              (= 2 (pitch-step mod)))
          (glue-word-to-step "sus" mod)
          (glue-word-to-step "huh" mod)))

    (define (prefix-modifier->markup mod)
      (if (and (= 3 (pitch-step mod))
               (= FLAT (ly:pitch-alteration mod)))
          (if lowercase-root?
              ""
              minor-chord-modifier)
          "huh"))

    (define (filter-alterations alters)
      "Filter out uninteresting (natural) pitches from ALTERS."

      (define (altered? p)
        (not (is-natural-alteration? p)))

      (if
       (null? alters)
       '()
       (let* ((lst (filter altered? alters))
              (lp (last-pair alters)))

         ;; we want the highest also if unaltered
         (if (and (not (altered? (car lp)))
                  (> (pitch-step (car lp)) 5))
             (append lst (last-pair alters))
             lst))))

    (define (name-step pitch)
      (define (step-alteration pitch)
        (- (ly:pitch-alteration pitch)
           (natural-chord-alteration pitch)))

      (let* ((num-markup (number->string (pitch-step pitch)))
             (args (list num-markup))
             (total 
               (if (= (ly:pitch-alteration pitch) 0)                                    
                   (if (= (pitch-step pitch) 7)                                    
                       (list major-seven-symbol)                                   
                       args)                                                       
                   (cons (accidental->string (step-alteration pitch)) args))))
        (string-concatenate total)))

    (let* ((sep chord-name-separator)
           (slashsep slash-chord-separator)
           (root-markup (name-root root lowercase-root?))
           (add-pitch-prefix additional-pitch-prefix)
           (add-markups (map (lambda (x) (glue-word-to-step add-pitch-prefix x))
                             addition-pitches))
           (filtered-alterations (filter-alterations alteration-pitches))
           (alterations (map name-step filtered-alterations))
           (suffixes (map suffix-modifier->markup suffix-modifiers))
           (prefixes (map prefix-modifier->markup prefix-modifiers))
           (main-markups (filter-main-name main-name))
           ;; keeping the name, although it isn't raised anymore
           (to-be-raised-stuff (string-append
                                 (string-concatenate main-markups)
                                 (string-concatenate alterations)
                                 (string-concatenate suffixes)
                                 (string-concatenate add-markups)))
           (base-stuff (if (ly:pitch? bass-pitch)
                           (list slashsep (name-note bass-pitch #f))
                           '())))

      (set! base-stuff
            (append
             (list root-markup
                   (string-concatenate prefixes)
                   to-be-raised-stuff)
             base-stuff))
      (string-concatenate base-stuff)))

  (define (ignatzek-format-exception
           root
           exception-markup
           bass-pitch
           lowercase-root?)

    (string-concatenate
     `(
       ,(name-root root lowercase-root?)
       ,exception-markup
       .
       ,(if (ly:pitch? bass-pitch)
            (list slash-chord-separator
                  (name-note bass-pitch #f))
            '()))))

  (let* ((root (car in-pitches))
         (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
         (lowercase-root?
          (and chord-name-lowercase-minor
               (let ((third (get-step 3 pitches)))
                 (and third (= (ly:pitch-alteration third) FLAT)))))
         (exceptions chord-name-exceptions)
         (exception 
           (let ((except (assoc-get pitches exceptions)))
             (if except
                 (car except)
                 except)))
         (prefixes '())
         (suffixes '())
         (add-steps '())
         (main-name #f)
         (bass-note
          (if (ly:pitch? inversion)
              inversion
              bass))
         (alterations '()))
           
  (let ((result
    (if exception
        (ignatzek-format-exception root exception bass-note lowercase-root?)
        
        (begin
          ;; no exception.
          ;; handle sus4 and sus2 suffix: if there is a 3 together with
          ;; sus2 or sus4, then we explicitly say add3.
          (for-each
           (lambda (j)
             (if (get-step j pitches)
                 (begin
                   (if (get-step 3 pitches)
                       (begin
                         (set! add-steps (cons (get-step 3 pitches) add-steps))
                         (set! pitches (remove-step 3 pitches))))
                   (set! suffixes (cons (get-step j pitches) suffixes)))))
           '(2 4))

          ;; do minor-3rd modifier.
          (if (and (get-step 3 pitches)
                   (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
              (set! prefixes (cons (get-step 3 pitches) prefixes)))

          ;; lazy bum. Should write loop.
          (cond
           ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
           ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
           ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
           ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
           ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))

          (let* ((3-diff? (lambda (x y)
                            (= (- (pitch-step y) (pitch-step x)) 2)))
                 (split (split-at-predicate
                         3-diff? (remove-uptil-step 5 pitches))))
            (set! alterations (append alterations (car split)))
            (set! add-steps (append add-steps (cdr split)))
            (set! alterations (delq main-name alterations))
            (set! add-steps (delq main-name add-steps))

            ;; chords with natural (5 7 9 11 13) or leading subsequence.
            ;; etc. are named by the top pitch, without any further
            ;; alterations.
            (if (and
                 (ly:pitch? main-name)
                 (= 7 (pitch-step main-name))
                 (is-natural-alteration? main-name)
                 (pair? (remove-uptil-step 7 alterations))
                 (every is-natural-alteration? alterations))
                (begin
                  (set! main-name (last alterations))
                  (set! alterations '())))

            (ignatzek-format-chord-name
             root prefixes main-name alterations add-steps suffixes bass-note
             lowercase-root?))))))
    ;(newline)(display result)
    result)))
    
%% TEST
%  
% \include "predefined-guitar-fretboards.ly"
%   
% %% Adding a simple chord-name as last entry of 
% %% every sublist of default-fret-table
% #(for-each
%   (lambda (e)
%     (newline)
%     (write
%      (cons e
%       (simple-chord-names
%         (cdar e)
%         '()
%         '()
%         ))))
%   (hash-table->alist default-fret-table))
%