From e90a5854b35b81b6902da778e1a0ec9b63492e0b Mon Sep 17 00:00:00 2001 From: rekado Date: Tue, 6 Dec 2016 12:30:22 +0100 Subject: Add stafftab engraver for Stick. --- stafftab-engraver.scm | 373 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 373 insertions(+) create mode 100644 stafftab-engraver.scm (limited to 'stafftab-engraver.scm') 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 +;;;; +;;;; 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 . + +(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) + (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)))))))))) -- cgit v1.2.3