Add stafftab engraver for Stick.

1 files changed, 373 insertions, 0 deletions

diff --git a/stafftab-engraver.scm b/stafftab-engraver.scm
new file mode 100644
index 0000000..16bd917
--- /dev/null
+++ b/stafftab-engraver.scm
@@ -0,0 +1,373 @@
+;;;; 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))))))))))