;;;; 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))))))))))