X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=5dbc5d2f5254b61bd4e3bd4c42b4143807501812;hb=3c6c00c08ff31f57ec8d88450b4e4e7917bc4f3e;hp=1d1c30cc6757ec94bdbffa28cf9d1a91dd841c97;hpb=32f5bf1a2255777c44aaf201843b17f3a3ef2131;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index 1d1c30cc67..5dbc5d2f52 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--2010 Han-Wen Nienhuys +;;;; Copyright (C) 2000--2011 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -45,27 +45,19 @@ ;;; using `chain-assoc-get' (more on that below) ;;; ;;; args... -;;; the command arguments. There are restrictions on the -;;; possible arguments for a markup command. -;;; First, arguments are distinguished according to their type: -;;; 1) a markup (or a string), corresponding to type predicate `markup?' -;;; 2) a list of markups, corresponding to type predicate `markup-list?' -;;; 3) any scheme object, corresponding to type predicates such as -;;; `list?', 'number?', 'boolean?', etc. -;;; The supported arrangements of arguments, according to their type, are: -;;; - no argument -;;; - markup -;;; - scheme -;;; - markup, markup -;;; - markup-list -;;; - scheme, scheme -;;; - scheme, markup -;;; - scheme, scheme, markup -;;; - scheme, scheme, markup, markup -;;; - scheme, markup, markup -;;; - scheme, scheme, scheme -;;; This combinations are hard-coded in the lexer and in the parser -;;; (lily/lexer.ll and lily/parser.yy) +;;; the command arguments. +;;; There is no limitation on the order of command arguments. +;;; However, markup functions taking a markup as their last +;;; argument are somewhat special as you can apply them to a +;;; markup list, and the result is a markup list where the +;;; markup function (with the specified leading arguments) has +;;; been applied to every element of the original markup list. +;;; +;;; Since replicating the leading arguments for applying a +;;; markup function to a markup list is cheap mostly for +;;; Scheme arguments, you avoid performance pitfalls by just +;;; using Scheme arguments for the leading arguments of markup +;;; functions that take a markup as their last argument. ;;; ;;; args-signature ;;; the arguments signature, i.e. a list of type predicates which @@ -277,30 +269,31 @@ Create a beam with the specified parameters. (define-markup-command (underline layout props arg) (markup?) #:category font - #:properties ((thickness 1)) + #:properties ((thickness 1) (offset 2)) " @cindex underlining text Underline @var{arg}. Looks at @code{thickness} to determine line -thickness and y-offset. +thickness, and @code{offset} to determine line y-offset. @lilypond[verbatim,quote] -\\markup { - default - \\hspace #2 - \\override #'(thickness . 2) - \\underline { - underline - } +\\markup \\fill-line { + \\underline \"underlined\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\underline \"underlined\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\underline \"underlined\" } @end lilypond" - (let* ((thick (* (ly:output-def-lookup layout 'line-thickness) - thickness)) + (let* ((thick (ly:output-def-lookup layout 'line-thickness)) + (underline-thick (* thickness thick)) (markup (interpret-markup layout props arg)) (x1 (car (ly:stencil-extent markup X))) (x2 (cdr (ly:stencil-extent markup X))) - (y (* thick -2)) - (line (make-line-stencil thick x1 y x2 y))) + (y (* thick (- offset))) + (line (make-line-stencil underline-thick x1 y x2 y))) (ly:stencil-add markup line))) (define-markup-command (box layout props arg) @@ -726,13 +719,13 @@ samplePath = ;; see `without-closepath'. (else x))) commands)) - ;; connected-shape-min-max does not accept 0-arg lists, + ;; path-min-max does not accept 0-arg lists, ;; and since closepath does not affect extents, filter ;; out those commands here. (without-closepath (filter (lambda (x) (not (equal? 'closepath (car x)))) new-commands)) - (extents (connected-shape-min-max + (extents (path-min-max ;; set the origin to the first moveto (list (list-ref (car without-closepath) 0) (list-ref (car without-closepath) 1)) @@ -884,14 +877,16 @@ Like simple-markup, but use tie characters for @q{~} tilde symbols. (make-simple-markup "")) ;; helper for justifying lines. -(define (get-fill-space word-count line-width text-widths) +(define (get-fill-space word-count line-width word-space text-widths) "Calculate the necessary paddings between each two adjacent texts. - The lengths of all texts are stored in @var{text-widths}. - The normal formula for the padding between texts a and b is: - padding = line-width/(word-count - 1) - (length(a) + length(b))/2 - The first and last padding have to be calculated specially using the - whole length of the first or last text. - Return a list of paddings." + The lengths of all texts are stored in @var{text-widths}. + The normal formula for the padding between texts a and b is: + padding = line-width/(word-count - 1) - (length(a) + length(b))/2 + The first and last padding have to be calculated specially using the + whole length of the first or last text. + All paddings are checked to be at least word-space, to ensure that + no texts collide. + Return a list of paddings." (cond ((null? text-widths) '()) @@ -900,23 +895,27 @@ Like simple-markup, but use tie characters for @q{~} tilde symbols. (cons (- (- (/ line-width (1- word-count)) (car text-widths)) (/ (car (cdr text-widths)) 2)) - (get-fill-space word-count line-width (cdr text-widths)))) + (get-fill-space word-count line-width word-space (cdr text-widths)))) ;; special case last padding ((= (length text-widths) 2) (list (- (/ line-width (1- word-count)) (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0)) (else - (cons - (- (/ line-width (1- word-count)) - (/ (+ (car text-widths) (car (cdr text-widths))) 2)) - (get-fill-space word-count line-width (cdr text-widths)))))) + (let ((default-padding + (- (/ line-width (1- word-count)) + (/ (+ (car text-widths) (car (cdr text-widths))) 2)))) + (cons + (if (> word-space default-padding) + word-space + default-padding) + (get-fill-space word-count line-width word-space (cdr text-widths))))))) (define-markup-command (fill-line layout props args) (markup-list?) #:category align #:properties ((text-direction RIGHT) - (word-space 1) - (line-width #f)) + (word-space 0.6) + (line-width #f)) "Put @var{markups} in a horizontal line of width @var{line-width}. The markups are spaced or flushed to fill the entire line. If there are no arguments, return an empty stencil. @@ -939,55 +938,58 @@ If there are no arguments, return an empty stencil. } @end lilypond" (let* ((orig-stencils (interpret-markup-list layout props args)) - (stencils - (map (lambda (stc) - (if (ly:stencil-empty? stc) - point-stencil - stc)) orig-stencils)) - (text-widths - (map (lambda (stc) - (if (ly:stencil-empty? stc) - 0.0 - (interval-length (ly:stencil-extent stc X)))) - stencils)) - (text-width (apply + text-widths)) - (word-count (length stencils)) - (line-width (or line-width (ly:output-def-lookup layout 'line-width))) - (fill-space - (cond - ((= word-count 1) - (list - (/ (- line-width text-width) 2) - (/ (- line-width text-width) 2))) - ((= word-count 2) - (list - (- line-width text-width))) - (else - (get-fill-space word-count line-width text-widths)))) - (fill-space-normal - (map (lambda (x) - (if (< x word-space) - word-space - x)) - fill-space)) - - (line-stencils (if (= word-count 1) - (list - point-stencil - (car stencils) - point-stencil) - stencils))) - - (if (= text-direction LEFT) - (set! line-stencils (reverse line-stencils))) + (stencils + (map (lambda (stc) + (if (ly:stencil-empty? stc) + point-stencil + stc)) orig-stencils)) + (text-widths + (map (lambda (stc) + (if (ly:stencil-empty? stc) + 0.0 + (interval-length (ly:stencil-extent stc X)))) + stencils)) + (text-width (apply + text-widths)) + (word-count (length stencils)) + (line-width (or line-width (ly:output-def-lookup layout 'line-width))) + (fill-space + (cond + ((= word-count 1) + (list + (/ (- line-width text-width) 2) + (/ (- line-width text-width) 2))) + ((= word-count 2) + (list + (- line-width text-width))) + (else + (get-fill-space word-count line-width word-space text-widths)))) + + (line-contents (if (= word-count 1) + (list + point-stencil + (car stencils) + point-stencil) + stencils))) (if (null? (remove ly:stencil-empty? orig-stencils)) - empty-stencil - (ly:stencil-translate-axis - (stack-stencils-padding-list X - RIGHT fill-space-normal line-stencils) - (- (car (ly:stencil-extent (car stencils) X))) - X)))) + empty-stencil + (begin + (if (= text-direction LEFT) + (set! line-contents (reverse line-contents))) + (set! line-contents + (stack-stencils-padding-list + X RIGHT fill-space line-contents)) + (if (> word-count 1) + ;; shift s.t. stencils align on the left edge, even if + ;; first stencil had negative X-extent (e.g. center-column) + ;; (if word-count = 1, X-extents are already normalized in + ;; the definition of line-contents) + (set! line-contents + (ly:stencil-translate-axis + line-contents + (- (car (ly:stencil-extent (car stencils) X))) + X))) + line-contents)))) (define-markup-command (line layout props args) (markup-list?) @@ -2377,6 +2379,32 @@ normal text font, no matter what font was used earlier. ;; symbols. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-markup-command (musicglyph layout props glyph-name) + (string?) + #: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 possible glyphs. + +@lilypond[verbatim,quote] +\\markup { + \\musicglyph #\"f\" + \\musicglyph #\"rests.2\" + \\musicglyph #\"clefs.G_change\" +} +@end lilypond" + (let* ((font (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic) + (font-name . #f)) + + props))) + (glyph (ly:font-get-glyph font glyph-name))) + (if (null? (ly:stencil-expr glyph)) + (ly:warning (_ "Cannot find glyph ~a") glyph-name)) + + glyph)) + (define-markup-command (doublesharp layout props) () #:category music @@ -2544,33 +2572,6 @@ Use the filled head if @var{filled} is specified. props)) name))) -(define-markup-command (musicglyph layout props glyph-name) - (string?) - #: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 possible glyphs. - -@lilypond[verbatim,quote] -\\markup { - \\musicglyph #\"f\" - \\musicglyph #\"rests.2\" - \\musicglyph #\"clefs.G_change\" -} -@end lilypond" - (let* ((font (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic) - (font-name . #f)) - - props))) - (glyph (ly:font-get-glyph font glyph-name))) - (if (null? (ly:stencil-expr glyph)) - (ly:warning (_ "Cannot find glyph ~a") glyph-name)) - - glyph)) - - (define-markup-command (lookup layout props glyph-name) (string?) #:category other @@ -2758,25 +2759,28 @@ figured bass notation. (slashed-digit-internal layout props num #f font-size thickness)) ;; eyeglasses -(define eyeglassesps - "0.15 setlinewidth - -0.9 0 translate - 1.1 1.1 scale - 1.2 0.7 moveto - 0.7 0.7 0.5 0 361 arc - stroke - 2.20 0.70 0.50 0 361 arc - stroke - 1.45 0.85 0.30 0 180 arc - stroke - 0.20 0.70 moveto - 0.80 2.00 lineto - 0.92 2.26 1.30 2.40 1.15 1.70 curveto - stroke - 2.70 0.70 moveto - 3.30 2.00 lineto - 3.42 2.26 3.80 2.40 3.65 1.70 curveto - stroke") +(define eyeglassespath + '((moveto 0.42 0.77) + (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55) + (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55) + (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55) + (rcurveto 0.304 0 0.55 0.246 0.55 0.55) + (closepath) + (moveto 2.07 0.77) + (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55) + (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55) + (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55) + (rcurveto 0.304 0 0.55 0.246 0.55 0.55) + (closepath) + (moveto 1.025 0.935) + (rcurveto 0 0.182 -0.148 0.33 -0.33 0.33) + (rcurveto -0.182 0 -0.33 -0.148 -0.33 -0.33) + (moveto -0.68 0.77) + (rlineto 0.66 1.43) + (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33) + (moveto 2.07 0.77) + (rlineto 0.66 1.43) + (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33))) (define-markup-command (eyeglasses layout props) () @@ -2786,8 +2790,8 @@ figured bass notation. \\markup { \\eyeglasses } @end lilypond" (interpret-markup layout props - (make-with-dimensions-markup '(-0.61 . 3.22) '(0.2 . 2.41) - (make-postscript-markup eyeglassesps)))) + (make-override-markup '(line-cap-style . butt) + (make-path-markup 0.15 eyeglassespath)))) (define-markup-command (left-brace layout props size) (number?) @@ -3362,6 +3366,36 @@ when @var{label} is not found." x-ext y-ext))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scaling +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (scale layout props factor-pair arg) + (number-pair? markup?) + #:category graphic + " +@cindex scaling markup +@cindex mirroring markup + +Scale @var{arg}. @var{factor-pair} is a pair of numbers +representing the scaling-factor in the X and Y axes. +Negative values may be used to produce mirror images. + +@lilypond[verbatim,quote] +\\markup { + \\line { + \\scale #'(2 . 1) + stretched + \\scale #'(1 . -1) + mirrored + } +} +@end lilypond" + (let ((stil (interpret-markup layout props arg)) + (sx (car factor-pair)) + (sy (cdr factor-pair))) + (ly:stencil-scale stil sx sy))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Markup list commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;