scm/fret-diagrams.scm

   1 ;;;; fret-diagrams.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004--2008 Carl D. Sorensen <c_sorensen@byu.edu>
   6
   7 (define (fret-parse-marking-list marking-list fret-count)
   8   (let* ((fret-range (list 1 fret-count))
   9          (barre-list '())
  10          (dot-list '())
  11          (xo-list '())
  12          (output-alist '()))
  13     (let parse-item ((mylist marking-list))
  14       (if (not (null? mylist))
  15           (let* ((my-item (car mylist)) (my-code (car my-item)))
  16             (cond
  17              ((or (eq? my-code 'open)(eq? my-code 'mute))
  18               (set! xo-list (cons* my-item xo-list)))
  19              ((eq? my-code 'barre)
  20               (set! barre-list (cons* (cdr my-item) barre-list)))
  21              ((eq? my-code 'place-fret)
  22               (set! dot-list (cons* (cdr my-item) dot-list))))
  23             (parse-item (cdr mylist)))))
  24     ;; calculate fret-range
  25     (let ((maxfret 0) (minfret 99))
  26       (let updatemax ((fret-list dot-list))
  27         (if (null? fret-list)
  28             '()
  29             (let ((fretval (second (car fret-list))))
  30               (if (> fretval maxfret) (set! maxfret fretval))
  31               (if (< fretval minfret) (set! minfret fretval))
  32               (updatemax (cdr fret-list)))))
  33       (if (> maxfret fret-count)
  34           (set! fret-range
  35                 (list minfret
  36                       (let ((upfret (- (+ minfret fret-count) 1)))
  37                         (if (> maxfret upfret) maxfret upfret)))))
  38       ; subtract fret from dots
  39       (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
  40     (acons 'fret-range fret-range
  41            (acons 'barre-list barre-list
  42                   (acons 'dot-list dot-list
  43                          (acons 'xo-list xo-list '()))))))
  44
  45 (define (subtract-base-fret base-fret dot-list)
  46   "Subtract @var{base-fret} from every fret in @var{dot-list}"
  47   (if (null? dot-list)
  48       '()
  49       (let ((this-list (car dot-list)))
  50         (cons* (list (car this-list) (- (second this-list) base-fret)
  51                      (if (null? (cddr this-list))
  52                          '()
  53                          (third this-list)))
  54                (subtract-base-fret base-fret (cdr dot-list))))))
  55
  56 (define (sans-serif-stencil layout props mag text)
  57   "Create a stencil in sans-serif font based on @var{layout} and @var{props}
  58 with magnification @var{mag} of the string @var{text}."
  59   (let* ((my-props
  60           (prepend-alist-chain
  61            'font-size (stepmag mag)
  62            (prepend-alist-chain 'font-family 'sans props))))
  63     (interpret-markup layout my-props text)))
  64
  65 (define (draw-strings string-count fret-range th size orientation)
  66   "Draw the string lines for a fret diagram with
  67 @var{string-count} strings and frets as indicated in @var{fret-range}.
  68 Line thickness is given by @var{th}, fret & string spacing by
  69 @var{size}.  Orientation is determined by @var{orientation}. "
  70   (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
  71          (sl (* (+ fret-count 1) size))
  72          (sth (* size th))
  73          (half-thickness (* sth 0.5))
  74          (gap (- size sth))
  75          (string-stencil
  76           (if (eq? orientation 'normal)
  77               (ly:make-stencil
  78                (list 'draw-line sth 0 0 0 sl)
  79                (cons (- half-thickness) half-thickness)
  80                (cons (- half-thickness) (+ sl half-thickness)))
  81               (ly:make-stencil
  82                (list 'draw-line sth 0 0 sl 0)
  83                (cons (- half-thickness) (+ sl half-thickness))
  84                (cons (- half-thickness) half-thickness)))))
  85     (if (= string-count 1)
  86         string-stencil
  87         (if (eq? orientation 'normal)
  88             (ly:stencil-combine-at-edge
  89              (draw-strings (- string-count 1) fret-range th size orientation)
  90              X RIGHT
  91              string-stencil
  92              gap)
  93             (ly:stencil-combine-at-edge
  94              (draw-strings (- string-count 1) fret-range th size orientation)
  95              Y UP
  96              string-stencil
  97              gap)))))
  98
  99 (define (draw-fret-lines fret-count string-count th size orientation)
 100   "Draw @var{fret-count} fret lines for a fret diagram
 101 with @var{string-count} strings.  Line thickness is given by @var{th},
 102 fret & string spacing by @var{size}. Orientation is given by @var{orientation}"
 103   (let* ((sth (* size th))
 104          (gap (- size sth))
 105          (fret-line (draw-fret-line string-count th size orientation)))
 106     (if (= fret-count 1)
 107         fret-line
 108         (if (eq? orientation 'normal)
 109             (ly:stencil-combine-at-edge
 110              (draw-fret-lines
 111               (- fret-count 1) string-count th size orientation)
 112              Y UP
 113              fret-line
 114              gap 0)
 115             (ly:stencil-combine-at-edge
 116              (draw-fret-lines
 117               (- fret-count 1) string-count th size orientation)
 118              X RIGHT
 119              fret-line
 120              gap 0)))))
 121
 122 (define (draw-fret-line string-count th size orientation)
 123   "Draw a fret line for a fret diagram."
 124   (let* ((fret-length (* (- string-count 1) size))
 125          (sth (* size th))
 126          (half-thickness (* sth 0.5)))
 127     (if (eq? orientation 'normal)
 128         (ly:make-stencil
 129          (list 'draw-line sth half-thickness size
 130                (- fret-length half-thickness) size)
 131          (cons 0 fret-length)
 132          (cons (- half-thickness) half-thickness))
 133         (ly:make-stencil
 134          (list 'draw-line sth 0 half-thickness
 135                0 (- fret-length half-thickness))
 136          (cons (- half-thickness) half-thickness)
 137          (cons 0 fret-length)))))
 138
 139 (define (draw-thick-zero-fret details string-count th size orientation)
 140   "Draw a thick zeroth fret for a fret diagram whose base fret is not 1."
 141   (let* ((sth (* th size))
 142          (top-fret-thick
 143           (* sth (assoc-get 'top-fret-thickness details 3.0)))
 144          (half-thick (* sth 0.5))
 145          (x1 half-thick)
 146          (x2 (+ half-thick (* size (- string-count 1))))
 147          (y1 (- half-thick))
 148          (y2 (+ top-fret-thick half-thick))
 149          (x-extent (cons (- x1) x2))
 150          (y-extent (cons sth top-fret-thick)))
 151     (if (eq? orientation 'normal)
 152         (ly:make-stencil (list 'round-filled-box x1 x2 y1 y2 sth)
 153                          x-extent y-extent)
 154         (ly:make-stencil (list 'round-filled-box y1 y2 x1 x2 sth)
 155                          y-extent x-extent))))
 156
 157 (define (draw-frets fret-range string-count th size orientation)
 158   "Draw the fret lines for a fret diagram with
 159 @var{string-count} strings and frets as indicated in @var{fret-range}.
 160 Line thickness is given by @var{th}, fret & string spacing by
 161 @var{size}. Orientation is given by @var{orientation}."
 162   (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
 163          (fret-length (* (- string-count 1) size))
 164          (half-thickness (* th 0.5))
 165          (base-fret (car fret-range))
 166          (fret-zero (draw-fret-line string-count th size orientation)))
 167     (if (eq? orientation 'normal)
 168         (ly:stencil-combine-at-edge
 169          (draw-fret-lines fret-count string-count th size orientation)
 170          Y UP
 171          fret-zero
 172          (- size th))
 173         (ly:stencil-combine-at-edge
 174          fret-zero X RIGHT
 175          (draw-fret-lines fret-count string-count th size orientation)
 176          (- size th)))))
 177
 178 (define (draw-dots layout props string-count fret-count
 179                    fret-range size finger-code
 180                    dot-position dot-radius dot-thickness dot-list orientation)
 181   "Make dots for fret diagram."
 182
 183   (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
 184          (scale-dot-radius (* size dot-radius))
 185          (scale-dot-thick (* size dot-thickness))
 186          (dot-color (assoc-get 'dot-color details 'black))
 187          (finger-xoffset -0.25)
 188          (finger-yoffset (* -0.5 size ))
 189          (dot-label-font-mag
 190           (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
 191          (string-label-font-mag
 192           (* size (assoc-get 'string-label-font-mag details 0.6)))
 193          (mypair (car dot-list))
 194          (restlist (cdr dot-list))
 195          (string (car mypair))
 196          (fret (cadr mypair))
 197          (xpos (* size (if (eq? orientation 'normal)
 198                            (- string-count string)
 199                            (+ (- fret 1 ) dot-position))))
 200          (ypos (* size (if (eq? orientation 'normal)
 201                            (+ 2 (- fret-count fret dot-position ))
 202                            (- string-count string))))
 203          (extent (cons (- scale-dot-radius) scale-dot-radius))
 204          (finger (caddr mypair))
 205          (finger (if (number? finger) (number->string finger) finger))
 206          (dotstencil (if (eq? dot-color 'white)
 207                          (ly:stencil-add
 208                           (make-circle-stencil
 209                            scale-dot-radius scale-dot-thick #t)
 210                           (ly:stencil-in-color
 211                            (make-circle-stencil
 212                             (- scale-dot-radius (* 0.5 scale-dot-thick))
 213                             0  #t)
 214                            1 1 1))
 215                          (make-circle-stencil
 216                           scale-dot-radius scale-dot-thick #t)))
 217          (positioned-dot (begin
 218                            (ly:stencil-translate-axis
 219                             (ly:stencil-translate-axis dotstencil xpos X)
 220                             ypos Y)))
 221          (labeled-dot-stencil
 222           (if (or (eq? finger '())(eq? finger-code 'none))
 223               positioned-dot
 224               (if (eq? finger-code 'in-dot)
 225                   (let* ((finger-label
 226                           (centered-stencil
 227                            (sans-serif-stencil
 228                             layout props dot-label-font-mag finger))))
 229                     (ly:stencil-translate-axis
 230                      (ly:stencil-translate-axis
 231                       (ly:stencil-add
 232                        dotstencil
 233                        (if (eq? dot-color 'white)
 234                            finger-label
 235                            (ly:stencil-in-color finger-label 1 1 1)))
 236                       xpos X)
 237                      ypos Y))
 238                   (if (eq? finger-code 'below-string)
 239                       (ly:stencil-add
 240                        positioned-dot
 241                        (if (eq? orientation 'normal)
 242                            (ly:stencil-translate-axis
 243                             (ly:stencil-translate-axis
 244                              (centered-stencil
 245                               (sans-serif-stencil
 246                                layout props string-label-font-mag finger))
 247                              xpos X)
 248                             (* size finger-yoffset) Y)
 249                            (ly:stencil-translate-axis
 250                             (ly:stencil-translate-axis
 251                              (centered-stencil
 252                               (sans-serif-stencil
 253                                layout props string-label-font-mag finger))
 254                              (* size (+ 2 fret-count finger-yoffset)) X)
 255                             ypos Y)))
 256                       ;unknown finger-code
 257                       positioned-dot)))))
 258     (if (null? restlist)
 259         labeled-dot-stencil
 260         (ly:stencil-add
 261          (draw-dots
 262           layout props string-count fret-count fret-range size finger-code
 263           dot-position dot-radius dot-thickness restlist orientation)
 264          labeled-dot-stencil))))
 265
 266 (define (draw-xo layout props string-count fret-range size xo-list orientation)
 267   "Put open and mute string indications on diagram, as contained in
 268 @var{xo-list}."
 269   (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
 270          (fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
 271          (xo-font-mag
 272           (* size (assoc-get 'xo-font-magnification details 0.5)))
 273          (xo-horizontal-offset (* size -0.35))
 274          (mypair (car xo-list))
 275          (restlist (cdr xo-list))
 276          (glyph-string (if (eq? (car mypair) 'mute)
 277                            (assoc-get 'mute-string details "X")
 278                            (assoc-get 'open-string details "O")))
 279          (xpos
 280           (+ (* (- string-count (cadr mypair)) size) xo-horizontal-offset ))
 281          (glyph-stencil (if (eq? orientation 'normal)
 282                             (ly:stencil-translate-axis
 283                              (sans-serif-stencil
 284                               layout props (* size xo-font-mag) glyph-string)
 285                              xpos X)
 286                             (ly:stencil-translate-axis
 287                              (sans-serif-stencil
 288                               layout props (* size xo-font-mag) glyph-string)
 289                              xpos Y))))
 290     (if (null? restlist)
 291         glyph-stencil
 292         (ly:stencil-add
 293          (draw-xo
 294           layout props string-count fret-range size restlist orientation)
 295          glyph-stencil))))
 296
 297 (define (make-bezier-sandwich-list start stop base height thickness orientation)
 298   "Make the argument list for a bezier sandwich from
 299 @var{start} to @var{stop} with a baseline at @var{base}, a height of
 300 @var{height}, and a thickness of @var{thickness}.  If @var{orientation} is
 301 @var{'normal}, @var{base} is a y coordinate, otherwise it's an x coordinate."
 302   (let* ((width (+ (- stop start) 1))
 303          (x1 (+ (* width thickness) start))
 304          (x2 (- stop (* width thickness)))
 305          (bottom-control-point-height
 306           (if (eq? orientation 'normal)
 307               (+ base (- height thickness))
 308               (- base (- height thickness))))
 309          (top-control-point-height
 310           (if (eq? orientation 'normal)
 311               (+ base height)
 312               (- base height))))
 313  ; order of bezier control points is:
 314  ;    left cp low, right cp low, right end low, left end low
 315  ;    right cp high, left cp high, left end high, right end high.
 316     (if (eq? orientation 'normal)
 317         (list (cons x1 bottom-control-point-height)
 318               (cons x2 bottom-control-point-height)
 319               (cons stop base)
 320               (cons start base)
 321               (cons x2 top-control-point-height)
 322               (cons x1 top-control-point-height)
 323               (cons start base)
 324               (cons stop base))
 325         (list (cons bottom-control-point-height x1)
 326               (cons bottom-control-point-height x2)
 327               (cons base stop)
 328               (cons base start)
 329               (cons top-control-point-height x2)
 330               (cons top-control-point-height x1)
 331               (cons base start)
 332               (cons base stop)))))
 333
 334 (define (draw-barre layout props string-count fret-range
 335                     size finger-code dot-position dot-radius
 336                     barre-list orientation)
 337   "Create barre indications for a fret diagram"
 338   (if (not (null? barre-list))
 339       (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
 340              (string1 (caar barre-list))
 341              (string2 (cadar barre-list))
 342              (fret (caddar barre-list))
 343              (top-fret (cadr fret-range))
 344              (low-fret (car fret-range))
 345              (barre-type (assoc-get 'barre-type details 'curved))
 346              (scale-dot-radius (* size dot-radius))
 347              (barre-vertical-offset 0.5)
 348              ;; 2 is 1 for empty fret at bottom of figure + 1 for interval
 349              ;; (top-fret - fret + 1) -- not an arbitrary constant
 350              (dot-center-y
 351               (* size (- (+ 2 (- (cadr fret-range) fret)) dot-position)))
 352              (dot-center-fret-coordinate (+ (- fret low-fret) dot-position))
 353              (barre-fret-coordinate
 354               (+ dot-center-fret-coordinate
 355                  (* (- barre-vertical-offset 0.5) dot-radius)))
 356              (barre-start-string-coordinate (- string-count string1))
 357              (barre-end-string-coordinate (- string-count string2))
 358              (bottom
 359               (+ dot-center-y (* barre-vertical-offset scale-dot-radius)))
 360              (left (* size (- string-count string1)))
 361              (right (* size (- string-count string2)))
 362              (bezier-thick 0.1)
 363              (bezier-height 0.5)
 364              (bezier-list
 365               (if (eq? orientation 'normal)
 366                   (make-bezier-sandwich-list
 367                    (* size barre-start-string-coordinate)
 368                    (* size barre-end-string-coordinate)
 369                    (* size (+ 2 (- top-fret
 370                                    (+ low-fret barre-fret-coordinate))))
 371                    (* size bezier-height)
 372                    (* size bezier-thick)
 373                    orientation)
 374                   (make-bezier-sandwich-list
 375                    (* size barre-start-string-coordinate)
 376                    (* size barre-end-string-coordinate)
 377                    (* size barre-fret-coordinate)
 378                    (* size bezier-height)
 379                    (* size bezier-thick)
 380                    orientation)))
 381              (barre-stencil
 382               (if (eq? barre-type 'straight)
 383                   (if (eq? orientation 'normal)
 384                       (ly:make-stencil
 385                        (list
 386                         'draw-line (* size dot-radius) left dot-center-y
 387                         right dot-center-y)
 388                        (cons left right)
 389                        (cons (- dot-center-y scale-dot-radius)
 390                              (+ dot-center-y scale-dot-radius)))
 391                       (ly:make-stencil
 392                        (list 'draw-line (* size dot-radius)
 393                              (* size barre-fret-coordinate)
 394                              (* size barre-start-string-coordinate)
 395                              (* size barre-fret-coordinate)
 396                              (* size barre-end-string-coordinate))
 397                        (cons (- (* size barre-fret-coordinate)
 398                                 scale-dot-radius)
 399                              (+ (* size barre-fret-coordinate)
 400                                 scale-dot-radius))
 401                        (cons (* size barre-start-string-coordinate)
 402                              (* size barre-end-string-coordinate))))
 403                   (if (eq? orientation 'normal)
 404                       (ly:make-stencil
 405                        (list 'bezier-sandwich
 406                              `(quote ,bezier-list)
 407                              (* size bezier-thick))
 408                        (cons left right)
 409                        (cons bottom (+ bottom (* size bezier-height))))
 410                       (ly:make-stencil
 411                        (list 'bezier-sandwich
 412                              `(quote ,bezier-list)
 413                              (* size bezier-thick))
 414                        (cons bottom (+ bottom (* size bezier-height)))
 415                        (cons left right))))))
 416         (if (not (null? (cdr barre-list)))
 417             (ly:stencil-add
 418              barre-stencil
 419              (draw-barre layout props string-count fret-range size finger-code
 420                          dot-position dot-radius (cdr barre-list)))
 421             barre-stencil ))))
 422
 423 (define (stepmag mag)
 424   "Calculate the font step necessary to get a desired magnification"
 425   (* 6 (/ (log mag) (log 2))))
 426
 427 (define (label-fret layout props string-count fret-range size orientation)
 428   "Label the base fret on a fret diagram"
 429   (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
 430          (base-fret (car fret-range))
 431          (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
 432          (label-vertical-offset
 433           (assoc-get 'fret-label-vertical-offset details -0.2))
 434          (number-type (assoc-get 'number-type details 'roman-lower))
 435          (fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
 436          (label-text
 437           (cond
 438            ((equal? number-type 'roman-lower)
 439             (fancy-format #f "~(~@r~)" base-fret))
 440            ((equal? number-type 'roman-upper)
 441             (fancy-format #f "~@r" base-fret))
 442            ((equal? 'arabic number-type)
 443             (fancy-format #f "~d" base-fret))
 444            (else (fancy-format #f "~(~@r~)" base-fret)))))
 445     (if (eq? orientation 'normal)
 446         (ly:stencil-translate-axis
 447          (sans-serif-stencil layout props (* size label-font-mag) label-text)
 448          (* size (+ fret-count label-vertical-offset)) Y)
 449         (ly:stencil-translate-axis
 450          (sans-serif-stencil layout props (* size label-font-mag) label-text)
 451          (* size (+ 1 label-vertical-offset)) X))))
 452
 453 (define-builtin-markup-command (fret-diagram-verbose layout props marking-list)
 454   (list?) ; argument type
 455   fret-diagram ; markup type
 456   ((align-dir -0.4) ; properties and defaults
 457    (size 1.0)
 458    (fret-diagram-details)
 459    (thickness 0.5))
 460   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
 461
 462   For example,
 463
 464 @example
 465 \\markup \\fret-diagram-verbose
 466   #'((mute 6) (mute 5) (open 4)
 467      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
 468 @end example
 469
 470 @noindent
 471 produces a standard D@tie{}chord diagram without fingering indications.
 472
 473 Possible elements in @var{marking-list}:
 474
 475 @table @code
 476 @item (mute @var{string-number})
 477 Place a small @q{x} at the top of string @var{string-number}.
 478
 479 @item (open @var{string-number})
 480 Place a small @q{o} at the top of string @var{string-number}.
 481
 482 @item (barre @var{start-string} @var{end-string} @var{fret-number})
 483 Place a barre indicator (much like a tie) from string @var{start-string}
 484 to string @var{end-string} at fret @var{fret-number}.
 485
 486 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
 487 Place a fret playing indication on string @var{string-number} at fret
 488 @var{fret-number} with an optional fingering label @var{finger-value}.
 489 By default, the fret playing indicator is a solid dot.  This can be
 490 changed by setting the value of the variable @var{dot-color}.  If the
 491 @var{finger} part of the @code{place-fret} element is present,
 492 @var{finger-value} will be displayed according to the setting of the
 493 variable @var{finger-code}.  There is no limit to the number of fret
 494 indications per string.
 495 @end table"
 496
 497   (make-fret-diagram layout props marking-list))
 498
 499 (define (make-fret-diagram layout props marking-list)
 500   "Make a fret diagram markup"
 501   (let* (
 502          ; note: here we get items from props that are needed in this routine,
 503          ; or that are needed in more than one of the procedures
 504          ; called from this routine.  If they're only used in one of the
 505          ; sub-procedure, they're obtained in that procedure
 506          (size (chain-assoc-get 'size props 1.0)) ; needed for everything
 507 ;TODO -- get string-count directly from length of stringTunings;
 508 ;         from FretBoard engraver, but not from markup call
 509 ;TODO -- adjust padding for fret label?  it appears to be too close to dots
 510          (details
 511           (chain-assoc-get
 512            'fret-diagram-details props '())) ; fret diagram details
 513          (string-count
 514           (assoc-get 'string-count details 6)) ; needed for everything
 515          (fret-count
 516           (assoc-get 'fret-count details 4)) ; needed for everything
 517          (orientation
 518           (assoc-get 'orientation details 'normal)) ; needed for everything
 519          (finger-code
 520           (assoc-get
 521            'finger-code details 'none)) ; needed for draw-dots and draw-barre
 522          (default-dot-radius
 523            (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
 524          (default-dot-position
 525            (if (eq? finger-code 'in-dot)
 526                (- 0.95 default-dot-radius)
 527                0.6)) ; move up to make room for bigger if labeled
 528          (dot-radius
 529           (assoc-get
 530            'dot-radius details default-dot-radius))  ; needed for draw-dots
 531                                                      ; and draw-barre
 532          (dot-position
 533           (assoc-get
 534            'dot-position details default-dot-position)) ; needed for draw-dots
 535                                                         ; and draw-barre
 536          (th
 537           (* (ly:output-def-lookup layout 'line-thickness)
 538              (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
 539                                                       ; and draw-strings
 540          (alignment
 541           (chain-assoc-get 'align-dir props -0.4)) ; needed only here
 542          (xo-padding
 543           (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
 544          (label-space (* 0.25 size))
 545          (label-dir (assoc-get 'label-dir details RIGHT))
 546          (parameters (fret-parse-marking-list marking-list fret-count))
 547          (dot-list (cdr (assoc 'dot-list parameters)))
 548          (xo-list (cdr (assoc 'xo-list parameters)))
 549          (fret-range (cdr (assoc 'fret-range parameters)))
 550          (barre-list (cdr (assoc 'barre-list parameters)))
 551          (fret-diagram-stencil
 552           (ly:stencil-add
 553            (draw-strings string-count fret-range th size orientation)
 554            (draw-frets fret-range string-count th size orientation))))
 555     (if (not (null? barre-list))
 556         (set! fret-diagram-stencil
 557               (ly:stencil-add
 558                (draw-barre layout props string-count fret-range size
 559                            finger-code dot-position dot-radius
 560                            barre-list orientation)
 561                fret-diagram-stencil)))
 562     (if (not (null? dot-list))
 563         (set! fret-diagram-stencil
 564               (ly:stencil-add
 565                fret-diagram-stencil
 566                (draw-dots layout props string-count fret-count fret-range
 567                           size finger-code dot-position dot-radius
 568                           th dot-list orientation))))
 569     (if (= (car fret-range) 1)
 570         (set! fret-diagram-stencil
 571               (if (eq? orientation 'normal)
 572                   (ly:stencil-combine-at-edge
 573                    fret-diagram-stencil Y UP
 574                    (draw-thick-zero-fret
 575                     props string-count th size orientation))
 576                   (ly:stencil-combine-at-edge
 577                    fret-diagram-stencil X LEFT
 578                    (draw-thick-zero-fret
 579                     props string-count th size orientation)))))
 580     (if (not (null? xo-list))
 581         (set! fret-diagram-stencil
 582               (if (eq? orientation 'normal)
 583                   (ly:stencil-combine-at-edge
 584                    fret-diagram-stencil Y UP
 585                    (draw-xo layout props string-count fret-range
 586                             size xo-list orientation)
 587                    xo-padding )
 588                   (ly:stencil-combine-at-edge
 589                    fret-diagram-stencil X LEFT
 590                    (draw-xo layout props string-count fret-range
 591                             size xo-list orientation)
 592                    xo-padding))))
 593     (if (> (car fret-range) 1)
 594         (set! fret-diagram-stencil
 595               (if (eq? orientation 'normal)
 596                   (ly:stencil-combine-at-edge
 597                    fret-diagram-stencil X label-dir
 598                    (label-fret layout props string-count fret-range
 599                                size orientation)
 600                    label-space)
 601                   (ly:stencil-combine-at-edge
 602                    fret-diagram-stencil Y label-dir
 603                    (label-fret layout props string-count fret-range
 604                                size orientation)
 605                    label-space))))
 606     (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
 607
 608 (define-builtin-markup-command (fret-diagram layout props definition-string)
 609   (string?) ; argument type
 610   fret-diagram ; markup category
 611   (fret-diagram-verbose-markup) ; properties and defaults
 612   "Make a (guitar) fret diagram.  For example, say
 613
 614 @example
 615 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
 616 @end example
 617
 618 @noindent
 619 for fret spacing 3/4 of staff space, D chord diagram
 620
 621 Syntax rules for @var{definition-string}:
 622 @itemize @minus
 623
 624 @item
 625 Diagram items are separated by semicolons.
 626
 627 @item
 628 Possible items:
 629
 630 @itemize @bullet
 631 @item
 632 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
 633 spaces).
 634 Default:@tie{}1.
 635
 636 @item
 637 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
 638 Default:@tie{}0.05.
 639
 640 @item
 641 @code{h:}@var{number} -- Set the height of the diagram in frets.
 642 Default:@tie{}4.
 643
 644 @item
 645 @code{w:}@var{number} -- Set the width of the diagram in strings.
 646 Default:@tie{}6.
 647
 648 @item
 649 @code{f:}@var{number} -- Set fingering label type
 650  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
 651 Default:@tie{}0.
 652
 653 @item
 654 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
 655 Default:@tie{}0.25.
 656
 657 @item
 658 @code{p:}@var{number} -- Set the position of the dot in the fret space.
 659 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
 660 Default:@tie{}0.6.
 661
 662 @item
 663 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
 664 barre mark from @var{string1} to @var{string2} on @var{fret}.
 665
 666 @item
 667 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
 668 If @var{fret} is @samp{o}, @var{string} is identified as open.
 669 If @var{fret} is @samp{x}, @var{string} is identified as muted.
 670
 671 @item
 672 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
 673 @var{string} at @var{fret}, and label with @var{fingering} as defined
 674 by the @code{f:} code.
 675 @end itemize
 676
 677 @item
 678 Note: There is no limit to the number of fret indications per string.
 679 @end itemize"
 680   (let ((definition-list
 681           (fret-parse-definition-string props definition-string)))
 682     (fret-diagram-verbose-markup
 683      layout (car definition-list) (cdr definition-list))))
 684
 685 (define (fret-parse-definition-string props definition-string)
 686  "Parse a fret diagram string and return a pair containing:
 687   props, modified as necessary by the definition-string
 688   a fret-indication list with the appropriate values"
 689  (let* ((fret-count 4)
 690         (string-count 6)
 691         (fret-range (list 1 fret-count))
 692         (barre-list '())
 693         (dot-list '())
 694         (xo-list '())
 695         (output-list '())
 696         (new-props '())
 697         (details (merge-details 'fret-diagram-details props '()))
 698         (items (string-split definition-string #\;)))
 699    (let parse-item ((myitems items))
 700      (if (not (null? (cdr myitems)))
 701          (let ((test-string (car myitems)))
 702            (case (car (string->list (substring test-string 0 1)))
 703              ((#\s) (let ((size (get-numeric-from-key test-string)))
 704                       (set! props (prepend-alist-chain 'size size props))))
 705              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 706                            (finger-id (case finger-code
 707                                         ((0) 'none)
 708                                         ((1) 'in-dot)
 709                                         ((2) 'below-string))))
 710                       (set! details
 711                             (acons 'finger-code finger-id details))))
 712              ((#\c) (set! output-list
 713                           (cons-fret
 714                            (cons
 715                             'barre
 716                             (numerify
 717                              (string-split (substring test-string 2) #\-)))
 718                            output-list)))
 719              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 720                       (set! details
 721                             (acons 'fret-count fret-count details))))
 722              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 723                       (set! details
 724                             (acons 'string-count string-count details))))
 725              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 726                       (set! details
 727                             (acons 'dot-radius dot-size details))))
 728              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 729                       (set! details
 730                             (acons 'dot-position dot-position details))))
 731              (else
 732               (let ((this-list (string-split test-string #\-)))
 733                 (if (string->number (cadr this-list))
 734                     (set! output-list
 735                           (cons-fret
 736                            (cons 'place-fret (numerify this-list))
 737                            output-list))
 738                     (if (equal? (cadr this-list) "x" )
 739                         (set! output-list
 740                               (cons-fret
 741                                (list 'mute (string->number (car this-list)))
 742                                output-list))
 743                         (set! output-list
 744                               (cons-fret
 745                                (list 'open (string->number (car this-list)))
 746                                output-list)))))))
 747            (parse-item (cdr myitems)))))
 748    ;  add the modified details
 749    (set! props
 750          (prepend-alist-chain 'fret-diagram-details details props))
 751    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 752
 753 (define (cons-fret new-value old-list)
 754   "Put together a fret-list in the format desired by parse-string"
 755   (if (eq? old-list '())
 756       (list new-value)
 757       (cons* new-value old-list)))
 758
 759 (define (get-numeric-from-key keystring)
 760   "Get the numeric value from a key of the form k:val"
 761   (string->number (substring keystring 2 (string-length keystring))))
 762
 763 (define (numerify mylist)
 764   "Convert string values to numeric or character"
 765   (if (null? mylist)
 766       '()
 767       (let ((numeric-value (string->number (car mylist))))
 768         (if numeric-value
 769             (cons* numeric-value (numerify (cdr mylist)))
 770             (cons* (car (string->list (car mylist)))
 771                    (numerify (cdr mylist)))))))
 772
 773 (define-builtin-markup-command
 774   (fret-diagram-terse layout props definition-string)
 775   (string?) ; argument type
 776   fret-diagram ; markup category
 777   (fret-diagram-verbose-markup) ; properties
 778   "Make a fret diagram markup using terse string-based syntax.
 779
 780 Here is an example
 781
 782 @example
 783 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
 784 @end example
 785
 786 @noindent
 787 for a D@tie{}chord diagram.
 788
 789 Syntax rules for @var{definition-string}:
 790
 791 @itemize @bullet
 792
 793 @item
 794 Strings are terminated by semicolons; the number of semicolons
 795 is the number of strings in the diagram.
 796
 797 @item
 798 Mute strings are indicated by @samp{x}.
 799
 800 @item
 801 Open strings are indicated by @samp{o}.
 802
 803 @item
 804 A number indicates a fret indication at that fret.
 805
 806 @item
 807 If there are multiple fret indicators desired on a string, they
 808 should be separated by spaces.
 809
 810 @item
 811 Fingerings are given by following the fret number with a @code{-},
 812 followed by the finger indicator, e.g. @samp{3-2} for playing the third
 813 fret with the second finger.
 814
 815 @item
 816 Where a barre indicator is desired, follow the fret (or fingering) symbol
 817 with @code{-(} to start a barre and @code{-)} to end the barre.
 818
 819 @end itemize"
 820   ;; TODO -- change syntax to fret\string-finger
 821   (let ((definition-list
 822           (fret-parse-terse-definition-string props definition-string)))
 823     (fret-diagram-verbose-markup layout
 824                                  (car definition-list)
 825                                  (cdr definition-list))))
 826
 827 (define-public
 828   (fret-parse-terse-definition-string props definition-string)
 829   "Parse a fret diagram string that uses terse syntax; return a pair containing:
 830     props, modified to include the string-count determined by the
 831     definition-string, and
 832     a fret-indication list with the appropriate values"
 833 ;TODO -- change syntax to fret\string-finger
 834
 835   (let* ((details (merge-details 'fret-diagram-details props '()))
 836          (barre-start-list '())
 837          (output-list '())
 838          (new-props '())
 839          (items (string-split definition-string #\;))
 840          (string-count (- (length items) 1)))
 841     (let parse-item ((myitems items))
 842       (if (not (null? (cdr myitems)))
 843           (let* ((test-string (car myitems))
 844                  (current-string (- (length myitems) 1))
 845                  (indicators (string-split test-string #\ )))
 846             (let parse-indicators ((myindicators indicators))
 847               (if (not (eq? '() myindicators))
 848                   (let* ((this-list (string-split (car myindicators) #\-))
 849                          (max-element-index (- (length this-list) 1))
 850                          (last-element
 851                           (car (list-tail this-list max-element-index)))
 852                          (fret
 853                           (if (string->number (car this-list))
 854                               (string->number (car this-list))
 855                               (car this-list))))
 856                     (if (equal? last-element "(")
 857                         (begin
 858                           (set! barre-start-list
 859                                 (cons-fret (list current-string fret)
 860                                            barre-start-list))
 861                           (set! this-list
 862                                 (list-head this-list max-element-index))))
 863                     (if (equal? last-element ")")
 864                         (let* ((this-barre
 865                                 (get-sub-list fret barre-start-list))
 866                                (insert-index (- (length this-barre) 1)))
 867                           (set! output-list
 868                                 (cons-fret (cons* 'barre
 869                                                   (car this-barre)
 870                                                   current-string
 871                                                   (cdr this-barre))
 872                                            output-list))
 873                           (set! this-list
 874                                 (list-head this-list max-element-index))))
 875                     (if (number? fret)
 876                         (set!
 877                          output-list
 878                          (cons-fret (cons*
 879                                      'place-fret
 880                                      current-string
 881                                      (drop-paren (numerify this-list)))
 882                                     output-list))
 883                         (if (equal? (car this-list) "x" )
 884                             (set!
 885                              output-list
 886                              (cons-fret
 887                               (list 'mute current-string)
 888                               output-list))
 889                             (set!
 890                              output-list
 891                              (cons-fret
 892                               (list 'open current-string)
 893                               output-list))))
 894                     (parse-indicators (cdr myindicators)))))
 895             (parse-item (cdr myitems)))))
 896     (set! details (acons 'string-count string-count details))
 897     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 898     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 899
 900 (define (drop-paren item-list)
 901   "Drop a final parentheses from a fret indication list
 902    resulting from a terse string specification of barre."
 903   (if (> (length item-list) 0)
 904       (let* ((max-index (- (length item-list) 1))
 905              (last-element (car (list-tail item-list max-index))))
 906         (if (or (equal? last-element ")") (equal? last-element "("))
 907             (list-head item-list max-index)
 908             item-list))
 909       item-list))
 910
 911 (define (get-sub-list value master-list)
 912   "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
 913   (if (eq? master-list '())
 914       #f
 915       (let ((sublist (car master-list)))
 916         (if (equal? (cadr sublist) value)
 917             sublist
 918             (get-sub-list value (cdr master-list))))))
 919
 920 (define (merge-details key alist-list . default)
 921   "Return ALIST-LIST entries for key, in one combined alist.
 922   There can be two ALIST-LIST entries for a given key. The first
 923   comes from the override-markup function, the second comes
 924   from property settings during a regular override.
 925   This is necessary because some details can be set in one
 926   place, while others are set in the other.  Both details
 927   lists must be merged into a single alist.
 928   Return DEFAULT (optional, else #f) if not
 929   found."
 930
 931   (define (helper key alist-list default)
 932     (if (null? alist-list)
 933         default
 934         (let* ((handle (assoc key (car alist-list))))
 935           (if (pair? handle)
 936               (append (cdr handle) (chain-assoc-get key (cdr alist-list) '()))
 937               (helper key (cdr alist-list) default)))))
 938
 939   (helper key alist-list
 940           (if (pair? default) (car default) #f)))