2016-09-02 23:34 GMT+02:00 Trevor Daniels <t.dani...@treda.co.uk>:
>
> Thomas Morley wrote Friday, September 02, 2016 8:22 PM
>
>
>> 2016-09-02 13:05 GMT+02:00 Trevor Daniels <t.dani...@treda.co.uk>:
>>>
>>> There already is a helpful working example in the code base. See
>>>
>>> input/regression/scheme-engraver.ly
>>>
>>> This doesn't go as far as creating new grobs, so I've attached a
>>> simple example that does. This is a bit of a hack, used as part of
>>> a learning process, and a bit messy as it evolved from an earlier
>>> attempt, but it illustrates one way.
>>>
>>> Actually, comments from the experts on this would be very helpful.
>>
>> I stumbled across you're printing a rest-glyph for a quarter-note.
>>
>> Eventually I might have some ideas, but there are a plethora of
>> variants for historic tablaures. Which glyphs do you want to be
>> printed above the TabStaff for the code below. Only flags, flags with
>> stems, stems only for quarters, what to do for notes longer than a
>> quarter?
>>
>> m = { \compressFullBarRests c'\maxima \longa \breve 1 2 4 8 16 32 }
>>
>> <<
>> \new MensuralVoice \m
>> \new TabStaff \with { \revert TextScript.stencil }
>> \new TabVoice
>> \with {
>> \consists \Lute_tab_duration_engraver
>> } \m
>
> I really know very little about lute tablature, but I believe there are many
> different styles. Should this ever get close to operational we'd need
> to discuss which styles to support and what glyphs would be needed.
> But I fear that's some way in the future. The mensural (and rest) glyphs
> I used in this little example are just markers really, while I explore how to
> deal with other aspects - fingering, bass courses, articulations, etc.
>
> Trevor
Hi Trevor,
I've put some work on it. See attached duration-as-markup-5b-harm.ly
The general work should be clear from comments and descriptions.
There's some ugly code in it, although it works so far, wide room for
improvements still there.
Nevertheless it works now even in polyphonic.
For the ornaments you may be interested in Nicolas' engraver.
Attached you'll find my fix to make it compile with newer
devel-versions. Though I didn't do any testings for ornaments in
TabStaff.
You may notice the little bug I detected (close to the red exclamation
mark in pdf), no clue how to fix this.
Cheers,
Harm
\version "2.19.42"
%% taken from:
%% https://github.com/nsceaux/nenuvar/blob/master/common/side-ornementations.ily
%% and adapted for v2.19.42
%%%
%%% Utilities for defining new grobs, grob properties and music event types
%%% (there should be built-in commands to do that in LilyPond)
%%%
#(define (define-grob-definition grob-name grob-entry)
"Define a new grob and add it to `all-grob-definitions', after
scm/define-grobs.scm fashion.
After grob definitions are added, use:
\\layout {
\\context {
\\Global
\\grobdescriptions #all-grob-descriptions
}
}
to register them."
(let* ((meta-entry (assoc-get 'meta grob-entry))
(class (assoc-get 'class meta-entry))
(ifaces-entry (assoc-get 'interfaces meta-entry)))
(set-object-property! grob-name 'translation-type? ly:grob-properties?)
(set-object-property! grob-name 'is-grob? #t)
(set! ifaces-entry (append (case class
((Item) '(item-interface))
((Spanner) '(spanner-interface))
((Paper_column) '((item-interface
paper-column-interface)))
((System) '((system-interface
spanner-interface)))
(else '(unknown-interface)))
ifaces-entry))
(set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
(set! ifaces-entry (cons 'grob-interface ifaces-entry))
(set! meta-entry (assoc-set! meta-entry 'name grob-name))
(set! meta-entry (assoc-set! meta-entry 'interfaces
ifaces-entry))
(set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
(set! all-grob-descriptions
(cons (cons grob-name grob-entry)
all-grob-descriptions))))
#(define-public (define-grob-property symbol type? description)
"Define a new grob property.
`symbol': the property name
`type?': the type predicate for this property
`description': the type documentation"
(set-object-property! symbol 'backend-type? type?)
(set-object-property! symbol 'backend-doc description)
symbol)
#(define-public (define-music-type type-name properties)
"Add a new music type description to `music-descriptions'
and `music-name-to-property-table'."
(set-object-property! type-name
'music-description
(cdr (assq 'description properties)))
(let ((properties (list-copy properties)))
(set! properties (assoc-set! properties 'name type-name))
(set! properties (assq-remove! properties 'description))
(hashq-set! music-name-to-property-table type-name properties)
(set! music-descriptions
(cons (cons type-name properties)
music-descriptions))))
%%%
%%% HeadOrnementation grob type
%%%
#(define (head-ornementation::print me)
"Prints a HeadOrnementation grob (at a note head side)"
(let* ((notes (ly:grob-object me 'elements))
(staff-pos (ly:grob-staff-position (ly:grob-array-ref notes 0)))
(y-ref (ly:grob-common-refpoint-of-array me notes Y))
(x-ref (ly:grob-common-refpoint-of-array me notes X))
(x-ext (ly:relative-group-extent notes x-ref X))
(y-ext (ly:relative-group-extent notes y-ref Y))
(y-coord (+ (interval-center y-ext)
(if (and (eq? (ly:grob-property me 'shift-when-on-line) #t)
(memq staff-pos '(-2 0 2)))
0.5
0)))
(padding (ly:grob-property me 'padding 0.1))
(direction (ly:grob-property me 'direction LEFT))
(text (ly:text-interface::print me))
(width (/ (interval-length (ly:stencil-extent text X)) 2.0))
(x-coord (if (= direction LEFT)
(- (car x-ext) width padding)
(+ (cdr x-ext) width padding))))
(ly:stencil-translate
text
(cons
(- x-coord (ly:grob-relative-coordinate me x-ref X))
(- y-coord (ly:grob-relative-coordinate me y-ref Y))))))
%% a new grob property (used to shift an ornementation when the
%% note head is on a staff line)
#(define-grob-property 'shift-when-on-line boolean?
"If true, then the ornementation is vertically shifted when
the note head is on a staff line.")
%% HeadOrnemenation grob definition:
%% a piece of text attached to a note head side.
#(define-grob-definition
'HeadOrnementation
`((font-size . 0)
(padding . 0.1)
(shift-when-on-line . #f)
(stencil . ,head-ornementation::print)
(meta . ((class . Item)
(interfaces . (font-interface))))))
\layout {
\context {
\Global
\grobdescriptions #all-grob-descriptions
}
}
%%% Head-ornementation Engraver
%%%
#(define (make-head-ornementation
engraver note-grob markp direction is-inside shift-on-line)
"Creates a HeadOrnementation grob attached to a note head.
`note-grob': the note head the ornementation is attached to
`markp': the ornementation markup
`direction': where the ornementation should be printed (LEFT or RIGHT of the note head)
`is-inside': if true, then the ornemenation is printed between accidental
or dots and the note head (in this case the accidental or dots are shifted
to the outside); otherwise it is printed outside dots or accidentals.
`shift-on-line': if true, and when the note head is on a staff line, then the
ornementation is vertically shifted."
(let ((ornementation (ly:engraver-make-grob engraver
'HeadOrnementation
note-grob)))
(set! (ly:grob-property ornementation 'direction) direction)
(set! (ly:grob-property ornementation 'text) markp)
(set! (ly:grob-property ornementation 'shift-when-on-line) shift-on-line)
(ly:pointer-group-interface::add-grob ornementation 'elements note-grob)
(set! (ly:grob-parent ornementation Y) note-grob)
(set! (ly:grob-property ornementation 'font-size)
(+ (ly:grob-property ornementation 'font-size 0.0)
(ly:grob-property note-grob 'font-size 0.0)))
(let* ((orn-stencil (ly:text-interface::print ornementation))
(orn-width (interval-length (ly:stencil-extent orn-stencil X)))
(note-column (ly:grob-object note-grob 'axis-group-parent-X))
(accidentals (ly:note-column-accidentals note-column))
(dot-column (ly:note-column-dot-column note-column))
(dot-column-x-off
(if (ly:grob? dot-column)
(ly:grob-property dot-column 'X-offset 'foo)
0)))
(cond ((and (= direction LEFT) (ly:grob? accidentals) is-inside)
;; if ornementation on the left side of the note is "inside",
;; then shift the accidental to the left to make room for
;; the ornementation
(set! (ly:grob-property accidentals 'padding)
(+ orn-width (* 2 (ly:grob-property ornementation 'padding)))))
((and (= direction RIGHT) (ly:grob? dot-column) is-inside)
;; if ornementation on the right side of the note is "inside",
;; then shift the dots to the right to make room for
;; the ornementation
;; see discussion at
;; http://lilypond.1069038.n5.nabble.com/crash-moving-DotColumn-td190493.html
(set! (ly:grob-property dot-column 'positioning-done)
(lambda (grob)
(ly:dot-column::calc-positioning-done grob)
(ly:grob-translate-axis! grob orn-width X)
#t)))))
ornementation))
#(define (head-ornementation-engraver-acknowledge-note-head
engraver note-grob source-engraver)
"Note head acknowledge method for the head ornementation engraver.
When the note head event attached to the note head grob has ornementation
events among its articulations, then create a HeadOrnementation grob"
(let* ((note-event (ly:grob-property note-grob 'cause)))
(for-each (lambda (articulation)
(if (memq 'head-ornementation-event
(ly:event-property articulation 'class))
(begin
(if (markup? (ly:event-property articulation 'text-left))
(make-head-ornementation
engraver
note-grob
(ly:event-property articulation 'text-left)
LEFT
(ly:event-property articulation 'is-inside)
(ly:event-property articulation 'shift-when-on-line)))
(if (markup? (ly:event-property articulation 'text-right))
(make-head-ornementation
engraver
note-grob
(ly:event-property articulation 'text-right)
RIGHT
(ly:event-property articulation 'is-inside)
(ly:event-property articulation 'shift-when-on-line)))
)))
(ly:event-property note-event 'articulations))))
%% The head-ornementation engraver, with its note-head acknowledger
%% (which creates the HeadOrnementation grobs)
#(define head-ornementation-engraver
`((acknowledgers
(note-head-interface
. ,head-ornementation-engraver-acknowledge-note-head))))
\layout {
\context {
\Score
\consists #head-ornementation-engraver
}
}
%%%
%%% HeadOrnementationEvent definition
%%%
#(define-event-class 'head-ornementation-event 'music-event)
%% a post script event for ornementations attached to note heads
#(define-music-type 'HeadOrnementationEvent
'((description . "Print an ornementation at a note head side")
(types . (general-music post-event event head-ornementation-event))))
%%%
%%% Head ornementation music functions
%%%
%% Helper music function for defining head-ornementation events
#(define (make-head-ornementation-event text-left text-right is-inside shift-on-line)
"Makes a head ornementation"
(make-music 'HeadOrnementationEvent
'text-left text-left
'text-right text-right
'is-inside is-inside
'shift-when-on-line shift-on-line))
#(define (make-left-head-ornementation-event text is-inside shift-on-line)
"Makes a head ornementation"
(make-head-ornementation-event text #f is-inside shift-on-line))
#(define (make-right-head-ornementation-event text is-inside shift-on-line)
"Makes a head ornementation"
(make-head-ornementation-event #f text is-inside shift-on-line))
%%%
%%% Ornementation definitions
%%%
%% Parenthesis before note head
parb = #(make-left-head-ornementation-event
(markup #:fontsize -4 #:musicglyph "accidentals.leftparen")
#t #f)
%% Parenthesis after note head
para = #(make-right-head-ornementation-event
(markup #:fontsize -4 #:musicglyph "accidentals.rightparen")
#t #f)
%% Parenthesis before and after note head
parc = #(make-head-ornementation-event
(markup #:fontsize -4 #:musicglyph "accidentals.leftparen")
(markup #:fontsize -4 #:musicglyph "accidentals.rightparen")
#t #f)
%% Prall after note head
pralla = #(make-right-head-ornementation-event
(markup #:concat (#:hspace 0.2 #:musicglyph "scripts.prall"))
#t #t)
%% Prall before note head
prallb = #(make-left-head-ornementation-event
(markup #:concat (#:musicglyph "scripts.prall" #:hspace 0.2))
#t #t)
%% ^ sign after note head
circA = #(make-right-head-ornementation-event
(markup #:concat (#:hspace 1 #:raise 0.5 #:musicglyph "scripts.umarcato"))
#f #f)
%%%%%%%%%%%%
%% TEST
%%%%%%%%%%%%
{
a'4.\para gis'8\parb a'2\parc
}
{
a'4.\pralla
gis'8\prallb
\voiceOne
\textLengthOff
%% TODO: DotColumn is moved too much
<>^\markup { \with-color #red \fontsize #4 "!" }
<
gis'
a'
c''\pralla
e''\pralla
>4.
aes'8\prallb
}
{
a'4.\circA a'
}
\version "2.19.48"
%#(define (t->m t)
% "Return the current moment of translator object @var{t}."
% (ly:context-current-moment (ly:translator-context t)))
%% The following three definitions are soso down to ugly
%% They work with limited testings, but should be replaced/reworked.
#(define (replace-adjacent-duplicates lst rl)
"Takes a list of strings. Puts out a list where every adjactent duplicate is
transformed into an empty-string."
(if (null? lst)
(append-map
(lambda (l) (cons (car l) (make-list (length (cdr l)) "")))
(reverse rl))
;; split-at-predicate is not public and probably too expensive
(let ((splitted-list ((@@ (lily) split-at-predicate) string=? lst)))
(replace-adjacent-duplicates
(cdr splitted-list)
(cons (car splitted-list) rl)))))
#(define (moments-diff-list moments-list)
"Takes a list of moments. Puts out a list where the difference between each
moments is calculated via ly:moment-sub."
(remove
(lambda (mom) (equal? mom ZERO-MOMENT))
(reverse
(fold
(lambda (a b rl) (cons (ly:moment-sub b a) rl))
(list (car moments-list))
moments-list
(cdr moments-list)))))
#(define (moment->duration-string moment lst)
"Transforms a list of moments into strings representing a duration and then
suitable for make-note-markup."
(cond ((and (null? lst) (= (ly:moment-main-denominator moment) 1))
;; This is buggy and will not work for longer (dotted) notes
;; Too tired ...
(let* ((denom (ly:moment-main-denominator moment))
(num (ly:moment-main-numerator moment)))
(case num
((8) "maxima")
((4) "longa")
((2) "breve")
((1) "1")
(else
(cond ((and (> num 8) (= 4 (remainder num 8)))
"maxima.")
((and (> num 4) (= 2 (remainder num 4)))
"longa.")
((and (> num 2) (= 1 (remainder num 2)))
"breve.")
((and (> num 1) (= 0 (remainder num 1)))
"breve.")
(else
(begin
(ly:warning "not defined for moment ~a" moment)
"foo")))))))
((and (not (null? lst))
(equal? ZERO-MOMENT (car lst)))
(format #f "~a~a"
(cdar (remove ly:moment? lst))
(make-string (1- (length (remove ly:moment? lst))) #\.)))
(else
(let* ((denom (ly:moment-main-denominator moment))
(num (ly:moment-main-numerator moment)))
(if (= 1 denom num)
(format #f "1~a"
(make-string (length (remove ly:moment? lst)) #\.))
(let ((new-moment
(fraction->moment
(cons (floor (/ num 2)) (/ denom 2)))))
(moment->duration-string
new-moment
(append
(list new-moment (cons (remainder num 2) denom))
lst))))))))
%% The idea:
%% Assemble all moments where note-events start into a list.
%% Calculate the difference between each those moments. In order to get
%% durations as a duration-string for make-note-markup.
%% Replace every string in this list with "" if it is a duplicate.
%% Create TextScript-grobs at every note-event, but kill them if text is ""
%%
%% Will most likely not work for tuplets. Not tested, though.
Lute_tab_duration_engraver =
#(lambda (context)
(let ((m-n '())
(grobs '())
(ev '()))
(make-engraver
;((initialize translator)
; (format 1 "\n\n~16a: (initialize)\n" (t->m translator)))
;((start-translation-timestep translator)
; (format 1 "~16a: (start-translation-timestep)\n" (t->m translator)))
(listeners
((note-event engraver event)
;(format 1 "~16a: detected this note event: ~a\n "
; (t->m engraver) event)
(set! m-n (cons (ly:context-current-moment context) m-n))
(set! ev (cons event ev))))
;(acknowledgers
; ((note-head-interface engraver grob source-engraver)
; (format 1 "~16a: saw ~a coming from ~a\n"
; (t->m engraver) grob source-engraver)))
;(end-acknowledgers
; ((beam-interface engraver grob source-engraver)
; (format 1 "~16a: saw end of ~a coming from ~a\n"
; (t->m engraver) grob source-engraver)))
((process-music translator)
;(format 1 "~16a: (process-music)\n" (t->m translator))
(if (member (ly:context-current-moment context) m-n)
(let ((grob
(ly:engraver-make-grob translator 'TextScript (car ev))))
(set! grobs (cons grob grobs)))))
;((process-acknowledged translator)
; (format 1 "~16a: (process-acknowledged)\n" (t->m translator)))
((stop-translation-timestep translator)
; (format 1 "~16a: (stop-translation-timestep)\n" (t->m translator))
;; needs to be here, otherwise the moments are not completely collected
(let* ((moments-diffs
(moments-diff-list (reverse m-n)))
(moment-diff-strings
(map
(lambda (x)
(moment->duration-string x '()))
moments-diffs)))
(for-each
(lambda (g strg)
(if (string-null? strg)
(ly:grob-suicide! g)
(begin
(ly:grob-set-property! g 'direction UP)
(ly:grob-set-property! g 'text
(markup #:override '(style . mensural) #:note strg UP)))))
(reverse grobs)
(append
(replace-adjacent-duplicates moment-diff-strings '())
;; Urgh, not that nice to add this here, and it may be wrong :((
(list
(ly:duration->string (ly:event-property (car ev) 'duration)))))))
((finalize translator)
(set! ev '())
(set! grobs '())))))
%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%
%% first example
notes =
\relative c'' {
\time 3/4
\partial 4.
a8 r a |
<f d>4.
f8 <g e>4 |
\break
\time 4/4
c1 |
cis2 d4 ees8 e16 f32 fis64 g64 |
gis16 a16 bes8 c cis d ees e f |
fis g gis a bes b
c16..
cis64
d8
}
\score {
<<
\new Staff \new Voice \notes
\new TabStaff \new TabVoice \notes
\new TabStaff
<<
\new TabVoice \notes
\new TabVoice \repeat unfold 28 a8
>>
>>
\layout {
\context {
\TabStaff
\consists \Lute_tab_duration_engraver
% Use letters to indicate frets
tablatureFormat = #fret-letter-tablature-format
% Usual string tuning for 6-course Baroque lute
stringTunings = \stringTuning <a d' f' a' d'' f''>
% Choose a suitable font for fret letters
\override TabNoteHead.font-name = #"Fronimo Gavotta"
\override Flag.style = #'straight
\revert TextScript.stencil
}
\context {
\TabVoice
\consists "Fingering_engraver"
\consists "New_fingering_engraver"
\revert Slur.stencil
\textLengthOn
}
}
}
%% second example
m = {
\compressFullBarRests
c'\maxima \longa \breve 1 2 4 8 16 32
\maxima. \longa. \breve. 1. 2. 4. 8. 16. 32.
}
<<
\new MensuralVoice \m
\new TabStaff
\with { \consists \Lute_tab_duration_engraver \revert TextScript.stencil }
\new TabVoice \m
>>_______________________________________________
lilypond-devel mailing list
lilypond-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-devel
