Re: Altérations dièse ou bémol au lieu de bécarre avec easyHeadsOn

[Ya Gloops]

Bonjour Jean!
Je ne sais pas si tu connais le sinppet color_interval_engraver? Je l'utilse 
régulièrement, malheureusement il n'est visiblement pas compatible avec 
Relative_alterations_engraver, ce qui, je suppose est normal. Sais-tu si il y a 
moyen d'adapter l'un ou l'autre ?


#(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))))


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)))))))))




#(define (Relative_alterations_engraver context)
   (let ((note-events '()))
     (make-engraver
      (listeners
       ((note-event engraver event)
        (set! note-events (cons event note-events))))
      ((pre-process-music engraver)
       (let ((tonic (ly:context-property context 'tonic)))
         (for-each
          (lambda (ev)
            (let* ((pitch (ly:event-property ev 'pitch))
                   (octave (ly:pitch-octave pitch))
                   (notename (ly:pitch-notename pitch))
                   (rel-pitch (ly:pitch-diff pitch tonic))
                   (rel-alt (ly:pitch-alteration rel-pitch)))
              (ly:event-set-property!
               ev 'pitch
               (ly:make-pitch octave notename rel-alt))))
          note-events)
         (set! note-events '()))))))


#(define (No_key_alterations_engraver context)
   (make-engraver
    ((pre-process-music engraver)
     (ly:context-set-property! context 'keyAlterations '()))))




\score {
  \new Voice
  \relative c'' 
  {\key as \major
   c des es fes
  }
  \layout {
    \context {
      \Voice
   
      \consists \color_interval_engraver #intervaldefs
      #`(("2-" ,UP #f ,red)) 
      %\consists \Relative_alterations_engraver
    }
    \context {
      \Staff
      %\consists \No_key_alterations_engraver
    }
  }
}








Le mardi 21 mars 2023 à 09:46:25 UTC+1, Ya Gloops <yagloops@yahoo.fr> a écrit : 





Magnifique Jean !!!
Toute ma gratitude…
Gilles






Le mardi 21 mars 2023 à 09:11:04 UTC+1, Jean Abou Samra <jean@abou-samra.fr> a 
écrit : 





Le lundi 20 mars 2023 à 23:48 +0000, Ya Gloops a écrit :

>  
> C'est exactement ça !, c'est génial… Bravo Jean
> Pour une question pratique, y a-t-il un moyen, en gardant exactement ce 
> résultat, d'éviter d'avoir à modifier \key ?
> 
> C'est-à-dire appliquer le context automatiquement ...
> J'ai essayé ça mais ça plante 
> 
> key =
> #(define-music-function (pitch mode) (ly:pitch? number-pair-list?)
>    #{
>      \key #pitch #mode
>      \context Staff \applyContext
>        #(lambda (context)
>           (ly:context-set-property! context 'keyAlterations '()))
>    #})
> 
> \relative c' {
>   \easyHeadsOn
>   \key fis \major
>   fis gis ais b cisis d eis fis  e eis fis
> }
> 

Normal : comme tu redéfinis la fonction \key, le \key qui se trouve à 
l'intérieur n'est pas un appel à la fonction \key de LilyPond mais à la 
nouvelle fonction. Donc cette fonction s'appelle elle-même, à l'infini, ou plus 
exactement jusqu'à ce que l'espace alloué à la « pile d'appels » (là où la 
liste des fonctions qui sont en train d'être exécutées est stockée, de manière 
simplifiée) soit épuisé et que crash s'ensuive. Si tu veux le faire de cette 
manière, il faut d'abord mettre la fonction \key de LilyPond dans une variable, 
avec keyDefault = \key \etc ou keyDefault = #key, puis utiliser \defaultKey 
dans la fonction. Cela dit, en fait on peut s'en passer :
\version "2.24.1"

#(define Ez_numbers_engraver
   (make-engraver
    (acknowledgers
     ((note-head-interface engraver grob source-engraver)
      (let* ((context (ly:translator-context engraver))
             (tonic-pitch (ly:context-property context 'tonic))
             (tonic-name (ly:pitch-notename tonic-pitch))
             (grob-pitch
              (ly:event-property (event-cause grob) 'pitch))
             (grob-name (ly:pitch-notename grob-pitch))
             (delta (modulo (- grob-name tonic-name) 7))
             (note-names
              (make-vector 7 (number->string (1+ delta)))))
        (ly:grob-set-property! grob 'note-names note-names))))))

#(define (Relative_alterations_engraver context)
   (let ((note-events '()))
     (make-engraver
      (listeners
       ((note-event engraver event)
        (set! note-events (cons event note-events))))
      ((pre-process-music engraver)
       (let ((tonic (ly:context-property context 'tonic)))
         (for-each
          (lambda (ev)
            (let* ((pitch (ly:event-property ev 'pitch))
                   (octave (ly:pitch-octave pitch))
                   (notename (ly:pitch-notename pitch))
                   (rel-pitch (ly:pitch-diff pitch tonic))
                   (rel-alt (ly:pitch-alteration rel-pitch)))
              (ly:event-set-property!
               ev 'pitch
               (ly:make-pitch octave notename rel-alt))))
          note-events)
         (set! note-events '()))))))

#(define (No_key_alterations_engraver context)
   (make-engraver
    ((pre-process-music engraver)
     (ly:context-set-property! context 'keyAlterations '()))))

\layout {
  ragged-right = ##t
  \context {
    \Voice
    \consists \Ez_numbers_engraver
    \consists \Relative_alterations_engraver
  }
  \context {
    \Staff
    \consists \No_key_alterations_engraver
  }
}

\relative c' {
  \easyHeadsOn
  \key c \major
c d e f gis as b c  
}


\relative c' {
  \easyHeadsOn
  \key fis \major
  fis gis ais b cisis d eis fis  
}


\relative c' {
  \easyHeadsOn
  \key ges \major
  ges' as bes ces d eses f ges   
}

Cordialement,

Jean