+2005-03-30 Jan Nieuwenhuizen <janneke@gnu.org>
+
+ * scm/markup.scm:
+ * input/regression/markup-scheme.ly:
+ * input/regression/markup-syntax.ly: Drop 'new-' from name.
+
+ * scm/stencil.scm (make-circle-stencil): New function.
+
+ * scm/define-markup-commands.scm (draw-circle): Use it. New
+ name (was cicle). Update callers.
+ (circle): New markup command, similar to box.
+
+ * scm/stencil.scm (circle-stencil): New function.
+
2005-03-29 David Jedlinsky <lilypond@ipnh.com>
* configure.in: Detect libutf8/wchar.h variant.
BUG HUNTERS/SUGGESTIONS
-Jose Miguel Pasini
Alexandre Beneteau
Andreas Scherer
Anthony W. Youngman
Fernando Pablo Lopez-Lezcano
Jack O'Quin
Johannes Schindelin
+Jose Miguel Pasini
Juergen Reuter
Karl Hammar
Laura Conrad
Paul Scott
Richard Schoeller
+Roman Stöckl-Schmidt
Tapio Tuovila
Will Oram
Wolfgang Hoffmann
--- /dev/null
+
+\header {
+
+ texidoc = "There is a Scheme macro @code{markup} to produce markup
+ texts using a similar syntax as @code{\\markup}.
+
+"
+
+ }
+\version "2.5.2"
+\score {
+ {
+ \fatText
+ f'1-\markup {
+ foo
+ \raise #0.2 \hbracket \bold bar
+ \override #'(baseline-skip . 4)
+
+ \bracket \column { baz bazr bla }
+ \hspace #2.0
+ \override #'(font-encoding . fetaMusic) {
+ \lookup #"noteheads-0"
+ }
+ \musicglyph #"accidentals.-1"
+ \combine "X" "+"
+ \combine "o" "/"
+ \box \column { \line { "string 1" } \line { "string 2" } }
+ "$\\emptyset$"
+ \italic Norsk
+ \super "2"
+ \dynamic sfzp
+ \huge { "A" \smaller "A" \smaller \smaller "A"
+ \smaller \smaller \smaller "A" }
+ \sub "alike"
+ }
+ \break
+ f'1-#(markup*
+ "foo"
+ #:raise 0.2 #:hbracket #:bold "bar"
+ #:override '(baseline-skip . 4)
+ #:bracket #:column ( "baz" "bazr" "bla" )
+ #:hspace 2.0
+ #:override '(font-encoding . fetaMusic) #:line (#:lookup "noteheads-0"
+ )
+ #:musicglyph "accidentals.-1"
+ #:combine "X" "+"
+ #:combine "o" "/"
+ #:box #:column ("string 1" "string 2")
+ "$\\emptyset$"
+ #:draw-circle 1 0.3
+ " "
+ #:italic "Norsk"
+ #:super "2"
+ #:circle #:dynamic "p"
+ " "
+ #:dynamic "sfzp"
+ #:huge #:line ("A" #:smaller "A" #:smaller #:smaller "A"
+ #:smaller #:smaller #:smaller "A")
+ #:sub "alike")
+ }
+ \layout {
+ raggedright = ##t
+ indent = #0
+ \context {
+ \Staff
+ \remove Time_signature_engraver
+ }
+ }
+}
--- /dev/null
+\header {
+texidoc = "With the new markup syntax, text may be written in various manners."
+}
+
+\version "2.5.2"
+
+
+\score {
+
+ {
+ f'-\markup {
+ foo
+ \raise #0.2 \hbracket \bold bar
+ \override #'(baseline-skip . 4)
+
+ \bracket \column { baz bazr bla }
+ \hspace #2.0
+ \override #'(font-encoding . fetaMusic) {
+ \lookup #"noteheads-0"
+ }
+ \semiflat
+
+ { }
+
+ \combine "X" "+"
+ \combine "o" "/"
+% \char-number #"abc1234abc"
+ \box \column { \line { "string 1" } \line { "string 2" } }
+ "$\\emptyset$"
+ \draw-circle #1 #0.3
+ " "
+ \italic Norsk
+ \super "2"
+ " "
+ \circle \dynamic p
+ \dynamic sfzp
+ \huge { "A" \smaller "A" \smaller \smaller "A"
+ \smaller \smaller \smaller "A" }
+ \sub "alike"
+ }
+ c''4
+ }
+}
+++ /dev/null
-
-\header {
-
- texidoc = "There is a Scheme macro @code{markup} to produce markup
- texts using a similar syntax as @code{\\markup}.
-
-"
-
- }
-\version "2.5.2"
-\score {
- {
- \fatText
- f'1-\markup {
- foo
- \raise #0.2 \hbracket \bold bar
- \override #'(baseline-skip . 4)
-
- \bracket \column { baz bazr bla }
- \hspace #2.0
- \override #'(font-encoding . fetaMusic) {
- \lookup #"noteheads-0"
- }
- \musicglyph #"accidentals.-1"
- \combine "X" "+"
- \combine "o" "/"
- \box \column { \line { "string 1" } \line { "string 2" } }
- "$\\emptyset$"
- \italic Norsk
- \super "2"
- \dynamic sfzp
- \huge { "A" \smaller "A" \smaller \smaller "A"
- \smaller \smaller \smaller "A" }
- \sub "alike"
- }
- \break
- f'1-#(markup*
- "foo"
- #:raise 0.2 #:hbracket #:bold "bar"
- #:override '(baseline-skip . 4)
- #:bracket #:column ( "baz" "bazr" "bla" )
- #:hspace 2.0
- #:override '(font-encoding . fetaMusic) #:line (#:lookup "noteheads-0"
- )
- #:musicglyph "accidentals.-1"
- #:combine "X" "+"
- #:combine "o" "/"
- #:box #:column ("string 1" "string 2")
- "$\\emptyset$"
- #:italic "Norsk"
- #:super "2"
- #:dynamic "sfzp"
- #:huge #:line ("A" #:smaller "A" #:smaller #:smaller "A"
- #:smaller #:smaller #:smaller "A")
- #:sub "alike")
- }
- \layout {
- raggedright = ##t
- indent = #0
- \context {
- \Staff
- \remove Time_signature_engraver
- }
- }
-}
+++ /dev/null
-\header {
-texidoc = "With the new markup syntax, text may be written in various manners."
-}
-
-\version "2.5.2"
-
-
-\score {
-
- {
- f'-\markup {
- foo
- \raise #0.2 \hbracket \bold bar
- \override #'(baseline-skip . 4)
-
- \bracket \column { baz bazr bla }
- \hspace #2.0
- \override #'(font-encoding . fetaMusic) {
- \lookup #"noteheads-0"
- }
- \semiflat
-
- { }
-
- \combine "X" "+"
- \combine "o" "/"
-% \char-number #"abc1234abc"
- \box \column { \line { "string 1" } \line { "string 2" } }
- "$\\emptyset$"
- \circle #4 #0.2
- \italic Norsk
- \super "2"
- \dynamic sfzp
- \huge { "A" \smaller "A" \smaller \smaller "A"
- \smaller \smaller \smaller "A" }
- \sub "alike"
- }
- c''4
- }
-}
msgstr ""
"Project-Id-Version: PACKAGE VERSION\n"
"Report-Msgid-Bugs-To: \n"
-"POT-Creation-Date: 2005-03-29 14:04+0200\n"
+"POT-Creation-Date: 2005-03-30 10:33+0200\n"
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
"Language-Team: LANGUAGE <LL@li.org>\n"
msgid "Or save as UTF-8 in your editor"
msgstr ""
-#: convert-ly.py:2462
+#: convert-ly.py:2476
msgid "Applying conversion: "
msgstr ""
-#: convert-ly.py:2474
+#: convert-ly.py:2488
#, python-format
msgid "%s: error while converting"
msgstr ""
-#: convert-ly.py:2477 score-engraver.cc:111
+#: convert-ly.py:2491 score-engraver.cc:111
msgid "Aborting"
msgstr ""
-#: convert-ly.py:2498
+#: convert-ly.py:2512
#, python-format
msgid "Processing `%s'... "
msgstr ""
-#: convert-ly.py:2600
+#: convert-ly.py:2614
#, python-format
msgid "%s: cannot determine version for `%s'"
msgstr ""
-#: convert-ly.py:2609
+#: convert-ly.py:2623
#, python-format
msgid "%s: skipping: `%s'"
msgstr ""
msgid "`~a' failed (~a)"
msgstr ""
-#: backend-library.scm:44 framework-tex.scm:366
+#: backend-library.scm:44 framework-tex.scm:340 framework-tex.scm:367
#, lisp-format
msgid "Converting to `~a'..."
msgstr ""
msgid "See scm/lily.scm for supported clefs"
msgstr ""
-#: framework-tex.scm:339
-#, lisp-format
-msgid "Converting to `~a'...n"
+#: define-markup-commands.scm:54
+msgid "No systems found in \\score markup. Does it have a \\layout? block"
msgstr ""
-#: framework-tex.scm:358
+#: framework-tex.scm:359
#, lisp-format
msgid "TeX file name must not contain whitespace: `~a'"
msgstr ""
msgid "wrong type for argument ~a. Expecting ~a, found ~s"
msgstr ""
-#: lily.scm:316
+#: lily.scm:317
msgid "error: failed files: "
msgstr ""
msgid "See scm/lily.scm for supported clefs"
msgstr ""
-# lisp-format
-#: framework-tex.scm:339
-#, fuzzy, lisp-format
-msgid "Converting to `~a'...n"
-msgstr "Converteren naar ~a..."
-
#: framework-tex.scm:358
-#, fuzzy, lisp-format
+#, lisp-format
msgid "TeX file name must not contain whitespace: `~a'"
-msgstr "bestandsnaam mag geen spaties bevatten: `%s'"
+msgstr "TeX bestandsnaam mag geen spaties bevatten: `~a'"
#: lily-library.scm:346
-#, fuzzy, lisp-format
+#, lisp-format
msgid "No \\version statement found. Add~afor future compatibility."
msgstr ""
"Geen \\version uitdrukking gevonden. Voeg~atoe voor toekomstige "
;;; * each markup function should have a doc string with
;; syntax, description and example.
+(use-modules (ice-9 regex))
+
(define-public empty-stencil (ly:make-stencil '() '(1 . -1) '(1 . -1)))
(define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
"Stencil as markup"
stil)
-(def-markup-command (circle layout props radius thickness)
+(def-markup-command (draw-circle layout props radius thickness)
(number? number?)
"A circle of radius @var{radius} and thickness @var{thickness}"
+ (make-circle-stencil radius thickness))
- (ly:make-stencil
- (list 'circle radius thickness)
- (cons (- radius) radius)
- (cons (- radius) radius)))
+(def-markup-command (circle layout props arg) (markup?)
+ "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
+ (* (magstep size)
+ (chain-assoc-get 'circle-padding props 0.2)))
+ (m (interpret-markup layout props arg)))
+ (circle-stencil m th pad)))
(def-markup-command (with-url layout props url arg) (string? markup?)
"Add a link to URL @var{url} around @var{arg}. This only works in
the PDF backend."
- (let*
- ((stil (interpret-markup layout props arg))
- (xextent (ly:stencil-extent stil X))
- (yextent (ly:stencil-extent stil Y))
- (old-expr (ly:stencil-expr stil))
- (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
-
- (ly:stencil-add
- (ly:make-stencil url-expr xextent yextent)
- stil)))
+ (let* ((stil (interpret-markup layout props arg))
+ (xextent (ly:stencil-extent stil X))
+ (yextent (ly:stencil-extent stil Y))
+ (old-expr (ly:stencil-expr stil))
+ (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
+ (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
(def-markup-command (score layout props score) (ly:score?)
"Inline an image of music."
(if (= 0 (vector-length systems))
(begin
- (ly:warn "No systems found in \\score markup. Did you forget \\layout?")
+ (ly:warn (_"No systems found in \\score markup. Does it have a \\layout? block"))
empty-markup)
(let* ((stencil (ly:paper-system-stencil (vector-ref systems 0))))
- (ly:stencil-aligned-to stencil Y CENTER)
- ))))
+ (ly:stencil-aligned-to stencil Y CENTER)))))
(def-markup-command (simple layout props str) (string?)
"A simple text string; @code{\\markup @{ foo @}} is equivalent with
(def-markup-command (encoded-simple layout props sym str) (symbol? string?)
"A text string, encoded with encoding @var{sym}. See
@usermanref{Text encoding} for more information."
- (Text_interface::interpret_string layout
- props sym str))
+ (Text_interface::interpret_string layout props sym str))
;; TODO: use font recoding.
(stack-stencils-padding-list X RIGHT fill-space-normal line-stencils))))
(define (get-fill-space word-count line-width text-widths)
- "Calculates the necessary paddings between each two adjacent texts.
+ "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.
- Returns a list of paddings.
+ Return a list of paddings.
"
(cond
- ;; special case first padding
- ((= (length text-widths) word-count)
- (cons
- (- (- (/ line-width (1- word-count)) (car text-widths)) (/ (car (cdr text-widths)) 2))
- (get-fill-space word-count line-width (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))))))
+ ;; special case first padding
+ ((= (length text-widths) word-count)
+ (cons
+ (- (- (/ line-width (1- word-count)) (car text-widths))
+ (/ (car (cdr text-widths)) 2))
+ (get-fill-space word-count line-width (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))))))
(define (font-markup qualifier value)
(lambda (layout props arg)
- (interpret-markup layout
- (prepend-alist-chain qualifier value props)
- arg)))
-
+ (interpret-markup layout (prepend-alist-chain qualifier value props) arg)))
(def-markup-command (line layout props args) (markup-list?)
"Put @var{args} in a horizontal line. The property @code{word-space}
arg))
(def-markup-command (fontsize layout props mag arg) (number? markup?)
- "This sets the relative font size, e.g.
+ "Set the relative font size, e.g.
@example
A \\fontsize #2 @{ B C @} D
@end example
arg))
(def-markup-command (magnify layout props sz arg) (number? markup?)
- "This sets the font magnification for the its argument. In the following
+ "Set the font magnification for the its argument. In the following
example, the middle A will be 10% larger:
@example
A \\magnify #1.1 @{ A @} A
(def-markup-command (vcenter layout props arg) (markup?)
"Align @code{arg} to its Y center. "
(let* ((mol (interpret-markup layout props arg)))
- (ly:stencil-aligned-to mol Y CENTER)
- ))
+ (ly:stencil-aligned-to mol Y CENTER)))
(def-markup-command (hcenter layout props arg) (markup?)
"Align @code{arg} to its X center. "
(if (ly:stencil? dots)
(set! stem-glyph
(ly:stencil-add
- (ly:stencil-translate-axis dots
- (+ (if (and (> dir 0) (> log 2))
- (* 1.5 dotwid)
- 0)
- ;; huh ? why not necessary?
- ;;(cdr (ly:stencil-extent head-glyph X))
- dotwid)
- X)
+ (ly:stencil-translate-axis
+ dots
+ (+ (if (and (> dir 0) (> log 2))
+ (* 1.5 dotwid)
+ 0)
+ ;; huh ? why not necessary?
+ ;;(cdr (ly:stencil-extent head-glyph X))
+ dotwid)
+ X)
stem-glyph)))
stem-glyph))
-(use-modules (ice-9 regex))
-
(define-public log2
(let ((divisor (log 2)))
(lambda (z) (inexact->exact (/ (log z) divisor)))))
(if (and match (string=? duration-string (match:substring match 0)))
(let ((len (match:substring match 1))
(dots (match:substring match 2)))
- (list (cond ((string=? len "breve") -1)
- ((string=? len "longa") -2)
+ (list (cond ((string=? len "breve") -1)
+ ((string=? len "longa") -2)
((string=? len "maxima") -3)
(else (log2 (string->number len))))
(if dots (string-length dots) 0)))
(def-markup-command (normal-size-super layout props arg) (markup?)
"Set @var{arg} in superscript with a normal font size."
- (ly:stencil-translate-axis (interpret-markup
- layout
- props arg)
- (* 0.5 (chain-assoc-get 'baseline-skip props))
- Y))
+ (ly:stencil-translate-axis
+ (interpret-markup layout props arg)
+ (* 0.5 (chain-assoc-get 'baseline-skip props)) Y))
(def-markup-command (super layout props arg) (markup?)
"
(* -0.5 (chain-assoc-get 'baseline-skip props))
Y))
-(def-markup-command (beam layout props width slope thickness) (number? number? number?)
+(def-markup-command (beam layout props width slope thickness)
+ (number? number? number?)
"Create a beam with the specified parameters."
+ (let* ((y (* slope width))
+ (yext (cons (min 0 y) (max 0 y)))
+ (half (/ thickness 2)))
- (let*
- ((y (* slope width))
- (yext (cons (min 0 y) (max 0 y)))
- (half (/ thickness 2)))
-
(ly:make-stencil
(list 'beam width
slope
(ly:output-def-lookup layout 'blotdiameter))
(cons 0 width)
(cons (+ (- half) (car yext))
- (+ half (cdr yext))))
-
- ))
-
+ (+ half (cdr yext))))))
(def-markup-command (normal-size-sub layout props arg) (markup?)
"Set @var{arg} in subscript, in a normal font size."
thickness and padding around the markup."
(let* ((th (chain-assoc-get 'thickness props 0.1))
(size (chain-assoc-get 'font-size props 0))
- (pad
- (* (magstep size)
- (chain-assoc-get 'box-padding props 0.2)))
+ (pad (* (magstep size)
+ (chain-assoc-get 'box-padding props 0.2)))
(m (interpret-markup layout props arg)))
(box-stencil m th pad)))
(if (access? ps-name W_OK)
(delete-file ps-name))
(if (not (ly:get-option 'verbose))
- (format (current-error-port)
- (_ "Converting to `~a'...\n")
- (string-append base ".dvi")))
+ (begin
+ (format (current-error-port)
+ (_ "Converting to `~a'...") (string-append base ".dvi"))
+ (newline (current-error-port))))
(ly:system cmd)))
(define-public (convert-to-dvi book name)
round-filled-box
text
url-link
+ utf8-string
white-dot
white-text
embedded-ps
"chord-entry.scm"
"chord-generic-names.scm"
"stencil.scm"
- "new-markup.scm"
+ "markup.scm"
"bass-figure.scm"
"music-functions.scm"
"part-combiner.scm"
--- /dev/null
+;;;; markup.scm -- Implement a user extensible markup scheme.
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+"
+Internally markup is stored as lists, whose head is a function.
+
+ (FUNCTION ARG1 ARG2 ... )
+
+When the markup is formatted, then FUNCTION is called as follows
+
+ (FUNCTION GROB PROPS ARG1 ARG2 ... )
+
+GROB is the current grob, PROPS is a list of alists, and ARG1.. are
+the rest of the arguments.
+
+The function should return a stencil (i.e. a formatted, ready to
+print object).
+
+
+To add a function, use the def-markup-command utility.
+
+ (def-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
+ \"my command usage and description\"
+ ...function body...)
+
+The command is now available in markup mode, e.g.
+
+
+ \\markup { .... \\MYCOMMAND #1 argument ... }
+
+" ; "
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup definer utilities
+;;; `def-markup-command' can be used both for built-in markup
+;;; definitions and user defined markups.
+
+(defmacro-public def-markup-command (command-and-args signature . body)
+ "
+
+* Define a COMMAND-markup function after command-and-args and body,
+register COMMAND-markup and its signature,
+
+* add COMMAND-markup to markup-function-list,
+
+* sets COMMAND-markup markup-signature and markup-keyword object properties,
+
+* define a make-COMMAND-markup function.
+
+Syntax:
+ (def-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ \"documentation string\"
+ ...command body...)
+ or:
+ (def-markup-command COMMAND (arg1-type? arg2-type? ...)
+ function)
+"
+ (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 (string-append (symbol->string command) "-markup")))
+ (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
+ `(begin
+ (define-public ,(if (pair? args)
+ (cons command-name args)
+ command-name)
+ ,@body)
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ (if (not (member ,command-name markup-function-list))
+ (set! markup-function-list (cons ,command-name markup-function-list)))
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (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.
+"
+ (let* ((arglen (length args))
+ (siglen (length signature))
+ (error-msg (if (and (> siglen 0) (> arglen 0))
+ (markup-argument-list-error signature args 1)
+ #f)))
+ (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
+ (scm-error 'markup-format make-name
+ "Expect ~A arguments for ~A. Found ~A: ~S"
+ (list siglen make-name arglen args)
+ #f))
+ (if error-msg
+ (scm-error 'markup-format make-name
+ "Invalid argument in position ~A\nExpect: ~A\nFound: ~S."
+ error-msg #f)
+ (cons markup-function args))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup constructors
+;;; lilypond-like syntax for markup construction in scheme.
+
+(use-modules (ice-9 optargs)
+ (ice-9 receive))
+
+(defmacro*-public markup (#:rest body)
+ "The `markup' macro provides a lilypond-like syntax for building markups.
+
+ - #:COMMAND is used instead of \\COMMAND
+ - #:lines ( ... ) is used instead of { ... }
+ - #:center-align ( ... ) is used instead of \\center-align < ... >
+ - etc.
+
+Example:
+ \\markup { foo
+ \\raise #0.2 \\hbracket \\bold bar
+ \\override #'(baseline-skip . 4)
+ \\bracket \\column < baz bazr bla >
+ }
+ <==>
+ (markup \"foo\"
+ #:raise 0.2 #:hbracket #:bold \"bar\"
+ #:override '(baseline-skip . 4)
+ #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
+Use `markup*' in a \\notes block."
+
+ (car (compile-all-markup-expressions `(#:line ,body))))
+
+(defmacro*-public markup* (#:rest body)
+ "Same as `markup', for use in a \\notes block."
+ `(ly:export (markup ,@body)))
+
+
+(define (compile-all-markup-expressions expr)
+ "Return a list of canonical markups expressions, e.g.:
+ (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
+ ===>
+ ((make-COMMAND1-markup arg11 arg12)
+ (make-COMMAND2-markup arg21 arg22 arg23) ...)"
+ (do ((rest expr rest)
+ (markps '() markps))
+ ((null? rest) (reverse markps))
+ (receive (m r) (compile-markup-expression rest)
+ (set! markps (cons m markps))
+ (set! rest r))))
+
+(define (keyword->make-markup key)
+ "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
+ (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
+
+(define (compile-markup-expression expr)
+ "Return two values: the first complete canonical markup expression found in `expr',
+e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
+ (cond ((and (pair? expr)
+ (keyword? (car expr)))
+ ;; expr === (#:COMMAND arg1 ...)
+ (let* ((command (symbol->string (keyword->symbol (car expr))))
+ (sig (markup-command-signature (car (lookup-markup-command command))))
+ (sig-len (length sig)))
+ (do ((i 0 (1+ i))
+ (args '() args)
+ (rest (cdr expr) rest))
+ ((>= i sig-len)
+ (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
+ (cond ((eqv? (list-ref sig i) markup-list?)
+ ;; (car rest) is a markup list
+ (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
+ (set! rest (cdr rest)))
+ (else
+ ;; pick up one arg in `rest'
+ (receive (a r) (compile-markup-arg rest)
+ (set! args (cons a args))
+ (set! rest r)))))))
+ ((and (pair? expr)
+ (pair? (car expr))
+ (keyword? (caar expr)))
+ ;; expr === ((#:COMMAND arg1 ...) ...)
+ (receive (m r) (compile-markup-expression (car expr))
+ (values m (cdr expr))))
+ ((and (pair? expr)
+ (string? (car expr))) ;; expr === ("string" ...)
+ (values `(make-simple-markup ,(car expr)) (cdr expr)))
+ (else
+ ;; expr === (symbol ...) or ((funcall ...) ...)
+ (values (car expr)
+ (cdr expr)))))
+
+(define (compile-all-markup-args expr)
+ "Transform `expr' into markup arguments"
+ (do ((rest expr rest)
+ (args '() args))
+ ((null? rest) (reverse args))
+ (receive (a r) (compile-markup-arg rest)
+ (set! args (cons a args))
+ (set! rest r))))
+
+(define (compile-markup-arg expr)
+ "Return two values: the desired markup argument, and the rest arguments"
+ (cond ((null? expr)
+ ;; no more args
+ (values '() '()))
+ ((keyword? (car expr))
+ ;; expr === (#:COMMAND ...)
+ ;; ==> build and return the whole markup expression
+ (compile-markup-expression expr))
+ ((and (pair? (car expr))
+ (keyword? (caar expr)))
+ ;; expr === ((#:COMMAND ...) ...)
+ ;; ==> build and return the whole markup expression(s)
+ ;; found in (car expr)
+ (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
+ (if (null? rest-expr)
+ (values markup-expr (cdr expr))
+ (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
+ (cdr expr)))))
+ ((and (pair? (car expr))
+ (pair? (caar expr)))
+ ;; expr === (((foo ...) ...) ...)
+ (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
+ (else (values (car expr) (cdr expr)))))
+
+;;;;;;;;;;;;;;;
+;;; Debugging utilities: print markup expressions in a friendly fashion
+
+(use-modules (ice-9 format))
+(define (markup->string markup-expr)
+ "Return a string describing, in LilyPond syntax, the given markup expression."
+ (define (proc->command proc)
+ (let ((cmd-markup (symbol->string (procedure-name proc))))
+ (substring cmd-markup 0 (- (string-length cmd-markup)
+ (string-length "-markup")))))
+ (define (arg->string arg)
+ (cond ((and (pair? arg) (pair? (car arg))) ;; markup list
+ (format #f "~{ ~a~}" (map markup->string arg)))
+ ((pair? arg) ;; markup
+ (markup->string arg))
+ ((string? arg) ;; scheme string argument
+ (format #f "#\"~a\"" arg))
+ (else ;; other scheme arg
+ (format #f "#~a" arg))))
+ (let ((cmd (car markup-expr))
+ (args (cdr markup-expr)))
+ (cond ((eqv? cmd simple-markup) ;; a simple string
+ (format #f "\"~a\"" (car args)))
+ ((eqv? cmd line-markup) ;; { ... }
+ (format #f "{~a}" (arg->string (car args))))
+ ((eqv? cmd center-align-markup) ;; \center < ... >
+ (format #f "\\center-align <~a>" (arg->string (car args))))
+ ((eqv? cmd column-markup) ;; \column < ... >
+ (format #f "\\column <~a>" (arg->string (car args))))
+ (else ;; \command ...
+ (format #f "\\~a~{ ~a~} " (proc->command cmd) (map arg->string args))))))
+
+(define-public (display-markup markup-expr)
+ "Print a LilyPond-syntax equivalent for the given markup expression."
+ (display "\\markup ")
+ (display (markup->string markup-expr)))
+
+;;;;;;;;;;;;;;;
+;;; Utilities for storing and accessing markup commands signature
+;;; and keyword.
+;;; Examples:
+;;;
+;;; (set! (markup-command-signature raise-markup) (list number? markup?))
+;;; ==> ((#<primitive-procedure number?> #<procedure markup? (obj)>) . scheme0-markup1)
+;;;
+;;; (markup-command-signature raise-markup)
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
+;;;
+;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
+;;;
+
+(define markup-command-signatures (make-hash-table 50))
+
+(define (markup-command-signature-ref markup-command)
+ "Return markup-command's signature, e.g. (number? markup?).
+markup-command may be a procedure."
+ (let ((sig-key (hashq-ref markup-command-signatures
+ markup-command)))
+ (if sig-key (car sig-key) #f)))
+
+(define-public (markup-command-keyword markup-command)
+ "Return markup-command's keyword, e.g. \"scheme0markup1\".
+markup-command may be a procedure."
+ (let ((sig-key (hashq-ref markup-command-signatures
+ markup-command)))
+ (if sig-key (cdr sig-key) #f)))
+
+(define (markup-command-signatureset! markup-command signature)
+ "Set markup-command's signature. markup-command must be a named procedure.
+Also set markup-signature and markup-keyword object properties."
+ (hashq-set! markup-command-signatures
+ markup-command
+ (cons signature (markup-signature-to-keyword signature)))
+ ;; these object properties are still in use somewhere
+ (set-object-property! markup-command 'markup-signature signature)
+ (set-object-property! markup-command 'markup-keyword (markup-signature-to-keyword signature)))
+
+(define-public markup-command-signature
+ (make-procedure-with-setter markup-command-signature-ref markup-command-signatureset!))
+
+(define (markup-symbol-to-proc markup-sym)
+ "Return the markup command procedure which name is `markup-sym', if any."
+ (hash-fold (lambda (key val prev)
+ (or prev
+ (if (eqv? (procedure-name key) markup-sym) key #f)))
+ #f
+ markup-command-signatures))
+
+(define-public markup-function-list '())
+
+(define-public (markup-signature-to-keyword sig)
+ " (A B C) -> a0-b1-c2 "
+ (if (null? sig)
+ 'empty
+ (string->symbol (string-join (map
+ (let* ((count 0))
+ (lambda (func)
+ (set! count (+ count 1))
+ (string-append
+ ;; for reasons I don't get,
+ ;; (case func ((markup?) .. )
+ ;; doesn't work.
+ (cond
+ ((eq? func markup?) "markup")
+ ((eq? func markup-list?) "markup-list")
+ (else "scheme"))
+ (number->string (- count 1)))))
+ sig)
+ "-"))))
+
+(define-public (lookup-markup-command code)
+ (let ((proc (markup-symbol-to-proc (string->symbol (string-append code "-markup")))))
+ (and proc (cons proc (markup-command-keyword proc)))))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; used in parser.yy to map a list of markup commands on markup arguments
+(define-public (map-markup-command-list commands markups)
+ "`markups' being a list of markups, eg (markup1 markup2 markup3),
+and `commands' a list of commands with their scheme arguments, in reverse order,
+eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
+ ((bold (raise 4 (italic markup1)))
+ (bold (raise 4 (italic markup2)))
+ (bold (raise 4 (italic markup3))))
+"
+ (map-in-order (lambda (arg)
+ (let ((result arg))
+ (for-each (lambda (cmd)
+ (set! result (append cmd (list result))))
+ commands)
+ result))
+ markups))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; markup type predicates
+
+(define (markup-function? x)
+ (not (not (markup-command-signature x))))
+
+(define-public (markup-list? arg)
+ (define (markup-list-inner? lst)
+ (or (null? lst)
+ (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
+ (and (list? arg) (markup-list-inner? arg)))
+
+(define (markup-argument-list? signature arguments)
+ "Typecheck argument list."
+ (if (and (pair? signature) (pair? arguments))
+ (and ((car signature) (car arguments))
+ (markup-argument-list? (cdr signature) (cdr arguments)))
+ (and (null? signature) (null? arguments))))
+
+
+(define (markup-argument-list-error signature arguments number)
+ "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
+#f is no error found.
+"
+ (if (and (pair? signature) (pair? arguments))
+ (if (not ((car signature) (car arguments)))
+ (list number (type-name (car signature)) (car arguments))
+ (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
+ #f))
+
+;;
+;; full recursive typecheck.
+;;
+(define (markup-typecheck? arg)
+ (or (string? arg)
+ (and (pair? arg)
+ (markup-function? (car arg))
+ (markup-argument-list? (markup-command-signature (car arg))
+ (cdr arg)))))
+
+;;
+;; typecheck, and throw an error when something amiss.
+;;
+(define (markup-thrower-typecheck arg)
+ (cond ((string? arg) #t)
+ ((not (pair? arg))
+ (throw 'markup-format "Not a pair" arg))
+ ((not (markup-function? (car arg)))
+ (throw 'markup-format "Not a markup function " (car arg)))
+ ((not (markup-argument-list? (markup-command-signature (car arg))
+ (cdr arg)))
+ (throw 'markup-format "Arguments failed typecheck for " arg)))
+ #t)
+
+;;
+;; good enough if you only use make-XXX-markup functions.
+;;
+(define (cheap-markup? x)
+ (or (string? x)
+ (and (pair? x)
+ (markup-function? (car x)))))
+
+;;
+;; replace by markup-thrower-typecheck for more detailed diagnostics.
+;;
+(define-public markup? cheap-markup?)
+
+;; utility
+
+(define (markup-join markups sep)
+ "Return line-markup of MARKUPS, joining them with markup SEP"
+ (if (pair? markups)
+ (make-line-markup (list-insert-separator markups sep))
+ empty-markup))
+
+;; unused?
+;;(define-public brew-markup-stencil Text_interface::print)
+
+(define-public interpret-markup Text_interface::interpret_markup)
+(define-public (prepend-alist-chain key val chain)
+ (cons (acons key val (car chain)) (cdr chain)))
+
+(define-public (stack-stencil-line space stencils)
+ "DOCME"
+ (if (and (pair? stencils)
+ (ly:stencil? (car stencils)))
+
+ (if (and (pair? (cdr stencils))
+ (ly:stencil? (cadr stencils)))
+ (let* ((tail (stack-stencil-line space (cdr stencils)))
+ (head (car stencils))
+ (xoff (+ space (cdr (ly:stencil-extent head X)))))
+ (ly:stencil-add head
+ (ly:stencil-translate-axis tail xoff X)))
+ (car stencils))
+ (ly:make-stencil '() '(0 . 0) '(0 . 0))))
+
+
+
+
+
+
+
+++ /dev/null
-;;;; new-markup.scm -- Implement a user extensible markup scheme.
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-
-"
-Internally markup is stored as lists, whose head is a function.
-
- (FUNCTION ARG1 ARG2 ... )
-
-When the markup is formatted, then FUNCTION is called as follows
-
- (FUNCTION GROB PROPS ARG1 ARG2 ... )
-
-GROB is the current grob, PROPS is a list of alists, and ARG1.. are
-the rest of the arguments.
-
-The function should return a stencil (i.e. a formatted, ready to
-print object).
-
-
-To add a function, use the def-markup-command utility.
-
- (def-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
- \"my command usage and description\"
- ...function body...)
-
-The command is now available in markup mode, e.g.
-
-
- \\markup { .... \\MYCOMMAND #1 argument ... }
-
-" ; "
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; markup definer utilities
-;;; `def-markup-command' can be used both for built-in markup
-;;; definitions and user defined markups.
-
-(defmacro-public def-markup-command (command-and-args signature . body)
- "
-
-* Define a COMMAND-markup function after command-and-args and body,
-register COMMAND-markup and its signature,
-
-* add COMMAND-markup to markup-function-list,
-
-* sets COMMAND-markup markup-signature and markup-keyword object properties,
-
-* define a make-COMMAND-markup function.
-
-Syntax:
- (def-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
- \"documentation string\"
- ...command body...)
- or:
- (def-markup-command COMMAND (arg1-type? arg2-type? ...)
- function)
-"
- (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 (string-append (symbol->string command) "-markup")))
- (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
- `(begin
- (define-public ,(if (pair? args)
- (cons command-name args)
- command-name)
- ,@body)
- (set! (markup-command-signature ,command-name) (list ,@signature))
- (if (not (member ,command-name markup-function-list))
- (set! markup-function-list (cons ,command-name markup-function-list)))
- (define-public (,make-markup-name . args)
- (let ((sig (list ,@signature)))
- (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.
-"
- (let* ((arglen (length args))
- (siglen (length signature))
- (error-msg (if (and (> siglen 0) (> arglen 0))
- (markup-argument-list-error signature args 1)
- #f)))
- (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
- (scm-error 'markup-format make-name
- "Expect ~A arguments for ~A. Found ~A: ~S"
- (list siglen make-name arglen args)
- #f))
- (if error-msg
- (scm-error 'markup-format make-name
- "Invalid argument in position ~A\nExpect: ~A\nFound: ~S."
- error-msg #f)
- (cons markup-function args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; markup constructors
-;;; lilypond-like syntax for markup construction in scheme.
-
-(use-modules (ice-9 optargs)
- (ice-9 receive))
-
-(defmacro*-public markup (#:rest body)
- "The `markup' macro provides a lilypond-like syntax for building markups.
-
- - #:COMMAND is used instead of \\COMMAND
- - #:lines ( ... ) is used instead of { ... }
- - #:center-align ( ... ) is used instead of \\center-align < ... >
- - etc.
-
-Example:
- \\markup { foo
- \\raise #0.2 \\hbracket \\bold bar
- \\override #'(baseline-skip . 4)
- \\bracket \\column < baz bazr bla >
- }
- <==>
- (markup \"foo\"
- #:raise 0.2 #:hbracket #:bold \"bar\"
- #:override '(baseline-skip . 4)
- #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
-Use `markup*' in a \\notes block."
-
- (car (compile-all-markup-expressions `(#:line ,body))))
-
-(defmacro*-public markup* (#:rest body)
- "Same as `markup', for use in a \\notes block."
- `(ly:export (markup ,@body)))
-
-
-(define (compile-all-markup-expressions expr)
- "Return a list of canonical markups expressions, e.g.:
- (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
- ===>
- ((make-COMMAND1-markup arg11 arg12)
- (make-COMMAND2-markup arg21 arg22 arg23) ...)"
- (do ((rest expr rest)
- (markps '() markps))
- ((null? rest) (reverse markps))
- (receive (m r) (compile-markup-expression rest)
- (set! markps (cons m markps))
- (set! rest r))))
-
-(define (keyword->make-markup key)
- "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
- (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
-
-(define (compile-markup-expression expr)
- "Return two values: the first complete canonical markup expression found in `expr',
-e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
- (cond ((and (pair? expr)
- (keyword? (car expr)))
- ;; expr === (#:COMMAND arg1 ...)
- (let* ((command (symbol->string (keyword->symbol (car expr))))
- (sig (markup-command-signature (car (lookup-markup-command command))))
- (sig-len (length sig)))
- (do ((i 0 (1+ i))
- (args '() args)
- (rest (cdr expr) rest))
- ((>= i sig-len)
- (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
- (cond ((eqv? (list-ref sig i) markup-list?)
- ;; (car rest) is a markup list
- (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
- (set! rest (cdr rest)))
- (else
- ;; pick up one arg in `rest'
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r)))))))
- ((and (pair? expr)
- (pair? (car expr))
- (keyword? (caar expr)))
- ;; expr === ((#:COMMAND arg1 ...) ...)
- (receive (m r) (compile-markup-expression (car expr))
- (values m (cdr expr))))
- ((and (pair? expr)
- (string? (car expr))) ;; expr === ("string" ...)
- (values `(make-simple-markup ,(car expr)) (cdr expr)))
- (else
- ;; expr === (symbol ...) or ((funcall ...) ...)
- (values (car expr)
- (cdr expr)))))
-
-(define (compile-all-markup-args expr)
- "Transform `expr' into markup arguments"
- (do ((rest expr rest)
- (args '() args))
- ((null? rest) (reverse args))
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r))))
-
-(define (compile-markup-arg expr)
- "Return two values: the desired markup argument, and the rest arguments"
- (cond ((null? expr)
- ;; no more args
- (values '() '()))
- ((keyword? (car expr))
- ;; expr === (#:COMMAND ...)
- ;; ==> build and return the whole markup expression
- (compile-markup-expression expr))
- ((and (pair? (car expr))
- (keyword? (caar expr)))
- ;; expr === ((#:COMMAND ...) ...)
- ;; ==> build and return the whole markup expression(s)
- ;; found in (car expr)
- (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
- (if (null? rest-expr)
- (values markup-expr (cdr expr))
- (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
- (cdr expr)))))
- ((and (pair? (car expr))
- (pair? (caar expr)))
- ;; expr === (((foo ...) ...) ...)
- (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
- (else (values (car expr) (cdr expr)))))
-
-;;;;;;;;;;;;;;;
-;;; Debugging utilities: print markup expressions in a friendly fashion
-
-(use-modules (ice-9 format))
-(define (markup->string markup-expr)
- "Return a string describing, in LilyPond syntax, the given markup expression."
- (define (proc->command proc)
- (let ((cmd-markup (symbol->string (procedure-name proc))))
- (substring cmd-markup 0 (- (string-length cmd-markup)
- (string-length "-markup")))))
- (define (arg->string arg)
- (cond ((and (pair? arg) (pair? (car arg))) ;; markup list
- (format #f "~{ ~a~}" (map markup->string arg)))
- ((pair? arg) ;; markup
- (markup->string arg))
- ((string? arg) ;; scheme string argument
- (format #f "#\"~a\"" arg))
- (else ;; other scheme arg
- (format #f "#~a" arg))))
- (let ((cmd (car markup-expr))
- (args (cdr markup-expr)))
- (cond ((eqv? cmd simple-markup) ;; a simple string
- (format #f "\"~a\"" (car args)))
- ((eqv? cmd line-markup) ;; { ... }
- (format #f "{~a}" (arg->string (car args))))
- ((eqv? cmd center-align-markup) ;; \center < ... >
- (format #f "\\center-align <~a>" (arg->string (car args))))
- ((eqv? cmd column-markup) ;; \column < ... >
- (format #f "\\column <~a>" (arg->string (car args))))
- (else ;; \command ...
- (format #f "\\~a~{ ~a~} " (proc->command cmd) (map arg->string args))))))
-
-(define-public (display-markup markup-expr)
- "Print a LilyPond-syntax equivalent for the given markup expression."
- (display "\\markup ")
- (display (markup->string markup-expr)))
-
-;;;;;;;;;;;;;;;
-;;; Utilities for storing and accessing markup commands signature
-;;; and keyword.
-;;; Examples:
-;;;
-;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> ((#<primitive-procedure number?> #<procedure markup? (obj)>) . scheme0-markup1)
-;;;
-;;; (markup-command-signature raise-markup)
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
-;;;
-
-(define markup-command-signatures (make-hash-table 50))
-
-(define (markup-command-signature-ref markup-command)
- "Return markup-command's signature, e.g. (number? markup?).
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (car sig-key) #f)))
-
-(define-public (markup-command-keyword markup-command)
- "Return markup-command's keyword, e.g. \"scheme0markup1\".
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (cdr sig-key) #f)))
-
-(define (markup-command-signatureset! markup-command signature)
- "Set markup-command's signature. markup-command must be a named procedure.
-Also set markup-signature and markup-keyword object properties."
- (hashq-set! markup-command-signatures
- markup-command
- (cons signature (markup-signature-to-keyword signature)))
- ;; these object properties are still in use somewhere
- (set-object-property! markup-command 'markup-signature signature)
- (set-object-property! markup-command 'markup-keyword (markup-signature-to-keyword signature)))
-
-(define-public markup-command-signature
- (make-procedure-with-setter markup-command-signature-ref markup-command-signatureset!))
-
-(define (markup-symbol-to-proc markup-sym)
- "Return the markup command procedure which name is `markup-sym', if any."
- (hash-fold (lambda (key val prev)
- (or prev
- (if (eqv? (procedure-name key) markup-sym) key #f)))
- #f
- markup-command-signatures))
-
-(define-public markup-function-list '())
-
-(define-public (markup-signature-to-keyword sig)
- " (A B C) -> a0-b1-c2 "
- (if (null? sig)
- 'empty
- (string->symbol (string-join (map
- (let* ((count 0))
- (lambda (func)
- (set! count (+ count 1))
- (string-append
- ;; for reasons I don't get,
- ;; (case func ((markup?) .. )
- ;; doesn't work.
- (cond
- ((eq? func markup?) "markup")
- ((eq? func markup-list?) "markup-list")
- (else "scheme"))
- (number->string (- count 1)))))
- sig)
- "-"))))
-
-(define-public (lookup-markup-command code)
- (let ((proc (markup-symbol-to-proc (string->symbol (string-append code "-markup")))))
- (and proc (cons proc (markup-command-keyword proc)))))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; used in parser.yy to map a list of markup commands on markup arguments
-(define-public (map-markup-command-list commands markups)
- "`markups' being a list of markups, eg (markup1 markup2 markup3),
-and `commands' a list of commands with their scheme arguments, in reverse order,
-eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
- ((bold (raise 4 (italic markup1)))
- (bold (raise 4 (italic markup2)))
- (bold (raise 4 (italic markup3))))
-"
- (map-in-order (lambda (arg)
- (let ((result arg))
- (for-each (lambda (cmd)
- (set! result (append cmd (list result))))
- commands)
- result))
- markups))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; markup type predicates
-
-(define (markup-function? x)
- (not (not (markup-command-signature x))))
-
-(define-public (markup-list? arg)
- (define (markup-list-inner? lst)
- (or (null? lst)
- (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
- (and (list? arg) (markup-list-inner? arg)))
-
-(define (markup-argument-list? signature arguments)
- "Typecheck argument list."
- (if (and (pair? signature) (pair? arguments))
- (and ((car signature) (car arguments))
- (markup-argument-list? (cdr signature) (cdr arguments)))
- (and (null? signature) (null? arguments))))
-
-
-(define (markup-argument-list-error signature arguments number)
- "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
-#f is no error found.
-"
- (if (and (pair? signature) (pair? arguments))
- (if (not ((car signature) (car arguments)))
- (list number (type-name (car signature)) (car arguments))
- (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
- #f))
-
-;;
-;; full recursive typecheck.
-;;
-(define (markup-typecheck? arg)
- (or (string? arg)
- (and (pair? arg)
- (markup-function? (car arg))
- (markup-argument-list? (markup-command-signature (car arg))
- (cdr arg)))))
-
-;;
-;; typecheck, and throw an error when something amiss.
-;;
-(define (markup-thrower-typecheck arg)
- (cond ((string? arg) #t)
- ((not (pair? arg))
- (throw 'markup-format "Not a pair" arg))
- ((not (markup-function? (car arg)))
- (throw 'markup-format "Not a markup function " (car arg)))
- ((not (markup-argument-list? (markup-command-signature (car arg))
- (cdr arg)))
- (throw 'markup-format "Arguments failed typecheck for " arg)))
- #t)
-
-;;
-;; good enough if you only use make-XXX-markup functions.
-;;
-(define (cheap-markup? x)
- (or (string? x)
- (and (pair? x)
- (markup-function? (car x)))))
-
-;;
-;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;;
-(define-public markup? cheap-markup?)
-
-;; utility
-
-(define (markup-join markups sep)
- "Return line-markup of MARKUPS, joining them with markup SEP"
- (if (pair? markups)
- (make-line-markup (list-insert-separator markups sep))
- empty-markup))
-
-(define-public brew-new-markup-stencil Text_interface::print)
-(define-public interpret-markup Text_interface::interpret_markup)
-(define-public (prepend-alist-chain key val chain)
- (cons (acons key val (car chain)) (cdr chain)))
-
-
-
-
-(define-public (stack-stencil-line space stencils)
- "DOCME"
- (if (and (pair? stencils)
- (ly:stencil? (car stencils)))
-
- (if (and (pair? (cdr stencils))
- (ly:stencil? (cadr stencils)))
- (let* ((tail (stack-stencil-line space (cdr stencils)))
- (head (car stencils))
- (xoff (+ space (cdr (ly:stencil-extent head X)))))
- (ly:stencil-add head
- (ly:stencil-translate-axis tail xoff X)))
- (car stencils))
- (ly:make-stencil '() '(0 . 0) '(0 . 0))))
-
-
-
-
-
-
-
((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
(define-public (print-circled-text-callback grob)
- (let*
- ((text (ly:grob-property grob 'text))
- (layout (ly:grob-layout grob))
- (defs (ly:output-def-lookup layout 'text-font-defaults))
- (props (ly:grob-alist-chain grob defs))
- (circle (Text_interface::interpret_markup layout props
- (make-circle-markup
- 0.8 0.1)))
- (text-stencil
- (Text_interface::interpret_markup layout props text)))
-
-
- (ly:stencil-add
- (centered-stencil text-stencil)
- circle)
- ))
+ (let* ((text (ly:grob-property grob 'text))
+ (layout (ly:grob-layout grob))
+ (defs (ly:output-def-lookup layout 'text-font-defaults))
+ (props (ly:grob-alist-chain grob defs))
+ (circle (Text_interface::interpret_markup
+ layout props (make-draw-circle-markup 0.8 0.1)))
+ (text-stencil (Text_interface::interpret_markup layout props text)))
+ (ly:stencil-add (centered-stencil text-stencil) circle)))
;;(define (mm-to-pt x)
(list arch_angle arch_width arch_height height arch_thick thick))
" draw_bracket"))
+(define (circle radius thick)
+ (format
+ "~a ~a draw_circle" radius thick))
+
(define (char font i)
(string-append
(ps-font-command font) " setfont "
"(\\" (ly:inexact->string i 8) ") show"))
-;; save current color on stack and set new color
-(define (setcolor r g b)
- (string-append "currentrgbcolor "
- (ly:numbers->string (list r g b))
- " setrgbcolor\n"))
-
-;; restore color from stack
-(define (resetcolor)
- (string-append "setrgbcolor\n"))
-
(define (dashed-line thick on off dx dy)
(string-append
(ly:number->string dx) " "
(ly:number->string off)
" ] 0 draw_dashed_slur"))
-(define (circle radius thick)
- (format
- "~a ~a draw_circle" radius thick))
-
-
(define (dot x y radius)
(string-append
" "
(string-append (ly:numbers->string (list breapth width depth height))
" draw_box"))
-
-(define (utf8-string pango-font-description string)
- (ly:warn "utf8-string encountered in PS backend"))
-
(define (glyph-string
postscript-font-name
size
(ly:numbers->string (list wid slope thick))
" draw_repeat_slash"))
+;; restore color from stack
+(define (resetcolor)
+ (string-append "setrgbcolor\n"))
+
(define (round-filled-box x y width height blotdiam)
(string-append
(ly:numbers->string
(list x y width height blotdiam)) " draw_round_box"))
+;; save current color on stack and set new color
+(define (setcolor r g b)
+ (string-append "currentrgbcolor "
+ (ly:numbers->string (list r g b))
+ " setrgbcolor\n"))
+
(define (text font s)
; (ly:warn "TEXT backend-command encountered in Pango backend\nargs: ~a ~a" font str)
(cdr y)
url))
+(define (utf8-string pango-font-description string)
+ (ly:warn "utf8-string encountered in PS backend"))
+
(define (white-dot x y radius)
(string-append
" "
;; JUNK this -- see lily.scm: ly:all-output-backend-commands
#:export (unknown
blank
+ circle
dot
white-dot
beam
(define (url-link url x y)
"")
-
(define (blank)
"")
-(define (dot x y radius)
- (embedded-ps (list 'dot x y radius)))
-
(define (circle radius thick)
(embedded-ps (list 'circle radius thick)))
+(define (dot x y radius)
+ (embedded-ps (list 'dot x y radius)))
(define (embedded-ps string)
(embedded-ps (list 'embedded-ps string)))
(define-public (centered-stencil stencil)
"Center stencil @var{stencil} in both the X and Y directions"
-
- (ly:stencil-aligned-to
- (ly:stencil-aligned-to stencil X CENTER)
- Y CENTER))
+ (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
(define-public (stack-lines dir padding baseline stils)
"Stack vertically with a baseline-skip."
(- (car yext)) (cdr yext))
xext yext))
+(define-public (make-circle-stencil radius thickness)
+ "Make a circle of radius @var{radius} and thickness @var{thickness}"
+ (ly:make-stencil
+ (list 'circle radius thickness)
+ (cons (- radius) radius)
+ (cons (- radius) radius)))
+
(define-public (box-grob-stencil grob)
"Make a box of exactly the extents of the grob. The box precisely
encloses the contents.
(ly:stencil-add
(make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
- (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
+ (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
(make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
(make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
;; TODO merge this and prev function.
-(define-public (box-stencil stil thick padding)
- "Add a box around STIL, producing a new stencil."
- (let* ((x-ext (interval-widen (ly:stencil-extent stil 0) padding))
- (y-ext (interval-widen (ly:stencil-extent stil 1) padding))
+(define-public (box-stencil stencil thick padding)
+ "Add a box around STENCIL, producing a new stencil."
+ (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
+ (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
(y-rule (make-filled-box-stencil (cons 0 thick) y-ext))
- (x-rule (make-filled-box-stencil (interval-widen x-ext thick)
- (cons 0 thick))))
-
- (set! stil (ly:stencil-combine-at-edge stil X 1 y-rule padding))
- (set! stil (ly:stencil-combine-at-edge stil X -1 y-rule padding))
- (set! stil (ly:stencil-combine-at-edge stil Y 1 x-rule 0.0))
- (set! stil (ly:stencil-combine-at-edge stil Y -1 x-rule 0.0))
-
- stil))
+ (x-rule (make-filled-box-stencil
+ (interval-widen x-ext thick) (cons 0 thick))))
+ (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
+ (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
+ (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
+ (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
+ stencil))
+
+(define-public (circle-stencil stencil thickness padding)
+ "Add a circle around STENCIL, producing a new stencil."
+ (let* ((x-ext (ly:stencil-extent stencil 0))
+ (y-ext (ly:stencil-extent stencil 1))
+ (diameter (max (- (cdr x-ext) (car x-ext))
+ (- (cdr y-ext) (car y-ext))))
+ (radius (+ (/ diameter 2) padding)))
+ (ly:stencil-add
+ (centered-stencil stencil) (make-circle-stencil radius thickness))))
(define-public (fontify-text font-metric text)
"Set TEXT with font FONT-METRIC, returning a stencil."
projects / lilypond.git / commitdiff