scm/new-markup.scm

   1 (define-public (simple-markup grob props . rest)
   2   (Text_item::text_to_molecule grob props (car rest))
   3   )
   4
   5 (define-public (stack-molecule-line space molecules)
   6   (if (pair? molecules)
   7       (if (pair? (cdr molecules))
   8           (let* (
   9                  (tail (stack-molecule-line  space (cdr molecules)))
  10                  (head (car molecules))
  11                  (xoff (+ space (cdr (ly:get-molecule-extent head X))))
  12                  )
  13
  14             (ly:add-molecule
  15              head
  16              (ly:molecule-translate-axis tail xoff X))
  17           )
  18           (car molecules))
  19       '())
  20   )
  21
  22 (define-public (line-markup grob props . rest)
  23   (stack-molecule-line
  24    (cdr (chain-assoc 'word-space props))
  25    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
  26   )
  27
  28 (define (combine-molecule-list lst)
  29   (if (null? (cdr lst)) (car lst)
  30       (ly:add-molecule (car lst) (combine-molecule-list (cdr lst)))
  31       ))
  32
  33 (define-public (combine-markup grob props . rest)
  34   (ly:add-molecule
  35    (interpret-markup grob props (car rest))
  36    (interpret-markup grob props (cadr rest))))
  37
  38 ;   (combine-molecule-list (map (lambda (x) (interpret-markup grob props x)) (car rest))))
  39
  40 (define (font-markup qualifier value)
  41   (lambda (grob props . rest)
  42     (interpret-markup grob (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
  43
  44   ))
  45
  46
  47 (define-public (set-property-markup qualifier)
  48   (lambda (grob props . rest  )
  49     (interpret-markup grob
  50                       (cons (cons `(,qualifier . ,(car rest))
  51                                   (car props)) (cdr props))
  52                       (cadr rest))
  53     ))
  54
  55
  56 (define-public fontsize-markup (set-property-markup 'font-relative-size))
  57 (define-public magnify-markup (set-property-markup 'font-magnification))
  58
  59 (define-public bold-markup
  60   (font-markup 'font-series 'bold))
  61 (define-public number-markup
  62   (font-markup 'font-family 'number))
  63
  64
  65 (define-public huge-markup
  66   (font-markup 'font-relative-size 2))
  67 (define-public large-markup
  68   (font-markup 'font-relative-size 1))
  69 (define-public small-markup
  70   (font-markup 'font-relative-size -1))
  71 (define-public tiny-markup
  72   (font-markup 'font-relative-size -2))
  73 (define-public teeny-markup
  74   (font-markup 'font-relative-size -3))
  75 (define-public dynamic-markup
  76   (font-markup 'font-family 'dynamic))
  77 (define-public italic-markup
  78   (font-markup 'font-shape 'italic))
  79
  80
  81 ;; TODO: baseline-skip should come from the font.
  82 (define-public (column-markup grob props . rest)
  83   (stack-lines
  84    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
  85    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
  86   )
  87
  88 (define-public (musicglyph-markup grob props . rest)
  89   (ly:find-glyph-by-name
  90    (ly:get-font grob (cons '((font-family . music)) props))
  91    (car rest))
  92   )
  93
  94 (define-public (lookup-markup grob props . rest)
  95   "Lookup a glyph by name."
  96   (ly:find-glyph-by-name
  97    (ly:get-font grob props)
  98    (car rest))
  99   )
 100
 101 (define-public (char-markup grob props . rest)
 102   "Syntax: \\char NUMBER. "
 103   (ly:get-glyph  (ly:get-font grob props) (car rest))
 104   )
 105
 106 (define-public (raise-markup grob props  . rest)
 107   "Syntax: \\raise AMOUNT MARKUP. "
 108   (ly:molecule-translate-axis (interpret-markup
 109                                grob
 110                                props
 111                                (cadr rest))
 112                               (car rest) Y)
 113   )
 114
 115 (define-public (normal-size-superscript-markup grob props . rest)
 116   (ly:molecule-translate-axis (interpret-markup
 117                                grob
 118                                props (car rest))
 119                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 120                               Y)
 121   )
 122
 123 (define-public (super-markup grob props  . rest)
 124   "Syntax: \\super MARKUP. "
 125   (ly:molecule-translate-axis (interpret-markup
 126                                grob
 127                                (cons '((font-relative-size . -2)) props) (car rest))
 128                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 129                               Y)
 130   )
 131
 132 (define-public (translate-markup grob props . rest)
 133   "Syntax: \\translate OFFSET MARKUP. "
 134   (ly:molecule-translate (interpret-markup  grob props (cadr rest))
 135                          (car rest))
 136
 137   )
 138
 139 (define-public (sub-markup grob props  . rest)
 140   "Syntax: \\sub MARKUP."
 141   (ly:molecule-translate-axis (interpret-markup
 142                                grob
 143                                (cons '((font-relative-size . -2)) props)
 144                                (car rest))
 145                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 146                               Y)
 147   )
 148
 149 ;; todo: fix negative space
 150 (define (hspace-markup grob props . rest)
 151   "Syntax: \\hspace NUMBER."
 152   (let*
 153       ((amount (car rest)))
 154     (if (> amount 0)
 155         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 156         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 157   ))
 158
 159 (define-public (override-markup grob props . rest)
 160   "Tack the 1st arg in REST onto PROPS, e.g.
 161
 162 \override #'(font-family . married) \"bla\"
 163
 164 "
 165
 166   (interpret-markup grob (cons (list (car rest)) props)
 167                     (cadr rest)))
 168
 169 (define-public (smaller-markup  grob props . rest)
 170   "Syntax: \\smaller MARKUP"
 171   (let*
 172       (
 173        (fs (cdr (chain-assoc 'font-relative-size props)))
 174        (entry (cons 'font-relative-size (- fs 1)))
 175        )
 176   (interpret-markup
 177    grob (cons (list entry) props)
 178    (car rest))
 179
 180   ))
 181
 182 (define-public (bigger-markup  grob props . rest)
 183   "Syntax: \\bigger MARKUP"
 184   (let*
 185       (
 186        (fs (cdr (chain-assoc 'font-relative-size props)))
 187        (entry (cons 'font-relative-size (+ fs 1)))
 188        )
 189   (interpret-markup
 190    grob (cons (list entry) props)
 191    (car rest))
 192   ))
 193
 194 (map (lambda (x)
 195        (set-object-property! (car x) 'markup-signature (cdr x))
 196        )
 197      (list
 198       (cons bold-markup 'markup0)
 199       (cons teeny-markup 'markup0)
 200       (cons tiny-markup 'markup0)
 201       (cons small-markup 'markup0)
 202       (cons smaller-markup 'markup0)
 203       (cons bigger-markup 'markup0)
 204       (cons italic-markup 'markup0)
 205       (cons dynamic-markup 'markup0)
 206       (cons large-markup 'markup0)
 207       (cons huge-markup 'markup0)
 208       (cons sub-markup 'markup0)
 209       (cons super-markup 'markup0)
 210       (cons number-markup 'markup0)
 211       (cons column-markup 'markup-list0)
 212       (cons line-markup  'markup-list0)
 213       (cons combine-markup 'markup0-markup1)
 214       (cons simple-markup 'markup0)
 215       (cons musicglyph-markup 'scm0)
 216       (cons translate-markup 'scm0-markup1)
 217       (cons override-markup 'scm0-markup1)
 218       (cons lookup-markup 'scm0)
 219       (cons raise-markup 'scm0-markup1)
 220       (cons char-markup 'scm0)
 221       (cons hspace-markup 'scm0)
 222       (cons magnify-markup 'scm0-markup1)
 223       (cons fontsize-markup 'scm0-markup1)
 224       (cons translate-markup 'scm0-markup1)
 225       ))
 226
 227 (define markup-module (current-module))
 228
 229 (define-public (lookup-markup-command code)
 230   (let*
 231       ( (sym (string->symbol (string-append code "-markup")))
 232         (var (module-local-variable markup-module sym))
 233         )
 234     (if (eq? var #f)
 235         #f
 236         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-signature))
 237     )
 238   ))
 239
 240
 241 (define-public (brew-new-markup-molecule grob)
 242   (interpret-markup grob
 243                     (Font_interface::get_property_alist_chain grob)
 244                     (ly:get-grob-property grob 'text)
 245                     )
 246   )
 247
 248 (define-public empty-markup `(,simple-markup ""))
 249
 250 (define (interpret-markup  grob props markup)
 251   (let*
 252       (
 253        (func (car markup))
 254        (args (cdr markup))
 255        )
 256
 257     (apply func (cons grob (cons props args)) )
 258     ))
 259
 260
 261 (define (new-markup? x)
 262         (markup-function? (car x))
 263 )
 264
 265 (define (markup-function? x)
 266         (object-property 'markup-signature? x))
 267
 268