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