\version "2.14.2"

% Thanks to David Nalesnik
 
#(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 x-offs) 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-2a (filter (lambda (x) (eq? 'KeySignature (grob-name x)))
                                (ly:grob-array->list array)))
            (lst-2 (remove (lambda (x) (interval-empty? (X-extent x))) lst-2a))
            (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 (cdr (X-extent (car bounds))))
                 (right (car (X-extent (cdr bounds)))))
                 
 ;;(display (cons left right)) (newline)
              
             (begin
             ;; NoteColumn
             	(cond ((not (null? note-heads))
		  (ly:grob-translate-axis! grob
		    (- (- (- (interval-center (X-extent grob))
		          (/ (+ left right) 2))) 
		       (if (> (interval-length (X-extent grob)) one-note-head-length)
			   (* stem-dir -0.25 grob-length)
			   0)
		       (* -1 x-offs))
		    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-offs)
                       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.9 grob-length)
                           (* 1.3 grob-length))
                        (* -1 x-offs))
                     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))
                           (* -1 x-offs))
                     X))))
             ;; Rest
                (cond ((ly:grob? rest)
                   (ly:grob-translate-axis! rest
                     (+ (- (- (interval-center (X-extent rest))
                           (/ (+ left right) 2)))
                           (* -1 x-offs))
                    X)))  
          )    
        )
      )
    );; End of let*
  )
  
centerNoteColumnOn = \override Staff.NoteColumn #'after-line-breaking = #(center-note-column 0)

centerNoteColumnOff = \revert Staff.NoteColumn #'after-line-breaking

onceCenterNoteColumn = 
#(define-music-function (parser location x-offs)(number?)
#{
        \once \override Staff.NoteColumn #'after-line-breaking = #(center-note-column $x-offs)
#})

%------------ Test

\paper {
        ragged-right = ##f
}
%%{
% tiny example:

   <<
   \new Staff
   { \time 3/4 \key b\minor R2.*3 }
   \new Staff
   { \time 3/4 \key b\minor  b''2. \key a\minor \onceCenterNoteColumn #0 <a'' bes''>  \clef "treble" R  }
   >>
%}
%%{
% full test:
\layout {
        indent = 0
    \context {
      \Score
      \override NonMusicalPaperColumn #'line-break-permission = ##f
      \override BarNumber #'break-visibility = #'#(#t #t #t)
    }
    \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 a\minor
        \time 3/4
        \clef "treble"
	R2.
	\key g\minor
        \clef "bass"
	R2.
	\key a\minor
        \clef "treble"
%5 
	R2. \break
	\key g\minor
        \clef "bass"
	R2.
	\key a\minor
        \clef "treble"
%7
	R2.
	\key g\minor
        \clef "bass"
	R2.*1\fermataMarkup
	\key a\minor
        \clef "treble"
	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
        \once \override Score.Arpeggio #'padding = #-1.5
        \set Score.connectArpeggios = ##t
        <fis ais>\arpeggio 
        <fis d'> 
        <e g c!>  )
%5
\onceCenterNoteColumn #-0.4
        <dis fis! a b> ( 
        <e g b> )
%7
        <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>\arpeggio |
        <d fis d'>  |
        <c g' c> ) |
%5
\onceCenterNoteColumn #-0.4
        <b b'> ~ |
        <b b'>-.-> |
%7
        <b b'> ~ |
        <b b'>\fermata |
        r
}
\score {
  <<
    \new Staff %\voice
               \testVoice
    \new PianoStaff <<
   	\new Staff <<
   	   \pUp
   	>>
    	\new Staff <<
    	   \pDown
    	>>
    	>>
  >>
  \layout {
    \context {
      \Score
      \remove "Bar_number_engraver"
    }
  }
}
%}