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 grob props (cadr rest))
 109                               (car rest) Y)
 110   )
 111
 112 (define-public (super-markup grob props  . rest)
 113   "Syntax: \\super MARKUP. "
 114   (ly:molecule-translate-axis (interpret-markup grob props (car rest))
 115                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 116                               Y)
 117   )
 118
 119 (define-public (translate-markup grob props . rest)
 120   "Syntax: \\translate OFFSET MARKUP. "
 121   (ly:molecule-translate (interpret-markup  grob props (cadr rest))
 122                          (car rest))
 123
 124   )
 125
 126 (define-public (sub-markup grob props  . rest)
 127   "Syntax: \\sub MARKUP."
 128   (ly:molecule-translate-axis (interpret-markup grob props (car rest))
 129                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 130                               Y)
 131   )
 132
 133 ;; todo: fix negative space
 134 (define (hspace-markup grob props . rest)
 135   "Syntax: \\hspace NUMBER."
 136   (let*
 137       ((amount (car rest)))
 138     (if (> amount 0)
 139         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 140         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 141   ))
 142
 143 (define-public (override-markup grob props . rest)
 144   "Tack the 1st args in REST onto PROPS."
 145   (interpret-markup grob (cons (list (car rest)) props)
 146                     (cadr rest)))
 147
 148 (map (lambda (x)
 149        (set-object-property! (car x) 'markup-signature (cdr x))
 150        )
 151      (list
 152       (cons bold-markup 'markup0)
 153       (cons teeny-markup 'markup0)
 154       (cons tiny-markup 'markup0)
 155       (cons small-markup 'markup0)
 156       (cons italic-markup 'markup0)
 157       (cons dynamic-markup 'markup0)
 158       (cons large-markup 'markup0)
 159       (cons huge-markup 'markup0)
 160       (cons sub-markup 'markup0)
 161       (cons super-markup 'markup0)
 162       (cons number-markup 'markup0)
 163
 164       (cons column-markup 'markup-list0)
 165       (cons line-markup  'markup-list0)
 166
 167       (cons combine-markup 'markup0-markup1)
 168
 169       (cons simple-markup 'markup0)
 170       (cons musicglyph-markup 'scm0)
 171       (cons translate-markup 'scm0-markup1)
 172       (cons override-markup 'scm0-markup1)
 173       (cons lookup-markup 'scm0)
 174       (cons raise-markup 'scm0-markup1)
 175       (cons char-markup 'scm0)
 176       (cons hspace-markup 'scm0)
 177       (cons magnify-markup 'scm0-markup1)
 178       (cons fontsize-markup 'scm0-markup1)
 179       (cons translate-markup 'scm0-markup1)
 180       ))
 181
 182
 183 (define markup-module (current-module))
 184
 185 (define-public (lookup-markup-command code)
 186   (let*
 187       ( (sym (string->symbol (string-append code "-markup")))
 188         (var (module-local-variable markup-module sym))
 189         )
 190     (if (eq? var #f)
 191         #f
 192         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-signature))
 193     )
 194   ))
 195
 196
 197 (define-public (brew-new-markup-molecule grob)
 198   (interpret-markup grob
 199                     (Font_interface::get_property_alist_chain grob)
 200                     (ly:get-grob-property grob 'text)
 201                     )
 202   )
 203
 204 (define (interpret-markup  grob props markup)
 205   (let*
 206       (
 207        (func (car markup))
 208        (args (cdr markup))
 209        )
 210
 211     (apply func (cons grob (cons props args)) )
 212     ))
 213
 214
 215 (define (new-markup? x)
 216         (markup-function? (car x))
 217 )
 218
 219 (define (markup-function? x)
 220         (object-property 'markup-signature? x))