\version "2.22.1" #(use-modules (ice-9 match) (ice-9 receive)) #(set-object-property! 'chord-name-fractions 'backend-type? list?) #(define (define-grob! grob-name grob-entry) (set! all-grob-descriptions (cons ((@@ (lily) completize-grob-entry) (cons grob-name grob-entry)) all-grob-descriptions))) #(define (chord-square::print grob) (let* ((left (ly:spanner-bound grob LEFT)) (right (ly:spanner-bound grob RIGHT)) (left-pos (car (ly:paper-column::break-align-width left 'staff-bar))) (right-pos (car (ly:paper-column::break-align-width right 'staff-bar))) (sys (ly:grob-system grob)) (my-X (ly:grob-relative-coordinate grob sys X)) (relative-left (- left-pos my-X)) (relative-right (- right-pos my-X)) (height (ly:grob-property grob 'height)) (top (* 1/2 height)) (bottom (* -1/2 height)) (thickness (* (ly:grob-property grob 'thickness) (ly:staff-symbol-line-thickness grob))) (chord-names (ly:grob-array->list (ly:grob-object grob 'elements))) (chord-name-fractions (ly:grob-property grob 'chord-name-fractions))) (receive (printed-lines positions) (match chord-name-fractions ((1) (values '(#f #f #f #f) '((0.0 . 0.0)))) ((1/2 1/2) (values '(#t #f #t #f) '((-0.5 . 0.3) (0.5 . -0.3)))) ((1/2 1/4 1/4) (values '(#t #f #t #t) '((-0.5 . 0.3) (0 . -0.6) (0.65 . 0.05)))) ((1/4 1/4 1/2) (values '(#t #t #t #f) '((-0.65 . 0.0) (0.0 . 0.6) (0.5 . -0.3)))) ((1/4 1/4 1/4 1/4) (values '(#t #t #t #t) '((-0.6 . 0.0) (0.0 . 0.6) (0.0 . -0.6) (0.5 . 0.05)))) ((1/4 3/4) (values '(#t #t #f #f) '((-0.65 . 0.0) (0.4 . 0.0)))) ((3/4 1/4) (values '(#f #f #t #t) '((-0.4 . 0.05) (0.65 . 0.05)))) (else (ly:event-warning (event-cause grob) "unsupported measure pattern: ~a" chord-name-fractions) (values '(#f #f #f #f) (make-list (length chord-names) '(0 . 0))))) (let* ((line-endings `((,relative-left ,bottom) (,relative-left ,top) (,relative-right ,top) (,relative-right ,bottom))) (x-interval (cons relative-left relative-right)) (y-interval (cons bottom top)) (x-center (interval-center x-interval)) (x-absolute-interval (cons left-pos right-pos)) (lines-stil (apply ly:stencil-add (filter-map (lambda (ending should-print) (and should-print (apply make-line-stencil thickness x-center 0 ending))) line-endings printed-lines)))) (for-each (match-lambda* ((chord-name (x . y)) (let ((rel-x (- (interval-index x-absolute-interval x) (interval-center (ly:grob-extent chord-name sys X)))) (rel-y (- (interval-index y-interval y) (interval-center (ly:grob-extent chord-name chord-name Y))))) (ly:grob-translate-axis! chord-name rel-x X) (ly:grob-translate-axis! chord-name rel-y Y)))) chord-names positions) lines-stil)))) #(define (chord-square::height grob) (let ((height (ly:grob-property grob 'height))) (cons (* -1/2 height) (* 1/2 height)))) #(define-grob! 'ChordSquare `((axes . (,Y)) (height . 10) (no-alignment . #t) (thickness . 1) (stencil . ,chord-square::print) (vertical-skylines . ,(ly:make-unpure-pure-container ly:grob::simple-vertical-skylines-from-extents ly:grob::pure-simple-vertical-skylines-from-extents)) (X-extent . ,ly:grob::stencil-width) (Y-extent . ,(ly:make-unpure-pure-container chord-square::height)) (meta . ((class . Spanner) (interfaces . (axis-group-interface)))))) #(define (Chord_square_engraver context) (let ((chord-names #f) (square #f) (moms '())) (make-engraver ((process-music engraver) (if (and square (string? (ly:context-property context 'whichBar)) (equal? ZERO-MOMENT (ly:context-property context 'measurePosition))) (begin (let ((col (ly:context-property context 'currentCommandColumn))) (ly:spanner-set-bound! square RIGHT col)) (let* ((now-mom (ly:context-current-moment context)) (extended-moms (cons now-mom moms)) (mom-deltas (let loop ((remaining extended-moms) (acc '())) (match remaining ((one) acc) ((one two . rest) (loop (cons two rest) (cons (ly:moment-sub one two) acc)))))) (total-span (ly:moment-sub now-mom (last moms))) (fracs (map (lambda (delta) (ly:moment-main (ly:moment-div delta total-span))) mom-deltas))) (ly:grob-set-property! square 'chord-name-fractions fracs)) (set! square #f) (set! moms '())))) (acknowledgers ((chord-name-interface engraver grob source-engraver) (if (not square) (let ((col (ly:context-property context 'currentCommandColumn))) (set! square (ly:engraver-make-grob engraver 'ChordSquare grob)) (ly:spanner-set-bound! square LEFT col))) (ly:axis-group-interface::add-element square grob) (let ((mom (ly:context-current-moment context))) (set! moms (cons mom moms)))))))) \layout { \context { \Global \grobdescriptions #all-grob-descriptions } \context { \Score \remove Bar_number_engraver \remove System_start_delimiter_engraver } \context { \ChordNames \name ChordGrid \consists #Chord_square_engraver \consists Bar_engraver \override BarLine.bar-extent = #'(-3 . 3) \consists System_start_delimiter_engraver systemStartDelimiter = #'SystemStartBar \override SystemStartBar.collapse-height = 0 \consists Staff_symbol_engraver \override StaffSymbol.line-positions = #'(-6 6) } \inherit-acceptability ChordGrid ChordNames } %% Repris de https://lists.gnu.org/archive/html/lilypond-user-fr/2022-02/msg00033.html %% (et légèrement arrangé). #(define (Recurring_break_engraver context) (let ((break-allowed #f) (bar 0) (was-start-partial #f)) (define (start-partial?) (or (and (equal? ZERO-MOMENT (ly:context-current-moment context)) (ly:moment