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* ((capo-thick
 401          (* size (assoc-get 'capo-thickness details 0.5)))
 402        (half-thick (* capo-thick 0.5))
 403        (last-string-pos 0)
 404        (first-string-pos (* size (- string-count 1)))
 405        (fret-pos ( * size (1- (+ dot-pos fret))))
 406        (start-point
 407          (stencil-coordinates fret-pos first-string-pos orientation))
 408        (end-point
 409          (stencil-coordinates fret-pos last-string-pos orientation)))
 410   (make-line-stencil
 411      capo-thick
 412      (car start-point) (cdr start-point)
 413      (car end-point) (cdr end-point))))
 414
 415 (define (draw-frets fret-range string-count th
 416                     thickness-factor size orientation)
 417   "Draw the fret lines for a fret diagram with
 418 @var{string-count} strings and frets as indicated in @var{fret-range}.
 419 Line thickness is given by @var{th}, fret & string spacing by
 420 @var{size}. Orientation is given by @var{orientation}."
 421   (let* ((my-fret-count (fret-count fret-range)))
 422    (draw-fret-lines
 423      my-fret-count string-count th thickness-factor size orientation)))
 424
 425 (define (draw-dots layout props string-count fret-count
 426                    size finger-code
 427                    dot-position dot-radius dot-thickness dot-list orientation)
 428   "Make dots for fret diagram."
 429
 430   (let* ((details (merge-details 'fret-diagram-details props '()))
 431          (scale-dot-radius (* size dot-radius))
 432          (scale-dot-thick (* size dot-thickness))
 433          (dot-color (assoc-get 'dot-color details 'black))
 434          (finger-label-padding 0.3)
 435          (dot-label-font-mag
 436            (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
 437          (string-label-font-mag
 438            (* size
 439              (assoc-get 'string-label-font-mag details
 440                         (cond ((or (eq? orientation 'landscape)
 441                                    (eq? orientation 'opposing-landscape))
 442                                0.5)
 443                               (else  0.6)))))
 444          (mypair (car dot-list))
 445          (restlist (cdr dot-list))
 446          (string (car mypair))
 447          (fret (cadr mypair))
 448          (fret-coordinate (* size (+ (1- fret) dot-position)))
 449          (string-coordinate (* size (- string-count string)))
 450          (dot-coordinates
 451           (stencil-coordinates fret-coordinate string-coordinate orientation))
 452          (extent (cons (- scale-dot-radius) scale-dot-radius))
 453          (finger (caddr mypair))
 454          (finger (if (number? finger) (number->string finger) finger))
 455          (dot-stencil (if (eq? dot-color 'white)
 456                        (ly:stencil-add
 457                          (make-circle-stencil
 458                            scale-dot-radius scale-dot-thick #t)
 459                          (ly:stencil-in-color
 460                            (make-circle-stencil
 461                              (- scale-dot-radius (* 0.5 scale-dot-thick))
 462                              0  #t)
 463                            1 1 1))
 464                        (make-circle-stencil
 465                          scale-dot-radius scale-dot-thick #t)))
 466          (positioned-dot (ly:stencil-translate dot-stencil dot-coordinates))
 467          (labeled-dot-stencil
 468            (cond
 469              ((or (eq? finger '())(eq? finger-code 'none))
 470               positioned-dot)
 471              ((eq? finger-code 'in-dot)
 472               (let ((finger-label
 473                      (centered-stencil
 474                        (sans-serif-stencil
 475                          layout props dot-label-font-mag finger))))
 476               (ly:stencil-translate
 477                 (ly:stencil-add
 478                   dot-stencil
 479                   (if (eq? dot-color 'white)
 480                       finger-label
 481                       (ly:stencil-in-color finger-label 1 1 1)))
 482                 dot-coordinates)))
 483              ((eq? finger-code 'below-string)
 484               (let* ((label-stencil
 485                        (centered-stencil
 486                          (sans-serif-stencil
 487                            layout props string-label-font-mag
 488                            finger)))
 489                      (label-fret-offset
 490                        (stencil-fretboard-offset
 491                          label-stencil 'fret orientation))
 492                      (label-fret-coordinate
 493                        (+ (* size (+ 1 fret-count finger-label-padding))
 494                           label-fret-offset))
 495                      (label-string-coordinate string-coordinate)
 496                      (label-translation
 497                        (stencil-coordinates
 498                          label-fret-coordinate
 499                          label-string-coordinate
 500                          orientation)))
 501                 (ly:stencil-add
 502                   positioned-dot
 503                   (ly:stencil-translate label-stencil label-translation))))
 504              (else ;unknown finger-code
 505                positioned-dot))))
 506     (if (null? restlist)
 507       labeled-dot-stencil
 508       (ly:stencil-add
 509         (draw-dots
 510           layout props string-count fret-count size finger-code
 511           dot-position dot-radius dot-thickness restlist orientation)
 512         labeled-dot-stencil))))
 513
 514 (define (draw-xo
 515           layout props string-count fret-range size xo-list orientation)
 516   "Put open and mute string indications on diagram, as contained in
 517 @var{xo-list}."
 518   (let* ((details (merge-details 'fret-diagram-details props '()))
 519          (xo-font-mag
 520            (* size (assoc-get
 521                     'xo-font-magnification details
 522                     (cond ((or (eq? orientation 'landscape)
 523                             (eq? orientation 'opposing-landscape))
 524                            0.4)
 525                      (else 0.4)))))
 526          (mypair (car xo-list))
 527          (restlist (cdr xo-list))
 528          (glyph-string (if (eq? (car mypair) 'mute)
 529                          (assoc-get 'mute-string details "X")
 530                          (assoc-get 'open-string details "O")))
 531          (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
 532          (glyph-stencil
 533            (centered-stencil
 534              (sans-serif-stencil
 535                layout props (* size xo-font-mag) glyph-string)))
 536          (glyph-stencil-coordinates
 537            (stencil-coordinates 0 glyph-string-coordinate orientation))
 538          (positioned-glyph
 539            (ly:stencil-translate glyph-stencil glyph-stencil-coordinates)))
 540     (if (null? restlist)
 541         positioned-glyph
 542         (ly:stencil-add
 543          (draw-xo
 544           layout props string-count fret-range size restlist orientation)
 545          positioned-glyph))))
 546
 547 (define (draw-barre layout props string-count fret-range
 548                     size finger-code dot-position dot-radius
 549                     barre-list orientation)
 550   "Create barre indications for a fret diagram"
 551   (if (not (null? barre-list))
 552     (let* ((details (merge-details 'fret-diagram-details props '()))
 553            (string1 (caar barre-list))
 554            (string2 (cadar barre-list))
 555            (barre-fret (caddar barre-list))
 556            (top-fret (cdr fret-range))
 557            (low-fret (car fret-range))
 558            (fret (1+ (- barre-fret low-fret)))
 559            (barre-vertical-offset 0.5)
 560            (dot-center-fret-coordinate (+ (1- fret) dot-position))
 561            (barre-fret-coordinate
 562              (+ dot-center-fret-coordinate
 563                 (* (- barre-vertical-offset 0.5) dot-radius)))
 564            (barre-start-string-coordinate (- string-count string1))
 565            (barre-end-string-coordinate (- string-count string2))
 566            (scale-dot-radius (* size dot-radius))
 567            (barre-type (assoc-get 'barre-type details 'curved))
 568            (barre-stencil
 569              (cond
 570                ((eq? barre-type 'straight)
 571                 (make-straight-barre-stencil
 572                   size scale-dot-radius
 573                   barre-fret-coordinate barre-start-string-coordinate
 574                   barre-end-string-coordinate orientation))
 575                ((eq? barre-type 'curved)
 576                 (make-curved-barre-stencil
 577                   size scale-dot-radius
 578                   barre-fret-coordinate barre-start-string-coordinate
 579                   barre-end-string-coordinate orientation)))))
 580       (if (not (null? (cdr barre-list)))
 581         (ly:stencil-add
 582           barre-stencil
 583           (draw-barre layout props string-count fret-range size finger-code
 584                       dot-position dot-radius (cdr barre-list) orientation))
 585         barre-stencil ))))
 586
 587 (define (label-fret layout props string-count fret-range size orientation)
 588   "Label the base fret on a fret diagram"
 589   (let* ((details (merge-details 'fret-diagram-details props '()))
 590          (base-fret (car fret-range))
 591          (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
 592          (label-space (* 0.5 size))
 593          (label-dir (assoc-get 'label-dir details RIGHT))
 594          (label-vertical-offset
 595            (assoc-get 'fret-label-vertical-offset details 0))
 596          (number-type
 597            (assoc-get 'number-type details 'roman-lower))
 598          (label-text
 599            (cond
 600              ((equal? number-type 'roman-lower)
 601               (fancy-format #f "~(~@r~)" base-fret))
 602              ((equal? number-type 'roman-upper)
 603               (fancy-format #f "~@r" base-fret))
 604              ((equal? 'arabic number-type)
 605               (fancy-format #f "~d" base-fret))
 606              (else (fancy-format #f "~(~@r~)" base-fret))))
 607          (label-stencil
 608            (centered-stencil
 609              (sans-serif-stencil
 610                layout props (* size label-font-mag) label-text)))
 611          (label-half-width
 612            (stencil-fretboard-offset label-stencil 'string orientation))
 613          (label-outside-diagram (+ label-space label-half-width)))
 614     (ly:stencil-translate
 615       label-stencil
 616       (stencil-coordinates
 617         (1+ (* size label-vertical-offset))
 618         (if (eq? label-dir LEFT)
 619             (- label-outside-diagram)
 620             (+ (* size (1- string-count)) label-outside-diagram))
 621         orientation))))
 622
 623 ;;
 624 ;;
 625 ;;  markup commands and associated functions
 626 ;;
 627 ;;
 628 ;;
 629
 630 (define (fret-parse-marking-list marking-list my-fret-count)
 631  "Parse a fret-diagram-verbose marking list into component sublists"
 632  (let* ((fret-range (cons 1 my-fret-count))
 633          (capo-fret 0)
 634          (barre-list '())
 635          (dot-list '())
 636          (xo-list '())
 637          (output-alist '()))
 638     (let parse-item ((mylist marking-list))
 639       (if (not (null? mylist))
 640           (let* ((my-item (car mylist)) (my-code (car my-item)))
 641             (cond
 642              ((or (eq? my-code 'open)(eq? my-code 'mute))
 643               (set! xo-list (cons* my-item xo-list)))
 644              ((eq? my-code 'barre)
 645               (set! barre-list (cons* (cdr my-item) barre-list)))
 646              ((eq? my-code 'capo)
 647                (set! capo-fret (cadr my-item)))
 648              ((eq? my-code 'place-fret)
 649               (set! dot-list (cons* (cdr my-item) dot-list))))
 650             (parse-item (cdr mylist)))))
 651     ;; calculate fret-range
 652     (let ((maxfret 0)
 653           (minfret (if (> capo-fret 0) capo-fret 99)))
 654       (let updatemax ((fret-list dot-list))  ;CHANGE THIS TO HELPER FUNCTION?
 655         (if (null? fret-list)
 656             '()
 657             (let ((fretval (second (car fret-list))))
 658               (if (> fretval maxfret) (set! maxfret fretval))
 659               (if (< fretval minfret) (set! minfret fretval))
 660               (updatemax (cdr fret-list)))))
 661       (if (> maxfret my-fret-count)
 662           (set! fret-range
 663                 (cons minfret
 664                       (let ((upfret (- (+ minfret my-fret-count) 1)))
 665                         (if (> maxfret upfret) maxfret upfret)))))
 666       (set! capo-fret (1+ (- capo-fret minfret)))
 667       ; subtract fret from dots
 668       (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
 669     (acons 'fret-range fret-range
 670            (acons 'barre-list barre-list
 671                   (acons 'dot-list dot-list
 672                          (acons 'xo-list xo-list
 673                                 (acons 'capo-fret capo-fret '())))))))
 674
 675 (define (make-fret-diagram layout props marking-list)
 676   "Make a fret diagram markup"
 677   (let* (
 678          ; note: here we get items from props that are needed in this routine,
 679          ; or that are needed in more than one of the procedures
 680          ; called from this routine.  If they're only used in one of the
 681          ; sub-procedure, they're obtained in that procedure
 682          (size (chain-assoc-get 'size props 1.0)) ; needed for everything
 683 ;TODO -- get string-count directly from length of stringTunings;
 684 ;         from FretBoard engraver, but not from markup call
 685          (details (merge-details 'fret-diagram-details props '()))
 686          (string-count
 687           (assoc-get 'string-count details 6)) ; needed for everything
 688          (my-fret-count
 689           (assoc-get 'fret-count details 4)) ; needed for everything
 690          (orientation
 691           (assoc-get 'orientation details 'normal)) ; needed for everything
 692          (finger-code
 693           (assoc-get
 694            'finger-code details 'none)) ; needed for draw-dots and draw-barre
 695          (default-dot-radius
 696            (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
 697          (default-dot-position
 698            (if (eq? finger-code 'in-dot)
 699                (- 0.95 default-dot-radius)
 700                0.6)) ; move up to make room for bigger if labeled
 701          (dot-radius
 702           (assoc-get
 703            'dot-radius details default-dot-radius))  ; needed for draw-dots
 704                                                      ; and draw-barre
 705          (dot-position
 706           (assoc-get
 707            'dot-position details default-dot-position)) ; needed for draw-dots
 708                                                         ; and draw-barre
 709          (th
 710           (* (ly:output-def-lookup layout 'line-thickness)
 711              (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
 712                                                       ; and draw-strings
 713          (thickness-factor (assoc-get 'string-thickness-factor details 0))
 714          (alignment
 715           (chain-assoc-get 'align-dir props -0.4)) ; needed only here
 716          (xo-padding
 717           (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
 718          (parameters (fret-parse-marking-list marking-list my-fret-count))
 719          (capo-fret (assoc-get 'capo-fret parameters 0))
 720          (dot-list (cdr (assoc 'dot-list parameters)))
 721          (xo-list (cdr (assoc 'xo-list parameters)))
 722          (fret-range (cdr (assoc 'fret-range parameters)))
 723          (my-fret-count (fret-count fret-range))
 724          (barre-list (cdr (assoc 'barre-list parameters)))
 725          (barre-type
 726           (assoc-get 'barre-type details 'curved))
 727          (fret-diagram-stencil
 728           (ly:stencil-add
 729            (draw-strings
 730              string-count fret-range th thickness-factor size orientation)
 731            (draw-frets
 732              fret-range string-count th thickness-factor size orientation))))
 733     (if (and (not (null? barre-list))
 734              (not (eq? 'none barre-type)))
 735         (set! fret-diagram-stencil
 736               (ly:stencil-add
 737                (draw-barre layout props string-count fret-range size
 738                            finger-code dot-position dot-radius
 739                            barre-list orientation)
 740                fret-diagram-stencil)))
 741     (if (not (null? dot-list))
 742         (set! fret-diagram-stencil
 743               (ly:stencil-add
 744                fret-diagram-stencil
 745                (draw-dots layout props string-count my-fret-count
 746                           size finger-code dot-position dot-radius
 747                           th dot-list orientation))))
 748     (if (= (car fret-range) 1)
 749         (set! fret-diagram-stencil
 750                   (ly:stencil-add
 751                      fret-diagram-stencil
 752                      (draw-thick-zero-fret
 753                        details string-count th
 754                        thickness-factor size orientation))))
 755     (if (not (null? xo-list))
 756      (let* ((diagram-fret-top
 757               (car (stencil-fretboard-extent
 758                      fret-diagram-stencil
 759                      'fret
 760                      orientation)))
 761             (xo-stencil
 762               (draw-xo layout props string-count fret-range
 763                        size xo-list orientation))
 764             (xo-fret-offset
 765               (stencil-fretboard-offset
 766                 xo-stencil 'fret orientation)))
 767       (set! fret-diagram-stencil
 768         (ly:stencil-add
 769           fret-diagram-stencil
 770           (ly:stencil-translate
 771             xo-stencil
 772             (stencil-coordinates
 773              (- diagram-fret-top
 774                 xo-fret-offset
 775                 (* size xo-padding))
 776              0 ; no string offset
 777              orientation))))))
 778
 779     (if (> capo-fret 0)
 780         (set! fret-diagram-stencil
 781               (ly:stencil-add
 782                 fret-diagram-stencil
 783                 (draw-capo details string-count capo-fret my-fret-count
 784                            th size dot-position orientation))))
 785     (if (> (car fret-range) 1)
 786       (set! fret-diagram-stencil
 787         (ly:stencil-add
 788            fret-diagram-stencil
 789            (label-fret
 790              layout props string-count fret-range size orientation))))
 791       (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
 792
 793 (define (fret-parse-definition-string props definition-string)
 794  "Parse a fret diagram string and return a pair containing:
 795 @var{props}, modified as necessary by the definition-string
 796 a fret-indication list with the appropriate values"
 797  (let* ((fret-count 4)
 798         (string-count 6)
 799         (fret-range (cons 1 fret-count))
 800         (barre-list '())
 801         (dot-list '())
 802         (xo-list '())
 803         (output-list '())
 804         (new-props '())
 805         (details (merge-details 'fret-diagram-details props '()))
 806         (items (string-split definition-string #\;)))
 807    (let parse-item ((myitems items))
 808      (if (not (null? (cdr myitems)))
 809          (let ((test-string (car myitems)))
 810            (case (car (string->list (substring test-string 0 1)))
 811              ((#\s) (let ((size (get-numeric-from-key test-string)))
 812                       (set! props (prepend-alist-chain 'size size props))))
 813              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 814                            (finger-id (case finger-code
 815                                         ((0) 'none)
 816                                         ((1) 'in-dot)
 817                                         ((2) 'below-string))))
 818                       (set! details
 819                             (acons 'finger-code finger-id details))))
 820              ((#\c) (set! output-list
 821                           (cons-fret
 822                            (cons
 823                             'barre
 824                             (numerify
 825                              (string-split (substring test-string 2) #\-)))
 826                            output-list)))
 827              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 828                       (set! details
 829                             (acons 'fret-count fret-count details))))
 830              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 831                       (set! details
 832                             (acons 'string-count string-count details))))
 833              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 834                       (set! details
 835                             (acons 'dot-radius dot-size details))))
 836              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 837                       (set! details
 838                             (acons 'dot-position dot-position details))))
 839              (else
 840               (let ((this-list (string-split test-string #\-)))
 841                 (if (string->number (cadr this-list))
 842                     (set! output-list
 843                           (cons-fret
 844                            (cons 'place-fret (numerify this-list))
 845                            output-list))
 846                     (if (equal? (cadr this-list) "x" )
 847                         (set! output-list
 848                               (cons-fret
 849                                (list 'mute (string->number (car this-list)))
 850                                output-list))
 851                         (set! output-list
 852                               (cons-fret
 853                                (list 'open (string->number (car this-list)))
 854                                output-list)))))))
 855            (parse-item (cdr myitems)))))
 856    ;  add the modified details
 857    (set! props
 858          (prepend-alist-chain 'fret-diagram-details details props))
 859    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 860
 861 (define-public
 862   (fret-parse-terse-definition-string props definition-string)
 863   "Parse a fret diagram string that uses terse syntax;
 864 return a pair containing:
 865 @var{props}, modified to include the string-count determined by the
 866 definition-string, and
 867 a fret-indication list with the appropriate values"
 868 ;TODO -- change syntax to fret\string-finger
 869
 870   (let* ((details (merge-details 'fret-diagram-details props '()))
 871          (barre-start-list '())
 872          (output-list '())
 873          (new-props '())
 874          (items (string-split definition-string #\;))
 875          (string-count (- (length items) 1)))
 876     (let parse-item ((myitems items))
 877       (if (not (null? (cdr myitems)))
 878           (let* ((test-string (car myitems))
 879                  (current-string (- (length myitems) 1))
 880                  (indicators (string-split test-string #\ )))
 881             (let parse-indicators ((myindicators indicators))
 882               (if (not (eq? '() myindicators))
 883                   (let* ((this-list (string-split (car myindicators) #\-))
 884                          (max-element-index (- (length this-list) 1))
 885                          (last-element
 886                           (car (list-tail this-list max-element-index)))
 887                          (fret
 888                           (if (string->number (car this-list))
 889                               (string->number (car this-list))
 890                               (car this-list))))
 891                     (if (equal? last-element "(")
 892                         (begin
 893                           (set! barre-start-list
 894                                 (cons-fret (list current-string fret)
 895                                            barre-start-list))
 896                           (set! this-list
 897                                 (list-head this-list max-element-index))))
 898                     (if (equal? last-element ")")
 899                         (let* ((this-barre
 900                                 (get-sub-list fret barre-start-list))
 901                                (insert-index (- (length this-barre) 1)))
 902                           (set! output-list
 903                                 (cons-fret (cons* 'barre
 904                                                   (car this-barre)
 905                                                   current-string
 906                                                   (cdr this-barre))
 907                                            output-list))
 908                           (set! this-list
 909                                 (list-head this-list max-element-index))))
 910                     (if (number? fret)
 911                         (set!
 912                          output-list
 913                          (cons-fret (cons*
 914                                      'place-fret
 915                                      current-string
 916                                      (drop-paren (numerify this-list)))
 917                                     output-list))
 918                         (if (equal? (car this-list) "x" )
 919                             (set!
 920                              output-list
 921                              (cons-fret
 922                               (list 'mute current-string)
 923                               output-list))
 924                             (set!
 925                              output-list
 926                              (cons-fret
 927                               (list 'open current-string)
 928                               output-list))))
 929                     (parse-indicators (cdr myindicators)))))
 930             (parse-item (cdr myitems)))))
 931     (set! details (acons 'string-count string-count details))
 932     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 933     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 934
 935
 936 (define-builtin-markup-command
 937   (fret-diagram-verbose layout props marking-list)
 938   (pair?) ; argument type (list, but use pair? for speed)
 939   instrument-specific-markup ; markup type
 940   ((align-dir -0.4) ; properties and defaults
 941    (size 1.0)
 942    (fret-diagram-details)
 943    (thickness 0.5))
 944   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
 945
 946   For example,
 947
 948 @example
 949 \\markup \\fret-diagram-verbose
 950   #'((mute 6) (mute 5) (open 4)
 951      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
 952 @end example
 953
 954 @noindent
 955 produces a standard D@tie{}chord diagram without fingering indications.
 956
 957 Possible elements in @var{marking-list}:
 958
 959 @table @code
 960 @item (mute @var{string-number})
 961 Place a small @q{x} at the top of string @var{string-number}.
 962
 963 @item (open @var{string-number})
 964 Place a small @q{o} at the top of string @var{string-number}.
 965
 966 @item (barre @var{start-string} @var{end-string} @var{fret-number})
 967 Place a barre indicator (much like a tie) from string @var{start-string}
 968 to string @var{end-string} at fret @var{fret-number}.
 969
 970 @item (capo @var{fret-number})
 971 Place a capo indicator (a large solid bar) across the entire fretboard
 972 at fret location @var{fret-number}.  Also, set fret @var{fret-number}
 973 to be the lowest fret on the fret diagram.
 974
 975 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
 976 Place a fret playing indication on string @var{string-number} at fret
 977 @var{fret-number} with an optional fingering label @var{finger-value}.
 978 By default, the fret playing indicator is a solid dot.  This can be
 979 changed by setting the value of the variable @var{dot-color}.  If the
 980 @var{finger} part of the @code{place-fret} element is present,
 981 @var{finger-value} will be displayed according to the setting of the
 982 variable @var{finger-code}.  There is no limit to the number of fret
 983 indications per string.
 984 @end table"
 985
 986   (make-fret-diagram layout props marking-list))
 987
 988
 989 (define-builtin-markup-command (fret-diagram layout props definition-string)
 990   (string?) ; argument type
 991   instrument-specific-markup ; markup category
 992   (fret-diagram-verbose-markup) ; properties and defaults
 993   "Make a (guitar) fret diagram.  For example, say
 994
 995 @example
 996 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
 997 @end example
 998
 999 @noindent
1000 for fret spacing 3/4 of staff space, D chord diagram
1001
1002 Syntax rules for @var{definition-string}:
1003 @itemize @minus
1004
1005 @item
1006 Diagram items are separated by semicolons.
1007
1008 @item
1009 Possible items:
1010
1011 @itemize @bullet
1012 @item
1013 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1014 spaces).
1015 Default:@tie{}1.
1016
1017 @item
1018 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
1019 Default:@tie{}0.05.
1020
1021 @item
1022 @code{h:}@var{number} -- Set the height of the diagram in frets.
1023 Default:@tie{}4.
1024
1025 @item
1026 @code{w:}@var{number} -- Set the width of the diagram in strings.
1027 Default:@tie{}6.
1028
1029 @item
1030 @code{f:}@var{number} -- Set fingering label type
1031  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1032 Default:@tie{}0.
1033
1034 @item
1035 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1036 Default:@tie{}0.25.
1037
1038 @item
1039 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1040 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1041 Default:@tie{}0.6.
1042
1043 @item
1044 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1045 barre mark from @var{string1} to @var{string2} on @var{fret}.
1046
1047 @item
1048 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1049 If @var{fret} is @samp{o}, @var{string} is identified as open.
1050 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1051
1052 @item
1053 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1054 @var{string} at @var{fret}, and label with @var{fingering} as defined
1055 by the @code{f:} code.
1056 @end itemize
1057
1058 @item
1059 Note: There is no limit to the number of fret indications per string.
1060 @end itemize"
1061   (let ((definition-list
1062           (fret-parse-definition-string props definition-string)))
1063     (fret-diagram-verbose-markup
1064      layout (car definition-list) (cdr definition-list))))
1065
1066 (define-builtin-markup-command
1067   (fret-diagram-terse layout props definition-string)
1068   (string?) ; argument type
1069   instrument-specific-markup ; markup category
1070   (fret-diagram-verbose-markup) ; properties
1071   "Make a fret diagram markup using terse string-based syntax.
1072
1073 Here is an example
1074
1075 @example
1076 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1077 @end example
1078
1079 @noindent
1080 for a D@tie{}chord diagram.
1081
1082 Syntax rules for @var{definition-string}:
1083
1084 @itemize @bullet
1085
1086 @item
1087 Strings are terminated by semicolons; the number of semicolons
1088 is the number of strings in the diagram.
1089
1090 @item
1091 Mute strings are indicated by @samp{x}.
1092
1093 @item
1094 Open strings are indicated by @samp{o}.
1095
1096 @item
1097 A number indicates a fret indication at that fret.
1098
1099 @item
1100 If there are multiple fret indicators desired on a string, they
1101 should be separated by spaces.
1102
1103 @item
1104 Fingerings are given by following the fret number with a @code{-},
1105 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1106 fret with the second finger.
1107
1108 @item
1109 Where a barre indicator is desired, follow the fret (or fingering) symbol
1110 with @code{-(} to start a barre and @code{-)} to end the barre.
1111
1112 @end itemize"
1113   ;; TODO -- change syntax to fret\string-finger
1114   (let ((definition-list
1115           (fret-parse-terse-definition-string props definition-string)))
1116     (fret-diagram-verbose-markup layout
1117                                  (car definition-list)
1118                                  (cdr definition-list))))
1119
1120