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          (barre-type
 552           (assoc-get 'barre-type details 'curved))
 553          (fret-diagram-stencil
 554           (ly:stencil-add
 555            (draw-strings string-count fret-range th size orientation)
 556            (draw-frets fret-range string-count th size orientation))))
 557     (if (and (not (null? barre-list))
 558              (not (eq? 'none barre-type)))
 559         (set! fret-diagram-stencil
 560               (ly:stencil-add
 561                (draw-barre layout props string-count fret-range size
 562                            finger-code dot-position dot-radius
 563                            barre-list orientation)
 564                fret-diagram-stencil)))
 565     (if (not (null? dot-list))
 566         (set! fret-diagram-stencil
 567               (ly:stencil-add
 568                fret-diagram-stencil
 569                (draw-dots layout props string-count fret-count fret-range
 570                           size finger-code dot-position dot-radius
 571                           th dot-list orientation))))
 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 Y UP
 577                    (draw-thick-zero-fret
 578                     props string-count th size orientation))
 579                   (ly:stencil-combine-at-edge
 580                    fret-diagram-stencil X LEFT
 581                    (draw-thick-zero-fret
 582                     props string-count th size orientation)))))
 583     (if (not (null? xo-list))
 584         (set! fret-diagram-stencil
 585               (if (eq? orientation 'normal)
 586                   (ly:stencil-combine-at-edge
 587                    fret-diagram-stencil Y UP
 588                    (draw-xo layout props string-count fret-range
 589                             size xo-list orientation)
 590                    xo-padding )
 591                   (ly:stencil-combine-at-edge
 592                    fret-diagram-stencil X LEFT
 593                    (draw-xo layout props string-count fret-range
 594                             size xo-list orientation)
 595                    xo-padding))))
 596     (if (> (car fret-range) 1)
 597         (set! fret-diagram-stencil
 598               (if (eq? orientation 'normal)
 599                   (ly:stencil-combine-at-edge
 600                    fret-diagram-stencil X label-dir
 601                    (label-fret layout props string-count fret-range
 602                                size orientation)
 603                    label-space)
 604                   (ly:stencil-combine-at-edge
 605                    fret-diagram-stencil Y label-dir
 606                    (label-fret layout props string-count fret-range
 607                                size orientation)
 608                    label-space))))
 609     (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
 610
 611 (define-builtin-markup-command (fret-diagram layout props definition-string)
 612   (string?) ; argument type
 613   fret-diagram ; markup category
 614   (fret-diagram-verbose-markup) ; properties and defaults
 615   "Make a (guitar) fret diagram.  For example, say
 616
 617 @example
 618 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
 619 @end example
 620
 621 @noindent
 622 for fret spacing 3/4 of staff space, D chord diagram
 623
 624 Syntax rules for @var{definition-string}:
 625 @itemize @minus
 626
 627 @item
 628 Diagram items are separated by semicolons.
 629
 630 @item
 631 Possible items:
 632
 633 @itemize @bullet
 634 @item
 635 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
 636 spaces).
 637 Default:@tie{}1.
 638
 639 @item
 640 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
 641 Default:@tie{}0.05.
 642
 643 @item
 644 @code{h:}@var{number} -- Set the height of the diagram in frets.
 645 Default:@tie{}4.
 646
 647 @item
 648 @code{w:}@var{number} -- Set the width of the diagram in strings.
 649 Default:@tie{}6.
 650
 651 @item
 652 @code{f:}@var{number} -- Set fingering label type
 653  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
 654 Default:@tie{}0.
 655
 656 @item
 657 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
 658 Default:@tie{}0.25.
 659
 660 @item
 661 @code{p:}@var{number} -- Set the position of the dot in the fret space.
 662 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
 663 Default:@tie{}0.6.
 664
 665 @item
 666 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
 667 barre mark from @var{string1} to @var{string2} on @var{fret}.
 668
 669 @item
 670 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
 671 If @var{fret} is @samp{o}, @var{string} is identified as open.
 672 If @var{fret} is @samp{x}, @var{string} is identified as muted.
 673
 674 @item
 675 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
 676 @var{string} at @var{fret}, and label with @var{fingering} as defined
 677 by the @code{f:} code.
 678 @end itemize
 679
 680 @item
 681 Note: There is no limit to the number of fret indications per string.
 682 @end itemize"
 683   (let ((definition-list
 684           (fret-parse-definition-string props definition-string)))
 685     (fret-diagram-verbose-markup
 686      layout (car definition-list) (cdr definition-list))))
 687
 688 (define (fret-parse-definition-string props definition-string)
 689  "Parse a fret diagram string and return a pair containing:
 690   props, modified as necessary by the definition-string
 691   a fret-indication list with the appropriate values"
 692  (let* ((fret-count 4)
 693         (string-count 6)
 694         (fret-range (list 1 fret-count))
 695         (barre-list '())
 696         (dot-list '())
 697         (xo-list '())
 698         (output-list '())
 699         (new-props '())
 700         (details (merge-details 'fret-diagram-details props '()))
 701         (items (string-split definition-string #\;)))
 702    (let parse-item ((myitems items))
 703      (if (not (null? (cdr myitems)))
 704          (let ((test-string (car myitems)))
 705            (case (car (string->list (substring test-string 0 1)))
 706              ((#\s) (let ((size (get-numeric-from-key test-string)))
 707                       (set! props (prepend-alist-chain 'size size props))))
 708              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 709                            (finger-id (case finger-code
 710                                         ((0) 'none)
 711                                         ((1) 'in-dot)
 712                                         ((2) 'below-string))))
 713                       (set! details
 714                             (acons 'finger-code finger-id details))))
 715              ((#\c) (set! output-list
 716                           (cons-fret
 717                            (cons
 718                             'barre
 719                             (numerify
 720                              (string-split (substring test-string 2) #\-)))
 721                            output-list)))
 722              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 723                       (set! details
 724                             (acons 'fret-count fret-count details))))
 725              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 726                       (set! details
 727                             (acons 'string-count string-count details))))
 728              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 729                       (set! details
 730                             (acons 'dot-radius dot-size details))))
 731              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 732                       (set! details
 733                             (acons 'dot-position dot-position details))))
 734              (else
 735               (let ((this-list (string-split test-string #\-)))
 736                 (if (string->number (cadr this-list))
 737                     (set! output-list
 738                           (cons-fret
 739                            (cons 'place-fret (numerify this-list))
 740                            output-list))
 741                     (if (equal? (cadr this-list) "x" )
 742                         (set! output-list
 743                               (cons-fret
 744                                (list 'mute (string->number (car this-list)))
 745                                output-list))
 746                         (set! output-list
 747                               (cons-fret
 748                                (list 'open (string->number (car this-list)))
 749                                output-list)))))))
 750            (parse-item (cdr myitems)))))
 751    ;  add the modified details
 752    (set! props
 753          (prepend-alist-chain 'fret-diagram-details details props))
 754    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 755
 756 (define (cons-fret new-value old-list)
 757   "Put together a fret-list in the format desired by parse-string"
 758   (if (eq? old-list '())
 759       (list new-value)
 760       (cons* new-value old-list)))
 761
 762 (define (get-numeric-from-key keystring)
 763   "Get the numeric value from a key of the form k:val"
 764   (string->number (substring keystring 2 (string-length keystring))))
 765
 766 (define (numerify mylist)
 767   "Convert string values to numeric or character"
 768   (if (null? mylist)
 769       '()
 770       (let ((numeric-value (string->number (car mylist))))
 771         (if numeric-value
 772             (cons* numeric-value (numerify (cdr mylist)))
 773             (cons* (car (string->list (car mylist)))
 774                    (numerify (cdr mylist)))))))
 775
 776 (define-builtin-markup-command
 777   (fret-diagram-terse layout props definition-string)
 778   (string?) ; argument type
 779   fret-diagram ; markup category
 780   (fret-diagram-verbose-markup) ; properties
 781   "Make a fret diagram markup using terse string-based syntax.
 782
 783 Here is an example
 784
 785 @example
 786 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
 787 @end example
 788
 789 @noindent
 790 for a D@tie{}chord diagram.
 791
 792 Syntax rules for @var{definition-string}:
 793
 794 @itemize @bullet
 795
 796 @item
 797 Strings are terminated by semicolons; the number of semicolons
 798 is the number of strings in the diagram.
 799
 800 @item
 801 Mute strings are indicated by @samp{x}.
 802
 803 @item
 804 Open strings are indicated by @samp{o}.
 805
 806 @item
 807 A number indicates a fret indication at that fret.
 808
 809 @item
 810 If there are multiple fret indicators desired on a string, they
 811 should be separated by spaces.
 812
 813 @item
 814 Fingerings are given by following the fret number with a @code{-},
 815 followed by the finger indicator, e.g. @samp{3-2} for playing the third
 816 fret with the second finger.
 817
 818 @item
 819 Where a barre indicator is desired, follow the fret (or fingering) symbol
 820 with @code{-(} to start a barre and @code{-)} to end the barre.
 821
 822 @end itemize"
 823   ;; TODO -- change syntax to fret\string-finger
 824   (let ((definition-list
 825           (fret-parse-terse-definition-string props definition-string)))
 826     (fret-diagram-verbose-markup layout
 827                                  (car definition-list)
 828                                  (cdr definition-list))))
 829
 830 (define-public
 831   (fret-parse-terse-definition-string props definition-string)
 832   "Parse a fret diagram string that uses terse syntax; return a pair containing:
 833     props, modified to include the string-count determined by the
 834     definition-string, and
 835     a fret-indication list with the appropriate values"
 836 ;TODO -- change syntax to fret\string-finger
 837
 838   (let* ((details (merge-details 'fret-diagram-details props '()))
 839          (barre-start-list '())
 840          (output-list '())
 841          (new-props '())
 842          (items (string-split definition-string #\;))
 843          (string-count (- (length items) 1)))
 844     (let parse-item ((myitems items))
 845       (if (not (null? (cdr myitems)))
 846           (let* ((test-string (car myitems))
 847                  (current-string (- (length myitems) 1))
 848                  (indicators (string-split test-string #\ )))
 849             (let parse-indicators ((myindicators indicators))
 850               (if (not (eq? '() myindicators))
 851                   (let* ((this-list (string-split (car myindicators) #\-))
 852                          (max-element-index (- (length this-list) 1))
 853                          (last-element
 854                           (car (list-tail this-list max-element-index)))
 855                          (fret
 856                           (if (string->number (car this-list))
 857                               (string->number (car this-list))
 858                               (car this-list))))
 859                     (if (equal? last-element "(")
 860                         (begin
 861                           (set! barre-start-list
 862                                 (cons-fret (list current-string fret)
 863                                            barre-start-list))
 864                           (set! this-list
 865                                 (list-head this-list max-element-index))))
 866                     (if (equal? last-element ")")
 867                         (let* ((this-barre
 868                                 (get-sub-list fret barre-start-list))
 869                                (insert-index (- (length this-barre) 1)))
 870                           (set! output-list
 871                                 (cons-fret (cons* 'barre
 872                                                   (car this-barre)
 873                                                   current-string
 874                                                   (cdr this-barre))
 875                                            output-list))
 876                           (set! this-list
 877                                 (list-head this-list max-element-index))))
 878                     (if (number? fret)
 879                         (set!
 880                          output-list
 881                          (cons-fret (cons*
 882                                      'place-fret
 883                                      current-string
 884                                      (drop-paren (numerify this-list)))
 885                                     output-list))
 886                         (if (equal? (car this-list) "x" )
 887                             (set!
 888                              output-list
 889                              (cons-fret
 890                               (list 'mute current-string)
 891                               output-list))
 892                             (set!
 893                              output-list
 894                              (cons-fret
 895                               (list 'open current-string)
 896                               output-list))))
 897                     (parse-indicators (cdr myindicators)))))
 898             (parse-item (cdr myitems)))))
 899     (set! details (acons 'string-count string-count details))
 900     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 901     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 902
 903 (define (drop-paren item-list)
 904   "Drop a final parentheses from a fret indication list
 905    resulting from a terse string specification of barre."
 906   (if (> (length item-list) 0)
 907       (let* ((max-index (- (length item-list) 1))
 908              (last-element (car (list-tail item-list max-index))))
 909         (if (or (equal? last-element ")") (equal? last-element "("))
 910             (list-head item-list max-index)
 911             item-list))
 912       item-list))
 913
 914 (define (get-sub-list value master-list)
 915   "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
 916   (if (eq? master-list '())
 917       #f
 918       (let ((sublist (car master-list)))
 919         (if (equal? (cadr sublist) value)
 920             sublist
 921             (get-sub-list value (cdr master-list))))))
 922
 923 (define (merge-details key alist-list . default)
 924   "Return ALIST-LIST entries for key, in one combined alist.
 925   There can be two ALIST-LIST entries for a given key. The first
 926   comes from the override-markup function, the second comes
 927   from property settings during a regular override.
 928   This is necessary because some details can be set in one
 929   place, while others are set in the other.  Both details
 930   lists must be merged into a single alist.
 931   Return DEFAULT (optional, else #f) if not
 932   found."
 933
 934   (define (helper key alist-list default)
 935     (if (null? alist-list)
 936         default
 937         (let* ((handle (assoc key (car alist-list))))
 938           (if (pair? handle)
 939               (append (cdr handle) (chain-assoc-get key (cdr alist-list) '()))
 940               (helper key (cdr alist-list) default)))))
 941
 942   (helper key alist-list
 943           (if (pair? default) (car default) #f)))