scm/fret-diagrams.scm

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