X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=5d96ecb179be690a0930a48c51ec4dfb72cddc8e;hb=75edbfd3592781fdd66f51bedd1c7d1de4a51639;hp=a601bd02607929a074df878481b05fbd5de83db8;hpb=7eaeba29769613cb105e71ac40a71746d1601d90;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index a601bd0260..5d96ecb179 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -55,6 +55,7 @@ optionally filled." "Draw a circle around @var{arg}. Use @code{thickness}, @code{circle-padding} and @code{font-size} properties to determine line thickness and padding around the markup." + (let* ((th (chain-assoc-get 'thickness props 0.1)) (size (chain-assoc-get 'font-size props 0)) (pad @@ -126,17 +127,7 @@ circle of diameter 0 (ie sharp corners)." (define-markup-command (whiteout layout props arg) (markup?) "Provide a white underground for @var{arg}" - (let* ((stil (interpret-markup layout props arg)) - (white - (interpret-markup layout props - (make-with-color-markup - white - (make-filled-box-markup - (ly:stencil-extent stil X) - (ly:stencil-extent stil Y) - 0.0))))) - - (ly:stencil-add white stil))) + (stencil-whiteout (interpret-markup layout props arg))) (define-markup-command (pad-markup layout props padding arg) (number? markup?) "Add space around a markup object." @@ -239,9 +230,17 @@ gsave /ecrm10 findfont scalefont setfont 90 rotate (hello) show grestore @end verbatim " + ;; FIXME (ly:make-stencil - (list 'embedded-ps str) + (list 'embedded-ps + (format " +gsave currentpoint translate +0.1 setlinewidth + ~a +grestore +" + str)) '(0 . 0) '(0 . 0))) @@ -265,11 +264,34 @@ gsave /ecrm10 findfont ;; basic formatting. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-markup-command (simple layout props str) (string?) "A simple text string; @code{\\markup @{ foo @}} is equivalent with @code{\\markup @{ \\simple #\"foo\" @}}." (interpret-markup layout props str)) +(define-markup-command (tied-lyric layout props str) (string?) + + "Like simple-markup, but use tie characters for ~ tilde symbols." + + (if (string-contains str "~") + (let* + ((parts (string-split str #\~)) + (tie-str (ly:wide-char->utf-8 #x203f)) + (joined (list-join parts tie-str)) + (join-stencil (interpret-markup layout props tie-str)) + ) + + (interpret-markup layout + (prepend-alist-chain + 'word-space + (/ (interval-length (ly:stencil-extent join-stencil X)) -3.5) + props) + (make-line-markup joined))) + ;(map (lambda (s) (interpret-markup layout props s)) parts)) + (interpret-markup layout props str))) + ;; TODO: use font recoding. ;; (make-line-markup @@ -384,6 +406,28 @@ determines the space between each markup in @var{args}." space (remove ly:stencil-empty? stencils)))) +(define-markup-command (concat layout props args) (markup-list?) + "Concatenate @var{args} in a horizontal line, without spaces inbetween. +Strings and simple markups are concatenated on the input level, allowing +ligatures. For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is +equivalent to @code{\"fi\"}." + + (define (concat-string-args arg-list) + (fold-right (lambda (arg result-list) + (let ((result (if (pair? result-list) + (car result-list) + '()))) + (if (and (pair? arg) (eqv? (car arg) simple-markup)) + (set! arg (cadr arg))) + (if (and (string? result) (string? arg)) + (cons (string-append arg result) (cdr result-list)) + (cons arg result-list)))) + '() + arg-list)) + + (interpret-markup layout + (prepend-alist-chain 'word-space 0 props) + (make-line-markup (concat-string-args args)))) (define (wordwrap-stencils stencils justify base-space line-width text-dir) @@ -545,7 +589,7 @@ line-width, where X is the number of staff spaces." (ly:make-stencil '() '(1 . -1) '(1 . -1))))) (define-markup-command (justify-field layout props symbol) (symbol?) -- (let* ((m (chain-assoc-get symbol props))) + (let* ((m (chain-assoc-get symbol props))) (if (string? m) (interpret-markup layout props (list justify-string-markup m)) @@ -864,7 +908,7 @@ some punctuation. It doesn't have any letters. " "Set font size to -3." (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg)) -(define-markup-command (caps layout props arg) (markup?) +(define-markup-command (fontCaps layout props arg) (markup?) "Set @code{font-shape} to @code{caps}." (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg)) @@ -934,6 +978,9 @@ some punctuation. It doesn't have any letters. " #f #f))) +(define-markup-command (caps layout props arg) (markup?) + (interpret-markup layout props (make-smallCaps-markup arg))) + (define-markup-command (dynamic layout props arg) (markup?) "Use the dynamic font. This font only contains @b{s}, @b{f}, @b{m}, @b{z}, @b{p}, and @b{r}. When producing phrases, like ``pi@`{u} @b{f}'', the @@ -1155,6 +1202,7 @@ figured bass notation" (define-markup-command (note-by-number layout props log dot-count dir) (number? number? number?) "Construct a note symbol, with stem. By using fractional values for @var{dir}, you can obtain longer or shorter stems." + (define (get-glyph-name-candidates dir log style) (map (lambda (dir-name) (format "noteheads.~a~a~a" dir-name (min log 2) @@ -1176,22 +1224,22 @@ figured bass notation" (size-factor (magstep (chain-assoc-get 'font-size props 0))) (style (chain-assoc-get 'style props '())) (stem-length (* size-factor (max 3 (- log 1)))) - (head-glyph-name (get-glyph-name font (get-glyph-name-candidates dir log style))) + (head-glyph-name (get-glyph-name font (get-glyph-name-candidates (sign dir) log style))) (head-glyph (ly:font-get-glyph font head-glyph-name)) (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) (stem-thickness (* size-factor 0.13)) (stemy (* dir stem-length)) (attach-off (cons (interval-index (ly:stencil-extent head-glyph X) - (* dir (car attach-indices))) - (* dir ; fixme, this is inconsistent between X & Y. + (* (sign dir) (car attach-indices))) + (* (sign dir) ; fixme, this is inconsistent between X & Y. (interval-index (ly:stencil-extent head-glyph Y) (cdr attach-indices))))) (stem-glyph (and (> log 0) (ly:round-filled-box (ordered-cons (car attach-off) - (+ (car attach-off) (* (- dir) stem-thickness))) + (+ (car attach-off) (* (- (sign dir)) stem-thickness))) (cons (min stemy (cdr attach-off)) (max stemy (cdr attach-off))) (/ stem-thickness 3)))) @@ -1303,21 +1351,26 @@ and/or @code{extra-offset} properties. " (define-markup-command (fraction layout props arg1 arg2) (markup? markup?) "Make a fraction of two markups." (let* ((m1 (interpret-markup layout props arg1)) - (m2 (interpret-markup layout props arg2))) + (m2 (interpret-markup layout props arg2)) + (factor (magstep (chain-assoc-get 'font-size props 0))) + (boxdimen (cons (* factor -0.05) (* factor 0.05))) + (padding (* factor 0.2)) + (baseline (* factor 0.6)) + (offset (* factor 0.75))) (set! m1 (ly:stencil-aligned-to m1 X CENTER)) (set! m2 (ly:stencil-aligned-to m2 X CENTER)) (let* ((x1 (ly:stencil-extent m1 X)) (x2 (ly:stencil-extent m2 X)) - (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0)) + (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0)) ;; should stack mols separately, to maintain LINE on baseline - (stack (stack-lines -1 0.2 0.6 (list m1 line m2)))) + (stack (stack-lines DOWN padding baseline (list m1 line m2)))) (set! stack (ly:stencil-aligned-to stack Y CENTER)) (set! stack (ly:stencil-aligned-to stack X LEFT)) ;; should have EX dimension ;; empirical anyway - (ly:stencil-translate-axis stack 0.75 Y)))) + (ly:stencil-translate-axis stack offset Y))))