scm/fret-diagrams.scm

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