From ca91e9064f2920586a4fd610bda911ab3b4d8793 Mon Sep 17 00:00:00 2001 From: Nicolas Sceaux Date: Sun, 10 Jun 2007 15:47:24 +0200 Subject: [PATCH 1/1] Breakable markups with \markuplines. - \markuplines is a new keyword for entering text that is not interpreted as a single markup of several lines, but as several one-line markups. The parser is modified to allow this, and define-(builtin-)markup-list-command macros are defined. - texts are collected into books as list of props. When Paper_book::get_system_specs finds a list of more than one props (ie a markup list, a list of a single prop being the result of a toplevel \markup), it sets their next-space and next-padding properties to zero, so that the lines of a paragraph are not stretched on a page --- Documentation/topdocs/NEWS.tely | 6 ++ Documentation/user/advanced-notation.itely | 42 ++++++++++ .../user/programming-interface.itely | 51 ++++++++++++ input/regression/markup-lines.ly | 38 +++++++++ lily/book.cc | 2 +- lily/include/text-interface.hh | 1 + lily/lexer.ll | 26 +++++- lily/lily-lexer.cc | 1 + lily/paper-book.cc | 48 +++++++---- lily/parser.yy | 42 ++++++++++ lily/text-interface.cc | 8 ++ ly/markup-init.ly | 33 ++++++++ scm/define-markup-commands.scm | 78 +++++++++++++----- scm/document-markup.scm | 16 +++- scm/documentation-generate.scm | 4 + scm/markup.scm | 81 +++++++++++++++++-- 16 files changed, 427 insertions(+), 50 deletions(-) create mode 100644 input/regression/markup-lines.ly diff --git a/Documentation/topdocs/NEWS.tely b/Documentation/topdocs/NEWS.tely index d651126018..9a8a7a3591 100644 --- a/Documentation/topdocs/NEWS.tely +++ b/Documentation/topdocs/NEWS.tely @@ -65,6 +65,12 @@ which scares away people. @end ignore +@item +Text spreading over several pages is entered using the +@code{\markuplines} keyword. Builtin markup list commands, such as +@code{\justified-lines} or @code{\wordwrap-lines} may be used, and new +ones created using the @code{define-markup-list-command} Scheme macro. + @item Particular points of a book may be marked with the @code{\label} command. Then, the page where these points are placed can be refered to diff --git a/Documentation/user/advanced-notation.itely b/Documentation/user/advanced-notation.itely index 3a5e554c03..068600c3c9 100644 --- a/Documentation/user/advanced-notation.itely +++ b/Documentation/user/advanced-notation.itely @@ -46,7 +46,9 @@ saved as UTF-8. For more information, see @ref{Text encoding}. * Text marks:: * Text markup:: * Nested scores:: +* Page wrapping text:: * Overview of text markup commands:: +* Overview of text markup list commands:: * Font selection:: * New dynamic marks:: @end menu @@ -575,6 +577,40 @@ block. } @end lilypond +@node Page wrapping text +@subsection Page wrapping text +Whereas @code{\markup} is used to enter a not breakable block of text, +@code{\markuplines} can be used at top-level to enter lines of text that +can spread over pages: + +@verbatim +\markuplines { + \justified-lines { + A very long text of justified lines. + ... + } + \justified-lines { + An other very long paragraph. + ... + } + ... +} +@end verbatim + +@code{\markuplines} accepts a list of markup, that is either the result +of a markup list command, or a list of markups or of markup lists. The +built-in markup list commands are described in +@ref{Overview of text markup list commands}. + +@seealso + +This manual: @ref{Overview of text markup list commands}, +@ref{New markup list command definition}. + +@refcommands + +@funindex \markuplines +@code{\markuplines} @node Overview of text markup commands @subsection Overview of text markup commands @@ -583,6 +619,12 @@ The following commands can all be used inside @code{\markup @{ @}}. @include markup-commands.tely +@node Overview of text markup list commands +@subsection Overview of text markup list commands + +The following commands can all be used with @code{\markuplines}. + +@include markup-list-commands.tely @node Font selection @subsection Font selection diff --git a/Documentation/user/programming-interface.itely b/Documentation/user/programming-interface.itely index e55d26471b..2d5e442e15 100644 --- a/Documentation/user/programming-interface.itely +++ b/Documentation/user/programming-interface.itely @@ -847,6 +847,7 @@ Stencil object given a number of arguments. * Markup construction in Scheme:: * How markups work internally:: * New markup command definition:: +* New markup list command definition:: @end menu @@ -1114,6 +1115,56 @@ be used to set text in small caps. See @ref{Overview of text markup commands}, for details. +@node New markup list command definition +@subsection New markup list command definition +Markup list commands are defined with the +@code{define-markup-list-command} Scheme macro, which is similar to the +@code{define-markup-command} macro described in +@ref{New markup command definition}, except that where the later returns +a single stencil, the former returns a list stencils. + +In the following example, a @code{\paragraph} markup list command is +defined, which returns a list of justified lines, the first one being +indented. The indent width is taken from the @code{props} argument. +@example +#(define-markup-list-command (paragraph layout props args) (markup-list?) + (let ((indent (chain-assoc-get 'par-indent props 2))) + (interpret-markup-list layout props + (make-justified-lines-markup-list (cons (make-hspace-markup indent) + args))))) +@end example + +Besides the usual @code{layout} and @code{props} arguments, the +@code{paragraph} markup list command takes a markup list argument, named +@code{args}. The predicate for markup lists is @code{markup-list?}. + +First, the function gets the indent width, a property here named +@code{par-indent}, from the property list @code{props} If the property +is not found, the default value is @code{2}. Then, a list of justified +lines is made using the @code{make-justified-lines-markup-list} +function, which is related to the @code{\justified-lines} +built-in markup list command. An horizontal space is added at the +begining using the @code{make-hspace-markup} function. Finally, the +markup list is interpreted using the @code{interpret-markup-list} +function. + +This new markup list command can be used as follows: +@example +\markuplines @{ + \paragraph @{ + The art of music typography is called \italic @{(plate) engraving.@} + The term derives from the traditional process of music printing. + Just a few decades ago, sheet music was made by cutting and stamping + the music into a zinc or pewter plate in mirror image. + @} + \override-lines #'(par-indent . 4) \paragraph @{ + The plate would be inked, the depressions caused by the cutting + and stamping would hold ink. An image was formed by pressing paper + to the plate. The stamping and cutting was completely done by + hand. + @} +@} +@end example @node Contexts for programmers @section Contexts for programmers diff --git a/input/regression/markup-lines.ly b/input/regression/markup-lines.ly new file mode 100644 index 0000000000..752dcf3bcb --- /dev/null +++ b/input/regression/markup-lines.ly @@ -0,0 +1,38 @@ +\version "2.11.25" + +\header { + texidoc = "Text that can spread over pages is entered with the +@code{\\markuplines} command." +} + +#(set-default-paper-size "a6") + +#(define-markup-list-command (paragraph layout props args) (markup-list?) + (interpret-markup-list layout props + (make-justified-lines-markup-list (cons (make-hspace-markup 2) args)))) + +%% Candide, Voltaire +\markuplines \override-lines #'(baseline-skip . 2.5) { + \paragraph { + Il y avait en Westphalie, dans le château de M. le baron de + Thunder-ten-tronckh, un jeune garçon à qui la nature avait donné + les mœurs les plus douces. Sa physionomie annonçait son âme. + Il avait le jugement assez droit, avec l'esprit le plus simple ; + c'est, je crois, pour cette raison qu'on le nommait Candide. Les + anciens domestiques de la maison soupçonnaient qu'il était fils + de la sœur de monsieur le baron et d'un bon et honnête + gentilhomme du voisinage, que cette demoiselle ne voulut jamais + épouser parce qu'il n'avait pu prouver que soixante et onze + quartiers, et que le reste de son arbre généalogique avait été + perdu par l'injure du temps. + } + \paragraph { + Monsieur le baron était un des plus puissants seigneurs de la + Westphalie, car son château avait une porte et des fenêtres. Sa + grande salle même était ornée d'une tapisserie. Tous les chiens + de ses basses-cours composaient une meute dans le besoin ; ses + palefreniers étaient ses piqueurs; le vicaire du village était + son grand-aumônier. Ils l'appelaient tous monseigneur, et ils + riaient quand il faisait des contes. + } +} diff --git a/lily/book.cc b/lily/book.cc index 265632a365..2a1038941b 100644 --- a/lily/book.cc +++ b/lily/book.cc @@ -154,7 +154,7 @@ Book::process (Output_def *default_paper, outputs = scm_cdr (outputs); } } - else if (Text_interface::is_markup (scm_car (s)) + else if (Text_interface::is_markup_list (scm_car (s)) || unsmob_page_marker (scm_car (s))) paper_book->add_score (scm_car (s)); else diff --git a/lily/include/text-interface.hh b/lily/include/text-interface.hh index 3f8685b15e..4a0fdb7710 100644 --- a/lily/include/text-interface.hh +++ b/lily/include/text-interface.hh @@ -22,6 +22,7 @@ public: DECLARE_SCHEME_CALLBACK (interpret_string, (SCM, SCM, SCM)); DECLARE_GROB_INTERFACE(); static bool is_markup (SCM); + static bool is_markup_list (SCM); }; #endif /* TEXT_ITEM */ diff --git a/lily/lexer.ll b/lily/lexer.ll index ec17fb399e..71fb56b385 100644 --- a/lily/lexer.ll +++ b/lily/lexer.ll @@ -62,6 +62,7 @@ void strip_trailing_white (string&); void strip_leading_white (string&); string lyric_fudge (string s); SCM lookup_markup_command (string s); +SCM lookup_markup_list_command (string s); bool is_valid_version (string s); @@ -516,7 +517,7 @@ BOM_UTF8 \357\273\277 {MARKUPCOMMAND} { string str (YYText () + 1); SCM s = lookup_markup_command (str); - + SCM s2 = lookup_markup_list_command (str); if (scm_is_pair (s) && scm_is_symbol (scm_cdr (s)) ) { yylval.scm = scm_car(s); SCM tag = scm_cdr(s); @@ -545,6 +546,22 @@ BOM_UTF8 \357\273\277 ly_display_scm (s); assert(false); } + } else if (scm_is_pair (s2) && scm_is_symbol (scm_cdr (s2))) { + yylval.scm = scm_car(s2); + SCM tag = scm_cdr(s2); + if (tag == ly_symbol2scm("empty")) + return MARKUP_LIST_HEAD_EMPTY; + else if (tag == ly_symbol2scm ("markup-list0")) + return MARKUP_LIST_HEAD_LIST0; + else if (tag == ly_symbol2scm ("scheme0-markup-list1")) + return MARKUP_LIST_HEAD_SCM0_LIST1; + else if (tag == ly_symbol2scm ("scheme0-scheme1-markup-list2")) + return MARKUP_LIST_HEAD_SCM0_SCM1_LIST2; + else { + programming_error ("no parser tag defined for this markup signature"); + ly_display_scm (s); + assert(false); + } } else return scan_escaped_word (str); } @@ -946,6 +963,13 @@ lookup_markup_command (string s) return scm_call_1 (proc, ly_string2scm (s)); } +SCM +lookup_markup_list_command (string s) +{ + SCM proc = ly_lily_module_constant ("lookup-markup-list-command"); + return scm_call_1 (proc, ly_string2scm (s)); +} + /* Shut up lexer warnings. */ #if YY_STACK_USED diff --git a/lily/lily-lexer.cc b/lily/lily-lexer.cc index 4eaa441569..7b77d58922 100644 --- a/lily/lily-lexer.cc +++ b/lily/lily-lexer.cc @@ -53,6 +53,7 @@ static Keyword_ent the_key_tab[] {"lyricsto", LYRICSTO}, {"mark", MARK}, {"markup", MARKUP}, + {"markuplines", MARKUPLINES}, {"midi", MIDI}, {"name", NAME}, {"new", NEWCONTEXT}, diff --git a/lily/paper-book.cc b/lily/paper-book.cc index 84191b7da8..72648b682f 100644 --- a/lily/paper-book.cc +++ b/lily/paper-book.cc @@ -331,6 +331,7 @@ Paper_book::get_system_specs () = scm_call_1 (ly_lily_module_constant ("layout-extract-page-properties"), paper_->self_scm ()); + SCM interpret_markup_list = ly_lily_module_constant ("interpret-markup-list"); SCM header = SCM_EOL; for (SCM s = scm_reverse (scores_); scm_is_pair (s); s = scm_cdr (s)) { @@ -384,24 +385,37 @@ Paper_book::get_system_specs () */ } } - else if (Text_interface::is_markup (scm_car (s))) + else if (Text_interface::is_markup_list (scm_car (s))) { - SCM t = Text_interface::interpret_markup (paper_->self_scm (), - page_properties, - scm_car (s)); - - // TODO: init props - Prob *ps = make_paper_system (SCM_EOL); - ps->set_property ("page-break-permission", ly_symbol2scm ("allow")); - ps->set_property ("page-turn-permission", ly_symbol2scm ("allow")); - - paper_system_set_stencil (ps, *unsmob_stencil (t)); - ps->set_property ("is-title", SCM_BOOL_T); - system_specs = scm_cons (ps->self_scm (), system_specs); - ps->unprotect (); - - // FIXME: figure out penalty. - //set_system_penalty (ps, scores_[i].header_); + SCM texts = scm_call_3 (interpret_markup_list, + paper_->self_scm (), + page_properties, + scm_car (s)); + for (SCM list = texts ; scm_is_pair (list) ; list = scm_cdr (list)) + { + SCM t = scm_car (list); + // TODO: init props + Prob *ps = make_paper_system (SCM_EOL); + ps->set_property ("page-break-permission", ly_symbol2scm ("allow")); + ps->set_property ("page-turn-permission", ly_symbol2scm ("allow")); + + paper_system_set_stencil (ps, *unsmob_stencil (t)); + ps->set_property ("is-title", SCM_BOOL_T); + if (scm_is_pair (scm_cdr (list))) + { + /* If an other markup is following, set this markup + * next padding and next space to 0, so that baseline-skip + * only should be taken into account for lines vertical + * spacing. */ + ps->set_property ("next-padding", scm_double2num (0.0)); + ps->set_property ("next-space", scm_double2num (0.0)); + } + system_specs = scm_cons (ps->self_scm (), system_specs); + ps->unprotect (); + + // FIXME: figure out penalty. + //set_system_penalty (ps, scores_[i].header_); + } } else assert (0); diff --git a/lily/parser.yy b/lily/parser.yy index 18668dead0..7ded9b7377 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -182,6 +182,7 @@ void set_music_properties (Music *p, SCM a); %token LYRICSTO "\\lyricsto" %token MARK "\\mark" %token MARKUP "\\markup" +%token MARKUPLINES "\\markuplines" %token MIDI "\\midi" %token NAME "\\name" %token NOTEMODE "\\notemode" @@ -281,6 +282,10 @@ If we give names, Bison complains. %token MARKUP_HEAD_SCM0_SCM1_MARKUP2 %token MARKUP_HEAD_SCM0_MARKUP1_MARKUP2 %token MARKUP_HEAD_SCM0_SCM1_SCM2 +%token MARKUP_LIST_HEAD_EMPTY +%token MARKUP_LIST_HEAD_LIST0 +%token MARKUP_LIST_HEAD_SCM0_LIST1 +%token MARKUP_LIST_HEAD_SCM0_SCM1_LIST2 %token MARKUP_IDENTIFIER %token MUSIC_FUNCTION %token MUSIC_IDENTIFIER @@ -373,6 +378,7 @@ If we give names, Bison complains. %type figure_spec %type fraction %type full_markup +%type full_markup_list %type function_scm_argument %type function_arglist %type function_arglist_music_last @@ -387,6 +393,7 @@ If we give names, Bison complains. %type markup_braced_list %type markup_braced_list_body %type markup_composed_list +%type markup_command_list %type markup_head_1_item %type markup_head_1_list %type markup_list @@ -478,6 +485,10 @@ toplevel_expression: scm_call_2 (proc, PARSER->self_scm (), music->self_scm ()); } | full_markup { + SCM proc = PARSER->lexer_->lookup_identifier ("toplevel-text-handler"); + scm_call_2 (proc, PARSER->self_scm (), scm_list_1 ($1)); + } + | full_markup_list { SCM proc = PARSER->lexer_->lookup_identifier ("toplevel-text-handler"); scm_call_2 (proc, PARSER->self_scm (), $1); } @@ -663,6 +674,10 @@ book_body: scm_call_3 (proc, PARSER->self_scm (), $$->self_scm (), music->self_scm ()); } | book_body full_markup { + SCM proc = PARSER->lexer_->lookup_identifier ("book-text-handler"); + scm_call_2 (proc, $$->self_scm (), scm_list_1 ($2)); + } + | book_body full_markup_list { SCM proc = PARSER->lexer_->lookup_identifier ("book-text-handler"); scm_call_2 (proc, $$->self_scm (), $2); } @@ -2186,6 +2201,15 @@ lyric_markup: } ; +full_markup_list: + MARKUPLINES + { PARSER->lexer_->push_markup_state (); } + markup_list { + $$ = $3; + PARSER->lexer_->pop_state (); + } + ; + full_markup: MARKUP_IDENTIFIER { $$ = $1; @@ -2217,6 +2241,9 @@ markup_list: | markup_braced_list { $$ = $1; } + | markup_command_list { + $$ = scm_list_1 ($1); + } ; markup_composed_list: @@ -2242,6 +2269,21 @@ markup_braced_list_body: } ; +markup_command_list: + MARKUP_LIST_HEAD_EMPTY { + $$ = scm_list_1 ($1); + } + | MARKUP_LIST_HEAD_LIST0 markup_list { + $$ = scm_list_2 ($1, $2); + } + | MARKUP_LIST_HEAD_SCM0_LIST1 embedded_scm markup_list { + $$ = scm_list_3 ($1, $2, $3); + } + | MARKUP_LIST_HEAD_SCM0_SCM1_LIST2 embedded_scm embedded_scm markup_list { + $$ = scm_list_4 ($1, $2, $3, $4); + } + ; + markup_head_1_item: MARKUP_HEAD_MARKUP0 { $$ = scm_list_1 ($1); diff --git a/lily/text-interface.cc b/lily/text-interface.cc index 55e7bb7ec4..0c514a35d8 100644 --- a/lily/text-interface.cc +++ b/lily/text-interface.cc @@ -96,6 +96,14 @@ Text_interface::is_markup (SCM x) ly_symbol2scm ("markup-signature")))); } +bool +Text_interface::is_markup_list (SCM x) +{ + SCM music_list_p = ly_lily_module_constant ("markup-list?"); + return scm_is_true (scm_call_1 (music_list_p, x)); +} + + ADD_INTERFACE (Text_interface, "A scheme markup text, see @usermanref{Text markup} and " "@usermanref{New markup command definition}. " diff --git a/ly/markup-init.ly b/ly/markup-init.ly index c40bd88ad4..49c155c94e 100644 --- a/ly/markup-init.ly +++ b/ly/markup-init.ly @@ -85,3 +85,36 @@ or: ,(symbol->string make-markup-name) (list ,@signature) args)))))) + +#(defmacro-public define-markup-list-command (command-and-args signature . body) + "Same as `define-markup-command', but defines a command that, when interpreted, +returns a list of stencils, instead of a single one." + (let* ((command (if (pair? command-and-args) + (car command-and-args) + command-and-args)) + (command-name (string->symbol (format #f "~a-markup-list" command))) + (make-markup-name (string->symbol (format #f "make-~a-markup-list" command)))) + `(begin + ;; define the COMMAND-markup-list procedure in toplevel module + ,(if (pair? command-and-args) + ;; 1/ (define (COMMAND-markup-list layout props arg1 arg2 ...) + ;; ..command body)) + `(define-public-toplevel (,command-name ,@(cdr command-and-args)) + ,@body) + ;; 2/ (define (COMMAND-markup-list . args) (apply function args)) + (let ((args (gensym "args")) + (command (car body))) + `(define-public-toplevel (,command-name . ,args) + (apply ,command ,args)))) + (let ((command-proc (toplevel-module-ref ',command-name))) + ;; register its command signature + (set! (markup-command-signature command-proc) + (list ,@signature)) + ;; it's a markup-list command: + (set-object-property! command-proc 'markup-list-command #t) + ;; define the make-COMMAND-markup-list procedure in the toplevel module + (define-public-toplevel (,make-markup-name . args) + (list (make-markup command-proc + ,(symbol->string make-markup-name) + (list ,@signature) + args))))))) diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index d1f5dd04f8..a6773286c6 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -346,9 +346,7 @@ grestore The markups are spaced or flushed to fill the entire line. If there are no arguments, return an empty stencil." - (let* ((orig-stencils - (map (lambda (x) (interpret-markup layout props x)) - markups)) + (let* ((orig-stencils (interpret-markup-list layout props markups)) (stencils (map (lambda (stc) (if (ly:stencil-empty? stc) @@ -404,7 +402,7 @@ If there are no arguments, return an empty stencil." "Put @var{args} in a horizontal line. The property @code{word-space} determines the space between each markup in @var{args}." (let* - ((stencils (map (lambda (m) (interpret-markup layout props m)) args)) + ((stencils (interpret-markup-list layout props args)) (space (chain-assoc-get 'word-space props)) (text-dir (chain-assoc-get 'text-direction props RIGHT)) ) @@ -438,7 +436,9 @@ equivalent to @code{\"fi\"}." (interpret-markup layout (prepend-alist-chain 'word-space 0 props) - (make-line-markup (concat-string-args args)))) + (make-line-markup (if (markup-command-list? args) + args + (concat-string-args args))))) (define (wordwrap-stencils stencils justify base-space line-width text-dir) @@ -520,32 +520,28 @@ equivalent to @code{\"fi\"}." (define (wordwrap-markups layout props args justify) (let* - ((baseline-skip (chain-assoc-get 'baseline-skip props)) - (prop-line-width (chain-assoc-get 'line-width props #f)) + ((prop-line-width (chain-assoc-get 'line-width props #f)) (line-width (if prop-line-width prop-line-width (ly:output-def-lookup layout 'line-width))) (word-space (chain-assoc-get 'word-space props)) - (text-dir (chain-assoc-get 'text-direction props RIGHT)) - (lines (wordwrap-stencils - (remove ly:stencil-empty? - (map (lambda (m) (interpret-markup layout props m)) args)) - justify word-space line-width - text-dir) - )) - - (stack-lines DOWN 0.0 baseline-skip lines))) + (text-dir (chain-assoc-get 'text-direction props RIGHT))) + (wordwrap-stencils (remove ly:stencil-empty? + (interpret-markup-list layout props args)) + justify word-space line-width + text-dir))) (define-builtin-markup-command (justify layout props args) (markup-list?) "Like wordwrap, but with lines stretched to justify the margins. Use @code{\\override #'(line-width . @var{X})} to set the line width; @var{X}@tie{}is the number of staff spaces." - (wordwrap-markups layout props args #t)) + (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props) + (wordwrap-markups layout props args #t))) (define-builtin-markup-command (wordwrap layout props args) (markup-list?) "Simple wordwrap. Use @code{\\override #'(line-width . @var{X})} to set the line width, where @var{X} is the number of staff spaces." - - (wordwrap-markups layout props args #f)) + (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props) + (wordwrap-markups layout props args #f))) (define (wordwrap-string layout props justify arg) (let* @@ -623,7 +619,7 @@ the line width, where @var{X} is the number of staff spaces." @code{baseline-skip} determines the space between each markup in @var{args}." (let* - ((arg-stencils (map (lambda (m) (interpret-markup layout props m)) args)) + ((arg-stencils (interpret-markup-list layout props args)) (skip (chain-assoc-get 'baseline-skip props))) @@ -640,11 +636,11 @@ of the @code{#'direction} layout property." (if (number? dir) dir -1) 0.0 (chain-assoc-get 'baseline-skip props) - (map (lambda (x) (interpret-markup layout props x)) args)))) + (interpret-markup-list layout props args)))) (define-builtin-markup-command (center-align layout props args) (markup-list?) "Put @code{args} in a centered column." - (let* ((mols (map (lambda (x) (interpret-markup layout props x)) args)) + (let* ((mols (interpret-markup-list layout props args)) (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols))) (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols))) @@ -1490,3 +1486,41 @@ when @var{label} is not found." (markup #:concat (#:hspace gap page-markup))))))) x-ext y-ext))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Markup list commands +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (space-lines baseline-skip lines) + (map (lambda (line) + (stack-lines DOWN 0.0 (/ baseline-skip 2.0) + (list (ly:make-stencil "" (cons 0 0) (cons 0 0)) + line + (ly:make-stencil "" (cons 0 0) (cons 0 0))))) + lines)) + +(define-builtin-markup-list-command (justified-lines layout props args) (markup-list?) + "Like @code{\\justify}, but return a list of lines instead of a single markup. +Use @code{\\override #'(line-width . @var{X})} to set the line width; +@var{X}@tie{}is the number of staff spaces." + (space-lines (chain-assoc-get 'baseline-skip props) + (wordwrap-markups layout props args #t))) + +(define-builtin-markup-list-command (wordwrap-lines layout props args) (markup-list?) + "Like @code{\\wordwrap}, but return a list of lines instead of a single markup. +Use @code{\\override #'(line-width . @var{X})} to set the line width, +where @var{X} is the number of staff spaces." + (space-lines (chain-assoc-get 'baseline-skip props) + (wordwrap-markups layout props args #f))) + +(define-builtin-markup-list-command (column-lines layout props args) (markup-list?) + "Like @code{\\column}, but return a list of lines instead of a single markup. +@code{baseline-skip} determines the space between each markup in @var{args}." + (space-lines (chain-assoc-get 'baseline-skip props) + (interpret-markup-list layout props args))) + +(define-builtin-markup-list-command (override-lines layout props new-prop args) + (pair? markup-list?) + "Like @code{\\override}, for markup lists." + (interpret-markup-list layout (cons (list new-prop) props) args)) diff --git a/scm/document-markup.scm b/scm/document-markup.scm index 27d1229dde..4396ea4d38 100644 --- a/scm/document-markup.scm +++ b/scm/document-markup.scm @@ -8,7 +8,7 @@ (define (doc-markup-function func) (let* ((doc-str (procedure-documentation func)) (f-name (symbol->string (procedure-name func))) - (c-name (regexp-substitute/global #f "-markup$" f-name 'pre "" 'post)) + (c-name (regexp-substitute/global #f "-markup(-list)?$" f-name 'pre "" 'post)) (sig (object-property func 'markup-signature)) (arg-names (let ((arg-list (cadr (procedure-source func)))) (if (list? arg-list) @@ -45,8 +45,22 @@ (sort markup-function-list markup-function #:name "Markup functions" #:desc "Definitions of the markup functions." #:text (markup-doc-string))) + +(define (markup-list-doc-node) + (make + #:name "Markup list functions" + #:desc "Definitions of the markup list functions." + #:text (markup-list-doc-string))) diff --git a/scm/documentation-generate.scm b/scm/documentation-generate.scm index 9c9e7acf03..fe37a366ba 100644 --- a/scm/documentation-generate.scm +++ b/scm/documentation-generate.scm @@ -34,6 +34,10 @@ (markup-doc-string) (open-output-file "markup-commands.tely")) +(display + (markup-list-doc-string) + (open-output-file "markup-list-commands.tely")) + (display (identifiers-doc-string) (open-output-file "identifiers.tely")) diff --git a/scm/markup.scm b/scm/markup.scm index f1d0863ff7..70baeaa54d 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -80,6 +80,36 @@ Syntax: (let ((sig (list ,@signature))) (make-markup ,command-name ,(symbol->string make-markup-name) sig args)))))) +(define-macro (define-builtin-markup-list-command command-and-args signature . body) + "Same as `define-builtin-markup-command, but defines a command that, when +interpreted, returns a list of stencils instead os a single one" + (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args)) + (args (if (pair? command-and-args) (cdr command-and-args) '())) + (command-name (string->symbol (format #f "~a-markup-list" command))) + (make-markup-name (string->symbol (format #f "make-~a-markup-list" command)))) + `(begin + ;; define the COMMAND-markup-list function + ,(if (pair? args) + `(define-public (,command-name ,@args) + ,@body) + (let ((args (gensym "args")) + (markup-command (car body))) + `(define-public (,command-name . ,args) + ,(format #f "Copy of the ~a command." markup-command) + (apply ,markup-command ,args)))) + (set! (markup-command-signature ,command-name) (list ,@signature)) + ;; add the command to markup-list-function-list, for markup documentation + (if (not (member ,command-name markup-list-function-list)) + (set! markup-list-function-list (cons ,command-name + markup-list-function-list))) + ;; it's a markup-list command: + (set-object-property! ,command-name 'markup-list-command #t) + ;; define the make-COMMAND-markup-list function + (define-public (,make-markup-name . args) + (let ((sig (list ,@signature))) + (list (make-markup ,command-name + ,(symbol->string make-markup-name) sig args))))))) + (define-public (make-markup markup-function make-name signature args) " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck against SIGNATURE, reporting MAKE-NAME as the user-invoked function. @@ -261,6 +291,7 @@ Use `markup*' in a \\notemode context." ;; For documentation purposes (define-public markup-function-list (list)) +(define-public markup-list-function-list (list)) (define-public (markup-signature-to-keyword sig) " (A B C) -> a0-b1-c2 " @@ -282,14 +313,24 @@ Use `markup*' in a \\notemode context." sig) "-")))) -(define-public (lookup-markup-command code) +(define (lookup-markup-command-aux symbol) (let ((proc (catch 'misc-error (lambda () - (module-ref (current-module) - (string->symbol (format #f "~a-markup" code)))) + (module-ref (current-module) symbol)) (lambda (key . args) #f)))) - (and (procedure? proc) - (cons proc (markup-command-keyword proc))))) + (and (procedure? proc) proc))) + +(define-public (lookup-markup-command code) + (let ((proc (lookup-markup-command-aux + (string->symbol (format #f "~a-markup" code))))) + (and proc (markup-function? proc) + (cons proc (markup-command-keyword proc))))) + +(define-public (lookup-markup-list-command code) + (let ((proc (lookup-markup-command-aux + (string->symbol (format #f "~a-markup-list" code))))) + (and proc (markup-list-function? proc) + (cons proc (markup-command-keyword proc))))) ;;;;;;;;;;;;;;;;;;;;;; ;;; used in parser.yy to map a list of markup commands on markup arguments @@ -313,13 +354,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: ;;; markup type predicates (define (markup-function? x) - (not (not (markup-command-signature x)))) + (and (markup-command-signature x) + (not (object-property x 'markup-list-command)))) + +(define (markup-list-function? x) + (and (markup-command-signature x) + (object-property x 'markup-list-command))) + +(define-public (markup-command-list? x) + "Determine if `x' is a markup command list, ie. a list composed of +a markup list function and its arguments." + (and (pair? x) (markup-list-function? (car x)))) (define-public (markup-list? arg) + "Return a true value if `x' is a list of markups or markup command lists." (define (markup-list-inner? lst) (or (null? lst) - (and (markup? (car lst)) (markup-list-inner? (cdr lst))))) - (and (list? arg) (markup-list-inner? arg))) + (and (or (markup? (car lst)) (markup-command-list? (car lst))) + (markup-list-inner? (cdr lst))))) + (not (not (and (list? arg) (markup-list-inner? arg))))) (define (markup-argument-list? signature arguments) "Typecheck argument list." @@ -391,6 +444,18 @@ Uncovered - cheap-markup? is used." (define-public interpret-markup ly:text-interface::interpret-markup) + +(define-public (interpret-markup-list layout props markup-list) + (let ((stencils (list))) + (for-each (lambda (m) + (set! stencils + (if (markup-command-list? m) + (append! (reverse! (apply (car m) layout props (cdr m))) + stencils) + (cons (interpret-markup layout props m) stencils)))) + markup-list) + (reverse! stencils))) + (define-public (prepend-alist-chain key val chain) (cons (acons key val (car chain)) (cdr chain))) -- 2.39.2