scm/tablature.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2009--2015 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-box (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     ;; 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)))
  87
  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
  95       X-extent)))
  96
  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)))
 102
 103       ;; yes -> draw double stem
 104       (let* ((separation (ly:grob-property grob 'double-stem-separation 0.5))
 105              (half-separation (/ separation 2)))
 106         (ly:stencil-add
 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)
 110       stem-stencil)))
 111
 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)))
 120
 121     (if (< (ly:pitch-tones right-pitch) (ly:pitch-tones left-pitch))
 122         -0.75
 123         0.75)))
 124
 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) '())))
 133
 134     (if spanner-start
 135         ;; tab note head is right bound of a tie and left of spanner,
 136         ;; -> parenthesize it at all events
 137         (begin
 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)))
 151
 152               (if tab-note-head-visible
 153                   ;; tab note head is visible
 154                   (if tab-note-head-parenthesized
 155                       (begin
 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)))
 160
 161             ;; tie is not split
 162             (ly:grob-set-property! tied-tab-note-head 'transparent #t)))))
 163
 164
 165
 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)))
 171     (if spanner-start
 172         ;; tab note head is between a tie and a slur/glissando
 173         ;; -> parenthesize it at all events
 174         (begin
 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)))
 182
 183           (if tab-note-head-visible
 184               ;; tab note head is visible
 185               (if tab-note-head-parenthesized
 186                   (begin
 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))))))
 191
 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
 204                               (lambda (p)
 205                                 (cons (car p)
 206                                       (- (cdr p)
 207                                          (* staff-space
 208                                             (ly:grob-property grob 'direction)
 209                                             0.35))))
 210                               control-points)))
 211
 212     (ly:grob-set-property! grob 'control-points new-control-points)
 213     (ly:slur::print grob)))
 214
 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)))
 221
 222     (and cautionary
 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)))
 227
 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)))
 234
 235
 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)
 241
 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))
 247                          arts))
 248           (eq? (ly:grob-property grob 'style) 'harmonic))))
 249
 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
 268                            (interval-length
 269                             (ly:stencil-extent ref-grob X)))))
 270
 271     (if (is-harmonic? grob)
 272         (set! output-grob (harmonic-proc output-grob
 273                                          harmonic-half-thick
 274                                          harmonic-width
 275                                          harmonic-angularity
 276                                          harmonic-padding)))
 277     (if cautionary
 278         (set! output-grob (cautionary-proc output-grob
 279                                            cautionary-half-thick
 280                                            cautionary-width
 281                                            cautionary-angularity
 282                                            cautionary-padding)))
 283     (ly:stencil-translate-axis
 284      (ly:stencil-aligned-to output-grob X CENTER)
 285      column-offset
 286      X)))
 287
 288 ;; Harmonic definitions
 289
 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
 295   ;; 1/2
 296   ;; 1/3 2/3
 297   ;; 1/4 2/4 3/4 etc.
 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
 303   (vector 12
 304           7   19
 305           5   12    24
 306           4    9    16   28
 307           3    7    12   19    31
 308           2.7  5.8  9.7  14.7  21.7  33.7
 309           2.3  5    8    12    17    24    36
 310           2    4.4  7    10    14    19    26  38 ))
 311
 312 (define partial-pitch
 313   (vector '(0 0 0)
 314           '(1 0 0)
 315           '(1 4 0)
 316           '(2 0 0)
 317           '(2 2 0)
 318           '(2 4 0)
 319           '(2 6 -1/2)
 320           '(3 0 0)
 321           '(3 1 0)))
 322
 323 (define fret-partials
 324   '(("0" . 0)
 325     ("12" . 1)
 326     ("7" . 2)
 327     ("19" . 2)
 328     ("5" . 3)
 329     ("24" . 3)
 330     ("4" . 4)
 331     ("9" . 4)
 332     ("16" . 4)
 333     ("3" . 5)
 334     ("2.7" . 6)
 335     ("2.3" . 7)
 336     ("2" . 8)))
 337
 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)
 343                       (- den 1)
 344                       1/2)
 345                    nom -1)))
 346     (number->string (vector-ref node-positions index))))
 347
 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)))
 352
 353     (ly:make-pitch (first pitch)
 354                    (second pitch)
 355                    (third pitch))))
 356
 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)))
 361
 362     (ly:make-pitch (first pitch)
 363                    (second pitch)
 364                    (third pitch))))
 365
 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)))
 372     (cond
 373      ((pair? es)
 374       (ly:music-set-property! music 'elements
 375                               (map (lambda (x) (calc-harmonic-pitch pitch x)) es)))
 376      ((ly:music? e)
 377       (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e)))
 378      ((ly:pitch? p)
 379       (begin
 380         (set! p (ly:pitch-transpose p pitch))
 381         (ly:music-set-property! music 'pitch p))))
 382     music))
 383
 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)))
 388     (cond
 389      ((pair? elts)
 390       (for-each make-harmonic elts))
 391      ((ly:music? elt)
 392       (make-harmonic elt))
 393      ((music-is-of-type? mus 'note-event)
 394       (set! (ly:music-property mus 'articulations)
 395             (append
 396              (ly:music-property mus 'articulations)
 397              (list (make-music 'HarmonicEvent))))))
 398     mus))