scm/fret-diagrams.scm

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