scm/tablature.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2009--2014 Marc Hohl <marc@hohlart.de>
   4 ;;;;
   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.
   9 ;;;;
  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.
  14 ;;;;
  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/>.
  17
  18
  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)))
  24
  25     (case style
  26       ((cross) "2cross")
  27       ((slash) "2slash")
  28       (else #f))))
  29
  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)))
  34
  35     (case style
  36       ((cross slash) (stencil-whiteout (ly:note-head::print grob)))
  37       (else (tab-note-head::print grob)))))
  38
  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)
  43
  44 ;; define sans serif-style tab-Clefs as a markup:
  45 (define-markup-command (customTabClef
  46                         layout props num-strings staff-space)
  47   (integer? number?)
  48   #:category music
  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)))
  54
  55     (interpret-markup layout props
  56                       (markup #:vcenter #:bold
  57                               #:override (cons 'font-family 'sans)
  58                               #:fontsize font-size
  59                               #:override (cons 'baseline-skip base-skip)
  60                               #:left-align #:center-column ("T" "A" "B")))))
  61
  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)))
  65
  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)
  72                                0))
  73                (staff-space (ly:staff-symbol-staff-space grob)))
  74
  75           (grob-interpret-markup grob (make-customTabClef-markup line-count
  76                                                                  staff-space)))
  77         ;; otherwise, we simply use the default printing routine
  78         (ly:clef::print grob))))
  79
  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
  85     ;; is the note a (dotted) half note?
  86     (if (= 1 (ly:grob-property grob 'duration-log))
  87         ;; yes -> return double stem width
  88         (cons (car X-extent) (+ 0.5 (* 2 (cdr X-extent))))
  89         ;; no -> return simple stem width
  90         X-extent)))
  91
  92 (define-public (tabvoice::draw-double-stem-for-half-notes grob)
  93   (let ((stem (ly:stem::print grob)))
  94
  95     ;; is the note a (dotted) half note?
  96     (if (= 1 (ly:grob-property grob 'duration-log))
  97         ;; yes -> draw double stem
  98         (ly:stencil-combine-at-edge stem X RIGHT stem 0.5)
  99         ;; no -> draw simple stem
 100         stem)))
 101
 102 ;; as default, the glissando line between fret numbers goes
 103 ;; upwards, here we have a function to correct this behavior:
 104 (define-public (glissando::calc-tab-extra-dy grob)
 105   (let* ((original (ly:grob-original grob))
 106          (left-bound (ly:spanner-bound original LEFT))
 107          (right-bound (ly:spanner-bound original RIGHT))
 108          (left-pitch (ly:event-property (event-cause left-bound) 'pitch))
 109          (right-pitch (ly:event-property (event-cause right-bound) 'pitch)))
 110
 111     (if (< (ly:pitch-tones right-pitch) (ly:pitch-tones left-pitch))
 112         -0.75
 113         0.75)))
 114
 115 ;; the handler for ties in tablature; according to TabNoteHead #'details,
 116 ;; the 'tied to' note is handled differently after a line break
 117 (define-public (tie::handle-tab-note-head grob)
 118   (let* ((original (ly:grob-original grob))
 119          (tied-tab-note-head (ly:spanner-bound grob RIGHT))
 120          (spanner-start (ly:grob-property tied-tab-note-head 'span-start #f))
 121          (siblings (if (ly:grob? original)
 122                        (ly:spanner-broken-into original) '())))
 123
 124     (if spanner-start
 125         ;; tab note head is right bound of a tie and left of spanner,
 126         ;; -> parenthesize it at all events
 127         (begin
 128           (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
 129           (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))
 130         ;; otherwise, check whether tie is split:
 131         (if (and (>= (length siblings) 2)
 132                  (eq? (car (last-pair siblings)) grob))
 133             ;; tie is split -> get TabNoteHead #'details
 134             (let* ((details (ly:grob-property tied-tab-note-head 'details))
 135                    (tied-properties (assoc-get 'tied-properties details '()))
 136                    (tab-note-head-parenthesized (assoc-get 'parenthesize tied-properties #t))
 137                    ;; we need the begin-of-line entry in the 'break-visibility vector
 138                    (tab-note-head-visible
 139                     (vector-ref (assoc-get 'break-visibility
 140                                            tied-properties #(#f #f #t)) 2)))
 141
 142               (if tab-note-head-visible
 143                   ;; tab note head is visible
 144                   (if tab-note-head-parenthesized
 145                       (begin
 146                         (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
 147                         (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
 148                   ;; tab note head is invisible
 149                   (ly:grob-set-property! tied-tab-note-head 'transparent #t)))
 150
 151             ;; tie is not split
 152             (ly:grob-set-property! tied-tab-note-head 'transparent #t)))))
 153
 154
 155
 156 ;; repeat ties occur within alternatives in a repeat construct;
 157 ;; TabNoteHead #'details handles the appearance in this case
 158 (define-public (repeat-tie::handle-tab-note-head grob)
 159   (let* ((tied-tab-note-head (ly:grob-object grob 'note-head))
 160          (spanner-start (ly:grob-property tied-tab-note-head 'span-start #f)))
 161     (if spanner-start
 162         ;; tab note head is between a tie and a slur/glissando
 163         ;; -> parenthesize it at all events
 164         (begin
 165           (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
 166           (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))
 167         ;; otherwise check 'details
 168         (let* ((details (ly:grob-property tied-tab-note-head 'details))
 169                (repeat-tied-properties (assoc-get 'repeat-tied-properties details '()))
 170                (tab-note-head-visible (assoc-get 'note-head-visible repeat-tied-properties #t))
 171                (tab-note-head-parenthesized (assoc-get 'parenthesize repeat-tied-properties #t)))
 172
 173           (if tab-note-head-visible
 174               ;; tab note head is visible
 175               (if tab-note-head-parenthesized
 176                   (begin
 177                     (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
 178                     (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
 179               ;; tab note head is invisible
 180               (ly:grob-set-property! tied-tab-note-head 'transparent #t))))))
 181
 182 ;; the slurs should not be too far apart from the corresponding fret number, so
 183 ;; we move the slur towards the TabNoteHeads; moreover, if the left fret number is
 184 ;; the right-bound of a tie, we'll set it in parentheses:
 185 (define-public (slur::draw-tab-slur grob)
 186   ;; TODO: use a less "brute-force" method to decrease
 187   ;; the distance between the slur ends and the fret numbers
 188   (let* ((original (ly:grob-original grob))
 189          (left-bound (ly:spanner-bound original LEFT))
 190          (left-tab-note-head (ly:grob-property left-bound 'cause))
 191          (staff-space (ly:staff-symbol-staff-space grob))
 192          (control-points (ly:grob-property grob 'control-points))
 193          (new-control-points (map
 194                               (lambda (p)
 195                                 (cons (car p)
 196                                       (- (cdr p)
 197                                          (* staff-space
 198                                             (ly:grob-property grob 'direction)
 199                                             0.35))))
 200                               control-points)))
 201
 202     (ly:grob-set-property! grob 'control-points new-control-points)
 203     (ly:slur::print grob)))
 204
 205 ;; The glissando routine works similarly to the slur routine; if the
 206 ;; fret number is "tied to", it should become parenthesized.
 207 (define-public (glissando::draw-tab-glissando grob)
 208   (let* ((original (ly:grob-original grob))
 209          (left-tab-note-head (ly:spanner-bound original LEFT))
 210          (cautionary (ly:grob-property left-tab-note-head 'display-cautionary #f)))
 211
 212     (and cautionary
 213          ;; increase left padding to avoid collision between
 214          ;; closing parenthesis and glissando line
 215          (ly:grob-set-nested-property! grob '(bound-details left padding) 0.5))
 216     (ly:line-spanner::print grob)))
 217
 218 ;; for \tabFullNotation, the stem tremolo beams are too big in comparison to
 219 ;; normal staves; this wrapper function scales accordingly:
 220 (define-public (stem-tremolo::calc-tab-width grob)
 221   (let ((width (ly:stem-tremolo::calc-width grob))
 222         (staff-space (ly:staff-symbol-staff-space grob)))
 223     (/ width staff-space)))
 224
 225
 226 ;; a callback for custom fret labels
 227 (define ((tab-note-head::print-custom-fret-label fret) grob)
 228   (ly:grob-set-property! grob 'text fret)
 229   (tab-note-head::print grob))
 230 (export tab-note-head::print-custom-fret-label)
 231
 232 (define-public (tab-note-head::print grob)
 233   (define (is-harmonic? grob)
 234     (let ((arts (ly:event-property (event-cause grob) 'articulations)))
 235       (or (pair? (filter (lambda (a)
 236                            (ly:in-event-class? a 'harmonic-event))
 237                          arts))
 238           (eq? (ly:grob-property grob 'style) 'harmonic))))
 239
 240   (let* ((cautionary (ly:grob-property grob 'display-cautionary #f))
 241          (details (ly:grob-property grob 'details '()))
 242          (harmonic-props (assoc-get 'harmonic-properties details '()))
 243          (harmonic-angularity (assoc-get 'angularity harmonic-props 2))
 244          (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075))
 245          (harmonic-padding (assoc-get 'padding harmonic-props 0))
 246          (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil))
 247          (harmonic-width (assoc-get 'width harmonic-props 0.25))
 248          (cautionary-props (assoc-get 'cautionary-properties details '()))
 249          (cautionary-angularity (assoc-get 'angularity cautionary-props 2))
 250          (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075))
 251          (cautionary-padding (assoc-get 'padding cautionary-props 0))
 252          (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil))
 253          (cautionary-width (assoc-get 'width cautionary-props 0.25))
 254          (output-grob (ly:text-interface::print grob))
 255          (ref-grob (grob-interpret-markup grob "8"))
 256          (offset-factor (assoc-get 'head-offset details 3/5))
 257          (column-offset (* offset-factor
 258                            (interval-length
 259                             (ly:stencil-extent
 260                              (grob-interpret-markup grob "8")
 261                              X)))))
 262
 263     (if (is-harmonic? grob)
 264         (set! output-grob (harmonic-proc output-grob
 265                                          harmonic-half-thick
 266                                          harmonic-width
 267                                          harmonic-angularity
 268                                          harmonic-padding)))
 269     (if cautionary
 270         (set! output-grob (cautionary-proc output-grob
 271                                            cautionary-half-thick
 272                                            cautionary-width
 273                                            cautionary-angularity
 274                                            cautionary-padding)))
 275     (ly:stencil-translate-axis (centered-stencil output-grob)
 276                                column-offset
 277                                X)))
 278
 279 ;; Harmonic definitions
 280
 281 (define node-positions
 282   ;; for the node on m/n-th of the string length, we get the corresponding
 283   ;; (exact) fret position by calculating p=(-12/log 2)*log(1-(m/n));
 284   ;; since guitarists normally use the forth fret and not the 3.8th, here
 285   ;; are rounded values, ordered by
 286   ;; 1/2
 287   ;; 1/3 2/3
 288   ;; 1/4 2/4 3/4 etc.
 289   ;; The value for 2/4 is irrelevant in practical, bacause the string sounds
 290   ;; only one octave higher, not two, but since scheme normalizes the fractions
 291   ;; anyway, these values are simply placeholders for easier indexing.
 292   ;; According to the arithmetic sum, the position of m/n is at 1/2*(n-2)(n-1)+(m-1)
 293   ;; if we start counting from zero
 294   (vector 12
 295           7   19
 296           5   12    24
 297           4    9    16   28
 298           3    7    12   19    31
 299           2.7  5.8  9.7  14.7  21.7  33.7
 300           2.3  5    8    12    17    24    36
 301           2    4.4  7    10    14    19    26  38 ))
 302
 303 (define partial-pitch
 304   (vector '(0 0 0)
 305           '(1 0 0)
 306           '(1 4 0)
 307           '(2 0 0)
 308           '(2 2 0)
 309           '(2 4 0)
 310           '(2 6 -1/2)
 311           '(3 0 0)
 312           '(3 1 0)))
 313
 314 (define fret-partials
 315   '(("0" . 0)
 316     ("12" . 1)
 317     ("7" . 2)
 318     ("19" . 2)
 319     ("5" . 3)
 320     ("24" . 3)
 321     ("4" . 4)
 322     ("9" . 4)
 323     ("16" . 4)
 324     ("3" . 5)
 325     ("2.7" . 6)
 326     ("2.3" . 7)
 327     ("2" . 8)))
 328
 329 (define-public (ratio->fret ratio)
 330   "Calculate a fret number given @var{ratio} for the harmonic."
 331   (let* ((nom (numerator ratio))
 332          (den (denominator ratio))
 333          (index (+ (* (- den 2)
 334                       (- den 1)
 335                       1/2)
 336                    nom -1)))
 337     (number->string (vector-ref node-positions index))))
 338
 339 (define-public (ratio->pitch ratio)
 340   "Calculate a pitch given @var{ratio} for the harmonic."
 341   (let* ((partial (1- (denominator ratio)))
 342          (pitch (vector-ref partial-pitch partial)))
 343
 344     (ly:make-pitch (first pitch)
 345                    (second pitch)
 346                    (third pitch))))
 347
 348 (define-public (fret->pitch fret)
 349   "Calculate a pitch given @var{fret} for the harmonic."
 350   (let* ((partial (assoc-get fret fret-partials 0))
 351          (pitch (vector-ref partial-pitch partial)))
 352
 353     (ly:make-pitch (first pitch)
 354                    (second pitch)
 355                    (third pitch))))
 356
 357 (define-public (calc-harmonic-pitch pitch music)
 358   "Calculate the harmonic pitches in @var{music} given
 359 @var{pitch} as the non-harmonic pitch."
 360   (let ((es (ly:music-property music 'elements))
 361         (e (ly:music-property music 'element))
 362         (p (ly:music-property music 'pitch)))
 363     (cond
 364      ((pair? es)
 365       (ly:music-set-property! music 'elements
 366                               (map (lambda (x) (calc-harmonic-pitch pitch x)) es)))
 367      ((ly:music? e)
 368       (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e)))
 369      ((ly:pitch? p)
 370       (begin
 371         (set! p (ly:pitch-transpose p pitch))
 372         (ly:music-set-property! music 'pitch p))))
 373     music))
 374
 375 (define-public (make-harmonic mus)
 376   "Convert music variable @var{mus} to harmonics."
 377   (let ((elts (ly:music-property mus 'elements))
 378         (elt (ly:music-property mus 'element)))
 379     (cond
 380      ((pair? elts)
 381       (for-each make-harmonic elts))
 382      ((ly:music? elt)
 383       (make-harmonic elt))
 384      ((music-is-of-type? mus 'note-event)
 385       (set! (ly:music-property mus 'articulations)
 386             (append
 387              (ly:music-property mus 'articulations)
 388              (list (make-music 'HarmonicEvent))))))
 389     mus))