path: root/stafftab-engraver.scm

;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; LilyPond is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (srfi srfi-1)
             (srfi srfi-26))


;; settings
(define staff-padding-bass 1.5)   ; Padding below bass staff
(define staff-padding-melody 1.5) ; Padding above melody staff
(define thickness 0.2)            ; Thickness of note head outline
(define spread 1.5)               ; Scaling factor for spreading
                                  ; string markers in chords according
                                  ; to their fret position.


(define (extract-property m)
  "Extract finger or string number from music event."
  (let ((name (ly:music-property m 'name)))
    (cond
     ((and (eq? name 'FingeringEvent)
           (not (null? (ly:music-property m 'digit))))
      (cons 'finger
            (ly:music-property m 'digit)))
     ((and (eq? name 'StringNumberEvent)
           (not (null? (ly:music-property m 'string-number))))
      (cons 'string-number
            (ly:music-property m 'string-number)))
     (else #f))))

(define (replace-note-head! grob finger filled?)
  "Replace note head in GROB with FINGER-dependent note head."
  (define (first)
    "Draw a circular note head."
    (let* ((radius 0.45)
           (out-radius (+ radius (/ thickness 2))))
      (ly:make-stencil
       (list 'circle 0.45 thickness filled?)
       (cons (- out-radius) out-radius)
       (cons (- out-radius) out-radius))))

  (define (second)
    "Draw a diamond-shaped note head."
    (ly:make-stencil
     `(polygon (list -0.5 0.0
                     0.0 0.5
                     0.5 0.0
                     0.0 -0.5)
               ,thickness ,filled?)
     (cons -0.5 0.5)
     (cons 0 0)))

  (define (third)
    "Draw a triangular note head."
    ;; adjust stem-attachment because downward facing stems are
    ;; broken otherwise
    (ly:grob-set-property!
     grob
     'stem-attachment
     (lambda (grob)
       (let* ((stem (ly:grob-object grob 'stem))
              (dir  (ly:grob-property stem 'direction)))
         (if (eq? UP dir)
             '(1 . -0.5)
             '(1 . 0.5)))))
    (ly:make-stencil
     `(polygon (list 0.0 0.4
                     0.45 -0.4
                     -0.45 -0.4)
               ,thickness ,filled?)
     (cons -0.5 0.5)
     (cons -1 1)))

  (define (fourth)
    "Draw a rectangular note head."
    (let* ((width (- 1 thickness))
           (edge (/ width 2))
           (outer (+ edge (/ thickness 2))))
      (ly:make-stencil
       `(polygon (list ,edge     ,edge
                       ,edge     ,(- edge)
                       ,(- edge) ,(- edge)
                       ,(- edge) ,edge)
                 ,thickness ,filled?)
       (cons (- outer) outer)
       (cons (- outer) outer))))

  ;; select the correct note head and replace stencil
  (let ((stencil (list-ref
                  (list first second third fourth)
                  (- finger 1))))
    (ly:grob-set-property! grob 'stencil (stencil))))


(define-public (stafftab-engraver context)
  "An engraver for StaffTab notation.

1. Listen for a music-event: collect pitch, note fill status,
finger, and string number for each encountered note and store them in
an alist in *props-list*.

2. Acknowledge note-head-interface: store all encountered note-head
grobs in the global list *grobs* so that they can be accessed in the
next stage

3. Process acknowledged: modify grobs dependent on the collected
properties.  This includes replacing the note head, placing a string
marker, as well as adding an empty fret marker with a list of
accumulated fret positions to be displayed.

4. Stop translation timestep: compute sorted fret marker text from
previously collected fret positions.

5. Start next translation timestep: reset all lists for the next
iteration."
  (let ((*grobs* '())               ; List of acknowleged grobs.

        (*props-list* '())          ; Properties for each note at
                                    ; current timestep.

        (*previous-props-list* '()) ; Copy of *props-list* for
                                    ; previous timestep.

        (*adjust-later*
         '((fret-grob . #f)         ; Shared grob for fret numbers.
           (properties . ())))      ; List of note properties needed
                                    ; at the end of the timestep for
                                    ; graphical adjustments.

        ;; The tuning of this context (bass or melody side)
        (tuning (reverse
                 (ly:context-property context 'stringTunings))))

    (define (bass? string-number)
      "Return #T if the STRING-NUMBER is on the bass side."
      (> string-number (/ (length tuning) 2)))

    (define (fret pitch string-number)
      "Return fret number on the string STRING-NUMBER given PITCH."
      (let* ((string     (remainder (- string-number 1)
                                    (length tuning)))
             (root       (list-ref tuning string))
             (root-semi  (ly:pitch-semitones root))
             (pitch-semi (ly:pitch-semitones pitch)))
        (- pitch-semi root-semi)))

    (define (make-fret-marker trans string-number)
      "Create and initialize a grob for fret position annotations in
translation context TRANS.  When STRING-NUMBER is greater than the
number of strings in this string group, it relates to bass strings and
thus has to be placed in the other direction."
      (let* ((grob  (ly:engraver-make-grob trans 'TextScript '()))
             (bass? (bass? string-number))
             (dir   (if bass? DOWN UP))
             (pad   (if bass?
                        staff-padding-bass
                        staff-padding-melody)))
        (for-each (lambda (pair)
                    (ly:grob-set-property! grob (car pair) (cdr pair)))
                  `((color . ,(x11-color 'DimGray))
                    (font-size . -5)
                    (side-axis . 0)        ;centre align
                    (self-alignment-X . 0) ;centre align
                    (direction . ,dir)
                    (staff-padding . ,pad)))
        grob))

    (define (make-string-marker trans string-number)
      "Add string marker for STRING-NUMBER in translation context
TRANS."
      (let* ((grob    (ly:engraver-make-grob trans 'StringNumber '()))
             (strings (/ (length tuning) 2))
             (bass?   (bass? string-number))
             (marker  (ly:make-stencil
                       (list 'embedded-ps
                             "gsave
                              currentpoint translate
                              newpath
                              0 setlinecap
                              0.05 setlinewidth
                              -1.2 0.2  moveto
                              1.2 0.2   lineto
                              1.2 -0.1  lineto
                              -1.2 -0.1 lineto
                              -1.2 0.2  lineto
                              stroke
                              grestore")
                       (cons -1.3 1.3)
                       (cons -0.1 0.2))))
        ;; centre-align
        (ly:grob-set-property! grob 'side-axis 0)
        ;; replace stencil
        (ly:grob-set-property! grob 'stencil marker)
        ;; move marker to staff line
        ;; - default placement on melody side equals to string 3
        ;; - default placement on bass side equals to third bass string
        ;;   (9 on a Grand, 8 on a 10-string)
        (ly:grob-set-property! grob 'Y-offset
                               (- (+ 3 (if bass? strings 0))
                                  string-number))
        ;; Oddly, this needs a direction or else Lilypond fails an
        ;; assertion.
        (ly:grob-set-property! grob 'direction (if bass? DOWN UP))
        grob))

    (define (add-properties! new? alist)
      "Add a property list ALIST to the current object in
*props-list*.  If NEW? is true, the properties are added to a new
object."
      (set! *props-list*
            (if new?
                (cons alist *props-list*)
                (if (null? *props-list*)
                    (list alist)
                    (let ((current (car *props-list*)))
                      (cons (append alist current)
                            (cdr *props-list*)))))))

    (define (process-note! trans total index grob props)
      "Render a note in the translator context TRANS given an
acknowledged GROB, a property list PROPS and an INDEX to look up the
matching previous note in a chord of TOTAL notes."
      (let* ((prev (if (> (length *previous-props-list*) index)
                       (list-ref *previous-props-list* index)
                       #f))
             (filled? (assoc-ref props 'filled?))
             (pitch   (assoc-ref props 'pitch))
             (finger  (or (assoc-ref props 'finger)
                          (and prev (assoc-ref prev 'finger)) 1))
             (string-number (or (assoc-ref props 'string-number)
                                (and prev (assoc-ref
                                           prev 'string-number)))))
        (replace-note-head! grob finger filled?)
        (if string-number
            (let ((fret-no (fret pitch string-number))
                  (string-marker (make-string-marker trans
                                                     string-number)))
              (if (> fret-no 0)
                  (begin
                    ;; If this is the first note in this timestep to
                    ;; need fret annotations, initialise the shared
                    ;; fret-marker first.
                    (if (not (assoc-ref *adjust-later* 'fret-grob))
                        (assoc-set! *adjust-later* 'fret-grob
                                    (make-fret-marker trans string-number)))
                    ;; Record fret position + string number + string
                    ;; marker for later adjustment
                    (assoc-set! *adjust-later* 'properties
                                (cons (list fret-no
                                            string-number
                                            string-marker)
                                      (assoc-ref *adjust-later*
                                                 'properties)))))))))

    (make-engraver
     (listeners
      ((music-event trans event)
       (let ((m (ly:event-property event 'music-cause #f)))
         (if m (cond
                ((eq? (ly:music-property m 'name) 'NoteEvent)
                 ;; create a new object to collect data
                 ;; whenever a note-event is encountered
                 (add-properties!
                  'as-new-note
                  (append
                   (list
                    (cons 'pitch
                          (ly:event-property event 'pitch))
                    (cons 'filled?
                          (ly:moment<? (ly:music-duration-length m)
                                       (ly:make-moment 1 2))))
                   ;; If this event has articulations, get the finger and
                   ;; string number from the inner music object
                   (let ((articulations (ly:music-property m 'articulations)))
                     (if articulations
                         (delq #f (map extract-property
                                       articulations)))))))

                ;; otherwise add properties to existing object
                (else
                 (let ((prop (extract-property m)))
                   (if prop (add-properties! #f (list prop))))))))))

     (acknowledgers
      ((note-head-interface trans grob source)
       (set! *grobs* (cons grob *grobs*))))

     ((process-acknowledged trans)
      (if (and (not (null? *grobs*))
               (= (length *grobs*)
                  (length *props-list*)))
          (begin
            (for-each (cute process-note!
                            trans (length *props-list*) <...>)
                      (iota (length *props-list*))
                      *grobs*
                      *props-list*)
            ;; clear grobs now or we will never get past this step
            (set! *grobs* '()))))

     ;; Reset all state at the beginning of the timestep
     ((start-translation-timestep trans)
      ;; Keep string-number and finger from the previous-props-list if
      ;; they are not in the current props-list.  Don't do this for
      ;; chords.
      (if (and (equal? 1 (length *props-list*))
               (equal? 1 (length *previous-props-list*)))
          ;; single notes, retain string-number and finger
          (let* ((props (first *props-list*))
                 (prev  (first *previous-props-list*))
                 (last-finger (or (assoc-ref props 'finger)
                                  (assoc-ref prev 'finger)))
                 (last-string (or (assoc-ref props 'string-number)
                                  (assoc-ref prev 'string-number))))
            (set! *previous-props-list*
              (list (list (cons 'string-number last-string)
                          (cons 'finger last-finger)))))
          ;; ignore chords
          (set! *previous-props-list* *props-list*))
      (set! *props-list* '())
      (set! *adjust-later* (list (cons 'fret-grob #f)
                                 (cons 'properties '()))))

     ;; Perform final graphical adjustments
     ((stop-translation-timestep trans)
      (let ((fret-grob (assoc-ref *adjust-later* 'fret-grob))
            (props     (assoc-ref *adjust-later* 'properties)))

        ;; Display fret numbers in string order.
        (if fret-grob
            (let* (;; sort on string number (cadr of each pair)
                   (sorted (sort props (lambda (a b)
                                         (< (cadr a) (cadr b)))))
                   ;; join all fret numbers with a dot
                   (text (string-join (map (lambda (p)
                                             (number->string (car p)))
                                           sorted) ".")))
              ;; update text
              (ly:grob-set-property! fret-grob 'text text)))

        ;; Adjust the string markers for chords
        ;; - those with lower fret number should be pushed left
        ;; - those with higher fret number should be pushed right
        (let ((frets (map car props)))
          (if (> (length frets) 1)
              (let* ((low (apply min frets))
                     (high (apply max frets))
                     (range (- high low)))
                (if (not (zero? range))
                    (for-each
                     (lambda (p)
                       (let* ((string-marker (caddr p))
                              (fret-no (car p))
                              (offset (/ (- fret-no low (/ range 2))
                                         range)))
                         (ly:grob-set-property! string-marker
                                                'X-offset
                                                (* spread offset))))
                     props))))))))))