scm/fret-diagrams.scm

   1 ;;;; fret-diagrams.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004--2007 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 (+ low-fret barre-fret-coordinate))))
 370                    (* size bezier-height)
 371                    (* size bezier-thick)
 372                    orientation)
 373                   (make-bezier-sandwich-list
 374                    (* size barre-start-string-coordinate)
 375                    (* size barre-end-string-coordinate)
 376                    (* size barre-fret-coordinate)
 377                    (* size bezier-height)
 378                    (* size bezier-thick)
 379                    orientation)))
 380              (barre-stencil
 381               (if (eq? barre-type 'straight)
 382                   (if (eq? orientation 'normal)
 383                       (ly:make-stencil
 384                        (list
 385                         'draw-line (* size dot-radius) left dot-center-y
 386                         right dot-center-y)
 387                        (cons left right)
 388                        (cons (- dot-center-y scale-dot-radius)
 389                              (+ dot-center-y scale-dot-radius)))
 390                       (ly:make-stencil
 391                        (list 'draw-line (* size dot-radius)
 392                              (* size barre-fret-coordinate)
 393                              (* size barre-start-string-coordinate)
 394                              (* size barre-fret-coordinate)
 395                              (* size barre-end-string-coordinate))
 396                        (cons (- (* size barre-fret-coordinate)
 397                                 scale-dot-radius)
 398                              (+ (* size barre-fret-coordinate)
 399                                 scale-dot-radius))
 400                        (cons (* size barre-start-string-coordinate)
 401                              (* size barre-end-string-coordinate))))
 402                   (if (eq? orientation 'normal)
 403                       (ly:make-stencil
 404                        (list 'bezier-sandwich
 405                              `(quote ,bezier-list)
 406                              (* size bezier-thick))
 407                        (cons left right)
 408                        (cons bottom (+ bottom (* size bezier-height))))
 409                       (ly:make-stencil
 410                        (list 'bezier-sandwich
 411                              `(quote ,bezier-list)
 412                              (* size bezier-thick))
 413                        (cons bottom (+ bottom (* size bezier-height)))
 414                        (cons left right))))))
 415         (if (not (null? (cdr barre-list)))
 416             (ly:stencil-add
 417              barre-stencil
 418              (draw-barre layout props string-count fret-range size finger-code
 419                          dot-position dot-radius (cdr barre-list)))
 420             barre-stencil ))))
 421
 422 (define (stepmag mag)
 423   "Calculate the font step necessary to get a desired magnification"
 424   (* 6 (/ (log mag) (log 2))))
 425
 426 (define (label-fret layout props string-count fret-range size orientation)
 427   "Label the base fret on a fret diagram"
 428   (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
 429          (base-fret (car fret-range))
 430          (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
 431          (label-vertical-offset
 432           (assoc-get 'fret-label-vertical-offset details -0.2))
 433          (number-type (assoc-get 'number-type details 'roman-lower))
 434          (fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
 435          (label-text
 436           (cond
 437            ((equal? number-type 'roman-lower)
 438             (fancy-format #f "~(~@r~)" base-fret))
 439            ((equal? number-type 'roman-upper)
 440             (fancy-format #f "~@r" base-fret))
 441            ((equal? 'arabic number-type)
 442             (fancy-format #f "~d" base-fret))
 443            (else (fancy-format #f "~(~@r~)" base-fret)))))
 444     (if (eq? orientation 'normal)
 445         (ly:stencil-translate-axis
 446          (sans-serif-stencil layout props (* size label-font-mag) label-text)
 447          (* size (+ fret-count label-vertical-offset)) Y)
 448         (ly:stencil-translate-axis
 449          (sans-serif-stencil layout props (* size label-font-mag) label-text)
 450          (* size (+ 1 label-vertical-offset)) X))))
 451
 452 (define-builtin-markup-command (fret-diagram-verbose layout props marking-list)
 453   (list?) ; argument type
 454   fret-diagram ; markup type
 455   ((align-dir -0.4) ; properties and defaults
 456    (size 1.0)
 457    (fret-diagram-details)
 458    (thickness 0.5))
 459   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
 460
 461   For example,
 462
 463 @example
 464 \\markup \\fret-diagram-verbose
 465   #'((mute 6) (mute 5) (open 4)
 466      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
 467 @end example
 468
 469 @noindent
 470 produces a standard D@tie{}chord diagram without fingering indications.
 471
 472 Possible elements in @var{marking-list}:
 473
 474 @table @code
 475 @item (mute @var{string-number})
 476 Place a small @q{x} at the top of string @var{string-number}.
 477
 478 @item (open @var{string-number})
 479 Place a small @q{o} at the top of string @var{string-number}.
 480
 481 @item (barre @var{start-string} @var{end-string} @var{fret-number})
 482 Place a barre indicator (much like a tie) from string @var{start-string}
 483 to string @var{end-string} at fret @var{fret-number}.
 484
 485 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
 486 Place a fret playing indication on string @var{string-number} at fret
 487 @var{fret-number} with an optional fingering label @var{finger-value}.
 488 By default, the fret playing indicator is a solid dot.  This can be
 489 changed by setting the value of the variable @var{dot-color}.  If the
 490 @var{finger} part of the @code{place-fret} element is present,
 491 @var{finger-value} will be displayed according to the setting of the
 492 variable @var{finger-code}.  There is no limit to the number of fret
 493 indications per string.
 494 @end table"
 495
 496   (make-fret-diagram layout props marking-list))
 497
 498 (define (make-fret-diagram layout props marking-list)
 499   "Make a fret diagram markup"
 500   (let* (
 501          ; note: here we get items from props that are needed in this routine,
 502          ; or that are needed in more than one of the procedures
 503          ; called from this routine.  If they're only used in one of the
 504          ; sub-procedure, they're obtained in that procedure
 505          (size (chain-assoc-get 'size props 1.0)) ; needed for everything
 506 ;TODO -- get string-count directly from length of stringTunings;
 507 ;         from FretBoard engraver, but not from markup call
 508 ;TODO -- adjust padding for fret label?  it appears to be too close to dots
 509          (details
 510           (chain-assoc-get
 511            'fret-diagram-details props '())) ; fret diagram details
 512          (string-count
 513           (assoc-get 'string-count details 6)) ; needed for everything
 514          (fret-count
 515           (assoc-get 'fret-count details 4)) ; needed for everything
 516          (orientation
 517           (assoc-get 'orientation details 'normal)) ; needed for everything
 518          (finger-code
 519           (assoc-get
 520            'finger-code details 'none)) ; needed for draw-dots and draw-barre
 521          (default-dot-radius
 522            (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
 523          (default-dot-position
 524            (if (eq? finger-code 'in-dot)
 525                (- 0.95 default-dot-radius)
 526                0.6)) ; move up to make room for bigger if labeled
 527          (dot-radius
 528           (assoc-get
 529            'dot-radius details default-dot-radius))  ; needed for draw-dots
 530                                                      ; and draw-barre
 531          (dot-position
 532           (assoc-get
 533            'dot-position details default-dot-position)) ; needed for draw-dots
 534                                                         ; and draw-barre
 535          (th
 536           (* (ly:output-def-lookup layout 'line-thickness)
 537              (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
 538                                                       ; and draw-strings
 539          (alignment
 540           (chain-assoc-get 'align-dir props -0.4)) ; needed only here
 541          (xo-padding
 542           (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
 543          (label-space (* 0.25 size))
 544          (label-dir (assoc-get 'label-dir details RIGHT))
 545          (parameters (fret-parse-marking-list marking-list fret-count))
 546          (dot-list (cdr (assoc 'dot-list parameters)))
 547          (xo-list (cdr (assoc 'xo-list parameters)))
 548          (fret-range (cdr (assoc 'fret-range parameters)))
 549          (barre-list (cdr (assoc 'barre-list parameters)))
 550          (fret-diagram-stencil
 551           (ly:stencil-add
 552            (draw-strings string-count fret-range th size orientation)
 553            (draw-frets fret-range string-count th size orientation))))
 554     (if (not (null? barre-list))
 555         (set! fret-diagram-stencil
 556               (ly:stencil-add
 557                (draw-barre layout props string-count fret-range size
 558                            finger-code dot-position dot-radius
 559                            barre-list orientation)
 560                fret-diagram-stencil)))
 561     (if (not (null? dot-list))
 562         (set! fret-diagram-stencil
 563               (ly:stencil-add
 564                fret-diagram-stencil
 565                (draw-dots layout props string-count fret-count fret-range
 566                           size finger-code dot-position dot-radius
 567                           th dot-list orientation))))
 568     (if (= (car fret-range) 1)
 569         (set! fret-diagram-stencil
 570               (if (eq? orientation 'normal)
 571                   (ly:stencil-combine-at-edge
 572                    fret-diagram-stencil Y UP
 573                    (draw-thick-zero-fret
 574                     props string-count th size orientation))
 575                   (ly:stencil-combine-at-edge
 576                    fret-diagram-stencil X LEFT
 577                    (draw-thick-zero-fret
 578                     props string-count th size orientation)))))
 579     (if (not (null? xo-list))
 580         (set! fret-diagram-stencil
 581               (if (eq? orientation 'normal)
 582                   (ly:stencil-combine-at-edge
 583                    fret-diagram-stencil Y UP
 584                    (draw-xo layout props string-count fret-range
 585                             size xo-list orientation)
 586                    xo-padding )
 587                   (ly:stencil-combine-at-edge
 588                    fret-diagram-stencil X LEFT
 589                    (draw-xo layout props string-count fret-range
 590                             size xo-list orientation)
 591                    xo-padding))))
 592     (if (> (car fret-range) 1)
 593         (set! fret-diagram-stencil
 594               (if (eq? orientation 'normal)
 595                   (ly:stencil-combine-at-edge
 596                    fret-diagram-stencil X label-dir
 597                    (label-fret layout props string-count fret-range
 598                                size orientation)
 599                    label-space)
 600                   (ly:stencil-combine-at-edge
 601                    fret-diagram-stencil Y label-dir
 602                    (label-fret layout props string-count fret-range
 603                                size orientation)
 604                    label-space))))
 605     (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
 606
 607 (define-builtin-markup-command (fret-diagram layout props definition-string)
 608   (string?) ; argument type
 609   fret-diagram ; markup category
 610   (fret-diagram-verbose-markup) ; properties and defaults
 611   "Make a (guitar) fret diagram.  For example, say
 612
 613 @example
 614 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
 615 @end example
 616
 617 @noindent
 618 for fret spacing 3/4 of staff space, D chord diagram
 619
 620 Syntax rules for @var{definition-string}:
 621 @itemize @minus
 622
 623 @item
 624 Diagram items are separated by semicolons.
 625
 626 @item
 627 Possible items:
 628
 629 @itemize @bullet
 630 @item
 631 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
 632 spaces).
 633 Default:@tie{}1.
 634
 635 @item
 636 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
 637 Default:@tie{}0.05.
 638
 639 @item
 640 @code{h:}@var{number} -- Set the height of the diagram in frets.
 641 Default:@tie{}4.
 642
 643 @item
 644 @code{w:}@var{number} -- Set the width of the diagram in strings.
 645 Default:@tie{}6.
 646
 647 @item
 648 @code{f:}@var{number} -- Set fingering label type
 649  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
 650 Default:@tie{}0.
 651
 652 @item
 653 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
 654 Default:@tie{}0.25.
 655
 656 @item
 657 @code{p:}@var{number} -- Set the position of the dot in the fret space.
 658 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
 659 Default:@tie{}0.6.
 660
 661 @item
 662 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
 663 barre mark from @var{string1} to @var{string2} on @var{fret}.
 664
 665 @item
 666 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
 667 If @var{fret} is @samp{o}, @var{string} is identified as open.
 668 If @var{fret} is @samp{x}, @var{string} is identified as muted.
 669
 670 @item
 671 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
 672 @var{string} at @var{fret}, and label with @var{fingering} as defined
 673 by the @code{f:} code.
 674 @end itemize
 675
 676 @item
 677 Note: There is no limit to the number of fret indications per string.
 678 @end itemize"
 679   (let ((definition-list
 680           (fret-parse-definition-string props definition-string)))
 681     (fret-diagram-verbose-markup
 682      layout (car definition-list) (cdr definition-list))))
 683
 684 (define (fret-parse-definition-string props definition-string)
 685  "Parse a fret diagram string and return a pair containing:
 686   props, modified as necessary by the definition-string
 687   a fret-indication list with the appropriate values"
 688  (let* ((fret-count 4)
 689         (string-count 6)
 690         (fret-range (list 1 fret-count))
 691         (barre-list '())
 692         (dot-list '())
 693         (xo-list '())
 694         (output-list '())
 695         (new-props '())
 696         (details (merge-details 'fret-diagram-details props '()))
 697         (items (string-split definition-string #\;)))
 698    (let parse-item ((myitems items))
 699      (if (not (null? (cdr myitems)))
 700          (let ((test-string (car myitems)))
 701            (case (car (string->list (substring test-string 0 1)))
 702              ((#\s) (let ((size (get-numeric-from-key test-string)))
 703                       (set! props (prepend-alist-chain 'size size props))))
 704              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 705                            (finger-id (case finger-code
 706                                         ((0) 'none)
 707                                         ((1) 'in-dot)
 708                                         ((2) 'below-string))))
 709                       (set! details
 710                             (acons 'finger-code finger-id details))))
 711              ((#\c) (set! output-list
 712                           (cons-fret
 713                            (cons
 714                             'barre
 715                             (numerify
 716                              (string-split (substring test-string 2) #\-)))
 717                            output-list)))
 718              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 719                       (set! details
 720                             (acons 'fret-count fret-count details))))
 721              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 722                       (set! details
 723                             (acons 'string-count string-count details))))
 724              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 725                       (set! details
 726                             (acons 'dot-radius dot-size details))))
 727              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 728                       (set! details
 729                             (acons 'dot-position dot-position details))))
 730              (else
 731               (let ((this-list (string-split test-string #\-)))
 732                 (if (string->number (cadr this-list))
 733                     (set! output-list
 734                           (cons-fret
 735                            (cons 'place-fret (numerify this-list))
 736                            output-list))
 737                     (if (equal? (cadr this-list) "x" )
 738                         (set! output-list
 739                               (cons-fret
 740                                (list 'mute (string->number (car this-list)))
 741                                output-list))
 742                         (set! output-list
 743                               (cons-fret
 744                                (list 'open (string->number (car this-list)))
 745                                output-list)))))))
 746            (parse-item (cdr myitems)))))
 747    ;  add the modified details
 748    (set! props
 749          (prepend-alist-chain 'fret-diagram-details details props))
 750    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 751
 752 (define (cons-fret new-value old-list)
 753   "Put together a fret-list in the format desired by parse-string"
 754   (if (eq? old-list '())
 755       (list new-value)
 756       (cons* new-value old-list)))
 757
 758 (define (get-numeric-from-key keystring)
 759   "Get the numeric value from a key of the form k:val"
 760   (string->number (substring keystring 2 (string-length keystring))))
 761
 762 (define (numerify mylist)
 763   "Convert string values to numeric or character"
 764   (if (null? mylist)
 765       '()
 766       (let ((numeric-value (string->number (car mylist))))
 767         (if numeric-value
 768             (cons* numeric-value (numerify (cdr mylist)))
 769             (cons* (car (string->list (car mylist)))
 770                    (numerify (cdr mylist)))))))
 771
 772 (define-builtin-markup-command
 773   (fret-diagram-terse layout props definition-string)
 774   (string?) ; argument type
 775   fret-diagram ; markup category
 776   (fret-diagram-verbose-markup) ; properties
 777   "Make a fret diagram markup using terse string-based syntax.
 778
 779 Here is an example
 780
 781 @example
 782 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
 783 @end example
 784
 785 @noindent
 786 for a D@tie{}chord diagram.
 787
 788 Syntax rules for @var{definition-string}:
 789
 790 @itemize @bullet
 791
 792 @item
 793 Strings are terminated by semicolons; the number of semicolons
 794 is the number of strings in the diagram.
 795
 796 @item
 797 Mute strings are indicated by @samp{x}.
 798
 799 @item
 800 Open strings are indicated by @samp{o}.
 801
 802 @item
 803 A number indicates a fret indication at that fret.
 804
 805 @item
 806 If there are multiple fret indicators desired on a string, they
 807 should be separated by spaces.
 808
 809 @item
 810 Fingerings are given by following the fret number with a @code{-},
 811 followed by the finger indicator, e.g. @samp{3-2} for playing the third
 812 fret with the second finger.
 813
 814 @item
 815 Where a barre indicator is desired, follow the fret (or fingering) symbol
 816 with @code{-(} to start a barre and @code{-)} to end the barre.
 817
 818 @end itemize"
 819   ;; TODO -- change syntax to fret\string-finger
 820   (let ((definition-list
 821           (fret-parse-terse-definition-string props definition-string)))
 822     (fret-diagram-verbose-markup layout
 823                                  (car definition-list)
 824                                  (cdr definition-list))))
 825
 826 (define (fret-parse-terse-definition-string props definition-string)
 827   "Parse a fret diagram string that uses terse syntax; return a pair containing:
 828     props, modified to include the string-count determined by the
 829     definition-string, and
 830     a fret-indication list with the appropriate values"
 831 ;TODO -- change syntax to fret\string-finger
 832
 833   (let* ((details (merge-details 'fret-diagram-details props '()))
 834          (barre-start-list '())
 835          (output-list '())
 836          (new-props '())
 837          (items (string-split definition-string #\;))
 838          (string-count (- (length items) 1)))
 839     (let parse-item ((myitems items))
 840       (if (not (null? (cdr myitems)))
 841           (let* ((test-string (car myitems))
 842                  (current-string (- (length myitems) 1))
 843                  (indicators (string-split test-string #\ )))
 844             (let parse-indicators ((myindicators indicators))
 845               (if (not (eq? '() myindicators))
 846                   (let* ((this-list (string-split (car myindicators) #\-))
 847                          (max-element-index (- (length this-list) 1))
 848                          (last-element
 849                           (car (list-tail this-list max-element-index)))
 850                          (fret
 851                           (if (string->number (car this-list))
 852                               (string->number (car this-list))
 853                               (car this-list))))
 854                     (if (equal? last-element "(")
 855                         (begin
 856                           (set! barre-start-list
 857                                 (cons-fret (list current-string fret)
 858                                            barre-start-list))
 859                           (set! this-list
 860                                 (list-head this-list max-element-index))))
 861                     (if (equal? last-element ")")
 862                         (let* ((this-barre
 863                                 (get-sub-list fret barre-start-list))
 864                                (insert-index (- (length this-barre) 1)))
 865                           (set! output-list
 866                                 (cons-fret (cons* 'barre
 867                                                   (car this-barre)
 868                                                   current-string
 869                                                   (cdr this-barre))
 870                                            output-list))
 871                           (set! this-list
 872                                 (list-head this-list max-element-index))))
 873                     (if (number? fret)
 874                         (set!
 875                          output-list
 876                          (cons-fret (cons*
 877                                      'place-fret
 878                                      current-string
 879                                      (drop-paren (numerify this-list)))
 880                                     output-list))
 881                         (if (equal? (car this-list) "x" )
 882                             (set!
 883                              output-list
 884                              (cons-fret
 885                               (list 'mute current-string)
 886                               output-list))
 887                             (set!
 888                              output-list
 889                              (cons-fret
 890                               (list 'open current-string)
 891                               output-list))))
 892                     (parse-indicators (cdr myindicators)))))
 893             (parse-item (cdr myitems)))))
 894     (set! details (acons 'string-count string-count details))
 895     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 896     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 897
 898 (define (drop-paren item-list)
 899   "Drop a final parentheses from a fret indication list
 900    resulting from a terse string specification of barre."
 901   (if (> (length item-list) 0)
 902       (let* ((max-index (- (length item-list) 1))
 903              (last-element (car (list-tail item-list max-index))))
 904         (if (or (equal? last-element ")") (equal? last-element "("))
 905             (list-head item-list max-index)
 906             item-list))
 907       item-list))
 908
 909 (define (get-sub-list value master-list)
 910   "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
 911   (if (eq? master-list '())
 912       #f
 913       (let ((sublist (car master-list)))
 914         (if (equal? (cadr sublist) value)
 915             sublist
 916             (get-sub-list value (cdr master-list))))))
 917
 918 (define (merge-details key alist-list . default)
 919   "Return ALIST-LIST entries for key, in one combined alist.
 920   There can be two ALIST-LIST entries for a given key. The first
 921   comes from the override-markup function, the second comes
 922   from property settings during a regular override.
 923   This is necessary because some details can be set in one
 924   place, while others are set in the other.  Both details
 925   lists must be merged into a single alist.
 926   Return DEFAULT (optional, else #f) if not
 927   found."
 928
 929   (define (helper key alist-list default)
 930     (if (null? alist-list)
 931         default
 932         (let* ((handle (assoc key (car alist-list))))
 933           (if (pair? handle)
 934               (append (cdr handle) (chain-assoc-get key (cdr alist-list) '()))
 935               (helper key (cdr alist-list) default)))))
 936
 937   (helper key alist-list
 938           (if (pair? default) (car default) #f)))