diff options
Diffstat (limited to 'scm/stafftab-engraver.scm')
| -rw-r--r-- | scm/stafftab-engraver.scm | 344 |
1 files changed, 344 insertions, 0 deletions
diff --git a/scm/stafftab-engraver.scm b/scm/stafftab-engraver.scm new file mode 100644 index 0000000000..f280255efc --- /dev/null +++ b/scm/stafftab-engraver.scm @@ -0,0 +1,344 @@ +;;;; This file is part of LilyPond, the GNU music typesetter. +;;;; +;;;; Copyright (C) 2015 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-26)) + + +;; settings +(define staff-padding-bass 2.5) ; Padding below bass staff +(define staff-padding-melody 4.5) ; Padding above melody staff +(define thickness 0.2) ; Thickness of note head outline +(define spread 1.5) ; Scaling factor for spreading + ; string markers 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 + ((eq? name 'FingeringEvent) + (cons 'finger + (ly:music-property m 'digit))) + ((eq? name 'StringNumberEvent) + (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 (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? (> string-number (length tuning))) + (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)) + (bass? (> string-number strings)) + (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)) + 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)) + (name (ly:music-property m 'name))) + (if (eq? 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 + (delq #f + (map extract-property + (ly:music-property m 'articulations))))) + ;; otherwise add properties to existing object + (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) + (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)))))))))) |