Re: Emacs: lilypond-ts-mode and the future of lilypond-mode

\version "2.19.22"

\paper {
  ragged-last = ##f
}

#(define (number-or-pitch? a) (or (integer? a) (ly:pitch? a)))

bass-staff = "lo"
bass-clef = "bass"
bass-desc = \markuplist { }
bari-low-desc = \markuplist { (stem down, solid heads) }
bv-one = { \voiceOne \harmonicsOn }
bv-two = { \voiceTwo \harmonicsOn }
tv-one = { \voiceOne \harmonicsOn }
tv-two = \voiceTwo
sv-one = { \voiceOne \harmonicsOn }
sv-two = \voiceTwo
%%{
bass-staff = "hi"
bass-clef = "treble"
bass-desc = \markuplist { (stem down, diamond heads) }
bari-low-desc = \markuplist { (stem up, solid heads) }
bv-one = { \voiceFour \harmonicsOn }
bv-two = { \voiceTwo \harmonicsOn }
tv-one = { \voiceOne \harmonicsOn }
tv-two = \voiceThree
sv-one = { \voiceOne \harmonicsOn }
sv-two = \voiceTwo
%}

#(define stats (make-hash-table 20))

#(define (add-to-stats pitch chordname count)
   (let ((p (hashv-create-handle! stats count '()))
	 (num (modulo (ly:pitch-semitones (ly:pitch-diff pitch #{ a #})) 12)))
     (set-cdr! p (cons (cons num chordname) (cdr p)))))

#(define (stats-list)
   (define (sort-pairs lst)
     (map cdr
	  (sort-list lst car<)))
   (map (lambda (e)
	#{ \markuplist \override-lines #'(word-space . 1) \wordwrap-lines
	   #(cons (format #f "~d reeds:" (car e))
	     (fold-right
	      (lambda (next lst)
	       (cons (string-append next (if (null? lst) "." ",")) lst))
	      '() (sort-pairs (reverse (cdr e))))) #})
	(sort-list (hash-table->alist stats) car<)))

chordmap =
#(define-music-function (start width music)
   (number-or-pitch? index? ly:music?)
   (if (ly:pitch? start) (set! start (ly:pitch-semitones start)))
   (map-some-music
    (lambda (m)
      (and
       (music-is-of-type? m 'event-chord)
       (begin
	 (set! (ly:music-property m 'elements)
	       (append-map
		(lambda (x)
		  (let ((p (ly:music-property x 'pitch)))
		    (if (ly:pitch? p)
			(let loop ((n (ly:make-pitch
				       (- (ly:pitch-octave p)
					  (floor (/ (- (ly:pitch-semitones p) start)
						    12)))
				       (ly:pitch-notename p)
				       (ly:pitch-alteration p)))
				   (l '()))
			  (if (< (ly:pitch-semitones n)
				 (+ start width))
			      (loop (ly:pitch-transpose (ly:make-pitch 1 0 0) n)
				    (cons (music-clone x 'pitch n) l))
			      l))
			(list x))))
		(ly:music-property m 'elements)))
	 m)))
    music))

#(define (conflate keys vals)
   (define (folder k v res)
     (if (or (null? res)
	     (not (equal? v (cdar res))))
	 (cons (cons (list k) v) res)
	 (cons (cons (cons k (caar res)) (cdar res)) (cdr res))))
   (fold-right folder '() keys vals))

#(define (one-set start count music)
   (map (lambda (kv)
	  (let ((keys (car kv)) (m (cdr kv)))
	    (cons (if (null? (cdr keys))
		      (format "~d" (car keys))
		      (format "~d–~d" (car keys) (last keys)))
		  m)))
	(conflate (iota count 1)
		  (map
		   (lambda (i) #{ \chordmap #i #12 $music #})
		   (iota count (ly:pitch-semitones start))))))

#(define (bass-format-set pitch name)
   (let ((bass #{ \chordmap e,, 12 < $pitch >4 #})
	 (accf #{ \chordmap a, 41 < $pitch >4 #})
	 (accp (one-set #{ a, #} 20 #{ < $pitch >4 #})))
     (add-to-stats pitch (string-upcase name) (+ 2 (* 2 (length (ly:music-property accf ' elements)))))
     #{ << \context Staff = "hi"
           << \new Voice \with \tv-one
              { \tempo \markup \caps #name \transpose c c' $accf }
              \new Voice \with \tv-two { <>_"*" $accf } >>
           \context Staff = \bass-staff
           { \clef \bass-clef \key $pitch \major
             << \new Voice \with \bv-one \transpose c c' $bass
	        \new Voice \with \bv-two { $bass } >>
	   }
        >>
	$@(map (lambda (p)
		 (let ((idx (car p)) (m (cdr p)))
		   #{ << \context Staff = "hi"
                         << \new Voice \with \tv-one \transpose c c' $m
                            \new Voice \with \tv-two { <>_\markup #idx $m } >>
		         \context Staff = \bass-staff
			 << \new Voice \with \bv-one \transpose c c' $bass
		            \new Voice \with \bv-two { $bass }
		          >>
		      >> #}))
	       accp)
	#}))

#(define (chord-format-set pitch chord name)
   (let ((accf #{ \chordmap a, 41 $chord #})
	 (accp (one-set #{ a, #} 20 chord)))
     (add-to-stats pitch name (* 2 (length (ly:music-property accf 'elements))))
     #{ << \new Voice \with \sv-one { \tempo \markup #name \transpose c c' $accf }
	   \new Voice \with \sv-two { <>_"*" $accf }
	>>
	$@(map (lambda (p)
		 (let ((idx (car p)) (m (cdr p)))
		   #{ << \new Voice \with \sv-one \transpose c c' $m
			 \new Voice \with \sv-two { <>_\markup #idx $m }
		      >>
		      #}))
	       accp)
	#}))

#(define (score-format-set pitch name)
   #{ \score { \new Staff = "hi"
	       { \key $pitch \major \cadenzaOn
		 $(bass-format-set pitch name) \bar "|"
		 $@(map
		    (lambda (c t)
			#{  \once \accidentalStyle forget
			  $(chord-format-set pitch c (string-append name t))
			  \bar "|"
			  #})
		    (ly:music-property
		     (ly:music-property
		      (ly:music-property
		       #{ \transpose c $pitch
			  \chordmode { c4 c:m c:7^5 c:dim7^5 } #}
		       'element)
		      'element)
		     'elements)
		    '("" "m" "7" "°"))
	       }
               \layout {
                 indent = 0
                 \context {
                   \Staff
                   \remove "Time_signature_engraver"
                   \override TextScript.self-alignment-X = #CENTER
                   \override VerticalAxisGroup.outside-staff-placement-directive
                             = #'right-to-left-greedy
                 }
	       }
           }
      #})

#(set-global-staff-size 16)

\markup \fill-line { \huge "Morino Sonderkonstruktion 100811, \"M. Thöni\"" }
\markup \vspace #2
\markup \fill-line
\general-align #Y #UP
{ \override #'(line-width . 45) \justify {
  Two sliders \bass-desc
  enable lower and upper bass reed sets.  One slider (stem
  up, diamond heads) enables upper baritone reed set.  The
  lower baritone reed set \bari-low-desc is not optional.
  Independent of the enabled reed sets is the chord note selection: a
  tutti slider (resulting chords marked with “*”) may be engaged.  Otherwise
  a chord root slider with positions 1–20 is consulted.
  Each chord in the diagram is marked either with
  “*” or with the range of slider positions producing it. }
 \epsfile #X #85 #"bassbuttons.eps" }
\markup \vspace #3

$@(map
   (lambda (p n)
     (score-format-set p n))
   (event-chord-pitches #{ <des as es bes f c g d a e b fis> #})
   #{ \markuplist { d♭ a♭ e♭ b♭ f c g d a e b f♯ } #})

\markup { Maximum number of reeds sounding with “*” slider engaged: }
\markuplist \override-lines #'(word-space . 4)
            \wordwrap-lines #(concatenate (stats-list))