3 Internally markup is stored as lists, whose head is a function.
5 (FUNCTION ARG1 ARG2 ... )
7 When the markup is formatted, then FUNCTION is called as follows
9 (FUNCTION GROB PROPS ARG1 ARG2 ... )
11 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
12 the rest of the arguments.
14 The function should return a molecule (i.e. a formatted, ready to
21 1. It should be named COMMAND-markup
23 2. It should have an object property set that describes it's
24 signature. This is to allow the parser to figure out how many
27 (set-object-property! COMMAND-markup scm0-markup1)
29 (insert in the list below).
31 3. The command is now available in markup mode, e.g.
34 \markup { .... \COMMAND #1 argument ... }
39 At present, markup functions must be defined in this
40 file. Implementing user-access for markup functions is an excercise
50 (define (mydisplay x) (display x) (newline) x)
52 (define-public (simple-markup grob props . rest)
53 (Text_item::text_to_molecule grob props (car rest))
56 (define-public (stack-molecule-line space molecules)
58 (if (pair? (cdr molecules))
60 (tail (stack-molecule-line space (cdr molecules)))
61 (head (car molecules))
62 (xoff (+ space (cdr (ly:get-molecule-extent head X))))
67 (ly:molecule-translate-axis tail xoff X))
73 (define-public (line-markup grob props . rest)
75 (cdr (chain-assoc 'word-space props))
76 (map (lambda (x) (interpret-markup grob props x)) (car rest)))
79 (define (combine-molecule-list lst)
80 (if (null? (cdr lst)) (car lst)
81 (ly:add-molecule (car lst) (combine-molecule-list (cdr lst)))
84 (define-public (combine-markup grob props . rest)
86 (interpret-markup grob props (car rest))
87 (interpret-markup grob props (cadr rest))))
89 ; (combine-molecule-list (map (lambda (x) (interpret-markup grob props x)) (car rest))))
91 (define (font-markup qualifier value)
92 (lambda (grob props . rest)
93 (interpret-markup grob (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
98 (define-public (set-property-markup qualifier)
99 (lambda (grob props . rest )
100 (interpret-markup grob
101 (cons (cons `(,qualifier . ,(car rest))
102 (car props)) (cdr props))
107 (define-public fontsize-markup (set-property-markup 'font-relative-size))
108 (define-public magnify-markup (set-property-markup 'font-magnification))
110 (define-public bold-markup
111 (font-markup 'font-series 'bold))
112 (define-public number-markup
113 (font-markup 'font-family 'number))
116 (define-public huge-markup
117 (font-markup 'font-relative-size 2))
118 (define-public large-markup
119 (font-markup 'font-relative-size 1))
120 (define-public small-markup
121 (font-markup 'font-relative-size -1))
122 (define-public tiny-markup
123 (font-markup 'font-relative-size -2))
124 (define-public teeny-markup
125 (font-markup 'font-relative-size -3))
126 (define-public dynamic-markup
127 (font-markup 'font-family 'dynamic))
128 (define-public italic-markup
129 (font-markup 'font-shape 'italic))
132 ;; TODO: baseline-skip should come from the font.
133 (define-public (column-markup grob props . rest)
135 -1 0.0 (cdr (chain-assoc 'baseline-skip props))
136 (map (lambda (x) (interpret-markup grob props x)) (car rest)))
139 (define-public (musicglyph-markup grob props . rest)
140 (ly:find-glyph-by-name
141 (ly:get-font grob (cons '((font-family . music)) props))
145 (define-public (lookup-markup grob props . rest)
146 "Lookup a glyph by name."
147 (ly:find-glyph-by-name
148 (ly:get-font grob props)
152 (define-public (char-markup grob props . rest)
153 "Syntax: \\char NUMBER. "
154 (ly:get-glyph (ly:get-font grob props) (car rest))
157 (define-public (raise-markup grob props . rest)
158 "Syntax: \\raise AMOUNT MARKUP. "
159 (ly:molecule-translate-axis (interpret-markup
166 (define-public (normal-size-superscript-markup grob props . rest)
167 (ly:molecule-translate-axis (interpret-markup
170 (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
174 (define-public (super-markup grob props . rest)
175 "Syntax: \\super MARKUP. "
176 (ly:molecule-translate-axis (interpret-markup
178 (cons '((font-relative-size . -2)) props) (car rest))
179 (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
183 (define-public (translate-markup grob props . rest)
184 "Syntax: \\translate OFFSET MARKUP. "
185 (ly:molecule-translate (interpret-markup grob props (cadr rest))
190 (define-public (sub-markup grob props . rest)
191 "Syntax: \\sub MARKUP."
192 (ly:molecule-translate-axis (interpret-markup
194 (cons '((font-relative-size . -2)) props)
196 (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
200 ;; todo: fix negative space
201 (define (hspace-markup grob props . rest)
202 "Syntax: \\hspace NUMBER."
204 ((amount (car rest)))
206 (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
207 (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
210 (define-public (override-markup grob props . rest)
211 "Tack the 1st arg in REST onto PROPS, e.g.
213 \override #'(font-family . married) \"bla\"
217 (interpret-markup grob (cons (list (car rest)) props)
220 (define-public (smaller-markup grob props . rest)
221 "Syntax: \\smaller MARKUP"
224 (fs (cdr (chain-assoc 'font-relative-size props)))
225 (entry (cons 'font-relative-size (- fs 1)))
228 grob (cons (list entry) props)
233 (define-public (bigger-markup grob props . rest)
234 "Syntax: \\bigger MARKUP"
237 (fs (cdr (chain-assoc 'font-relative-size props)))
238 (entry (cons 'font-relative-size (+ fs 1)))
241 grob (cons (list entry) props)
245 (define (markup-signature-to-keyword sig)
246 " (A B C) -> a0-b1-c2 "
249 (string->symbol (string-join
253 (set! count (+ count 1))
256 ;; for reasons I don't get,
257 ;; (case func ((markup?) .. )
260 ((eq? func markup?) "markup")
261 ((eq? func markup-list?) "markup-list")
264 (number->string (- count 1))
273 (define (markup-function? x)
274 (object-property x 'markup-signature)
277 (define (markup-list? arg)
278 (define (markup-list-inner? l)
281 (and (markup? (car l)) (markup-list-inner? (cdr l)))
284 (and (list? arg) (markup-list-inner? arg)))
287 (define (markup-argument-list? signature arguments)
288 (if (and (pair? signature) (pair? arguments))
289 (and ((car signature) (car arguments))
290 (markup-argument-list? (cdr signature) (cdr arguments)))
291 (and (null? signature) (null? arguments)))
295 (define (markup-argument-list-error signature arguments number)
296 (if (and (pair? signature) (pair? arguments))
297 (if (not ((car signature) (car arguments)))
298 (list number (type-name (car signature)) (car arguments))
299 (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
304 ;; full recursive typecheck.
306 (define (markup-typecheck? arg)
308 (markup-function? (car arg))
309 (markup-argument-list?
310 (object-property (car arg) 'markup-signature)
315 ;; typecheck, and throw an error when something amiss.
317 (define (markup-thrower-typecheck arg)
320 (throw 'markup-format "Not a pair" arg)
322 ((not (markup-function? (car arg)))
323 (throw 'markup-format "Not a markup function " (car arg)))
326 ((not (markup-argument-list?
327 (object-property (car arg) 'markup-signature)
329 (throw 'markup-format "Arguments failed typecheck for " arg)))
333 (define (cheap-markup? x)
335 (markup-function? (car x)))
339 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
341 (define markup? cheap-markup?)
344 (define markup-function-list
348 (cons teeny-markup (list markup?))
349 (cons tiny-markup (list markup?))
350 (cons small-markup (list markup?))
351 (cons dynamic-markup (list markup?))
352 (cons large-markup (list markup?))
354 (cons huge-markup (list markup?))
357 (cons smaller-markup (list markup?))
358 (cons bigger-markup (list markup?))
361 (cons sub-markup (list markup?))
362 (cons super-markup (list markup?))
364 (cons bold-markup (list markup?))
365 (cons italic-markup (list markup?))
367 (cons number-markup (list markup?))
369 (cons column-markup (list markup-list?))
370 (cons line-markup (list markup-list?))
372 (cons combine-markup (list markup? markup?))
373 (cons simple-markup (list string?))
374 (cons musicglyph-markup (list scheme?))
376 (cons translate-markup (list number-pair? markup?))
377 (cons override-markup (list pair? markup?))
378 (cons char-markup (list integer?))
379 (cons lookup-markup (list string?))
381 (cons hspace-markup (list number?))
383 (cons raise-markup (list number? markup?))
384 (cons magnify-markup (list number? markup?))
385 (cons fontsize-markup (list number? markup?))
390 (define markup-module (current-module))
393 (set-object-property! (car x) 'markup-signature (cdr x))
394 (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
396 markup-function-list)
401 ;; make-FOO-markup function that typechecks its arguments.
403 ;; TODO: should construct a message says
404 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
406 ;; right now, you get the entire argument list.
409 (define (make-markup-maker entry)
411 ((foo-markup (car entry))
412 (signature (cons 'list (cdr entry)))
413 (name (symbol->string (procedure-name foo-markup)))
414 (make-name (string-append "make-" name))
417 `(define (,(string->symbol make-name) . args)
418 (if (= (length args) (length ,signature))
420 (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
421 (list (length ,signature)
428 (error-msg (markup-argument-list-error ,signature args 1))
431 (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
433 (cons ,foo-markup args)
439 (cons 'begin (map make-markup-maker markup-function-list))
443 (define-public (lookup-markup-command code)
445 ( (sym (string->symbol (string-append code "-markup")))
446 (var (module-local-variable markup-module sym))
450 (cons (variable-ref var) (object-property (variable-ref var) 'markup-keyword))
455 (define-public (brew-new-markup-molecule grob)
456 (interpret-markup grob
457 (Font_interface::get_property_alist_chain grob)
458 (ly:get-grob-property grob 'text)
462 (define-public empty-markup `(,simple-markup ""))
464 (define (interpret-markup grob props markup)
471 (apply func (cons grob (cons props args)) )
475 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
477 ;; test make-foo-markup functions
480 (make-line-markup (make-simple-markup "FOO"))
481 (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
482 (make-raise-markup "foo" (make-simple-markup "foo"))
488 ;; test typecheckers. Not wholly useful, because errors are detected
489 ;; in other places than they're made.
494 ;; To get error messages, see above to install the alternate
495 ;; typecheck routine for markup?.
497 (define (typecheck-with-error x)
500 (lambda () (markup? x))
501 (lambda (key message arg)
502 (display "\nERROR: markup format error: \n")
505 (write arg (current-output-port))
509 (display (typecheck-with-error `(,simple-markup "foobar")))
510 (display (typecheck-with-error `(,simple-markup "foobar")))
511 (display (typecheck-with-error `(,simple-markup 1)))
513 (typecheck-with-error `(,line-markup ((,simple-markup "foobar"))
514 (,simple-markup 1))))
516 (typecheck-with-error `(,line-markup (,simple-markup "foobar")
517 (,simple-markup "bla"))))