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