\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
    	>>
    	>>
  >>
  
%}