X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=3e7b2f2308f2e61d35282743328ded3e69d90a81;hb=HEAD;hp=e3d6cc581b6d50198f64a36a940f971a9456de29;hpb=eadbe19c831900eab4aec87c394d5ac8f2ee3bb5;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index e3d6cc581b..3e7b2f2308 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -306,6 +306,87 @@ line-length. new-props (markup #:draw-dashed-line dest)))) +(define-markup-command (draw-squiggle-line layout props sq-length dest eq-end?) + (number? number-pair? boolean?) + #:category graphic + #:properties ((thickness 0.5) + (angularity 0) + (height 0.5) + (orientation 1)) + " +@cindex drawing squiggled lines within text + +A squiggled line. + +If @code{eq-end?} is set to @code{#t}, it is ensured the squiggled line ends +with a bow in same direction as the starting one. @code{sq-length} is the +length of the first bow. @code{dest} is the end point of the squiggled line. +To match @code{dest} the squiggled line is scaled accordingly. +Its appearance may be customized by overrides for @code{thickness}, +@code{angularity}, @code{height} and @code{orientation}. +@lilypond[verbatim,quote] +\\markup + \\column { + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(orientation . -1) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\draw-squiggle-line #0.5 #'(6 . 0) ##f + \\override #'(height . 1) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(thickness . 5) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(angularity . 2) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + } +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + (thick (* thickness line-thickness)) + (x (car dest)) + (y (cdr dest)) + (length-to-print (magnitude (make-rectangular x y))) + ;; Make a guess how many bows may be needed + (guess (max 1 (truncate (/ length-to-print sq-length)))) + ;; If `eq-end?' is set #t, make sure squiggle-line starts and ends + ;; with a bow in same direction + (amount (if (and (even? guess) eq-end?) (1+ guess) guess)) + ;; The lined-up bows needs to fit `length-to-print' + ;; Thus scale the length of first bow accordingly + ;; Other bows are copies + (guessed-squiggle-line-length (* amount sq-length)) + (line-length-diff (- length-to-print guessed-squiggle-line-length)) + (line-length-diff-for-each-squiggle + (/ line-length-diff amount)) + (first-bow-length (+ sq-length line-length-diff-for-each-squiggle)) + ;; Get first bows + ;; TODO two bows are created via `make-bow-stencil' + ;; cheaper to use `ly:stencil-scale'? + (first-bow-end-coord + (cons + (/ (* first-bow-length x) length-to-print) + (/ (* first-bow-length y) length-to-print))) + (init-bow + (lambda (o) + (make-bow-stencil + '(0 . 0) + first-bow-end-coord + thick angularity height o))) + (init-bow-up (init-bow orientation)) + (init-bow-down (init-bow (- orientation))) + ;; Get a list of starting-points for the bows + (list-of-starts + (map + (lambda (n) + (cons + (* n (car first-bow-end-coord)) + (* n (cdr first-bow-end-coord)))) + (iota amount)))) + ;; The final stencil: lined-up bows + (apply ly:stencil-add + (map + ly:stencil-translate + (circular-list init-bow-up init-bow-down) + list-of-starts)))) + (define-markup-command (draw-hline layout props) () #:category graphic @@ -615,6 +696,95 @@ thickness, and @code{offset} to determine line y-offset. (line (make-line-stencil underline-thick x1 y x2 y))) (ly:stencil-add m line))) +(define-markup-command (tie layout props arg) + (markup?) + #:category font + #:properties ((thickness 1) + (offset 2) + (direction UP) + (shorten-pair '(0 . 0))) + " +@cindex tie-ing text + +Adds a horizontal bow created with @code{make-tie-stencil} at bottom or top +of @var{arg}. Looks at @code{thickness} to determine line thickness, and +@code{offset} to determine y-offset. The added bow fits the extent of +@var{arg}, @code{shorten-pair} may be used to modify this. +@var{direction} may be set using an @code{override} or direction-modifiers or +@code{voiceOne}, etc. + +@lilypond[verbatim,quote] +\\markup { + \\override #'(direction . 1) + \\tie \"above\" + \\override #'(direction . -1) + \\tie \"below\" +} +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + (thick (* thickness line-thickness)) + (stil (interpret-markup layout props arg)) + (x1 (car (ly:stencil-extent stil X))) + (x2 (cdr (ly:stencil-extent stil X))) + (y-ext (ly:stencil-extent stil Y)) + (y (+ (* line-thickness offset direction) + ;; we put out zero for positive text-direction, to make it + ;; consistent with `underline-markup' + ;; TODO: this will be problematic for args like "Eng" + ;; fix it here _and_ in `underline-markup' + (if (negative? direction) 0 (cdr y-ext)))) + (tie + (make-tie-stencil + (cons (+ x1 (car shorten-pair) line-thickness) y) + (cons (- x2 (cdr shorten-pair) line-thickness) y) + thick + direction))) + (ly:stencil-add stil tie))) + +(define-markup-command (undertie layout props arg) + (markup?) + #:category font + #:properties (tie-markup) + " +@cindex undertie-ing text + +@lilypond[verbatim,quote] +\\markup \\line { + \\undertie \"undertied\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\undertie \"undertied\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\undertie \"undertied\" +} +@end lilypond" + (interpret-markup layout (prepend-alist-chain 'direction DOWN props) + (make-tie-markup arg))) + +(define-markup-command (overtie layout props arg) + (markup?) + #:category font + #:properties (tie-markup) + " +@cindex overtie-ing text + +Overtie @var{arg}. + +@lilypond[verbatim,quote] +\\markup \\line { + \\overtie \"overtied\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\overtie \"overtied\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\overtie \"overtied\" +} +@end lilypond" + (interpret-markup layout (prepend-alist-chain 'direction UP props) + (make-tie-markup arg))) + (define-markup-command (box layout props arg) (markup?) #:category font @@ -729,8 +899,9 @@ Rotate object with @var{ang} degrees around its center. Provide a white background for @var{arg}. The shape of the white background is determined by @code{style}. The default -is @code{box} which produces a white rectangle. @code{outline} -approximates the outline of the markup. +is @code{box} which produces a rectangle. @code{rounded-box} +produces a rounded rectangle. @code{outline} approximates the +outline of the markup. @lilypond[verbatim,quote] \\markup { @@ -739,6 +910,13 @@ approximates the outline of the markup. \\override #'(thickness . 1.5) \\whiteout whiteout-box } +\\markup { + \\combine + \\filled-box #'(-1 . 24) #'(-3 . 4) #1 + \\override #'(style . rounded-box) + \\override #'(thickness . 3) + \\whiteout whiteout-rounded-box +} \\markup { \\combine \\filled-box #'(-1 . 18) #'(-3 . 4) #1 @@ -1417,16 +1595,11 @@ equivalent to @code{\"fi\"}. (cons arg result-list)))) '() arg-list)) - - (interpret-markup layout - (prepend-alist-chain 'word-space 0 props) - (make-line-markup - (make-override-lines-markup-list - (cons 'word-space - (chain-assoc-get 'word-space props)) - (if (markup-command-list? args) - args - (concat-string-args args)))))) + (stack-stencil-line 0 + (interpret-markup-list layout props + (if (markup-command-list? args) + args + (concat-string-args args))))) (define (wordwrap-stencils stencils justify base-space line-width text-dir) @@ -2073,6 +2246,24 @@ Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}." `(delay-stencil-evaluation ,(delay expr)) x y)))) +(define-markup-command (with-outline layout props outline arg) + (markup? markup?) + #:category other + " +Print @var{arg} with the outline and dimensions of @var{outline}." + (ly:stencil-outline (interpret-markup layout props arg) + (interpret-markup layout props outline))) + +(define-markup-command (with-dimensions-from layout props arg1 arg2) + (markup? markup?) + #:category other + " +Print @var{arg2} with the dimensions of @var{arg1}." + (let* ((stil1 (interpret-markup layout props arg1)) + (x (ly:stencil-extent stil1 0)) + (y (ly:stencil-extent stil1 1))) + (interpret-markup layout props (markup #:with-dimensions x y arg2)))) + (define-markup-command (pad-around layout props amount arg) (number? markup?) #:category align @@ -2145,10 +2336,7 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. } } @end lilypond" - (let* ((m (interpret-markup layout props arg)) - (x (ly:stencil-extent m X)) - (y (ly:stencil-extent m Y))) - (ly:make-stencil (list 'transparent-stencil (ly:stencil-expr m)) x y))) + (ly:stencil-outline empty-stencil (interpret-markup layout props arg))) (define-markup-command (pad-to-box layout props x-ext y-ext arg) (number-pair? number-pair? markup?) @@ -2449,6 +2637,7 @@ may be any property supported by @rinternals{font-interface}, (define-markup-command (abs-fontsize layout props size arg) (number? markup?) + #:properties ((word-space 0.6) (baseline-skip 3)) #:category font "Use @var{size} as the absolute font size (in points) to display @var{arg}. Adjusts @code{baseline-skip} and @code{word-space} accordingly. @@ -2464,14 +2653,12 @@ Adjusts @code{baseline-skip} and @code{word-space} accordingly. @end lilypond" (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12)) (text-props (list (ly:output-def-lookup layout 'text-font-defaults))) - (ref-word-space (chain-assoc-get 'word-space text-props 0.6)) - (ref-baseline (chain-assoc-get 'baseline-skip text-props 3)) (magnification (/ size ref-size))) (interpret-markup layout (cons - `((baseline-skip . ,(* magnification ref-baseline)) - (word-space . ,(* magnification ref-word-space)) + `((baseline-skip . ,(* magnification baseline-skip)) + (word-space . ,(* magnification word-space)) (font-size . ,(magnification->font-size magnification))) props) arg))) @@ -2914,7 +3101,7 @@ normal text font, no matter what font was used earlier. #:category music "@var{glyph-name} is converted to a musical symbol; for example, @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from -the music font. See @ruser{The Feta font} for a complete listing of +the music font. See @ruser{The Emmentaler font} for a complete listing of the possible glyphs. @lilypond[verbatim,quote] @@ -3446,9 +3633,12 @@ A feta brace in point size @var{size}, rotated 180 degrees. Construct a note symbol, with stem and flag. By using fractional values for @var{dir}, longer or shorter stems can be obtained. -Supports all note-head-styles. +Supports all note-head-styles. Ancient note-head-styles will get +mensural-style-flags. @code{flag-style} may be overridden independently. Supported flag-styles are @code{default}, @code{old-straight-flag}, -@code{modern-straight-flag} and @code{flat-flag}. +@code{modern-straight-flag}, @code{flat-flag}, @code{mensural} and +@code{neomensural}. The latter two flag-styles will both result in +mensural-flags. Both are supplied for convenience. @lilypond[verbatim,quote] \\markup { @@ -3459,7 +3649,8 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, @end lilypond" (define (get-glyph-name-candidates dir log style) (map (lambda (dir-name) - (format #f "noteheads.~a~a" dir-name + (format #f "noteheads.~a~a" + dir-name (if (and (symbol? style) (not (equal? 'default style))) (select-head-glyph style (min log 2)) @@ -3509,17 +3700,18 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, (raw-length (if stem-up upflag-length downflag-length)) (angle (if stem-up upflag-angle downflag-angle)) (flag-length (+ (* raw-length factor) half-stem-thickness)) - (flag-end (if (= angle 0) - (cons flag-length (* half-stem-thickness dir)) - (polar->rectangular flag-length angle))) + (flag-end (polar->rectangular flag-length angle)) (thickness (* flag-thickness factor)) (thickness-offset (cons 0 (* -1 thickness dir))) (spacing (* -1 flag-spacing factor dir)) (start (cons (- half-stem-thickness) (* half-stem-thickness dir))) - (points (list start - flag-end - (offset-add flag-end thickness-offset) - (offset-add start thickness-offset))) + (raw-points + (list + '(0 . 0) + flag-end + (offset-add flag-end thickness-offset) + thickness-offset)) + (points (map (lambda (coord) (offset-add coord start)) raw-points)) (stencil (ly:round-filled-polygon points half-stem-thickness)) ;; Log for 1/8 is 3, so we need to subtract 3 (flag-stencil (buildflags stencil (- log 3) stencil spacing))) @@ -3528,6 +3720,10 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic) (font-name . #f)) props))) + ;; default for text-font-size is 11 + ;; hence we use (/ text-font-size 11) later, to ensure proper scaling + ;; of stem-length and thickness + (text-font-size (ly:output-def-lookup layout 'text-font-size 11)) (size-factor (magstep font-size)) (blot (ly:output-def-lookup layout 'blot-diameter)) (head-glyph-name @@ -3545,12 +3741,15 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, (sign dir) log 'default)) result))) (head-glyph (ly:font-get-glyph font head-glyph-name)) - (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural))) + (ancient-flags? + (member style + '(mensural neomensural petrucci semipetrucci blackpetrucci))) (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) (stem-length (* size-factor (max 3 (- log 1)))) ;; With ancient-flags we want a tighter stem - (stem-thickness (* size-factor (if ancient-flags? 0.1 0.13))) - (stemy (* dir stem-length)) + (stem-thickness + (* size-factor (/ text-font-size 11) (if ancient-flags? 0.1 0.13))) + (stemy (* dir (/ text-font-size 11) stem-length)) (attach-off (cons (interval-index (ly:stencil-extent head-glyph X) (* (sign dir) (car attach-indices))) @@ -3561,7 +3760,10 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, (cdr attach-indices))))) ;; For a tighter stem (with ancient-flags) the stem-width has to be ;; adjusted. - (stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0)) + (stem-X-corr + (if (or ancient-flags? + (member flag-style '(mensural neomensural))) + (* 0.5 dir stem-thickness) 0)) (stem-glyph (and (> log 0) (ly:round-filled-box (ordered-cons (+ stem-X-corr (car attach-off)) @@ -3599,11 +3801,15 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, flat-flag) (else (ly:font-get-glyph font - (format #f (if ancient-flags? - "flags.mensural~a2~a" - "flags.~a~a") - (if (> dir 0) "u" "d") - log)))) + (format #f + (if (or (member flag-style + '(mensural neomensural)) + (and ancient-flags? + (null? flag-style))) + "flags.mensural~a2~a" + "flags.~a~a") + (if (> dir 0) "u" "d") + log)))) (cons (+ (car attach-off) ;; For tighter stems (with ancient-flags) the ;; flag has to be adjusted different. @@ -3611,7 +3817,6 @@ Supported flag-styles are @code{default}, @code{old-straight-flag}, stem-thickness 0)) (+ stemy flag-style-Y-corr)))))) - ;; If there is a flag on an upstem and the stem is short, move the dots ;; to avoid the flag. 16th notes get a special case because their flags ;; hang lower than any other flags. @@ -4246,6 +4451,7 @@ Draw vertical brackets around @var{arg}. (padding) (size 1) (thickness 1) + (line-thickness 0.1) (width 0.25)) " @cindex placing parentheses around text @@ -4276,12 +4482,11 @@ a column containing several lines of text. (let* ((m (interpret-markup layout props arg)) (scaled-width (* size width)) (scaled-thickness - (* (chain-assoc-get 'line-thickness props 0.1) - thickness)) + (* line-thickness thickness)) (half-thickness (min (* size 0.5 scaled-thickness) (* (/ 4 3.0) scaled-width))) - (padding (chain-assoc-get 'padding props half-thickness))) + (padding (or padding half-thickness))) (parenthesize-stencil m half-thickness scaled-width angularity padding))) @@ -4522,6 +4727,152 @@ where @var{X} is the number of staff spaces." "Like @code{\\override}, for markup lists." (interpret-markup-list layout (cons (list new-prop) props) args)) +(define-markup-list-command (table layout props column-align lst) + (number-list? markup-list?) + #:properties ((padding 0) + (baseline-skip)) + "@cindex creating a table. + +Returns a table. + +@var{column-align} specifies how each column is aligned, possible values are +-1, 0, 1. The number of elements in @var{column-align} determines how many +columns will be printed. +The entries to print are given by @var{lst}, a markup-list. If needed, the last +row is filled up with @code{point-stencil}s. +Overriding @code{padding} may be used to increase columns horizontal distance. +Overriding @code{baseline-skip} to increase rows vertical distance. +@lilypond[verbatim,quote] +\\markuplist { + \\override #'(padding . 2) + \\table + #'(0 1 0 -1) + { + \\underline { center-aligned right-aligned center-aligned left-aligned } + one \\number 1 thousandth \\number 0.001 + eleven \\number 11 hundredth \\number 0.01 + twenty \\number 20 tenth \\number 0.1 + thousand \\number 1000 one \\number 1.0 + } +} +@end lilypond +" + + (define (split-lst initial-lst lngth result-lst) + ;; split a list into a list of sublists of length lngth + ;; eg. (split-lst '(1 2 3 4 5 6) 2 '()) + ;; -> ((1 2) (3 4) (5 6)) + (cond ((not (integer? (/ (length initial-lst) lngth))) + (ly:warning + "Can't split list of length ~a into ~a parts, returning empty list" + (length initial-lst) lngth) + '()) + ((null? initial-lst) + (reverse result-lst)) + (else + (split-lst + (drop initial-lst lngth) + lngth + (cons (take initial-lst lngth) result-lst))))) + + (define (dists-list init padding lst) + ;; Returns a list, where each element of `lst' is + ;; added to the sum of the previous elements of `lst' plus padding. + ;; `init' will be the first element of the resulting list. The addition + ;; starts with the values of `init', `padding' and `(car lst)'. + ;; eg. (dists-list 0.01 0.1 '(1 2 3 4))) + ;; -> (0.01 1.11 3.21 6.31 10.41) + (if (or (not (number? init)) + (not (number? padding)) + (not (number-list? lst))) + (begin + (ly:warning + "not fitting argument for `dists-list', return empty lst ") + '()) + (reverse + (fold (lambda (elem rl) (cons (+ elem padding (car rl)) rl)) + (list init) + lst)))) + + (let* (;; get the number of columns + (columns (length column-align)) + (init-stils (interpret-markup-list layout props lst)) + ;; If the given markup-list is the result of a markup-list call, their + ;; length may not be easily predictable, thus we add point-stencils + ;; to fill last row of the table. + (rem (remainder (length init-stils) columns)) + (filled-stils + (if (zero? rem) + init-stils + (append init-stils (make-list (- columns rem) point-stencil)))) + ;; get the stencils in sublists of length `columns' + (stils + (split-lst filled-stils columns '())) + ;; procedure to return stencil-length + ;; If it is nan, return 0 + (lengths-proc + (lambda (m) + (let ((lngth (interval-length (ly:stencil-extent m X)))) + (if (nan? lngth) 0 lngth)))) + ;; get the max width of each column in a list + (columns-max-x-lengths + (map + (lambda (x) + (apply max 0 + (map + lengths-proc + (map (lambda (l) (list-ref l x)) stils)))) + (iota columns))) + ;; create a list of (basic) distances, which each column should + ;; moved, using `dists-list'. Some padding may be added. + (dist-sequence + (dists-list 0 padding columns-max-x-lengths)) + ;; Get all stencils of a row, moved accurately to build columns. + ;; If the items of a column are aligned other than left, we need to + ;; move them to avoid collisions: + ;; center aligned: move all items half the width of the widest item + ;; right aligned: move all items the full width of the widest item. + ;; Added to the default-offset calculated in `dist-sequence'. + ;; `stencils-for-row-proc' needs four arguments: + ;; stil - a stencil + ;; dist - a numerical value as basic offset in X direction + ;; column - a numerical value for the column we're in + ;; x-align - a numerical value how current column should be + ;; aligned, where (-1, 0, 1) means (LEFT, CENTER, RIGHT) + (stencils-for-row-proc + (lambda (stil dist column x-align) + (ly:stencil-translate-axis + (ly:stencil-aligned-to stil X x-align) + (cond ((member x-align '(0 1)) + (let* (;; get the stuff for relevant column + (stuff-for-column + (map + (lambda (s) (list-ref s column)) + stils)) + ;; get length of every column-item + (lengths-for-column + (map lengths-proc stuff-for-column)) + (widest + (apply max 0 lengths-for-column))) + (+ dist (/ widest (if (= x-align 0) 2 1))))) + (else dist)) + X))) + ;; get a list of rows using `ly:stencil-add' on a list of stencils + (rows + (map + (lambda (stil-list) + (apply ly:stencil-add + (map + ;; the procedure creating the stencils: + stencils-for-row-proc + ;; the procedure's args: + stil-list + dist-sequence + (iota columns) + column-align))) + stils))) + (space-lines baseline-skip rows))) + (define-markup-list-command (map-markup-commands layout props compose args) (procedure? markup-list?) "This applies the function @var{compose} to every markup in