scm/fret-diagrams.scm

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