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