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