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