\version "2.14.2"

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% template and music store mechanism
%%% (c) 2011 by Jan-Peter Voigt

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% helpers

#(define-public (path->string lst)
  (string-join (map (lambda (s)(format "~A" s)) lst) "/" 'infix))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% a tree in scheme
%%% tree = (key . (val . (list)))

% tree predicate
#(define-public (tree? t)
  (let ((and-list (lambda (l) (let ((b #t)) (for-each (lambda (x) (set! b (and b x))) l) b))))
       (and (pair? t)
            (symbol? (car t))
            (pair? (cdr t))
            (list? (cdr (cdr t)))
            ;; (and-list (map (lambda (x) (tree? x)) (cdr (cdr t))))
       )
))
% create an empty tree
#(define-public (tree-create sym)(cons sym (cons #f (list))))

% set value in tree, path is a list
#(define-public (tree-set! tree path val)
  (let ((sym (if (and (list? path)(> (length path) 0))(car path) #f))
        (leaf (= (length path) 0)))
       (if (not (tree? tree)) (set! tree (tree-create 'root)))
       (let ((cval (car (cdr tree)))
             (clst (cdr (cdr tree))))
            (set! tree 
              (cons (car tree)
                    (if leaf
                      (cons val clst)
                      (cons cval (assoc-set! clst sym (cdr (tree-set! (assoc sym clst) (if (> (length path) 1) (cdr path) '()) val )) ))
                    )
            ))
       )
       tree))
% get value from tree, path is a list
#(define-public (tree-get tree path)
  (let ((sym (if (and (list? path)(> (length path) 0))(car path) #f))
        (leaf (= (length path) 0)))
       (if (tree? tree)
           (if leaf (car (cdr tree)) (tree-get (assoc sym (cdr (cdr tree))) (if (> (length path) 1) (cdr path) '())) )
           #f)
))

% get branch from tree
#(define-public (tree-get-tree tree path)
  (let ((sym (if (and (list? path)(> (length path) 0))(car path) #f)))
       (if (tree? tree)
           (if sym 
             (tree-get-tree (assoc sym (cdr (cdr tree))) (if (> (length path) 1) (cdr path) '()))
             tree)
           #f)
))

% walk through the tree and call (callback path key value)
% where path is the node path in the tree, key is the node name and value the value
#(define-public (tree-walk tree callback . opt)
  (if (tree? tree)
      (let ((path (ly:assoc-get 'path opt (list) #f))
            (dosort (ly:assoc-get 'sort opt #f #f)))
           (if (not (list? path)) (set! path (list path)))
           (callback path (car tree) (car (cdr tree)))
           (for-each (lambda (p)
                             (tree-walk p callback `(path . ,(append path (list (car p)))) `(sort . ,dosort)))
                     (if dosort
                       (sort (cdr (cdr tree)) (lambda (p1 p2) (string-ci<? (format "~A" (car p1)) (format "~A" (car p2)))))
                       (cdr (cdr tree)))
           )
      )
))

% convenience method to display a tree
#(define-public (tree-display tree . opt)
  (let ((indsp (lambda (n) #f))
        (dosort (ly:assoc-get 'sort opt #t #f))
        (empty (ly:assoc-get 'empty opt #f #f))
        (dval (ly:assoc-get 'value opt #f #f))
        (vformat (ly:assoc-get 'vformat opt (lambda (v)(format "~A" v)) #f)))
       (set! indsp (let ((str " . "))
              (lambda (n) (if (> n 0) (string-append str (indsp (- n 1))) ""))))
       (tree-walk tree 
         (lambda (path key val)
                 (if (or val empty)(begin
                       (if empty
                         (begin (display (indsp (length path))) (display key))
                         (display (path->string path)))
                       (if (and dval val) (begin
                             (display ": ")
                             (display (vformat val))
                       ))
                       (display "\n")))
         ) `(sort . ,dosort) `(empty . ,empty) `(value . ,dval) `(vformat . ,vformat)))
)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% store music in a tree

#(define-public (put-music path music) #f)
#(define-public (get-music path location) #f)
#(define-public (display-music-pieces) #f)
#(let ((table (tree-create 'music)))
     
     (set! put-music (lambda (path music)
               (set! table (tree-set! table path music))))
     (set! get-music (lambda (path location)
               (let* ((p (tree-get table path))
                      (m (if (ly:music? p) p
                             (begin 
                               (ly:input-message location "unknown music '~A'" (path->string path))
                               (make-music 'SequentialMusic 'void #t))
                             
                     )))
                     (ly:music-deep-copy m))))
     
     (set! display-music-pieces (lambda ()
               (tree-display table '(sort . #t) '(value . #t) '(empty . #f) 
                 `(vformat . ,(lambda (v) 
                           (let ((mom (ly:music-length v)))
                                (format "~A/~A" (ly:moment-main-numerator mom) (ly:moment-main-denominator mom))
     ))) )))
)

%%% get music for path
#(define-public getmusic (define-music-function (parser location path)(list?)
    (get-music path location)))
%%% store music for path. returns void
#(define-public putmusic (define-music-function (parser location path music)(list? ly:music?)
    (put-music path music)
    (make-music 'SimultaneousMusic 'void #t)))
%%% remove music for path
#(define-public delmusic (define-music-function (parser location path)(list?)
    (put-music path #f)
    (make-music 'SimultaneousMusic 'void #t)))

%%% store music for path. returns music
#(define-public savemusic (define-music-function (parser location path music)(list? ly:music?)
    (put-music path music)
    music))
%%% create skip event with duration of music stored in path
#(define-public skipmusic (define-music-function (parser location path)(list?)
    (let* ((music (get-music path location))
           (m (ly:music-length music)))
          (make-music 'SkipEvent
            'duration (ly:make-duration 0 0 (ly:moment-main-numerator m)(ly:moment-main-denominator m ))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% store templates in an alist

#(define-public (put-template name music) #f)
#(define-public (get-template name) #f)
#(define-public (display-templates) #f)
#(let* ((table (list))
       (empty-function (define-music-function (parser location piece options)(symbol? list?)
           (get-music (list piece) location)
      )))
      (set! put-template (lambda (name fun)
                (set! table (assoc-set! table name fun))))
      (set! get-template (lambda (name location)
                (let ((p (assoc name table))
                      (f empty-function)
                      (error (lambda () (ly:input-message location "unknown template '~A'" name))))
                     (if (pair? p)(set! f (cdr p)) (error))
                     (if (not (ly:music-function? f))(set! f 
                           (begin (error) empty-function)))
                     f)))
      (set! display-templates (lambda ()
                (for-each (lambda (p)
                                  (display (format "template '~A'\n" (car p))))
                          (sort table (lambda (p1 p2) (string-ci<? (format "~A" (car p1)) (format "~A" (car p2)))))
      )))
)
#(define-public puttemplate (define-music-function (parser location name fun)(symbol? ly:music-function?)
    (put-template name fun)
    (make-music 'SequentialMusic 'void #t)))
#(define-public calltemplate (define-music-function (parser location name music options)(symbol? list-or-symbol? list?)
    ((ly:music-function-extract (get-template name location)) parser location music options)))
#(define-public (loop-template parser location kind name piece options sym vals)
  (make-music
    kind
    'elements
    (map (lambda (x)
                 ((ly:music-function-extract (get-template name location)) parser location piece (assoc-set! options sym x))
         ) vals)))
#(define-public loopTemplate (define-music-function (parser location kind name piece options sym vals)(symbol? symbol? list-or-symbol? list? symbol? list?)
    (loop-template parser location kind name piece options sym vals)))
#(define-public stackTemplate (define-music-function (parser location name piece options sym vals)(symbol? list-or-symbol? list? symbol? list?)
    (loop-template parser location 'SimultaneousMusic name piece options sym vals)))
#(define-public repeatTemplate (define-music-function (parser location name piece options sym vals)(symbol? list-or-symbol? list? symbol? list?)
    (loop-template parser location 'SequentialMusic name piece options sym vals)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% store default template and options for a piece
%%% get/set current piece
#(define-public (get-current-piece) #f)
#(define-public (set-current-piece piece) #f)
#(define-public (set-default-template piece tmpl options) #f)
#(define-public (get-default-template piece location) #f)
#(define-public (get-default-options piece location) #f)

#(let ((templates (tree-create 'default))
      (current-piece #f))
     (set! get-current-piece (lambda () current-piece))
     (set! set-current-piece (lambda (piece) (set! current-piece piece)))
     (set! set-default-template (lambda (piece tmpl options)
               (if (not (list? piece))(set! piece (list piece)))
               (set! current-piece piece)
               (set! templates (tree-set! templates piece (cons tmpl options)))))
     (set! get-default-template (lambda (piece location)
               (if (not (list? piece))(set! piece (list piece)))
               (let ((p (tree-get templates piece)))
                    (if (pair? p) (car p) 'NOTFOUND))))
     (set! get-default-options (lambda (piece location)
               (if (not (list? piece))(set! piece (list piece)))
               (let ((p (tree-get templates piece)))
                    (if (pair? p) (cdr p) '()))))
)
%%% set default template and options for music at path (sets current piece)
#(define-public setDefaultTemplate (define-music-function (parser location piece template options)(list-or-symbol? symbol? list?)
    (begin
      (set-default-template piece template options)
      (make-music 'SequentialMusic 'void #t))))

%%% call template with options stored for piece
#(define-public createmusic (define-music-function (parser location piece)(list-or-symbol?)
    ((ly:music-function-extract (get-template (get-default-template piece location) location)) 
     parser location piece (get-default-options piece location))))
%%% set current piece
#(define-public setCurrentPiece (define-music-function (parser location piece)(list-or-symbol?)
    (if (not (list? piece)) (set! piece (list piece)))
    (set-current-piece piece)
    (make-music 'SequentialMusic 'void #t)))

%%% header information is stored in an alist with key 'header in default options for piece
#(define-public setDefaultHeader 
  (define-music-function (parser location piece field value)(list-or-symbol? symbol? scheme?)
    (let* ((tmpl (get-default-template piece location))
           (opts (get-default-options piece location))
           (header (ly:assoc-get 'header opts '() #f)))
          (set! header (assoc-set! header field value))
          (set! opts (assoc-set! opts 'header header))
          (set-default-template piece tmpl opts)
          (make-music 'SequentialMusic 'void #t)
)))

#(define-public (get-header-field piece field . default)
  (let* ((opts (get-default-options piece #f))
         (header (ly:assoc-get 'header opts '() #f)))
        (ly:assoc-get field header (if (>= (length default) 1) (car default) #f) #f)))

%%% get header field for current piece
#(define-public (get-current-header-field field . default)
  (get-header-field (get-current-piece) field (if (>= (length default) 1) (car default) #f)))
%%% get header field for current piece markup command
#(define-markup-command (current-header-field layout props field)(symbol?)
  (let* ((text (get-current-header-field field)))
        (if text
          (interpret-markup layout props (markup text))
          empty-stencil)
))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% two choral templates

%{
  A template is expected to be a music-function with a signature like this:
    #(define-music-function (parser location piece options)(list-or-symbol? list?) ...)
  This function can make use of the \getmusic command, to get the music stored before.
  Right now is has to append the piece list "by hand": \getmusic #(append $piece '(global))
%}

% 4-stave satb system with lyrics for all staffs
\puttemplate #'satb-lied-4 #(define-music-function (parser location piece options)(list-or-symbol? list?)
  (if (not (list? piece))(set! piece (list piece))) ; is piece already a list?
  #{
    \new StaffGroup \with {
      \override SpanBar #'transparent = ##t
    } <<
      \new Staff \with {
        instrumentName = "S"
      } <<
        \new Voice { \keepWithTag #'frauen \getmusic #(append $piece '(meta)) }
        \new Voice = "sop" { \getmusic #(append $piece '(global)) \getmusic #(append $piece '(noten sop)) }
      >>
      \new Lyrics \lyricsto "sop" { \getmusic #(append $piece '(text A)) }
      
      \new Staff \with {
        instrumentName = "A"
      } <<
        \new Voice { \keepWithTag #'frauen \getmusic #(append $piece '(meta)) }
        \new Voice = "alt" { \getmusic #(append $piece '(global)) \getmusic #(append $piece '(noten alt)) }
      >>
      \new Lyrics \lyricsto "alt" { \getmusic #(append $piece '(text A)) }
      
      \new Staff \with {
        instrumentName = "T"
      } <<
        \new Voice { \clef "G_8" \keepWithTag #'maenner \getmusic #(append $piece '(meta)) }
        \new Voice = "ten" { \getmusic #(append $piece '(global)) \getmusic #(append $piece '(noten ten)) }
      >>
      \new Lyrics \lyricsto "ten" { \getmusic #(append $piece '(text A)) }
      \new Staff \with {
        instrumentName = "B"
      } <<
        \new Voice { \clef "bass" \keepWithTag #'maenner \getmusic #(append $piece '(meta)) }
        \new Voice = "bas" { \getmusic #(append $piece '(global)) \getmusic #(append $piece '(noten bas)) }
      >>
      \new Lyrics \lyricsto "bas" { \getmusic #(append $piece '(text A)) }
    >>
#})

% 2-stave satb system with centered lyrics
\puttemplate #'satb-lied-2 #(define-music-function (parser location piece options)(list-or-symbol? list?)
  (if (not (list? piece))(set! piece (list piece)))
  (let ((verses (ly:assoc-get 'verses options '(A) #f)))
       #{
         \new StaffGroup \with {
           \override SpanBar #'transparent = ##t
         } <<
           \new Staff = "frauen" \with {
             instrumentName = \markup { \right-column { S A } }
           } <<
             \new Voice { \keepWithTag #'frauen \getmusic #(append $piece '(meta)) }
             \new Voice = "sop" { \getmusic #(append $piece '(global)) \voiceOne \getmusic #(append $piece '(noten sop)) }
             \new Voice = "alt" { \getmusic #(append $piece '(global)) \voiceTwo \getmusic #(append $piece '(noten alt)) }
           >>
           \stackTemplate #'satb-lied-2-lyrics #$piece #$options #'vers #$verses
           \new Staff = "maenner" \with {
             instrumentName = \markup { \right-column { T B } }
           } <<
             \new Voice { \clef "bass" \keepWithTag #'maenner \getmusic #(append $piece '(meta)) }
             \new Voice = "ten" { \getmusic #(append $piece '(global)) \voiceOne \getmusic #(append $piece '(noten ten)) }
             \new Voice = "bas" { \getmusic #(append $piece '(global)) \voiceTwo \getmusic #(append $piece '(noten bas)) }
           >>
         >>
#}))
\puttemplate #'satb-lied-2-lyrics #(define-music-function (parser location piece options)(list-or-symbol? list?)
  (if (not (list? piece))(set! piece (list piece)))
  #{
    \new Lyrics \with {
      \override VerticalAxisGroup #'staff-affinity = #CENTER
    } \lyricsto "sop" { \getmusic #(append $piece (list 'text (cdr (assoc 'vers $options)))) }
#})

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% an example

% set template for the piece ... this will also set current-piece
\setDefaultTemplate #'(choral satb altatrinita) #'satb-lied-4 #'()
% set header information (title etc.)
\setDefaultHeader #'(choral satb altatrinita) #'title "Alta Trinità Beata"
\setDefaultHeader #'(choral satb altatrinita) #'composer "Italy 15. century"

%%%
% the previous defined choral templates expect a global part
\putmusic #'(choral satb altatrinita global) {
  % faster midi
  \set Score.tempoWholesPerMinute = #(ly:make-moment 120 4)
  % vocal music usally has dynamics above the stave to let lyrics and dynamics as close as possible to the notes
  % I prefer melisma by beam ... well, the demo piece ain't got beams ...
  \autoBeamOff \dynamicUp
}
% the previous defined choral templates expect a meta part
\putmusic #'(choral satb altatrinita meta) {
  \key f \major \time 2/2
  % for choral music I like a StaffGroup with transparent SpanBars, so that I can once display them for endings.
  \repeat volta 2 { s1*16 \once \override StaffGroup.SpanBar #'transparent = ##f }
  \repeat volta 2 { s1*8 \once \override StaffGroup.SpanBar #'transparent = ##f }
}

% the lyrics for verse A (this is the only one in this piece)
\putmusic #'(choral satb altatrinita text A) \lyricmode {
  Al -- ta Tri -- ni -- tà be -- a -- ta, 
  da noi sem -- pre ad -- o -- ra -- ta, 
  Tri -- ni -- tà glo -- ri -- o -- sa 
  u -- ni -- tà ma -- ra -- vi -- glio -- sa, 
  Tu sei man -- na sa -- po -- ro -- sa 
  e tut -- ta de -- si -- de -- ro -- sa.
}
% soprano notes
\putmusic #'(choral satb altatrinita noten sop) \relative c' {
  f2 f4( g) | a2 g4( f) | bes2 a4( g) | a2 a |
  g2 a4( bes) | a2 g4( f) | g( bes) a( g) | f2 f \breathe |
  c'2 c4( d) | bes1 | c4( bes) a( g) | a2 a |
  g4( f) bes( g) | f2 bes4( a) | g( f) bes( g) | f2 f |
  c'2 c4( d) | bes2 c4( d) | ees( d) c( a) | bes2 g |
  f2 g4( a) | bes2 a | g4( f) bes( g) | f2 f |
}
% alto notes
\putmusic #'(choral satb altatrinita noten alt) \relative c' {
  c2 c4( e) | f2 e4( f) | f2 f4( e) | f2 f |
  e2 f | f e4( f) | e( f) f( e) | c2 c \breathe |
  a'2 a | g1 | g2 f4( e) | f2 f |
  e4( d) d( e) | f2 f | e4( d) d( e) | c2 c |
  a'2 a4( f) | g2 g4( bes) | c( bes) g( f) | f2 e |
  c2 e4( f) | f2 f | e4( d) d( e) | c2 c |
}
% tenor notes
\putmusic #'(choral satb altatrinita noten ten) \relative c' {
  a2 a4( c) | c2 c | d c | c c |
  c2 c4( d) | c2 c4( a) | c( d) c2 | a a \breathe |
  f'2 f | d1 | e2 c | c c |
  c4( a) bes( c) | c2 d4( c) | c( a) bes( c) | a2 a |
  f'2 f | d ees4( f) | g( f) ees( c) | d2 c |
  a2 c | d c | c4( a) bes( c) | a2 a |
}
% bass notes
\putmusic #'(choral satb altatrinita noten bas) \relative c {
  f2 f4( c) | f2 c4( f) | bes,2 f'4( c) | f2 f | 
  c2 f4( bes,) | f'2 c4( d) | c( bes) f'( c) | f,2 f \breathe |
  f'2 f4( d) | g1 | c,2 f4( c) | f2 f |
  c4( d) g,( c) | f2 bes,4( f') | c( d) g,( c) | f2 f |
  f2 f4( d) | g2 ees4( d) | c( d) ees( f) | bes,2 c |
  f2 c4( f) | bes,2 f' | c4( d) g,( c) | f,2 f |
}


%%%%%%%%%%%%%%
% instantiation

% prepare paper and layout ...
#(set-global-staff-size 18)
\paper {
  score-system-spacing = #'((basic-distance . 20)
   (minimum-distance . 6)
   (padding . 4)
   (stretchability . 15))
  system-system-spacing = #'((basic-distance . 20)
   (minimum-distance . 6)
   (padding . 2)
   (stretchability . 10))
  ragged-last = ##f
  ragged-last-bottom = ##f
}

\layout {
  indent = 3
  \context {
    \Staff
    \override InstrumentName #'self-alignment-X = #RIGHT
    \override InstrumentName #'padding = #1
  }
}

%%% create bookparts
% using the current-piece/header functions, you can use an include
% I. write out the music in four staffs
\bookpart {
  \header {
    title = #(get-current-header-field 'title)
    subtitle = #(get-current-header-field 'subtitle)
    subsubtitle = #(get-current-header-field 'subsubtitle)
    composer = #(get-current-header-field 'composer "Anonymous")
    poet = #(get-current-header-field 'poet)
  }
  \score {
    \createmusic #(get-current-piece)
    \layout { }
    \midi { }
  }
}

% II. write out the music in two staffs with centered lyrics
\bookpart {
  \paper {
    ragged-last-bottom = ##t
  }
  \header {
    title = #(get-current-header-field 'title)
    subtitle = #(get-current-header-field 'subtitle)
    subsubtitle = #(get-current-header-field 'subsubtitle)
    composer = #(get-current-header-field 'composer "Anonymous")
    poet = #(get-current-header-field 'poet)
  }
  \score {
    \calltemplate #'satb-lied-2 #(get-current-piece) #'((verses . (A)))
    \layout { }
  }
}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% for debugging purposes
#(display (format "current piece: ~A\n" (path->string (get-current-piece))))
#(display "templates:\n")
#(display-templates)
#(display "music-tree:\n")
#(display-music-pieces)