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