scm/fret-diagrams.scm

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