common/custom-bars.ily

   1 %%% Custom bars
   2 %%% Author: Nicolas Sceaux <nicolas.sceaux@free.fr>
   3 %%%
   4 %%% This lib defines several new bar styles for LilyPond:
   5 %%% \bar ";"    a single dashed bar line
   6 %%%             no span-bar
   7 %%% \bar "|;:"  suggested repeat bar (on an existing bar):
   8 %%%             thin-line + dashed-line + two-dots
   9 %%%             thin span-bar
  10 %%% \bar ";:"   suggested repeat bar (on no existing bar):
  11 %%%             2 dashed-lines + two-dots
  12 %%%             no span-bar (FIXME?)
  13 %%% \bar ":;|"  suggested repeat bar (on an existing bar):
  14 %%%             two-dots + dashed-line + thin-line
  15 %%%             thin span-bar
  16 %%% \bar ":;"   suggested repeat bar (on no existing bar):
  17 %%%             two-dots + 2 dashed-lines
  18 %%%             no span-bar (FIXME?)
  19 %%% \bar "|:|"  old-style repeat bar: thick-line + dotted-line + thick-line
  20 %%%             no span-bar (FIXME?)
  21 %%% \bar ":||:" old-style repeat bar2: dotted-line + 2 thin-lines + dotted-line
  22 %%%             double thin span-bar
  23 %%% \bar "://:" old-style repeat bar3: two-dots + 2 thin-lines + two-dots
  24 %%%             double thin span-bar
  25 %%% \bar ";;"   2 dashed-lines
  26 %%%             no span-bar (FIXME?)
  27
  28 #(define-public (make-round-filled-box x1 x2 y1 y2 blot-diameter)
  29    (let* ((width (- x2 x1))
  30           (height (- y2 y1))
  31           (blot-diameter (cond ((< width blot-diameter) width)
  32                               ((< height blot-diameter) height)
  33                               (else blot-diameter))))
  34      (ly:make-stencil (list 'round-filled-box (- x1) x2 (- y1) y2 blot-diameter)
  35                       (cons x1 x2)
  36                       (cons y1 y2))))
  37
  38 #(define-public (make-simple-bar-line grob width rounded)
  39    (let* ((extent (ly:grob-property grob 'bar-extent))
  40           (height (interval-length extent))
  41           (blot-diameter (if rounded
  42                              (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter)
  43                              0)))
  44      (make-round-filled-box 0 width (/ height -2) (/ height 2) blot-diameter)))
  45
  46 #(define-public (make-dotted-bar-line grob)
  47    (let* ((extent (ly:grob-property grob 'bar-extent))
  48           (position (round (* (interval-end extent) 2)))
  49           (correction (if (even? position) 0.5 0.0))
  50           (stencil empty-stencil))
  51      (let ((e (round (+ (interval-end extent) (- 0.5 correction)))))
  52        (do ((i (round (+ (interval-start extent) (- 0.5 correction)))
  53                (1+ i)))
  54            ((>= i e))
  55          (set! stencil
  56                (ly:stencil-add stencil
  57                                (ly:stencil-translate-axis
  58                                 (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot")
  59                                 (+ i correction)
  60                                 Y)))))
  61      stencil))
  62
  63 #(define-public (make-dashed-bar-line grob thickness)
  64    (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
  65           (staff-extent (ly:grob-extent staff-symbol staff-symbol Y))
  66           (height (interval-length staff-extent))
  67           (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
  68           (staff-space (ly:staff-symbol-staff-space grob))
  69           (line-thickness (ly:staff-symbol-line-thickness grob))
  70           (line-count (ly:grob-property staff-symbol 'line-count 0)))
  71      (if (< (abs (+ line-thickness
  72                     (* (1- line-count) staff-space)
  73                     (- height)))
  74             0.1)
  75          (let ((blot (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
  76                (half-space (/ staff-space 2.0))
  77                (bar empty-stencil))
  78            (do ((i (1- line-count) (- i 2)))
  79                ((< i (- 1 line-count)))
  80                (let ((top-y (min (* (+ i dash-size) half-space)
  81                                  (+ (* (1- line-count) half-space) (/ line-thickness 2.0))))
  82                      (bot-y (max (* (- i dash-size) half-space)
  83                                  (- 0 (* (1- line-count) half-space) (/ line-thickness 2.0)))))
  84                  (set! bar (ly:stencil-add bar
  85                                            (make-round-filled-box 0 thickness bot-y top-y blot)))))
  86            bar)
  87          (let ((dashes (/ height staff-space))
  88                (total-dash-size (/ height dashes))
  89                (factor (/ (- dash-size thickness) staff-size)))
  90            (ly:make-stencil (list 'dashed-line
  91                                   thickness
  92                                   (* factor total-dash-size)
  93                                   (* (- 1 factor) total-dash-size)
  94                                   0
  95                                   height
  96                                   (* factor total-dash-size 0.5))
  97                             (cons 0 0)
  98                             (cons (/ thickness -2) (/ thickness 2)))))))
  99
 100 #(define-public (make-colon-bar-line grob)
 101    (let* ((dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
 102           (staff-symbol (ly:grob-object grob 'staff-symbol))
 103           (line-count (ly:grob-property staff-symbol 'line-count 0))
 104           (staff-space (ly:staff-symbol-staff-space grob))
 105           (dist (cond ((odd? line-count) 1)
 106                       ((= line-count 0) 1)
 107                       ((< staff-space 2) (* 2 staff-space))
 108                       (else (* 0.5 staff-space))))
 109           (colon empty-stencil))
 110      (set! colon (ly:stencil-add colon dot))
 111      (set! colon (ly:stencil-translate-axis colon dist Y))
 112      (set! colon (ly:stencil-add colon dot))
 113      (set! colon (ly:stencil-translate-axis colon (/ dist -2) Y))
 114      colon))
 115
 116 #(define-public (bar-line::print-baroque-repeat bar-line)
 117    (let ((glyph-name (ly:grob-property bar-line 'glyph-name))
 118          (dir (ly:item-break-dir bar-line)))
 119      (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line) 'line-thickness))
 120             (kern (* (ly:grob-property bar-line 'kern) staff-line))
 121             (thickness (* 1.5 (ly:grob-property bar-line 'hair-thickness) staff-line)))
 122        (ly:stencil-combine-at-edge
 123         (make-simple-bar-line bar-line thickness #t)
 124         X RIGHT
 125         (ly:stencil-combine-at-edge
 126          (make-dotted-bar-line bar-line)
 127          X RIGHT
 128          (make-simple-bar-line bar-line thickness #t)
 129          kern)
 130         kern))))
 131
 132 #(define-public (bar-line::print-baroque-repeat2 bar-line)
 133    (let ((glyph-name (ly:grob-property bar-line 'glyph-name))
 134          (dir (ly:item-break-dir bar-line)))
 135      (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line)
 136                                               'line-thickness))
 137             (kern (* (ly:grob-property bar-line 'kern 1) staff-line))
 138             (thin-kern (* (ly:grob-property bar-line 'thin-kern 1) staff-line))
 139             (thickness (* (ly:grob-property bar-line 'hair-thickness 1) staff-line))
 140             (stencil empty-stencil))
 141        (set! stencil (ly:stencil-combine-at-edge
 142                       stencil
 143                       X LEFT
 144                       (make-simple-bar-line bar-line thickness #f)
 145                       thin-kern))
 146        (set! stencil (ly:stencil-combine-at-edge
 147                       stencil
 148                       X RIGHT
 149                       (make-simple-bar-line bar-line thickness #f)
 150                       thin-kern))
 151        (set! stencil (ly:stencil-combine-at-edge
 152                       stencil
 153                       X LEFT
 154                       (make-dotted-bar-line bar-line)
 155                       kern))
 156        (set! stencil (ly:stencil-combine-at-edge
 157                       stencil
 158                       X RIGHT
 159                       (make-dotted-bar-line bar-line)
 160                       kern))
 161        stencil)))
 162
 163 #(define-public (bar-line::print-baroque-repeat3 bar-line)
 164    (let ((glyph-name (ly:grob-property bar-line 'glyph-name))
 165          (dir (ly:item-break-dir bar-line)))
 166      (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line)
 167                                               'line-thickness))
 168             (kern (* (ly:grob-property bar-line 'kern 1) staff-line))
 169             (thin-kern (* (ly:grob-property bar-line 'thin-kern 1) staff-line))
 170             (thickness (* (ly:grob-property bar-line 'hair-thickness 1) staff-line))
 171             (stencil empty-stencil))
 172        (set! stencil (ly:stencil-combine-at-edge
 173                       stencil
 174                       X LEFT
 175                       (make-simple-bar-line bar-line thickness #f)
 176                       thin-kern))
 177        (set! stencil (ly:stencil-combine-at-edge
 178                       stencil
 179                       X RIGHT
 180                       (make-simple-bar-line bar-line thickness #f)
 181                       thin-kern))
 182        (set! stencil (ly:stencil-combine-at-edge
 183                       stencil
 184                       X LEFT
 185                       (make-colon-bar-line bar-line)
 186                       kern))
 187        (set! stencil (ly:stencil-combine-at-edge
 188                       stencil
 189                       X RIGHT
 190                       (make-colon-bar-line bar-line)
 191                       kern))
 192        stencil)))
 193
 194 #(define-public ((bar-line::print-dashed-repeat is-start-bar with-solid-bar) bar-line)
 195    (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line) 'line-thickness))
 196           (thin-thickness (* (ly:grob-property bar-line 'hair-thickness) staff-line))
 197           (kern (* (ly:grob-property bar-line 'kern) staff-line))
 198           (staff-symbol (ly:grob-object bar-line 'staff-symbol))
 199           (center (interval-center (ly:grob-extent staff-symbol staff-symbol Y))))
 200      (let ((simple-line (make-simple-bar-line bar-line thin-thickness #f))
 201            (dashed-line (make-dashed-bar-line bar-line thin-thickness))
 202            (colon-line  (make-colon-bar-line bar-line))
 203            (stencil empty-stencil))
 204      (cond ((and with-solid-bar is-start-bar)
 205             ;; simple-bar + dashed-bar + colon
 206             (set! stencil simple-line)
 207             (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT dashed-line kern))
 208             (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT colon-line kern)))
 209            (with-solid-bar
 210             ;; colon + dashed-bar + simple-bar
 211             (set! stencil simple-line)
 212             (set! stencil (ly:stencil-combine-at-edge stencil X LEFT dashed-line kern))
 213             (set! stencil (ly:stencil-combine-at-edge stencil X LEFT colon-line kern)))
 214            (is-start-bar
 215             ;; dashed-bar + dashed-bar + colon
 216             (set! stencil dashed-line)
 217             (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT dashed-line kern))
 218             (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT colon-line kern)))
 219            (else
 220             ;; colon + dashed-bar + dashed-bar
 221             (set! stencil dashed-line)
 222             (set! stencil (ly:stencil-combine-at-edge stencil X LEFT dashed-line kern))
 223             (set! stencil (ly:stencil-combine-at-edge stencil X LEFT colon-line kern))))
 224        (set! stencil (ly:stencil-translate-axis stencil center Y))
 225        stencil)))
 226
 227 #(define-public (bar-line::print-dashed-bar bar-line)
 228    (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line) 'line-thickness))
 229           (thickness (* (ly:grob-property bar-line 'hair-thickness) staff-line)))
 230      (make-dashed-bar-line bar-line thickness)))
 231
 232 #(define-public (bar-line::print-dashed-dashed-bar bar-line)
 233    (let* ((staff-line (ly:output-def-lookup (ly:grob-layout bar-line)
 234                                             'line-thickness))
 235           (kern (* (ly:grob-property bar-line 'kern) staff-line))
 236           (thickness (* (ly:grob-property bar-line 'hair-thickness)
 237                         staff-line)))
 238      (ly:stencil-combine-at-edge
 239       (make-dashed-bar-line bar-line thickness)
 240       X RIGHT
 241       (make-dashed-bar-line bar-line thickness)
 242       kern)))
 243
 244 #(define custom-bar-glyph-print-functions
 245    `(("|:|" . ,bar-line::print-baroque-repeat)
 246      (":||:" . ,bar-line::print-baroque-repeat2)
 247      ("://:" . ,bar-line::print-baroque-repeat3)
 248      (";:" . ,(bar-line::print-dashed-repeat #t #f))
 249      (":;" . ,(bar-line::print-dashed-repeat #f #f))
 250      ("|;:" . ,(bar-line::print-dashed-repeat #t #t))
 251      (":;|" . ,(bar-line::print-dashed-repeat #f #t))
 252      (";" . ,bar-line::print-dashed-bar)
 253      (";;" . ,bar-line::print-dashed-dashed-bar)))
 254
 255 #(define-public (bar-line::custom-print grob)
 256    (let* ((glyph-name (ly:grob-property grob 'glyph-name))
 257           (print-proc (assoc-get glyph-name custom-bar-glyph-print-functions)))
 258      (if (procedure? print-proc)
 259          (print-proc grob)
 260          (ly:bar-line::print grob))))
 261
 262 #(define custom-bar-glyph-alist
 263    '(("|:|" . ("|:|" . ()))
 264      (":||:" . (":||:" . ()))
 265      ("://:" . ("://:" . ()))
 266      (";:" . (() . ";:"))
 267      (":;" . (":;" . ()))
 268      ("|;:" . ("|" . ";:"))
 269      (":;|" . (":;|" . ()))
 270      (";" . (";" . ()))
 271      (";;" . (";;" . ()))))
 272
 273 #(define-public (bar-line::custom-calc-glyph-name grob)
 274    (let ((glyph (ly:grob-property grob 'glyph))
 275          (dir (ly:item-break-dir grob)))
 276      (if (= dir CENTER)
 277          glyph
 278          (let ((result (assoc glyph custom-bar-glyph-alist)))
 279            (if (pair? result)
 280                (let ((glyph-name (if (= dir LEFT)
 281                                      (cadr result)
 282                                      (cddr result))))
 283                  (and (string? glyph-name)
 284                       glyph-name))
 285                (bar-line::calc-glyph-name grob))))))
 286
 287 #(define (index-cell cell dir)
 288   (if (equal? dir 1)
 289       (cdr cell)
 290       (car cell)))
 291
 292 #(define-public (bar-line::custom-calc-glyph-name grob)
 293   (let* ((glyph (ly:grob-property grob 'glyph))
 294          (dir (ly:item-break-dir grob)))
 295     (if (= dir CENTER)
 296         glyph
 297         (let ((result (assoc-get glyph custom-bar-glyph-alist)))
 298           (if result
 299               (and (string? (index-cell result dir))
 300                    (index-cell result dir))
 301               (bar-line::calc-glyph-name grob))))))
 302
 303 #(define-public (bar-line::custom-calc-break-visibility grob)
 304    (let* ((glyph (ly:grob-property grob 'glyph))
 305           (result (assoc-get glyph custom-bar-glyph-alist)))
 306      (if result
 307         (vector (string? (car result)) #t (string? (cdr result)))
 308         (bar-line::calc-break-visibility grob))))
 309
 310 #(define span-bar-glyph-name-alist
 311    '(("|;:" . "|")
 312      (":;|" . "|")
 313      (":||:" . "||")
 314      ("://:" . "||")
 315      (";" . "")
 316      (";;" . "")))
 317
 318 #(define-public (span-bar::custom-calc-glyph-name grob)
 319    (let* ((glyph #f)
 320           (array (ly:grob-object grob 'elements))
 321           (array-size (ly:grob-array-length array)))
 322      (do ((i 0 (1+ i)))
 323          ((>= i array-size))
 324          (let* ((element (ly:grob-array-ref array i))
 325                 (glyph-name (ly:grob-property element 'glyph-name)))
 326            (if (string? glyph-name)
 327                (set! glyph glyph-name))))
 328      (let ((span-glyph (and (string? glyph)
 329                             (assoc-get glyph span-bar-glyph-name-alist))))
 330        (if (string? span-glyph)
 331            span-glyph
 332            (ly:span-bar::calc-glyph-name grob)))))
 333
 334 \layout {
 335   \context {
 336     \Staff
 337     \name "Staff"
 338     \override BarLine #'glyph-name = #bar-line::custom-calc-glyph-name
 339     \override BarLine #'break-visibility = #bar-line::custom-calc-break-visibility
 340     \override BarLine #'stencil = #bar-line::custom-print
 341     \override BarLine #'Y-extent =
 342     #(ly:make-unpure-pure-container
 343       ly:grob::stencil-height
 344       (lambda (grob b e)
 345         (ly:grob::stencil-height grob)))
 346     \override SpanBar #'glyph-name = #span-bar::custom-calc-glyph-name
 347   }
 348   \context {
 349     \Score
 350     \override SpanBar #'glyph-name = #span-bar::custom-calc-glyph-name
 351   }
 352 }