1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2009--2015 Marc Hohl <marc@hohlart.de>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
19 ;; for more control over glyph-name calculations,
20 ;; we use a custom callback for tab note heads
21 ;; which will ignore 'style = 'do
22 (define-public (tab-note-head::calc-glyph-name grob)
23 (let ((style (ly:grob-property grob 'style)))
30 ;; ensure we only call note head callback when
31 ;; style is set to a known value
32 (define-public (tab-note-head::whiteout-if-style-set grob)
33 (let ((style (ly:grob-property grob 'style)))
36 ((cross slash) (stencil-whiteout-box (ly:note-head::print grob)))
37 (else (tab-note-head::print grob)))))
39 ;; definitions for the "moderntab" clef:
40 ;; the "moderntab" clef will be added to the list of known clefs,
41 ;; so it can be used as any other clef: \clef "moderntab"
42 (add-new-clef "moderntab" "markup.moderntab" 0 0 0)
44 ;; define sans serif-style tab-Clefs as a markup:
45 (define-markup-command (customTabClef
46 layout props num-strings staff-space)
49 "Draw a tab clef sans-serif style."
50 (define (square x) (* x x))
51 (let* ((scale-factor (/ staff-space 1.5))
52 (font-size (- (* num-strings 1.5 scale-factor) 7))
53 (base-skip (* (square (+ (* num-strings 0.195) 0.4)) scale-factor)))
55 (interpret-markup layout props
56 (markup #:vcenter #:bold
57 #:override (cons 'font-family 'sans)
59 #:override (cons 'baseline-skip base-skip)
60 #:left-align #:center-column ("T" "A" "B")))))
62 ;; this function decides which clef to take
63 (define-public (clef::print-modern-tab-if-set grob)
64 (let ((glyph (ly:grob-property grob 'glyph)))
66 ;; which clef is wanted?
67 (if (string=? glyph "markup.moderntab")
68 ;; if it is "moderntab", we'll draw it
69 (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
70 (line-count (if (ly:grob? staff-symbol)
71 (ly:grob-property staff-symbol 'line-count)
73 (staff-space (ly:staff-symbol-staff-space grob)))
75 (grob-interpret-markup grob (make-customTabClef-markup line-count
77 ;; otherwise, we simply use the default printing routine
78 (ly:clef::print grob))))
80 ;; if stems are drawn, it is nice to have a double stem for
81 ;; (dotted) half notes to distinguish them from quarter notes:
82 (define-public (tabvoice::make-double-stem-width-for-half-notes grob)
83 (let ((X-extent (ly:stem::width grob)))
84 ;; does the stem exist and is it on a (dotted) half note?
85 (if (and (not (equal? X-extent empty-interval))
86 (= 1 (ly:grob-property grob 'duration-log)))
88 ;; yes -> return double stem X-extent
89 (let* ((single-stem-width (- (cdr X-extent) (car X-extent)))
90 (separation (ly:grob-property grob 'double-stem-separation 0.5))
91 (total-width (+ single-stem-width separation))
92 (half-width (/ total-width 2)))
93 (cons (- half-width) half-width))
94 ;; no -> return simple stem X-extent
97 (define-public (tabvoice::draw-double-stem-for-half-notes grob)
98 (let ((stem-stencil (ly:stem::print grob)))
99 ;; does the stem exist and is it on a (dotted) half note?
100 (if (and (ly:stencil? stem-stencil)
101 (= 1 (ly:grob-property grob 'duration-log)))
103 ;; yes -> draw double stem
104 (let* ((separation (ly:grob-property grob 'double-stem-separation 0.5))
105 (half-separation (/ separation 2)))
107 (ly:stencil-translate-axis stem-stencil (- half-separation) X)
108 (ly:stencil-translate-axis stem-stencil half-separation X)))
109 ;; no -> draw simple stem (or none at all)
112 ;; as default, the glissando line between fret numbers goes
113 ;; upwards, here we have a function to correct this behavior:
114 (define-public (glissando::calc-tab-extra-dy grob)
115 (let* ((original (ly:grob-original grob))
116 (left-bound (ly:spanner-bound original LEFT))
117 (right-bound (ly:spanner-bound original RIGHT))
118 (left-pitch (ly:event-property (event-cause left-bound) 'pitch))
119 (right-pitch (ly:event-property (event-cause right-bound) 'pitch)))
121 (if (< (ly:pitch-tones right-pitch) (ly:pitch-tones left-pitch))
125 ;; the handler for ties in tablature; according to TabNoteHead #'details,
126 ;; the 'tied to' note is handled differently after a line break
127 (define-public (tie::handle-tab-note-head grob)
128 (let* ((original (ly:grob-original grob))
129 (tied-tab-note-head (ly:spanner-bound grob RIGHT))
130 (spanner-start (ly:grob-property tied-tab-note-head 'span-start #f))
131 (siblings (if (ly:grob? original)
132 (ly:spanner-broken-into original) '())))
135 ;; tab note head is right bound of a tie and left of spanner,
136 ;; -> parenthesize it at all events
138 (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
139 (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))
140 ;; otherwise, check whether tie is split:
141 (if (and (>= (length siblings) 2)
142 (eq? (car (last-pair siblings)) grob))
143 ;; tie is split -> get TabNoteHead #'details
144 (let* ((details (ly:grob-property tied-tab-note-head 'details))
145 (tied-properties (assoc-get 'tied-properties details '()))
146 (tab-note-head-parenthesized (assoc-get 'parenthesize tied-properties #t))
147 ;; we need the begin-of-line entry in the 'break-visibility vector
148 (tab-note-head-visible
149 (vector-ref (assoc-get 'break-visibility
150 tied-properties #(#f #f #t)) 2)))
152 (if tab-note-head-visible
153 ;; tab note head is visible
154 (if tab-note-head-parenthesized
156 (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
157 (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
158 ;; tab note head is invisible
159 (ly:grob-set-property! tied-tab-note-head 'transparent #t)))
162 (ly:grob-set-property! tied-tab-note-head 'transparent #t)))))
166 ;; repeat ties occur within alternatives in a repeat construct;
167 ;; TabNoteHead #'details handles the appearance in this case
168 (define-public (repeat-tie::handle-tab-note-head grob)
169 (let* ((tied-tab-note-head (ly:grob-object grob 'note-head))
170 (spanner-start (ly:grob-property tied-tab-note-head 'span-start #f)))
172 ;; tab note head is between a tie and a slur/glissando
173 ;; -> parenthesize it at all events
175 (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
176 (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))
177 ;; otherwise check 'details
178 (let* ((details (ly:grob-property tied-tab-note-head 'details))
179 (repeat-tied-properties (assoc-get 'repeat-tied-properties details '()))
180 (tab-note-head-visible (assoc-get 'note-head-visible repeat-tied-properties #t))
181 (tab-note-head-parenthesized (assoc-get 'parenthesize repeat-tied-properties #t)))
183 (if tab-note-head-visible
184 ;; tab note head is visible
185 (if tab-note-head-parenthesized
187 (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
188 (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
189 ;; tab note head is invisible
190 (ly:grob-set-property! tied-tab-note-head 'transparent #t))))))
192 ;; the slurs should not be too far apart from the corresponding fret number, so
193 ;; we move the slur towards the TabNoteHeads; moreover, if the left fret number is
194 ;; the right-bound of a tie, we'll set it in parentheses:
195 (define-public (slur::draw-tab-slur grob)
196 ;; TODO: use a less "brute-force" method to decrease
197 ;; the distance between the slur ends and the fret numbers
198 (let* ((original (ly:grob-original grob))
199 (left-bound (ly:spanner-bound original LEFT))
200 (left-tab-note-head (ly:grob-property left-bound 'cause))
201 (staff-space (ly:staff-symbol-staff-space grob))
202 (control-points (ly:grob-property grob 'control-points))
203 (new-control-points (map
208 (ly:grob-property grob 'direction)
212 (ly:grob-set-property! grob 'control-points new-control-points)
213 (ly:slur::print grob)))
215 ;; The glissando routine works similarly to the slur routine; if the
216 ;; fret number is "tied to", it should become parenthesized.
217 (define-public (glissando::draw-tab-glissando grob)
218 (let* ((original (ly:grob-original grob))
219 (left-tab-note-head (ly:spanner-bound original LEFT))
220 (cautionary (ly:grob-property left-tab-note-head 'display-cautionary #f)))
223 ;; increase left padding to avoid collision between
224 ;; closing parenthesis and glissando line
225 (ly:grob-set-nested-property! grob '(bound-details left padding) 0.5))
226 (ly:line-spanner::print grob)))
228 ;; for \tabFullNotation, the stem tremolo beams are too big in comparison to
229 ;; normal staves; this wrapper function scales accordingly:
230 (define-public (stem-tremolo::calc-tab-width grob)
231 (let ((width (ly:stem-tremolo::calc-width grob))
232 (staff-space (ly:staff-symbol-staff-space grob)))
233 (/ width staff-space)))
236 ;; a callback for custom fret labels
237 (define ((tab-note-head::print-custom-fret-label fret) grob)
238 (ly:grob-set-property! grob 'text (make-vcenter-markup fret))
239 (tab-note-head::print grob))
240 (export tab-note-head::print-custom-fret-label)
242 (define-public (tab-note-head::print grob)
243 (define (is-harmonic? grob)
244 (let ((arts (ly:event-property (event-cause grob) 'articulations)))
245 (or (pair? (filter (lambda (a)
246 (ly:in-event-class? a 'harmonic-event))
248 (eq? (ly:grob-property grob 'style) 'harmonic))))
250 (let* ((cautionary (ly:grob-property grob 'display-cautionary #f))
251 (details (ly:grob-property grob 'details '()))
252 (harmonic-props (assoc-get 'harmonic-properties details '()))
253 (harmonic-angularity (assoc-get 'angularity harmonic-props 2))
254 (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075))
255 (harmonic-padding (assoc-get 'padding harmonic-props 0))
256 (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil))
257 (harmonic-width (assoc-get 'width harmonic-props 0.25))
258 (cautionary-props (assoc-get 'cautionary-properties details '()))
259 (cautionary-angularity (assoc-get 'angularity cautionary-props 2))
260 (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075))
261 (cautionary-padding (assoc-get 'padding cautionary-props 0))
262 (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil))
263 (cautionary-width (assoc-get 'width cautionary-props 0.25))
264 (output-grob (ly:text-interface::print grob))
265 (ref-grob (grob-interpret-markup grob "8"))
266 (offset-factor (assoc-get 'head-offset details 3/5))
267 (column-offset (* offset-factor
269 (ly:stencil-extent ref-grob X)))))
271 (if (is-harmonic? grob)
272 (set! output-grob (harmonic-proc output-grob
278 (set! output-grob (cautionary-proc output-grob
279 cautionary-half-thick
281 cautionary-angularity
282 cautionary-padding)))
283 (ly:stencil-translate-axis
284 (ly:stencil-aligned-to output-grob X CENTER)
288 ;; Harmonic definitions
290 (define node-positions
291 ;; for the node on m/n-th of the string length, we get the corresponding
292 ;; (exact) fret position by calculating p=(-12/log 2)*log(1-(m/n));
293 ;; since guitarists normally use the forth fret and not the 3.8th, here
294 ;; are rounded values, ordered by
298 ;; The value for 2/4 is irrelevant in practical, bacause the string sounds
299 ;; only one octave higher, not two, but since scheme normalizes the fractions
300 ;; anyway, these values are simply placeholders for easier indexing.
301 ;; According to the arithmetic sum, the position of m/n is at 1/2*(n-2)(n-1)+(m-1)
302 ;; if we start counting from zero
308 2.7 5.8 9.7 14.7 21.7 33.7
310 2 4.4 7 10 14 19 26 38 ))
312 (define partial-pitch
323 (define fret-partials
338 (define-public (ratio->fret ratio)
339 "Calculate a fret number given @var{ratio} for the harmonic."
340 (let* ((nom (numerator ratio))
341 (den (denominator ratio))
342 (index (+ (* (- den 2)
346 (number->string (vector-ref node-positions index))))
348 (define-public (ratio->pitch ratio)
349 "Calculate a pitch given @var{ratio} for the harmonic."
350 (let* ((partial (1- (denominator ratio)))
351 (pitch (vector-ref partial-pitch partial)))
353 (ly:make-pitch (first pitch)
357 (define-public (fret->pitch fret)
358 "Calculate a pitch given @var{fret} for the harmonic."
359 (let* ((partial (assoc-get fret fret-partials 0))
360 (pitch (vector-ref partial-pitch partial)))
362 (ly:make-pitch (first pitch)
366 (define-public (calc-harmonic-pitch pitch music)
367 "Calculate the harmonic pitches in @var{music} given
368 @var{pitch} as the non-harmonic pitch."
369 (let ((es (ly:music-property music 'elements))
370 (e (ly:music-property music 'element))
371 (p (ly:music-property music 'pitch)))
374 (ly:music-set-property! music 'elements
375 (map (lambda (x) (calc-harmonic-pitch pitch x)) es)))
377 (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e)))
380 (set! p (ly:pitch-transpose p pitch))
381 (ly:music-set-property! music 'pitch p))))
384 (define-public (make-harmonic mus)
385 "Convert music variable @var{mus} to harmonics."
386 (let ((elts (ly:music-property mus 'elements))
387 (elt (ly:music-property mus 'element)))
390 (for-each make-harmonic elts))
393 ((music-is-of-type? mus 'note-event)
394 (set! (ly:music-property mus 'articulations)
396 (ly:music-property mus 'articulations)
397 (list (make-music 'HarmonicEvent))))))