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 (line-markup grob props . rest)
   6   (stack-molecules
   7    X 1 1.0
   8    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
   9   )
  10
  11 (define (combine-molecule-list lst)
  12   (if (null? (cdr lst)) (car lst)
  13       (ly:add-molecule (car lst) (combine-molecule-list (cdr lst)))
  14       ))
  15
  16 (define-public (combine-markup grob props . rest)
  17    (combine-molecule-list (map (lambda (x) (interpret-markup grob props x)) (car rest))))
  18
  19 (define (font-markup qualifier value)
  20   (lambda (grob props . rest)
  21     (interpret-markup grob (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
  22
  23   ))
  24
  25 (define-public (magnify-markup grob props . rest  )
  26   (interpret-markup grob
  27                     (cons (cons `(font-magnification . ,(car rest))
  28                                 (car props)) (cdr props))
  29                     (cadr rest))
  30   )
  31
  32 (define-public bold-markup
  33   (font-markup 'font-series 'bold))
  34 (define-public dynamic-markup
  35   (font-markup 'font-family 'dynamic))
  36 (define-public italic-markup
  37   (font-markup 'font-shape 'italic))
  38
  39
  40 ;; TODO: baseline-skip should come from the font.
  41 (define-public (column-markup grob props . rest)
  42   (stack-lines
  43    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
  44    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
  45   )
  46
  47 (define-public (music-markup grob props . rest)
  48   (ly:find-glyph-by-name
  49    (ly:get-font grob (cons '((font-family . music)) props))
  50    (car rest))
  51   )
  52
  53 (define-public (lookup-markup grob props . rest)
  54   "Lookup a glyph by name."
  55   (ly:find-glyph-by-name
  56    (ly:get-font grob props)
  57    (car rest))
  58   )
  59
  60 (define-public (char-markup grob props . rest)
  61   (ly:get-glyph  (ly:get-font grob props) (car rest))
  62
  63   )
  64 (define-public (raise-markup grob props  . rest)
  65   (ly:molecule-translate-axis (interpret-markup grob props (cadr rest))
  66                               (car rest) Y)
  67   )
  68
  69 ;; this is too simplistic: doesn't do backup for negative dimensions.
  70 (define (hspace-markup grob props . rest)
  71   (ly:make-molecule "" (cons 0 (car rest)) '(-1 . 1) )
  72   )
  73
  74 (define-public (override-markup grob props . rest)
  75   "Tack the 1st args in REST onto PROPS."
  76   (interpret-markup grob (cons (list (car rest)) props)
  77                     (cadr rest)))
  78
  79 (map (lambda (x)
  80        (set-object-property! (car x) 'markup-signature (cdr x))
  81        )
  82      (list (cons bold-markup 'markup0)
  83            (cons column-markup 'markup-list0)
  84            (cons line-markup  'markup-list0)
  85            (cons combine-markup 'markup0-markup1)
  86            (cons simple-markup 'markup0)
  87            (cons music-markup 'scm0)
  88            (cons override-markup 'scm0-markup1)
  89            (cons lookup-markup 'scm0)
  90            (cons raise-markup 'scm0-markup1)
  91            (cons italic-markup 'markup0)
  92            (cons dynamic-markup 'markup0)
  93            (cons char-markup 'scm0)
  94            (cons hspace-markup 'scm0)
  95            (cons magnify-markup 'scm0-markup1)
  96            ))
  97
  98
  99 (define markup-module (current-module))
 100
 101 (define-public (lookup-markup-command code)
 102   (let*
 103       ( (sym (string->symbol (string-append code "-markup")))
 104         (var (module-local-variable markup-module sym))
 105         )
 106     (if (eq? var #f)
 107         #f
 108         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-signature))
 109     )
 110   ))
 111
 112
 113 (define-public (brew-new-markup-molecule grob)
 114   (interpret-markup grob
 115                     (Font_interface::get_property_alist_chain grob)
 116                     (ly:get-grob-property grob 'text)
 117                     )
 118   )
 119
 120 (define (interpret-markup  grob props markup)
 121   (let*
 122       (
 123        (func (car markup))
 124        (args (cdr markup))
 125        )
 126
 127     (apply func (cons grob (cons props args)) )
 128     ))
 129
 130
 131 (define (new-markup? x)
 132         (markup-function? (car x))
 133 )
 134
 135 (define (markup-function? x)
 136         (object-property 'markup-signature? x))