stafftab-engraver.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
   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 (use-modules (srfi srfi-1)
  19              (srfi srfi-26))
  20
  21 \f
  22 ;; settings
  23 (define staff-padding-bass 1.5)   ; Padding below bass staff
  24 (define staff-padding-melody 1.5) ; Padding above melody staff
  25 (define thickness 0.2)            ; Thickness of note head outline
  26 (define spread 1.5)               ; Scaling factor for spreading
  27                                   ; string markers in chords according
  28                                   ; to their fret position.
  29
  30 \f
  31 (define (extract-property m)
  32   "Extract finger or string number from music event."
  33   (let ((name (ly:music-property m 'name)))
  34     (cond
  35      ((and (eq? name 'FingeringEvent)
  36            (not (null? (ly:music-property m 'digit))))
  37       (cons 'finger
  38             (ly:music-property m 'digit)))
  39      ((and (eq? name 'StringNumberEvent)
  40            (not (null? (ly:music-property m 'string-number))))
  41       (cons 'string-number
  42             (ly:music-property m 'string-number)))
  43      (else #f))))
  44
  45 (define (replace-note-head! grob finger filled?)
  46   "Replace note head in GROB with FINGER-dependent note head."
  47   (define (first)
  48     "Draw a circular note head."
  49     (let* ((radius 0.45)
  50            (out-radius (+ radius (/ thickness 2))))
  51       (ly:make-stencil
  52        (list 'circle 0.45 thickness filled?)
  53        (cons (- out-radius) out-radius)
  54        (cons (- out-radius) out-radius))))
  55
  56   (define (second)
  57     "Draw a diamond-shaped note head."
  58     (ly:make-stencil
  59      `(polygon (list -0.5 0.0
  60                      0.0 0.5
  61                      0.5 0.0
  62                      0.0 -0.5)
  63                ,thickness ,filled?)
  64      (cons -0.5 0.5)
  65      (cons 0 0)))
  66
  67   (define (third)
  68     "Draw a triangular note head."
  69     ;; adjust stem-attachment because downward facing stems are
  70     ;; broken otherwise
  71     (ly:grob-set-property!
  72      grob
  73      'stem-attachment
  74      (lambda (grob)
  75        (let* ((stem (ly:grob-object grob 'stem))
  76               (dir  (ly:grob-property stem 'direction)))
  77          (if (eq? UP dir)
  78              '(1 . -0.5)
  79              '(1 . 0.5)))))
  80     (ly:make-stencil
  81      `(polygon (list 0.0 0.4
  82                      0.45 -0.4
  83                      -0.45 -0.4)
  84                ,thickness ,filled?)
  85      (cons -0.5 0.5)
  86      (cons -1 1)))
  87
  88   (define (fourth)
  89     "Draw a rectangular note head."
  90     (let* ((width (- 1 thickness))
  91            (edge (/ width 2))
  92            (outer (+ edge (/ thickness 2))))
  93       (ly:make-stencil
  94        `(polygon (list ,edge     ,edge
  95                        ,edge     ,(- edge)
  96                        ,(- edge) ,(- edge)
  97                        ,(- edge) ,edge)
  98                  ,thickness ,filled?)
  99        (cons (- outer) outer)
 100        (cons (- outer) outer))))
 101
 102   ;; select the correct note head and replace stencil
 103   (let ((stencil (list-ref
 104                   (list first second third fourth)
 105                   (- finger 1))))
 106     (ly:grob-set-property! grob 'stencil (stencil))))
 107
 108 \f
 109 (define-public (stafftab-engraver context)
 110   "An engraver for StaffTab notation.
 111
 112 1. Listen for a music-event: collect pitch, note fill status,
 113 finger, and string number for each encountered note and store them in
 114 an alist in *props-list*.
 115
 116 2. Acknowledge note-head-interface: store all encountered note-head
 117 grobs in the global list *grobs* so that they can be accessed in the
 118 next stage
 119
 120 3. Process acknowledged: modify grobs dependent on the collected
 121 properties.  This includes replacing the note head, placing a string
 122 marker, as well as adding an empty fret marker with a list of
 123 accumulated fret positions to be displayed.
 124
 125 4. Stop translation timestep: compute sorted fret marker text from
 126 previously collected fret positions.
 127
 128 5. Start next translation timestep: reset all lists for the next
 129 iteration."
 130   (let ((*grobs* '())               ; List of acknowleged grobs.
 131
 132         (*props-list* '())          ; Properties for each note at
 133                                     ; current timestep.
 134
 135         (*previous-props-list* '()) ; Copy of *props-list* for
 136                                     ; previous timestep.
 137
 138         (*adjust-later*
 139          '((fret-grob . #f)         ; Shared grob for fret numbers.
 140            (properties . ())))      ; List of note properties needed
 141                                     ; at the end of the timestep for
 142                                     ; graphical adjustments.
 143
 144         ;; The tuning of this context (bass or melody side)
 145         (tuning (reverse
 146                  (ly:context-property context 'stringTunings))))
 147
 148     (define (bass? string-number)
 149       "Return #T if the STRING-NUMBER is on the bass side."
 150       (> string-number (/ (length tuning) 2)))
 151
 152     (define (fret pitch string-number)
 153       "Return fret number on the string STRING-NUMBER given PITCH."
 154       (let* ((string     (remainder (- string-number 1)
 155                                     (length tuning)))
 156              (root       (list-ref tuning string))
 157              (root-semi  (ly:pitch-semitones root))
 158              (pitch-semi (ly:pitch-semitones pitch)))
 159         (- pitch-semi root-semi)))
 160
 161     (define (make-fret-marker trans string-number)
 162       "Create and initialize a grob for fret position annotations in
 163 translation context TRANS.  When STRING-NUMBER is greater than the
 164 number of strings in this string group, it relates to bass strings and
 165 thus has to be placed in the other direction."
 166       (let* ((grob  (ly:engraver-make-grob trans 'TextScript '()))
 167              (bass? (bass? string-number))
 168              (dir   (if bass? DOWN UP))
 169              (pad   (if bass?
 170                         staff-padding-bass
 171                         staff-padding-melody)))
 172         (for-each (lambda (pair)
 173                     (ly:grob-set-property! grob (car pair) (cdr pair)))
 174                   `((color . ,(x11-color 'DimGray))
 175                     (font-size . -5)
 176                     (side-axis . 0)        ;centre align
 177                     (self-alignment-X . 0) ;centre align
 178                     (direction . ,dir)
 179                     (staff-padding . ,pad)))
 180         grob))
 181
 182     (define (make-string-marker trans string-number)
 183       "Add string marker for STRING-NUMBER in translation context
 184 TRANS."
 185       (let* ((grob    (ly:engraver-make-grob trans 'StringNumber '()))
 186              (strings (/ (length tuning) 2))
 187              (bass?   (bass? string-number))
 188              (marker  (ly:make-stencil
 189                        (list 'embedded-ps
 190                              "gsave
 191                               currentpoint translate
 192                               newpath
 193                               0 setlinecap
 194                               0.05 setlinewidth
 195                               -1.2 0.2  moveto
 196                               1.2 0.2   lineto
 197                               1.2 -0.1  lineto
 198                               -1.2 -0.1 lineto
 199                               -1.2 0.2  lineto
 200                               stroke
 201                               grestore")
 202                        (cons -1.3 1.3)
 203                        (cons -0.1 0.2))))
 204         ;; centre-align
 205         (ly:grob-set-property! grob 'side-axis 0)
 206         ;; replace stencil
 207         (ly:grob-set-property! grob 'stencil marker)
 208         ;; move marker to staff line
 209         ;; - default placement on melody side equals to string 3
 210         ;; - default placement on bass side equals to third bass string
 211         ;;   (9 on a Grand, 8 on a 10-string)
 212         (ly:grob-set-property! grob 'Y-offset
 213                                (- (+ 3 (if bass? strings 0))
 214                                   string-number))
 215         ;; Oddly, this needs a direction or else Lilypond fails an
 216         ;; assertion.
 217         (ly:grob-set-property! grob 'direction (if bass? DOWN UP))
 218         grob))
 219
 220     (define (add-properties! new? alist)
 221       "Add a property list ALIST to the current object in
 222 *props-list*.  If NEW? is true, the properties are added to a new
 223 object."
 224       (set! *props-list*
 225             (if new?
 226                 (cons alist *props-list*)
 227                 (if (null? *props-list*)
 228                     (list alist)
 229                     (let ((current (car *props-list*)))
 230                       (cons (append alist current)
 231                             (cdr *props-list*)))))))
 232
 233     (define (process-note! trans total index grob props)
 234       "Render a note in the translator context TRANS given an
 235 acknowledged GROB, a property list PROPS and an INDEX to look up the
 236 matching previous note in a chord of TOTAL notes."
 237       (let* ((prev (if (> (length *previous-props-list*) index)
 238                        (list-ref *previous-props-list* index)
 239                        #f))
 240              (filled? (assoc-ref props 'filled?))
 241              (pitch   (assoc-ref props 'pitch))
 242              (finger  (or (assoc-ref props 'finger)
 243                           (and prev (assoc-ref prev 'finger)) 1))
 244              (string-number (or (assoc-ref props 'string-number)
 245                                 (and prev (assoc-ref
 246                                            prev 'string-number)))))
 247         (replace-note-head! grob finger filled?)
 248         (if string-number
 249             (let ((fret-no (fret pitch string-number))
 250                   (string-marker (make-string-marker trans
 251                                                      string-number)))
 252               (if (> fret-no 0)
 253                   (begin
 254                     ;; If this is the first note in this timestep to
 255                     ;; need fret annotations, initialise the shared
 256                     ;; fret-marker first.
 257                     (if (not (assoc-ref *adjust-later* 'fret-grob))
 258                         (assoc-set! *adjust-later* 'fret-grob
 259                                     (make-fret-marker trans string-number)))
 260                     ;; Record fret position + string number + string
 261                     ;; marker for later adjustment
 262                     (assoc-set! *adjust-later* 'properties
 263                                 (cons (list fret-no
 264                                             string-number
 265                                             string-marker)
 266                                       (assoc-ref *adjust-later*
 267                                                  'properties)))))))))
 268
 269     (make-engraver
 270      (listeners
 271       ((music-event trans event)
 272        (let ((m (ly:event-property event 'music-cause #f)))
 273          (if m (cond
 274                 ((eq? (ly:music-property m 'name) 'NoteEvent)
 275                  ;; create a new object to collect data
 276                  ;; whenever a note-event is encountered
 277                  (add-properties!
 278                   'as-new-note
 279                   (append
 280                    (list
 281                     (cons 'pitch
 282                           (ly:event-property event 'pitch))
 283                     (cons 'filled?
 284                           (ly:moment<? (ly:music-duration-length m)
 285                                        (ly:make-moment 1 2))))
 286                    ;; If this event has articulations, get the finger and
 287                    ;; string number from the inner music object
 288                    (let ((articulations (ly:music-property m 'articulations)))
 289                      (if articulations
 290                          (delq #f (map extract-property
 291                                        articulations)))))))
 292
 293                 ;; otherwise add properties to existing object
 294                 (else
 295                  (let ((prop (extract-property m)))
 296                    (if prop (add-properties! #f (list prop))))))))))
 297
 298      (acknowledgers
 299       ((note-head-interface trans grob source)
 300        (set! *grobs* (cons grob *grobs*))))
 301
 302      ((process-acknowledged trans)
 303       (if (and (not (null? *grobs*))
 304                (= (length *grobs*)
 305                   (length *props-list*)))
 306           (begin
 307             (for-each (cute process-note!
 308                             trans (length *props-list*) <...>)
 309                       (iota (length *props-list*))
 310                       *grobs*
 311                       *props-list*)
 312             ;; clear grobs now or we will never get past this step
 313             (set! *grobs* '()))))
 314
 315      ;; Reset all state at the beginning of the timestep
 316      ((start-translation-timestep trans)
 317       ;; Keep string-number and finger from the previous-props-list if
 318       ;; they are not in the current props-list.  Don't do this for
 319       ;; chords.
 320       (if (and (equal? 1 (length *props-list*))
 321                (equal? 1 (length *previous-props-list*)))
 322           ;; single notes, retain string-number and finger
 323           (let* ((props (first *props-list*))
 324                  (prev  (first *previous-props-list*))
 325                  (last-finger (or (assoc-ref props 'finger)
 326                                   (assoc-ref prev 'finger)))
 327                  (last-string (or (assoc-ref props 'string-number)
 328                                   (assoc-ref prev 'string-number))))
 329             (set! *previous-props-list*
 330               (list (list (cons 'string-number last-string)
 331                           (cons 'finger last-finger)))))
 332           ;; ignore chords
 333           (set! *previous-props-list* *props-list*))
 334       (set! *props-list* '())
 335       (set! *adjust-later* (list (cons 'fret-grob #f)
 336                                  (cons 'properties '()))))
 337
 338      ;; Perform final graphical adjustments
 339      ((stop-translation-timestep trans)
 340       (let ((fret-grob (assoc-ref *adjust-later* 'fret-grob))
 341             (props     (assoc-ref *adjust-later* 'properties)))
 342
 343         ;; Display fret numbers in string order.
 344         (if fret-grob
 345             (let* (;; sort on string number (cadr of each pair)
 346                    (sorted (sort props (lambda (a b)
 347                                          (< (cadr a) (cadr b)))))
 348                    ;; join all fret numbers with a dot
 349                    (text (string-join (map (lambda (p)
 350                                              (number->string (car p)))
 351                                            sorted) ".")))
 352               ;; update text
 353               (ly:grob-set-property! fret-grob 'text text)))
 354
 355         ;; Adjust the string markers for chords
 356         ;; - those with lower fret number should be pushed left
 357         ;; - those with higher fret number should be pushed right
 358         (let ((frets (map car props)))
 359           (if (> (length frets) 1)
 360               (let* ((low (apply min frets))
 361                      (high (apply max frets))
 362                      (range (- high low)))
 363                 (if (not (zero? range))
 364                     (for-each
 365                      (lambda (p)
 366                        (let* ((string-marker (caddr p))
 367                               (fret-no (car p))
 368                               (offset (/ (- fret-no low (/ range 2))
 369                                          range)))
 370                          (ly:grob-set-property! string-marker
 371                                                 'X-offset
 372                                                 (* spread offset))))
 373                      props))))))))))