markup syntax in scheme

[Nicolas Sceaux]

Hello,

Here is a proposal for a lilypond-like markup notation in scheme, in
order to ease markup command definition by users.

For instance:
  \markup { foo
            \raise #0.2 \hbracket \bold bar
            \override #'(baseline-skip . 4)
                      \bracket \column < baz bazr bla >
  }
  === (proposed syntax)
  (markup "foo"
          #:raise 0.2 #:hbracket #:bold "bar"
          #:override '(baseline-skip . 4) 
                     #:bracket #:column ("baz" "bazr" "bla"))
  === (how it can be done today)
  (make-line-markup
    "foo"
    (make-raise-markup 0.2 (make-hbracket-markup (make-bold-markup "bar")))
    (make-override-markup '(baseline-skip . 4)
                          (make-bracket-markup (make-column-markup
                                                 (list "baz" "bazr" "bla")))))

The third expression may be less accessible than the second.

The following example shows how to translate LilyPond markup notation
into this scheme notation:

------------------------------------------------------
\score {
    \notes {
        \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-family . music) {
                \lookup #"noteheads-0"
                \char #53
            }
            \musicglyph #"accidentals--1"
            \combine "X" "+"   
            \combine "o" "/"
            \box \column < { "string 1" } { "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-family . music) #:line (#:lookup "noteheads-0" 
                                                        #:char 53)
              #: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")
    }
    \paper { 
        raggedright = ##t
        indent = #0
        \translator {
            \StaffContext
            \remove Time_signature_engraver 
        }
    }
}
------------------------------------------------------

This one shows how to use the `markup' macro in order to define a
markup command:

------------------------------------------------------
#(define-public (number-or-string? obj)
  (or (number? obj)
      (string? obj)))

#(def-markup-command (tempo paper props tempo1 tempo2) (string? 
number-or-string?)
  "Syntax: \\tempo duration-string number
or: \\tempo duration-string1 duration-string2
eg: \\tempo #\"4.\" #120  ==> quater = 120
or: \\tempo #\4.\" \"4\"  ==> dotted-quater = quater"
  (let ((markup1 (markup #:tiny #:note tempo1 0.7))
        (markup2 (if (number? tempo2)
                     (number->string tempo2)
                     (markup #:tiny #:note tempo2 0.7))))
    (interpret-markup paper props (markup markup1 "=" markup2))))

\score {
    \notes {
        \time 4/4
        c''1^\markup \tempo #"4" #120
        \time 6/8
        c''2.^\markup \tempo #"4." #"4"
    }
    \paper { raggedright = ##t }
}
------------------------------------------------------

If you find that it might be interesting, here is a patch for
new-markup.scm

--- new-markup.scm.~1.63.~      2004-01-25 17:10:20.000000000 +0100
+++ new-markup.scm      2004-01-31 15:59:34.000000000 +0100
@@ -82,6 +82,123 @@
                    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 ( ... ) is used instead of \\center < ... >
+ - 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, eg:
+  (#: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, eg. #: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',
+eg (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))))
+        (else
+         ;; expr === (symbol ...) or ("string" ...) 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)))))
+
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature
 ;;; and keyword.

Changes:
(markup) a macro that provides a LilyPond-like syntax in scheme for
building markups, in order to help markup command definition.

nicolas