Hi,
the attached code is my attempt to center a NoteColumn in a measure (like
MultiMeasureRest).
It's based upon
http://old.nabble.com/centering-text-on-a-measure-td32377202.html (thanks
to David Nalesnik)
While it works fine in most cases, there is one major problem:
Having a key-change to a\minor or c\major the function should adress the
keyCancellation as left bound to center the following NoteColumn.
But it doesn't, instead I get the log-warning: Infinity or NaN encountered
I've no idea why!
How to improve?
Cheers,
Harm
\version "2.14.2"
#(set-global-staff-size 20)
#(define (helper ls1 ls2 ls3)
"Constructs an alist with the elements of ls1 and ls2"
(set! ls3 (assq-set! ls3 (car ls1) (car ls2)))
(if (null? (cdr ls1))
ls3
(helper (cdr ls1) (cdr ls2) ls3)))
#(define (helper-2 lst number)
"Search the first element of the sorted lst, which is greater than number"
(let ((ls (sort lst <)))
(if (> (car ls) number)
(car ls)
(if (null? (cdr ls))
(begin
(display "no member of the list is greater than the number")
(newline))
(helper-2 (cdr ls) number)))))
#(use-modules (srfi srfi-1))
#(define (delete-adjacent-duplicates lst)
"Deletes adjacent duplicates in lst
eg. '(1 1 2 2) -> '(1 2)"
(fold-right (lambda (elem ret)
(if (equal? elem (first ret))
ret
(cons elem ret)))
(list (last lst))
lst))
#(define (position-in-list obj ls)
"Search the position of obj in ls"
(define (position-in-list-helper obj ls bypassed)
(if (null? ls)
#f
(if (equal? obj (car ls))
bypassed
(position-in-list-helper obj (cdr ls) (+ bypassed 1))
)))
(position-in-list-helper obj ls 0))
#(define (center-note-column grob)
(let* ((sys (ly:grob-system grob))
(array (ly:grob-object sys 'all-elements))
(grob-name (lambda (x) (assq-ref (ly:grob-property x 'meta) 'name)))
(note-heads (ly:grob-object grob 'note-heads))
(X-extent (lambda (q) (ly:grob-extent q sys X)))
;; NoteHeads
(note-heads-grobs (if (not (null? note-heads))
(ly:grob-array->list note-heads)
'()))
(one-note-head (if (not (null? note-heads-grobs))
(car note-heads-grobs)
'()))
(one-note-head-length (if (not (null? one-note-head))
(interval-length (ly:grob-extent one-note-head sys X))
0))
;; Stem
(stem (ly:grob-object grob 'stem))
(stem-dir (ly:grob-property stem 'direction))
(stem-length-x (interval-length (ly:grob-extent stem sys X)))
;; DotColumn
(dot-column (ly:note-column-dot-column grob))
;; AccidentalPlacement
(accidental-placement (ly:note-column-accidentals grob))
;; Arpeggio
(arpeggio (ly:grob-object grob 'arpeggio))
;; Rest
(rest (ly:grob-object grob 'rest))
;; NoteColumn
(note-column-coord (ly:grob-relative-coordinate grob sys X))
(grob-ext (ly:grob-extent grob sys X))
(grob-length (interval-length grob-ext))
;; BarLine
(lst-1 (filter (lambda (x) (eq? 'BarLine (grob-name x)))
(ly:grob-array->list array)))
(bar-coords (map (lambda (x) (ly:grob-relative-coordinate x sys X)) lst-1))
(bar-alist (helper bar-coords lst-1 '()))
;; KeySignature
(lst-2 (filter (lambda (x) (eq? 'KeySignature (grob-name x)))
(ly:grob-array->list array)))
(key-sig-coords (map (lambda (x) (ly:grob-relative-coordinate x sys X)) lst-2))
(key-sig-alist (if (not (null? lst-2))
(helper key-sig-coords lst-2 '())
'()))
;; KeyCancellation
(lst-3 (filter (lambda (x) (eq? 'KeyCancellation (grob-name x)))
(ly:grob-array->list array)))
(key-canc-coords (map (lambda (x) (ly:grob-relative-coordinate x sys X)) lst-3))
(key-canc-alist (if (not (null? lst-3))
(helper key-canc-coords lst-3 '())
'()))
;; TimeSignature
(lst-4 (filter (lambda (x) (eq? 'TimeSignature (grob-name x)))
(ly:grob-array->list array)))
(time-sig-coords (map (lambda (x) (ly:grob-relative-coordinate x sys X)) lst-4))
(time-sig-alist (if (not (null? lst-4))
(helper time-sig-coords lst-4 '())
'()))
;; Clef
(lst-5 (filter (lambda (x) (eq? 'Clef (grob-name x)))
(ly:grob-array->list array)))
(clef-coords (map (lambda (x) (ly:grob-relative-coordinate x sys X)) lst-5))
(clef-alist (if (not (null? lst-5))
(helper clef-coords lst-5 '())
'()))
;; Lists
(coords-list (delete-adjacent-duplicates
(sort
(append bar-coords
key-sig-coords
key-canc-coords
time-sig-coords
clef-coords
)
<)))
(grob-alist (append bar-alist
key-sig-alist
key-canc-alist
time-sig-alist
clef-alist
))
;; Bounds
(right-bound-coords (helper-2 coords-list note-column-coord))
(right-bound-position-in-coords-list (position-in-list right-bound-coords coords-list))
(left-bound-coords (list-ref coords-list (- right-bound-position-in-coords-list 1)))
(grob-x1 (assoc-ref grob-alist left-bound-coords))
(grob-x2 (assoc-ref grob-alist right-bound-coords))
(bounds-coord (cons left-bound-coords right-bound-coords))
(bounds (cons grob-x1 grob-x2))
) ;; End of Defs in let*
(begin
(newline)
(display bounds-coord)
(newline)
(display bounds)
(newline)
(ly:grob-set-property! grob-x1 'color red)
(ly:grob-set-property! grob-x2 'color blue)
(let ((left (if (> (cdr (X-extent (car bounds)))
(car (X-extent (cdr bounds))))
(car (X-extent (car bounds)))
(cdr (X-extent (car bounds)))))
(right (car (X-extent (cdr bounds)))))
(begin
;; NoteColumn
(cond ((not (null? note-heads))
(if (= stem-dir -1)
(ly:grob-translate-axis! grob
(- (- (- (interval-center (X-extent grob))
(/ (+ left right) 2)))
(if (> (interval-length (X-extent grob)) one-note-head-length)
(* 0.25 grob-length)
0))
X)
(ly:grob-translate-axis! grob
(- (- (- (interval-center (X-extent grob))
(/ (+ left right) 2)))
(if (> (interval-length (X-extent grob)) one-note-head-length)
(* -0.25 grob-length)
0))
X))))
;; DotColumn
(cond ((ly:grob? dot-column)
(let* ((dot-column-coord (ly:grob-relative-coordinate dot-column sys X))
(dot-note-dif (- dot-column-coord note-column-coord))
)
(ly:grob-translate-axis! dot-column
(+ (- (- (interval-center (X-extent dot-column))
(/ (+ left right) 2)))
dot-note-dif
(* -1.5 stem-length-x))
X))))
;; AccidentalPlacement
(cond ((ly:grob? accidental-placement)
(ly:grob-translate-axis! accidental-placement
(- (- (- (interval-center (X-extent accidental-placement))
(/ (+ left right) 2)))
(if (and (> (interval-length (X-extent grob)) one-note-head-length)
(= stem-dir 1))
(* 0.8 grob-length)
(* 1.25 grob-length)))
X)))
;; Arpeggio
(cond ((ly:grob? arpeggio)
(let* ((arpeggio-coord (ly:grob-relative-coordinate arpeggio sys X))
(note-arp-dif (- note-column-coord arpeggio-coord))
)
(ly:grob-translate-axis! arpeggio
(+ (- (- (interval-center (X-extent arpeggio))
(/ (+ left right) 2)))
(if (ly:grob? accidental-placement)
(* -1.2 note-arp-dif)
(* -1.4 note-arp-dif)))
X))))
;; Rest
(cond ((ly:grob? rest)
(ly:grob-translate-axis! rest
(+ (- (- (interval-center (X-extent rest))
(/ (+ left right) 2))))
X)))
)
)
)
);; End of let*
)
centerNoteColumnOn = \override Staff.NoteColumn #'after-line-breaking = #center-note-column
centerNoteColumnOff = \revert Staff.NoteColumn #'after-line-breaking
onceCenterNoteColumn = \once \override Staff.NoteColumn #'after-line-breaking = #center-note-column
%------------ Test
\paper {
ragged-right = ##f
}
% tiny example:
% this works:
<<
\new Staff
{ \key b\minor R1*2 }
\new Staff
{ \key b\minor \centerNoteColumnOn b'1 b' }
>>
% this not: Infinity or NaN encountered
% <<
% \new Staff
% { \key b\minor R1*2 }
% \new Staff
% { \key b\minor b''1 \key a\minor \onceCenterNoteColumn b'' }
% >>
%{
% full test:
\layout {
\context {
\Score
%\override NonMusicalPaperColumn #'line-break-permission = ##f
}
\context {
\Staff
%\remove Time_signature_engraver
%\remove Key_engraver
%\remove Clef_engraver
}
}
\markup \vspace #2
testVoice = \relative c' {
\key b\minor
\time 3/4
b'2_"Zeit?" r4
\key g\minor
\time 3/4
\clef "bass"
R2.
\key b\minor
\time 3/4
\clef "treble"
R2.
\key g\minor
% \key a\minor
\clef "bass"
R2.
\key b\minor
\clef "treble"
R2.
\key g\minor
R2.
\key b\minor
R2.
\key g\minor
R2.*1\fermataMarkup
\key b\minor
\clef "bass"
R
\bar "|."
}
voice = \relative c' {
\key b\minor
\time 3/4
b'2 r4
R2.*6
R2.*1\fermataMarkup
R
\bar "|."
}
pUp = \relative c' {
\key b\minor
\clef "bass"
\time 3/4
% \stemUp
<d, fis b>2.\pp (
\centerNoteColumnOn
<fis ais>
<fis d'>
\onceCenterNoteColumn
<e g c!> )
<dis fis a! b>\ppp (
<e g b> )
% \set Score.connectArpeggios = ##t
<dis fis b> ~
<dis fis b>\fermata
r
}
pDown = \relative c' {
\key b\minor
\clef "bass"
\time 3/4
%\stemDown
<b,, fis' b>2. ( |
\centerNoteColumnOn
<ais fis' ais> |
<d fis d'> |
<c g' c> ) |
<b b'> ~ |
<b b'>-.-> |
<b b'> ~ |
<b b'>\fermata |
r
}
<<
\new Staff \voice
%\testVoice
\new PianoStaff <<
\new Staff <<
\pUp
>>
\new Staff <<
\pDown
>>
>>
>>
%}
_______________________________________________
lilypond-devel mailing list
lilypond-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-devel
