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