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