\version "2.19.15"

#(define (ledger-line-no middle-C-pos p)
   "Returns the number of ledger-lines a pitch @var{p} will have with
middle C position @var{middle-C-pos} expressed as staff-steps from the
middle staff line."
   (let* ((ps (ly:pitch-steps p))
          (mid-staff-steps (- middle-C-pos))
          (top-line (+ mid-staff-steps 4))
          (bottom-line (- mid-staff-steps 4))
          (above? (> ps top-line))
          (below? (< ps bottom-line))
          (steps-outside-staff
           (cond
            (below? (- ps bottom-line))
            (above? (- ps top-line))
            (else 0))))
     (truncate (/ steps-outside-staff 2))))

#(define (find-clefMiddleCPosition mus)
   (let ((clef-pos -6)) ; treble is default
     (for-some-music
      (lambda (x)
        (let ((n (ly:music-property x 'symbol)))
          (and (eq? n 'middleCClefPosition)
               (set! clef-pos (ly:music-property x 'value)))))
      mus)
     clef-pos))

#(define clefs
   ; An alist of (clef . position of middle C) pairs.  Center line of staff = 0.
   ; For use when \ottavate is called on a music expression which begins with a
   ; clef other than treble, which has been set before that expression.
   '((treble . -6)
     (treble_8 . 1)
     (bass . 6)
     (bass_8 . 13)
     (alto . 0)
     (tenor . 2)))

#(define (make-ottava-music arg)
   (list (make-music
          'OttavaMusic
          'ottava-number arg)))

#(define (select-ottava-music str)
   (let ((options
          '(("up-an-octave" . 1)
            ("down-an-octave" . -1)
            ("up-two-octaves" . 2)
            ("down-two-octaves" . -2)
            ("loco" . 0))))
     (make-ottava-music (assoc-get str options))))

#(define naming-options
   '((short . (("up-an-octave" . "8")
               ("down-an-octave" . "8")
               ("up-two-octaves" . "15")
               ("down-two-octaves" . "15")
               ("loco" . #f)))
     (long . (("up-an-octave" . "8va")
              ("down-an-octave" . "8va bassa")
              ("up-two-octaves" . "15ma")
              ("down-two-octaves" . "15ma")
              ("loco" , #f)))
     (default . #f)))

#(define (make-alternate-name name)
   (let* ((ps (make-music
               'PropertySet
               'symbol 'ottavation
               'value name))
          (csm (make-music
                'ContextSpeccedMusic
                'element ps
                'context-type 'Staff)))
     (list csm)))

#(define (select-name displacement name-style)
   (let* ((style (assoc-get name-style naming-options))
          (name (if style
                    (assoc-get displacement style)
                    #f)))
     (if name
         (make-alternate-name name)
         '())))


ottavate =
#(define-music-function (parser location upper lower options mus)
   (number-pair? number-pair? list? ly:music?)
   "Create ottavas for music based on numbers of ledger lines.  Both @var{upper}
and @var{lower} are pairs specifying a range of ledger lines: @var{upper}
determines @code{8va} and @code{15ma}, and @var{lower} determines @var{8vb} and
@var{15mb}.  Within this range (inclusive), an @code{8va} or @code{8ba} will
be created.  Notes with numbers of ledger lines exceeding these ranges will be
assigned @code{15ma} or @code{15mb}.

Numbers of ledger lines above the staff are specified in @var{upper} as
positive integers, while ledger lines below the staff are specified in @var{lower}
as negative numbers.

The parameter @var{options} is an alist of symbol/value pairs. The symbol
@var{name-style} may be paired with @var{short}, @var{long}, or @var{default}.
The symbol @var{opening-clef} is for use when the music expression on which
@code{ottavate} is called begins with a clef other than treble which has been
set before that music expression.

The parameter @var{options} is not optional.  Any symbol left out will be assigned
its default value.  The empty list selects all default values.
"
   (let* ((upper8 (car upper))
          (upper15 (cdr upper))
          (lower8 (car lower))
          (lower15 (cdr lower))
          (name-style (assoc-get 'name-style options 'default))
          ;; Since clef information is found by scanning the music expression, any clef
          ;; change must be within the music expression fed to ottavate.  There is no access
          ;; to context properties from within a music function.  User needs to tell
          ;; \ottavate the opening clef if it is other than treble and not set within
          ;; the music expression on which \ottavate is called.
          (opening-clef (assoc-get 'opening-clef options 'treble))
          (opening-middle-C-pos (assoc-get opening-clef clefs)) 
          (loco (make-ottava-music 0)))
     
     (define (select-displacement-string ledger-count)
       (cond 
        ((> ledger-count upper15)
         "up-two-octaves")
        ((>= ledger-count upper8)
         "up-an-octave")
        ((< ledger-count lower15)
         "down-two-octaves")
        ((<= ledger-count lower8)
         "down-an-octave")
        (else "loco")))
     
     (define (calc-displacement clef-pos mus-expr)
       ; Return a string designating displacement.  "Loco" means "as written."
       ; Chords have the ledger-line count of their members averaged.
       ; Algorithm ought to be more sophisticated, and take context into consideration.
       ; We should not lose an ottava if one note in a passage dips below the
       ; threshold.
       (cond
        ((music-is-of-type? mus-expr 'event-chord)
         (let* ((elts (ly:music-property mus-expr 'elements))
                (ledger-list
                 (map (lambda (e)
                        (ledger-line-no clef-pos (ly:music-property e 'pitch)))
                   elts))
                (lowest (apply min ledger-list))
                (highest (apply max ledger-list)))
           (cond
            ((every positive? ledger-list)
             (select-displacement-string lowest))
            ((every negative? ledger-list)
             (select-displacement-string highest))
            (else "loco"))))
        ((music-is-of-type? mus-expr 'note-event)
         (let* ((pitch (ly:music-property mus-expr 'pitch))
                (ledger-count (ledger-line-no clef-pos pitch)))
           (select-displacement-string ledger-count)))))
     
     (define (build-new-elts mus-expr new-expr prev clef-pos)
       (if (null? mus-expr)
           new-expr
           (begin
            (if (music-is-of-type? (car mus-expr) 'context-specification)
                (set! clef-pos (find-clefMiddleCPosition (car mus-expr))))
            (cond
             ;; We do not extend across rests for now.
             ((music-is-of-type? (car mus-expr) 'rest-event)
              (build-new-elts
               (cdr mus-expr)
               (append
                new-expr
                loco
                (list (car mus-expr)))
               "loco" clef-pos))
             
             ((or (music-is-of-type? (car mus-expr) 'event-chord)
                  (music-is-of-type? (car mus-expr) 'note-event))
              (let ((d (calc-displacement clef-pos (car mus-expr))))
                (cond
                 ((and d (not (string=? d prev)))
                  (build-new-elts
                   (cdr mus-expr)
                   (append
                    new-expr
                    (select-ottava-music d)
                    (select-name d name-style)
                    (list (car mus-expr)))
                   d clef-pos))
                 (else
                  (build-new-elts
                   (cdr mus-expr)
                   (append new-expr (list (car mus-expr)))
                   prev clef-pos)))))
             ; ew.
             (else 
              (build-new-elts
               (cdr mus-expr)
               (append new-expr (list (car mus-expr)))
               prev clef-pos))))))
     
     (define (recurse music)
       (let ((elts (ly:music-property music 'elements))
             (e (ly:music-property music 'element)))
         (if (ly:music? e)
             (recurse e))
         (if (pair? elts)
             (if (or
                  (any (lambda (elt) (music-is-of-type? elt 'note-event)) elts)
                  (any (lambda (elt) (music-is-of-type? elt 'event-chord)) elts)
                  (any (lambda (elt) (music-is-of-type? elt 'rest-event)) elts))
                 (set! (ly:music-property music 'elements)
                       (build-new-elts elts '() "loco" opening-middle-C-pos))
                 (map recurse elts)))))
     (recurse mus)
     
     ;(display-scheme-music mus) ; for testing
   
     mus))

%%%%%%%%%%% EXAMPLE %%%%%%%%%%%%
{
  f''' g''' \clef bass g,, e,,
}

{
  \ottavate #'(4 . 7) #'(-4 . -7) #'((name-style . short)) { f''' g''' \clef bass g,, e,,}
}

music = { c d e f }

% WRONG!

{
  \clef bass \ottavate #'(4 . 7) #'(-4 . -7) #'() \music
}

% RIGHT!
{
  \clef bass % not visible to \ottavate... 
  \ottavate #'(4 . 7) #'(-4 . -7) #'((opening-clef . bass)) \music
}


musFour = \relative c' {
  
  <c e g> <e g c> <g c e>
  <c e g> <e g c> <g c e>
  <c e g> <e g c> <g c e>
  <c e g> <e g c> <g c e>
  <c e g> <g c e> <e g c>
  <c e g> <g c e> <e g c>
  <c e g> <g c e> <e g c>
  <c e g> <g c e> <e g c>
}

{
  \musFour
}

{
  \ottavate #'(3 . 6) #'(-3 . -6) #'((name-style . short)) \musFour
}