scm/new-markup.scm

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