%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\version "2.21.80"

#(define to-ascii-replacements
   '(("Â" . "A")
     ("â" . "a")
     ("À" . "A")
     ("à" . "a")
     ("Ä" . "A")
     ("ä" . "a")
     ("Æ" . "A")
     ("æ" . "a")
     ("Ç" . "C")
     ("ç" . "c")
     ("É" . "E")
     ("é" . "e")
     ("Ê" . "E")
     ("ê" . "e")
     ("È" . "E")
     ("è" . "e")
     ("Ë" . "E")
     ("ë" . "e")
     ("Î" . "I")
     ("î" . "i")
     ("Ï" . "I")
     ("ï" . "i")
     ("Ô" . "O")
     ("ô" . "o")
     ("Ö" . "O")
     ("ö" . "o")
     ("Œ" . "O")
     ("œ" . "o")
     ("Û" . "U")
     ("Ü" . "U")
     (" " . "")
     (" " . "") ; espace insécable
     ("«" . "")
     ("»" . "")
     ("o" . "oo")))

#(define ((max-common-pref pred) lst1 lst2)
   (cond ((null? lst1)
          '())
         ((null? lst2)
          '())
         ((pred (car lst1)
                (car lst2))
          (cons (car lst1)
                ((max-common-pref pred)
                  (cdr lst1)
                  (cdr lst2))))
         (else
           '())))

#(define max-common-pref-q (max-common-pref eq?))
#(define max-common-prefix (max-common-pref equal?))

#(define char-to-ascii-replacements
   (map
     (lambda (entry)
       (cons
         (string->list (car entry))
         (string->list (cdr entry))))
     to-ascii-replacements))

% Largement inspiré de lily/text-interface.cc.
#(define (normalize-string str)
   (list->string
     (let loop ((chars (string->list str)))
       (if (null? chars)
           '()
           (let inner-loop ((remaining-replacements
                              char-to-ascii-replacements))
             (if (null? remaining-replacements)
                 (cons (car chars)
                       (loop (cdr chars)))
                 (let* ((entry (car remaining-replacements))
                        (search (car entry))
                        (replace (cdr entry)))
                   (if (equal? (max-common-prefix search chars)
                               search)
                       (append replace
                               (loop
                                 (list-tail chars (length search))))
                       (inner-loop (cdr remaining-replacements))))))))))


#(define ((compare-func-from-key key-func key-compare) a b)
   (key-compare
     (key-func a)
     (key-func b)))

#(define toc-entry<?
   (compare-func-from-key
     (lambda (entry)
       (normalize-string (assq-ref (cdr entry) 'text)))
     string<?))




#(let ((toc-item-list (list))
       (path '(0))
       (level '()))
   (set! add-toc-item!
    (lambda* (markup-symbol text new-level)
               (let* ((new-level
                        (if (symbol? new-level)
                            (list new-level)
                            new-level))
                      (common-part-length
                        (length
                          (max-common-prefix
                            level
                            new-level)))
                      (id (gensym "toc")))
                 (if (> (length path) (1+ common-part-length))
                     (set! path
                           (list-head path
                                      (1+ common-part-length))))
                 (list-set! path
                            (1- (length path))
                            (1+ (last path)))
                 (set! path
                       (append! path
                                (make-list
                                  (-
                                    (1+ (length new-level))
                                    (length path))
                                  1)))
                 (set! toc-item-list
                       (acons id `((text . ,text)
                                   (toc-markup . ,markup-symbol)
                                   (parents . ())
                                   (children . ())
                                   (path . ,(copy-tree path))
                                   (level . 0))
                              toc-item-list))
                 (set! level new-level)

                 #{ \label $id #})))
   (set! toc-items (lambda ()
                     (stable-sort (reverse toc-item-list) toc-entry<?))))


%%%% Redéfinition de la fonction \tocItem pour n'accepter
%%%% qu'une chaîne de caractères et pas un \markup quelconque,
%%%% car il faut pouvoir trier dans l'ordre alphabétique des
%%%% chaînes.

tocItem =
#(define-music-function (level text)
                        ((symbol-list-or-symbol? '()) string?)
   (add-toc-item! 'tocItemMarkup text level))

#(define-markup-list-command (table-of-contents layout props) ()
  #:properties ((baseline-skip))
  ( _i "Outputs the table of contents, using the paper variable
@code{tocTitleMarkup} for its title, then the list of lines
built using the @code{tocItem} music function.
Usage: @code{\\markuplist \\table-of-contents}" )
  (let* ((titleMarkup (ly:output-def-lookup layout
                                            'tocTitleMarkup))
         (indentMarkup (ly:output-def-lookup layout
                                             'tocIndentMarkup))
         (toplevelFormatter (ly:output-def-lookup layout
'tocFormatMarkup))
         ;;;; Lire la variable toc-no-separator
         (toc-no-separator (ly:output-def-lookup layout
'toc-no-separator))
         (toc-alist (toc-items)))
    (ly:output-def-set-variable! layout
                                 'label-alist-table
                                 (append (ly:output-def-lookup
                                           layout
                                           'label-alist-table)
                                         toc-alist))
    (cons (interpret-markup layout props titleMarkup)
          (space-lines
            baseline-skip
            (filter-map
              (lambda (toc-item)
                (let* ((label (car toc-item))
                       (alist (cdr toc-item))
                       (toc-markup (assoc-get 'toc-markup alist))
                       (text (assoc-get 'text alist))
                       (level (assoc-get 'level alist))
                       (children (assoc-get 'children alist))
                       (path (assoc-get 'path alist)))
                  ;;;; On n'affiche pas les entrées qui en contiennent
                  ;;;; d'autres, seulement le dernier niveau.
                  (if (null? children)
                    (interpret-markup
                     layout
                     (cons (list
                            (cons 'toc:page
                                  (markup #:with-link label
                                          #:page-ref label "XXX" "?"))
                            (cons 'toc:text
                                  (markup #:with-link label text))
                            (cons 'toc:label label)
                            (cons 'toc:level level)
                            (cons 'toc:path path)
                            (cons 'toc:toplevel-formatter toplevelFormatter)
                            ;;;; Pas d'indentation des sous-niveaux
                            (cons 'toc:indent indentMarkup))
                                               ;(make-line-markup
                                               ; (make-list level indentMarkup))))
                           props)
                     (ly:output-def-lookup layout
                                           toc-markup))
                    #f)))
              toc-alist)))))

#(define-markup-command
  (toc-path-with-separator layout props separator)
  (markup?)
  #:properties ((toc:path #f))
  (interpret-markup layout props #{
    \markup \line {
      #@(cdr (apply append
                    (zip (make-list (length toc:path)
                                    separator)
                         (map number->string toc:path))))
    }
  #}))

\paper {
  toc-no-separator = " : "
  tocItemMarkup = \markup
    \bold
    %%%% \on-the-fly #format-toc-toplevel
    \fill-line {
    \line { \fromproperty #'toc:indent \fromproperty #'toc:text }
    %%%% Au lieu du numéro de page, 'toc:page, on met le numéro
    %%%% de la pièce.
    %\fromproperty #'toc:page
    \toc-path-with-separator ":"
  }
}


%% Exemple (mots au hasard).

\markuplist \table-of-contents

\pageBreak


\bookpart {
  \paper {
    systems-per-page = 3
  }

  %{
  \tocItem zéphyr "Zéphyr (1)"
  \tocItem zéphyr "Zéphyr (2)"
  \tocItem galbe "Galbe"
  \tocItem capitale.suiteUne "Première pièce du premier sous-groupe de Capitale"
  \tocItem capitale.suiteUne "Deuxième pièce du premier sous-groupe de Capitale"
  \tocItem capitale.suiteDeux "Première pièce du deuxième sous-groupe de Capitale"
  \tocItem capitale.suiteDeux "Deuxième pièce du deuxième sous-groupe de Capitale"
  \tocItem élision "« Élision »"
  %}  
    
  % Identification de la 1e pièce (via le nom de sa strophe 1)
  \tocItem B-pièce "S 1e vers strophe 1"
  % Strophes successives
  \tocItem B-pièce "S 1e vers strophe 1"
  \tocItem B-pièce "U 1e vers strophe 2"
  \tocItem B-pièce "« D » 1e vers strophe 3"
  
  % Identification de la 2e pièce (via le nom de sa strophe 1)
  \tocItem A-pièce "X 1e vers strophe 1"
  % Strophes successives
  \tocItem A-pièce "X 1e vers strophe 1"
  \tocItem A-pièce "B 1e vers strophe 2"
  \tocItem A-pièce "G 1e vers strophe 3"
  \tocItem A-pièce "K 1e vers strophe 4"

  % La table des matières se répartit automatiquement
  % sur plusieurs pages.
  #(for-each
     (lambda (i)
       (add-score #{
         \score {
           { \tocItem rien "Rien" \repeat unfold 10 c' }
         }
       #}))
     (iota 50))
}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%