scm/fret-diagrams.scm

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