measureCounterEngraver.ily

   1 \version "2.15.40"\r
   2 \r
   3 % All this code was copied and adapted from lilypond's input/regression/scheme-text-spanner.ly\r
   4 % The real measure counter engraver was done by David Nalesnik in April 2012\r
   5 % \r
   6 #(define my-grob-descriptions '())\r
   7 \r
   8 #(define my-event-classes (ly:make-context-mod))\r
   9 \r
  10 defineEventClass =\r
  11 #(define-void-function (parser location class parent)\r
  12    (symbol? symbol?)\r
  13    (ly:add-context-mod\r
  14     my-event-classes\r
  15     `(apply\r
  16       ,(lambda (context class parent)\r
  17          (ly:context-set-property!\r
  18           context\r
  19           'EventClasses\r
  20           (event-class-cons\r
  21            class\r
  22            parent\r
  23            (ly:context-property context 'EventClasses '()))))\r
  24       ,class ,parent)))\r
  25 \r
  26 \defineEventClass #'measure-counter-event #'span-event\r
  27 \r
  28 #(define (define-grob-property symbol type? description)\r
  29   (if (not (equal? (object-property symbol 'backend-doc) #f))\r
  30       (ly:error (_ "symbol ~S redefined") symbol))\r
  31 \r
  32   (set-object-property! symbol 'backend-type? type?)\r
  33   (set-object-property! symbol 'backend-doc description)\r
  34   symbol)\r
  35 \r
  36 #(map\r
  37   (lambda (x)\r
  38     (apply define-grob-property x))\r
  39 \r
  40   `(\r
  41     (counter ,integer? "initial number of a measure count")\r
  42   ))\r
  43 \r
  44 #(define (add-grob-definition grob-name grob-entry)\r
  45    (let* ((meta-entry   (assoc-get 'meta grob-entry))\r
  46           (class        (assoc-get 'class meta-entry))\r
  47           (ifaces-entry (assoc-get 'interfaces meta-entry)))\r
  48      (set-object-property! grob-name 'translation-type? list?)\r
  49      (set-object-property! grob-name 'is-grob? #t)\r
  50      (set! ifaces-entry (append (case class\r
  51                                   ((Item) '(item-interface))\r
  52                                   ((Spanner) '(spanner-interface))\r
  53                                   ((Paper_column) '((item-interface\r
  54                                                      paper-column-interface)))\r
  55                                   ((System) '((system-interface\r
  56                                                spanner-interface)))\r
  57                                   (else '(unknown-interface)))\r
  58                                 ifaces-entry))\r
  59      (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))\r
  60      (set! ifaces-entry (cons 'grob-interface ifaces-entry))\r
  61      (set! meta-entry (assoc-set! meta-entry 'name grob-name))\r
  62      (set! meta-entry (assoc-set! meta-entry 'interfaces\r
  63                                   ifaces-entry))\r
  64      (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))\r
  65      (set! my-grob-descriptions\r
  66            (cons (cons grob-name grob-entry)\r
  67                  my-grob-descriptions))))\r
  68 \r
  69 #(define-public (measure-counter-stencil grob)\r
  70   (let* ((elts (ly:grob-object grob 'elements))\r
  71          (refp (ly:grob-common-refpoint-of-array grob elts X))\r
  72          (col-L (ly:spanner-bound grob LEFT))\r
  73          (col-R (ly:spanner-bound grob RIGHT))\r
  74          (left-self-ext (ly:grob-extent col-L col-L X))\r
  75          (left-ext (ly:grob-extent col-L refp X))\r
  76          (right-ext (ly:grob-extent col-R refp X))\r
  77          (counter (ly:grob-property grob 'counter))\r
  78          (num (grob-interpret-markup grob (markup (number->string counter)))))\r
  79 \r
  80     (set! num (ly:stencil-aligned-to num X CENTER))\r
  81     (set! num (ly:stencil-translate-axis num (cdr left-self-ext) X))\r
  82     (set! num (ly:stencil-translate-axis num (* 0.5 (- (car right-ext) (cdr left-ext))) X))\r
  83 \r
  84     num))\r
  85 \r
  86 #(add-grob-definition\r
  87   'MeasureCounter\r
  88   `(\r
  89     (counter . 1)\r
  90     (direction . ,UP)\r
  91     (outside-staff-priority . 350) ; what should this be?\r
  92     (stencil . ,measure-counter-stencil)\r
  93     (font-encoding . 'feta-text )\r
  94     (meta . ((class . Spanner)\r
  95              (interfaces . (text-interface\r
  96                             text-script-interface\r
  97                             font-interface))))))\r
  98 \r
  99 #(define measure-counter-types\r
 100    '(\r
 101      (MeasureCounterEvent\r
 102       . ((description . "Used to signal the start and end of a measure counter.")\r
 103          (types . (general-music measure-counter-event span-event event))\r
 104          ))\r
 105      ))\r
 106 \r
 107 #(set!\r
 108   measure-counter-types\r
 109   (map (lambda (x)\r
 110          (set-object-property! (car x)\r
 111                                'music-description\r
 112                                (cdr (assq 'description (cdr x))))\r
 113          (let ((lst (cdr x)))\r
 114            (set! lst (assoc-set! lst 'name (car x)))\r
 115            (set! lst (assq-remove! lst 'description))\r
 116            (hashq-set! music-name-to-property-table (car x) lst)\r
 117            (cons (car x) lst)))\r
 118        measure-counter-types))\r
 119 \r
 120 #(set! music-descriptions\r
 121        (append measure-counter-types music-descriptions))\r
 122 \r
 123 #(set! music-descriptions\r
 124        (sort music-descriptions alist<?))\r
 125 \r
 126 measureCounterEngraver =\r
 127 #(lambda (context)\r
 128   (let ((span '())\r
 129         (go? #f)\r
 130         (stop? #f)\r
 131         (last-measure-seen 0)\r
 132         (new-measure? #f)\r
 133         (increment 0))\r
 134 \r
 135     `((listeners\r
 136       (measure-counter-event .\r
 137         ,(lambda (engraver event)\r
 138           (set! last-measure-seen (ly:context-property context 'currentBarNumber))\r
 139           (set! new-measure? #t)\r
 140           (if (= START (ly:event-property event 'span-direction))\r
 141               (set! go? #t)\r
 142               (begin\r
 143                 (set! stop? #t)\r
 144                 (set! go? #f))))))\r
 145 \r
 146       (process-music .\r
 147         ,(lambda (trans)\r
 148           (let ((col (ly:context-property context 'currentCommandColumn))\r
 149                 (now (ly:context-property context 'measurePosition))\r
 150                 (current-bar (ly:context-property context 'currentBarNumber)))\r
 151             ; if spanner has been started, make sure we're in a new bar before adding to it\r
 152             (if (and (pair? span) (> current-bar last-measure-seen))\r
 153                 (set! new-measure? #t))\r
 154             (if new-measure?\r
 155                 (begin\r
 156                   (if (moment<=? now ZERO-MOMENT) ; first column of measure\r
 157                       (begin\r
 158                         (if (and stop? (pair? span))\r
 159                             (begin\r
 160                               (ly:spanner-set-bound! (last span) RIGHT col)\r
 161                               (ly:pointer-group-interface::add-grob (last span) 'elements col)\r
 162                               (ly:engraver-announce-end-grob trans (last span) col)\r
 163                               (set! span '())\r
 164                               (set! increment 0)\r
 165                               (set! stop? #f)))\r
 166                         (if go?\r
 167                             (begin\r
 168                               ; add a right bound to the current spanner\r
 169                               (if (pair? span)\r
 170                                   (begin\r
 171                                     (ly:spanner-set-bound! (last span) RIGHT col)\r
 172                                     (ly:pointer-group-interface::add-grob (last span) 'elements col)\r
 173                                     (ly:engraver-announce-end-grob trans (last span) col)))\r
 174                               ; make a new spanner with the same column as left bound\r
 175                               (let* ((x (ly:engraver-make-grob trans 'MeasureCounter col))\r
 176                                      (counter (ly:grob-property x 'counter)))\r
 177                                 (ly:spanner-set-bound! x LEFT col)\r
 178                                 (ly:pointer-group-interface::add-grob x 'elements col)\r
 179                                 (set! (ly:grob-property x 'counter) (+ counter increment))\r
 180                                 (set! span (append span (list x)))\r
 181                                 (set! increment (1+ increment)))))))\r
 182                     (set! new-measure? #f)))\r
 183             (set! last-measure-seen current-bar)))))))\r
 184 \r
 185 \r
 186 measureCounterStart =\r
 187 #(make-span-event 'MeasureCounterEvent START)\r
 188 \r
 189 measureCounterEnd =\r
 190 #(make-span-event 'MeasureCounterEvent STOP)\r
 191 \r
 192 \layout {\r
 193   \context {\r
 194     \Global\r
 195     \grobdescriptions #my-grob-descriptions\r
 196     #my-event-classes\r
 197   }\r
 198   \context{\r
 199     \Staff\r
 200     \consists \measureCounterEngraver\r
 201     \override MeasureCounter #'font-encoding = #'fetaText\r
 202     \override MeasureCounter #'font-size = #-2\r
 203   }\r
 204 }\r
 205 partCombineListener = \layout {\r
 206   \partCombineListener\r
 207   \context {\r
 208     \Global\r
 209     \grobdescriptions #my-grob-descriptions\r
 210     #my-event-classes\r
 211   }\r
 212 }\r
 213 \r
 214 \r