X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=42af2ab3f4c2c0f857ebed6b4d60b2820e1868f8;hb=9e781b7dc83b60a543ce218aa1a5f139f74c760f;hp=ca4fac36a9628d518d6fbea36106f7722ebdf6b2;hpb=ef5c8e061ba49682c06cdfbd3816c971d6accba4;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index ca4fac36a9..42af2ab3f4 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2000--2012 Han-Wen Nienhuys +;;;; Copyright (C) 2000--2014 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -889,21 +889,11 @@ grestore " @cindex paths, drawing @cindex drawing paths -Draws a path with line thickness @var{thickness} according to the +Draws a path with line @var{thickness} according to the directions given in @var{commands}. @var{commands} is a list of lists where the @code{car} of each sublist is a drawing command and the @code{cdr} comprises the associated arguments for each command. -Line-cap styles and line-join styles may be customized by -overriding the @code{line-cap-style} and @code{line-join-style} -properties, respectively. Available line-cap styles are -@code{'butt}, @code{'round}, and @code{'square}. Available -line-join styles are @code{'miter}, @code{'round}, and -@code{'bevel}. - -The property @code{filled} specifies whether or not the path is -filled with color. - There are seven commands available to use in the list @code{commands}: @code{moveto}, @code{rmoveto}, @code{lineto}, @code{rlineto}, @code{curveto}, @code{rcurveto}, and @@ -926,6 +916,16 @@ current subpath in the active path. Note that a sequence of commands @emph{must} begin with a @code{moveto} or @code{rmoveto} to work with the SVG output. +Line-cap styles and line-join styles may be customized by +overriding the @code{line-cap-style} and @code{line-join-style} +properties, respectively. Available line-cap styles are +@code{'butt}, @code{'round}, and @code{'square}. Available +line-join styles are @code{'miter}, @code{'round}, and +@code{'bevel}. + +The property @code{filled} specifies whether or not the path is +filled with color. + @lilypond[verbatim,quote] samplePath = #'((moveto 0 0) @@ -937,6 +937,10 @@ samplePath = \\markup { \\path #0.25 #samplePath + + \\override #'(line-join-style . miter) \\path #0.25 #samplePath + + \\override #'(filled . #t) \\path #0.25 #samplePath } @end lilypond" (let* ((half-thickness (/ thickness 2)) @@ -1014,13 +1018,9 @@ samplePath = (define-markup-list-command (score-lines layout props score) (ly:score?) - " -This is the same as the @code{\\score} markup but delivers its -systems as a list of lines. This is not usually called directly by -the user. Instead, it is called when the parser encounters -@code{\\score} in a context where only markup lists are allowed. When -used as the argument of a toplevel @code{\\markuplist}, the result can -be split across pages." + "This is the same as the @code{\\score} markup but delivers its +systems as a list of lines. Its @var{score} argument is entered in +braces like it would be for @code{\\score}." (let ((output (ly:score-embedded-format score layout))) (if (ly:music-output? output) @@ -1369,69 +1369,93 @@ equivalent to @code{\"fi\"}. "Perform simple wordwrap, return stencil of each line." (define space (if justify ;; justify only stretches lines. - (* 0.7 base-space) - base-space)) - (define (stencil-space stencil line-start) - (if (ly:stencil-empty? stencil X) - 0 - (cdr (ly:stencil-extent - (ly:stencil-stack (if line-start - empty-stencil - point-stencil) - X RIGHT stencil) - X)))) - (define (take-list width space stencils - accumulator accumulated-width) - "Return (head-list . tail) pair, with head-list fitting into width" - (if (null? stencils) - (cons accumulator stencils) - (let* ((first (car stencils)) - (first-wid (stencil-space first (null? accumulator))) - (newwid (+ (if (or (ly:stencil-empty? first Y) - (ly:stencil-empty? first X)) - 0 space) - first-wid accumulated-width))) - (if (or (null? accumulator) - (< newwid width)) - (take-list width space - (cdr stencils) - (cons first accumulator) - newwid) - (cons accumulator stencils))))) - (let loop ((lines '()) - (todo stencils)) - (let* ((line-break (take-list line-width space todo - '() 0.0)) - (line-stencils (car line-break)) - (space-left (- line-width - (stencil-space - (stack-stencil-line 0 line-stencils) - #t))) - (line-words (count (lambda (s) (not (or (ly:stencil-empty? s Y) - (ly:stencil-empty? s X)))) - line-stencils)) - (line-word-space (cond ((not justify) space) - ;; don't stretch last line of paragraph. - ;; hmmm . bug - will overstretch the last line in some case. - ((null? (cdr line-break)) - base-space) - ((< line-words 2) space) - (else (/ space-left (1- line-words))))) - (line (stack-stencil-line line-word-space - (if (= text-dir RIGHT) - (reverse line-stencils) - line-stencils)))) - (if (pair? (cdr line-break)) - (loop (cons line lines) - (cdr line-break)) - (begin - (if (= text-dir LEFT) - (set! line - (ly:stencil-translate-axis - line - (- line-width (interval-end (ly:stencil-extent line X))) - X))) - (reverse (cons line lines))))))) + (* 0.7 base-space) + base-space)) + (define (stencil-len s) + (interval-end (ly:stencil-extent s X))) + (define (maybe-shift line) + (if (= text-dir LEFT) + (ly:stencil-translate-axis + line + (- line-width (stencil-len line)) + X) + line)) + (if (null? stencils) + '() + (let loop ((lines '()) + (todo stencils)) + (let word-loop + ((line (first todo)) + (todo (cdr todo)) + (word-list (list (first todo)))) + (cond + ((pair? todo) + (let ((new (if (= text-dir LEFT) + (ly:stencil-stack (car todo) X RIGHT line space) + (ly:stencil-stack line X RIGHT (car todo) space)))) + (cond + ((<= (stencil-len new) line-width) + (word-loop new (cdr todo) + (cons (car todo) word-list))) + (justify + (let* ((word-list + ;; This depends on stencil stacking being + ;; associative so that stacking + ;; left-to-right and right-to-left leads to + ;; the same result + (if (= text-dir LEFT) + word-list + (reverse! word-list))) + (len (stencil-len line)) + (stretch (- line-width len)) + (spaces + (- (stencil-len + (stack-stencils X RIGHT (1+ space) word-list)) + len))) + (if (zero? spaces) + ;; Uh oh, nothing to fill. + (loop (cons (maybe-shift line) lines) todo) + (loop (cons + (stack-stencils X RIGHT + (+ space (/ stretch spaces)) + word-list) + lines) + todo)))) + (else ;; not justify + (loop (cons (maybe-shift line) lines) todo))))) + ;; todo is null + (justify + ;; Now we have the last line assembled with space + ;; which is compressed. We want to use the + ;; uncompressed version instead if it fits, and the + ;; justified version if it doesn't. + (let* ((word-list + ;; This depends on stencil stacking being + ;; associative so that stacking + ;; left-to-right and right-to-left leads to + ;; the same result + (if (= text-dir LEFT) + word-list + (reverse! word-list))) + (big-line (stack-stencils X RIGHT base-space word-list)) + (big-len (stencil-len big-line)) + (len (stencil-len line))) + (reverse! lines + (list + (if (> big-len line-width) + (stack-stencils X RIGHT + (/ + (+ + (* (- big-len line-width) + space) + (* (- line-width len) + base-space)) + (- big-len len)) + word-list) + (maybe-shift big-line)))))) + (else ;; not justify + (reverse! lines (list (maybe-shift line))))))))) + (define-markup-list-command (wordwrap-internal layout props justify args) (boolean? markup-list?) @@ -3295,8 +3319,8 @@ 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. -Supported flag-styles are @code{default}, @code{old-straight-flag} and -@code{modern-straight-flag}. +Supported flag-styles are @code{default}, @code{old-straight-flag}, +@code{modern-straight-flag} and @code{flat-flag}. @lilypond[verbatim,quote] \\markup { @@ -3357,7 +3381,9 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and (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 (polar->rectangular flag-length angle)) + (flag-end (if (= angle 0) + (cons flag-length (* half-stem-thickness dir)) + (polar->rectangular flag-length angle))) (thickness (* flag-thickness factor)) (thickness-offset (cons 0 (* -1 thickness dir))) (spacing (* -1 flag-spacing factor dir)) @@ -3365,9 +3391,11 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and ;; The points of a round-filled-polygon need to be given in ;; clockwise order, otherwise the polygon will be enlarged by ;; blot-size*2! - (points (if stem-up (list start flag-end - (offset-add flag-end thickness-offset) - (offset-add start thickness-offset)) + (points (if stem-up + (list start + flag-end + (offset-add flag-end thickness-offset) + (offset-add start thickness-offset)) (list start (offset-add start thickness-offset) (offset-add flag-end thickness-offset) @@ -3432,10 +3460,12 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and ;; Straight-flags. Values taken from /scm/flag-style.scm (modern-straight-flag (straight-flag-mrkp 0.55 1 -18 1.1 22 1.2 dir)) (old-straight-flag (straight-flag-mrkp 0.55 1 -45 1.2 45 1.4 dir)) + (flat-flag (straight-flag-mrkp 0.55 1.0 0 1.0 0 1.0 dir)) ;; Calculate a corrective to avoid a gap between ;; straight-flags and the stem. (flag-style-Y-corr (if (or (eq? flag-style 'modern-straight-flag) - (eq? flag-style 'old-straight-flag)) + (eq? flag-style 'old-straight-flag) + (eq? flag-style 'flat-flag)) (/ blot 10 (* -1 dir)) 0)) (flaggl (and (> log 2) @@ -3444,6 +3474,8 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and modern-straight-flag) ((eq? flag-style 'old-straight-flag) old-straight-flag) + ((eq? flag-style 'flat-flag) + flat-flag) (else (ly:font-get-glyph font (format #f (if ancient-flags? @@ -3926,7 +3958,7 @@ Make a fraction of two markups. (define-markup-command (normal-size-super layout props arg) (markup?) #:category font - #:properties ((baseline-skip)) + #:properties ((font-size 0)) " @cindex setting superscript in standard font size @@ -3942,13 +3974,12 @@ Set @var{arg} in superscript with a normal font size. @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (* 0.5 baseline-skip) Y)) + (* 1.0 (magstep font-size)) Y)) (define-markup-command (super layout props arg) (markup?) #:category font - #:properties ((font-size 0) - (baseline-skip)) + #:properties ((font-size 0)) " @cindex superscript text @@ -3969,7 +4000,7 @@ Set @var{arg} in superscript. layout (cons `((font-size . ,(- font-size 3))) props) arg) - (* 0.5 baseline-skip) + (* 1.0 (magstep font-size)) ; original font-size Y)) (define-markup-command (translate layout props offset arg) @@ -3994,8 +4025,7 @@ is a pair of numbers representing the displacement in the X and Y axis. (define-markup-command (sub layout props arg) (markup?) #:category font - #:properties ((font-size 0) - (baseline-skip)) + #:properties ((font-size 0)) " @cindex subscript text @@ -4017,13 +4047,13 @@ Set @var{arg} in subscript. layout (cons `((font-size . ,(- font-size 3))) props) arg) - (* -0.5 baseline-skip) + (* -0.75 (magstep font-size)) ; original font-size Y)) (define-markup-command (normal-size-sub layout props arg) (markup?) #:category font - #:properties ((baseline-skip)) + #:properties ((font-size 0)) " @cindex setting subscript in standard font size @@ -4039,7 +4069,7 @@ Set @var{arg} in subscript with a normal font size. @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (* -0.5 baseline-skip) + (* -0.75 (magstep font-size)) Y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;