scm/fret-diagrams.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2004--2012 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          (make-bezier-sandwich-stencil
 532            bezier-list
 533            (* size bezier-thick)
 534            x-extent
 535            y-extent)))
 536
 537      (define (draw-dots dot-list)
 538        "Make dots for fret diagram."
 539
 540        (let* ( (scale-dot-radius (* size dot-radius))
 541               (scale-dot-thick (* size th))
 542               (default-dot-color (assoc-get 'dot-color details 'black))
 543               (finger-label-padding 0.3)
 544               (dot-label-font-mag
 545                 (* scale-dot-radius
 546                    (assoc-get 'dot-label-font-mag details 1.0)))
 547               (string-label-font-mag
 548                 (* size
 549                    (assoc-get
 550                      'string-label-font-mag details
 551                      (cond ((or (eq? orientation 'landscape)
 552                                 (eq? orientation 'opposing-landscape))
 553                             0.5)
 554                            (else  0.6)))))
 555               (mypair (car dot-list))
 556               (restlist (cdr dot-list))
 557               (string (car mypair))
 558               (fret (cadr mypair))
 559               (fret-coordinate (* size (+ (1- fret) dot-position)))
 560               (string-coordinate (* size (- string-count string)))
 561               (dot-coordinates
 562                 (stencil-coordinates fret-coordinate string-coordinate))
 563               (extent (cons (- scale-dot-radius) scale-dot-radius))
 564               (finger (caddr mypair))
 565               (finger (if (number? finger) (number->string finger) finger))
 566               (inverted-color (eq? 'inverted (cadddr mypair)))
 567               (dot-color (if (or (and (eq? default-dot-color 'black) inverted-color)
 568                                  (and (eq? default-dot-color 'white) (not inverted-color)))
 569                              'white
 570                              'black))
 571               (dot-stencil (if (eq? dot-color 'white)
 572                              (ly:stencil-add
 573                                (make-circle-stencil
 574                                  scale-dot-radius scale-dot-thick #t)
 575                                (ly:stencil-in-color
 576                                  (make-circle-stencil
 577                                    (- scale-dot-radius (* 0.5 scale-dot-thick))
 578                                    0  #t)
 579                                  1 1 1))
 580                              (make-circle-stencil
 581                                scale-dot-radius scale-dot-thick #t)))
 582               (positioned-dot
 583                 (ly:stencil-translate dot-stencil dot-coordinates))
 584               (labeled-dot-stencil
 585                 (cond
 586                   ((or (eq? finger '())(eq? finger-code 'none))
 587                    positioned-dot)
 588                   ((eq? finger-code 'in-dot)
 589                    (let ((finger-label
 590                            (centered-stencil
 591                              (sans-serif-stencil
 592                                layout props dot-label-font-mag finger))))
 593                      (ly:stencil-translate
 594                        (ly:stencil-add
 595                          dot-stencil
 596                          (if (eq? dot-color 'white)
 597                            finger-label
 598                            (ly:stencil-in-color finger-label 1 1 1)))
 599                        dot-coordinates)))
 600                   ((eq? finger-code 'below-string)
 601                    (let* ((label-stencil
 602                             (centered-stencil
 603                               (sans-serif-stencil
 604                                 layout props string-label-font-mag
 605                                 finger)))
 606                           (label-fret-offset
 607                             (stencil-fretboard-offset
 608                               label-stencil 'fret orientation))
 609                           (label-fret-coordinate
 610                             (+ (* size
 611                                   (+ 1 my-fret-count finger-label-padding))
 612                                label-fret-offset))
 613                           (label-string-coordinate string-coordinate)
 614                           (label-translation
 615                             (stencil-coordinates
 616                               label-fret-coordinate
 617                               label-string-coordinate)))
 618                      (ly:stencil-add
 619                        positioned-dot
 620                        (ly:stencil-translate
 621                          label-stencil
 622                          label-translation))))
 623                   (else ;unknown finger-code
 624                     positioned-dot))))
 625          (if (null? restlist)
 626            labeled-dot-stencil
 627            (ly:stencil-add
 628              (draw-dots restlist)
 629              labeled-dot-stencil))))
 630
 631      (define (draw-thick-zero-fret)
 632        "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
 633        (let* ((half-lowest-string-thickness
 634                 (* 0.5 th (string-thickness string-count thickness-factor)))
 635               (half-thick (* 0.5 sth))
 636               (top-fret-thick
 637                 (* sth (assoc-get 'top-fret-thickness details 3.0)))
 638               (start-string-coordinate (- half-lowest-string-thickness))
 639               (end-string-coordinate (+ (* size (1- string-count)) half-thick))
 640               (start-fret-coordinate half-thick)
 641               (end-fret-coordinate (- half-thick top-fret-thick))
 642               (lower-left
 643                 (stencil-coordinates
 644                   start-fret-coordinate start-string-coordinate))
 645               (upper-right
 646                 (stencil-coordinates
 647                   end-fret-coordinate end-string-coordinate)))
 648          (ly:round-filled-box
 649            (cons (car lower-left) (car upper-right))
 650            (cons (cdr lower-left) (cdr upper-right))
 651            sth)))
 652
 653      (define (draw-xo xo-list)
 654        "Put open and mute string indications on diagram, as contained in
 655 @var{xo-list}."
 656        (let* ((xo-font-mag
 657                (assoc-get 'xo-font-magnification details
 658                           (cond ((or (eq? orientation 'landscape)
 659                                      (eq? orientation 'opposing-landscape))
 660                                  0.4)
 661                                 (else 0.4))))
 662               (mypair (car xo-list))
 663               (restlist (cdr xo-list))
 664               (glyph-string (if (eq? (car mypair) 'mute)
 665                               (assoc-get 'mute-string details "X")
 666                               (assoc-get 'open-string details "O")))
 667               (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
 668               (glyph-stencil
 669                 (centered-stencil
 670                   (sans-serif-stencil
 671                     layout props (* size xo-font-mag) glyph-string)))
 672               (glyph-stencil-coordinates
 673                 (stencil-coordinates 0 glyph-string-coordinate))
 674               (positioned-glyph
 675                 (ly:stencil-translate
 676                   glyph-stencil
 677                   glyph-stencil-coordinates)))
 678          (if (null? restlist)
 679            positioned-glyph
 680            (ly:stencil-add
 681              positioned-glyph
 682              (draw-xo restlist)))))
 683
 684        (define (draw-capo fret)
 685          "Draw a capo indicator across the full width of the fret-board
 686 at @var{fret}."
 687          (let* ((capo-thick
 688                   (* size (assoc-get 'capo-thickness details 0.5)))
 689                 (half-thick (* capo-thick 0.5))
 690                 (last-string-position 0)
 691                 (first-string-position (* size (- string-count 1)))
 692                 (fret-position ( * size (1- (+ dot-position fret))))
 693                 (start-point
 694                   (stencil-coordinates
 695                     fret-position
 696                     first-string-position))
 697                 (end-point
 698                   (stencil-coordinates
 699                     fret-position
 700                     last-string-position)))
 701            (make-line-stencil
 702              capo-thick
 703              (car start-point) (cdr start-point)
 704              (car end-point) (cdr end-point))))
 705
 706         (define (label-fret fret-range)
 707           "Label the base fret on a fret diagram"
 708           (let* ((base-fret (car fret-range))
 709                  (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
 710                  (label-space (* 0.5 size))
 711                  (label-dir (assoc-get 'label-dir details RIGHT))
 712                  (label-vertical-offset
 713                    (assoc-get 'fret-label-vertical-offset details 0))
 714                  (number-type
 715                    (assoc-get 'number-type details 'roman-lower))
 716                  (label-text
 717                    (cond
 718                      ((equal? number-type 'roman-lower)
 719                       (fancy-format #f "~(~@r~)" base-fret))
 720                      ((equal? number-type 'roman-upper)
 721                       (fancy-format #f "~@r" base-fret))
 722                      ((equal? 'arabic number-type)
 723                       (fancy-format #f "~d" base-fret))
 724                      ((equal? 'custom number-type)
 725                       (fancy-format #f
 726                                     (assoc-get 'fret-label-custom-format
 727                                                details "~a")
 728                                     base-fret))
 729                      (else (fancy-format #f "~(~@r~)" base-fret))))
 730                  (label-stencil
 731                    (centered-stencil
 732                      (sans-serif-stencil
 733                        layout props (* size label-font-mag) label-text)))
 734                  (label-half-width
 735                    (stencil-fretboard-offset
 736                      label-stencil
 737                      'string
 738                      orientation))
 739                  (label-outside-diagram (+ label-space label-half-width)))
 740             (ly:stencil-translate
 741               label-stencil
 742               (stencil-coordinates
 743                 (* size (+ 1.0 label-vertical-offset))
 744                 (if (eq? label-dir LEFT)
 745                   (- label-outside-diagram)
 746                   (+ (* size (1- string-count)) label-outside-diagram))))))
 747
 748
 749               ; Here is the body of make-fret-diagram
 750               ;
 751
 752     (set! fret-diagram-stencil
 753       (ly:stencil-add (draw-strings) (draw-frets)))
 754     (if (and (not (null? barre-list))
 755              (not (eq? 'none barre-type)))
 756       (set! fret-diagram-stencil
 757         (ly:stencil-add
 758           (draw-barre barre-list)
 759           fret-diagram-stencil)))
 760     (if (not (null? dot-list))
 761       (set! fret-diagram-stencil
 762         (ly:stencil-add
 763           fret-diagram-stencil
 764           (draw-dots dot-list))))
 765     (if (= (car fret-range) 1)
 766       (set! fret-diagram-stencil
 767         (ly:stencil-add
 768           fret-diagram-stencil
 769           (draw-thick-zero-fret))))
 770     (if (not (null? xo-list))
 771       (let* ((diagram-fret-top
 772                (car (stencil-fretboard-extent
 773                       fret-diagram-stencil
 774                       'fret
 775                       orientation)))
 776              (xo-stencil (draw-xo xo-list))
 777              (xo-fret-offset
 778                (stencil-fretboard-offset
 779                  xo-stencil 'fret orientation))
 780              (xo-stencil-offset
 781               (stencil-coordinate-offset
 782                (- diagram-fret-top
 783                   xo-fret-offset
 784                   (* size xo-padding))
 785                0)))
 786         (set! fret-diagram-stencil
 787           (ly:stencil-add
 788             fret-diagram-stencil
 789             (ly:stencil-translate
 790               xo-stencil
 791               xo-stencil-offset)))))
 792     (if (> capo-fret 0)
 793       (set! fret-diagram-stencil
 794         (ly:stencil-add
 795           fret-diagram-stencil
 796           (draw-capo capo-fret))))
 797     (if (> (car fret-range) 1)
 798       (set! fret-diagram-stencil
 799         (ly:stencil-add
 800           fret-diagram-stencil
 801           (label-fret fret-range))))
 802     (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
 803
 804 (define (fret-parse-definition-string props definition-string)
 805  "Parse a fret diagram string and return a pair containing:
 806 @var{props}, modified as necessary by the definition-string
 807 a fret-indication list with the appropriate values"
 808  (let* ((fret-count 4)
 809         (string-count 6)
 810         (fret-range (cons 1 fret-count))
 811         (barre-list '())
 812         (dot-list '())
 813         (xo-list '())
 814         (output-list '())
 815         (new-props '())
 816         (details (merge-details 'fret-diagram-details props '()))
 817         (items (string-split definition-string #\;)))
 818    (let parse-item ((myitems items))
 819      (if (not (null? (cdr myitems)))
 820          (let ((test-string (car myitems)))
 821            (case (car (string->list (substring test-string 0 1)))
 822              ((#\s) (let ((size (get-numeric-from-key test-string)))
 823                       (set! props (prepend-alist-chain 'size size props))))
 824              ((#\t) (let ((th (get-numeric-from-key test-string)))
 825                       (set! props (prepend-alist-chain 'thickness th props))))
 826              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 827                            (finger-id (case finger-code
 828                                         ((0) 'none)
 829                                         ((1) 'in-dot)
 830                                         ((2) 'below-string))))
 831                       (set! details
 832                             (acons 'finger-code finger-id details))))
 833              ((#\c) (set! output-list
 834                           (cons-fret
 835                            (cons
 836                             'barre
 837                             (numerify
 838                              (string-split (substring test-string 2) #\-)))
 839                            output-list)))
 840              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 841                       (set! details
 842                             (acons 'fret-count fret-count details))))
 843              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 844                       (set! details
 845                             (acons 'string-count string-count details))))
 846              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 847                       (set! details
 848                             (acons 'dot-radius dot-size details))))
 849              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 850                       (set! details
 851                             (acons 'dot-position dot-position details))))
 852              (else
 853               (let ((this-list (string-split test-string #\-)))
 854                 (if (string->number (cadr this-list))
 855                     (set! output-list
 856                           (cons-fret
 857                            (cons 'place-fret (numerify this-list))
 858                            output-list))
 859                     (if (equal? (cadr this-list) "x" )
 860                         (set! output-list
 861                               (cons-fret
 862                                (list 'mute (string->number (car this-list)))
 863                                output-list))
 864                         (set! output-list
 865                               (cons-fret
 866                                (list 'open (string->number (car this-list)))
 867                                output-list)))))))
 868            (parse-item (cdr myitems)))))
 869    ;  add the modified details
 870    (set! props
 871          (prepend-alist-chain 'fret-diagram-details details props))
 872    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 873
 874 (define-public
 875   (fret-parse-terse-definition-string props definition-string)
 876   "Parse a fret diagram string that uses terse syntax;
 877 return a pair containing:
 878 @var{props}, modified to include the string-count determined by the
 879 definition-string, and
 880 a fret-indication list with the appropriate values"
 881 ;TODO -- change syntax to fret\string-finger
 882
 883   (let* ((details (merge-details 'fret-diagram-details props '()))
 884          (barre-start-list '())
 885          (output-list '())
 886          (new-props '())
 887          (items (string-split definition-string #\;))
 888          (string-count (- (length items) 1)))
 889     (let parse-item ((myitems items))
 890       (if (not (null? (cdr myitems)))
 891           (let* ((test-string (car myitems))
 892                  (current-string (- (length myitems) 1))
 893                  (indicators (string-split test-string #\ )))
 894             (let parse-indicators ((myindicators indicators))
 895               (if (not (eq? '() myindicators))
 896                   (let* ((this-list (string-split (car myindicators) #\-))
 897                          (max-element-index (- (length this-list) 1))
 898                          (last-element
 899                           (car (list-tail this-list max-element-index)))
 900                          (fret
 901                           (if (string->number (car this-list))
 902                               (string->number (car this-list))
 903                               (car this-list))))
 904                     (if (equal? last-element "(")
 905                         (begin
 906                           (set! barre-start-list
 907                                 (cons-fret (list current-string fret)
 908                                            barre-start-list))
 909                           (set! this-list
 910                                 (list-head this-list max-element-index))))
 911                     (if (equal? last-element ")")
 912                         (let* ((this-barre
 913                                 (get-sub-list fret barre-start-list))
 914                                (insert-index (- (length this-barre) 1)))
 915                           (set! output-list
 916                                 (cons-fret (cons* 'barre
 917                                                   (car this-barre)
 918                                                   current-string
 919                                                   (cdr this-barre))
 920                                            output-list))
 921                           (set! this-list
 922                                 (list-head this-list max-element-index))))
 923                     (if (number? fret)
 924                         (set!
 925                          output-list
 926                          (cons-fret (cons*
 927                                      'place-fret
 928                                      current-string
 929                                      (drop-paren (numerify this-list)))
 930                                     output-list))
 931                         (if (equal? (car this-list) "x" )
 932                             (set!
 933                              output-list
 934                              (cons-fret
 935                               (list 'mute current-string)
 936                               output-list))
 937                             (set!
 938                              output-list
 939                              (cons-fret
 940                               (list 'open current-string)
 941                               output-list))))
 942                     (parse-indicators (cdr myindicators)))))
 943             (parse-item (cdr myitems)))))
 944     (set! details (acons 'string-count string-count details))
 945     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 946     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 947
 948
 949 (define-markup-command
 950   (fret-diagram-verbose layout props marking-list)
 951   (pair?) ; argument type (list, but use pair? for speed)
 952   #:category instrument-specific-markup ; markup type
 953   #:properties ((align-dir -0.4) ; properties and defaults
 954                 (size 1.0)
 955                 (fret-diagram-details)
 956                 (thickness 0.5))
 957   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
 958
 959   For example,
 960
 961 @example
 962 \\markup \\fret-diagram-verbose
 963   #'((mute 6) (mute 5) (open 4)
 964      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
 965 @end example
 966
 967 @noindent
 968 produces a standard D@tie{}chord diagram without fingering indications.
 969
 970 Possible elements in @var{marking-list}:
 971
 972 @table @code
 973 @item (mute @var{string-number})
 974 Place a small @q{x} at the top of string @var{string-number}.
 975
 976 @item (open @var{string-number})
 977 Place a small @q{o} at the top of string @var{string-number}.
 978
 979 @item (barre @var{start-string} @var{end-string} @var{fret-number})
 980 Place a barre indicator (much like a tie) from string @var{start-string}
 981 to string @var{end-string} at fret @var{fret-number}.
 982
 983 @item (capo @var{fret-number})
 984 Place a capo indicator (a large solid bar) across the entire fretboard
 985 at fret location @var{fret-number}.  Also, set fret @var{fret-number}
 986 to be the lowest fret on the fret diagram.
 987
 988 @item (place-fret @var{string-number} @var{fret-number} [@var{finger-value} [@var{color-modifier}]])
 989 Place a fret playing indication on string @var{string-number} at fret
 990 @var{fret-number} with an optional fingering label @var{finger-value},
 991 and an optional color modifier @var{color-modifier}.
 992 By default, the fret playing indicator is a solid dot.  This can be
 993 globally changed by setting the value of the variable @var{dot-color}.
 994 Setting @var{color-modifier} to @code{inverted} inverts the dot color
 995 for a specific fingering.
 996 If the @var{finger} part of the @code{place-fret} element is present,
 997 @var{finger-value} will be displayed according to the setting of the
 998 variable @var{finger-code}.  There is no limit to the number of fret
 999 indications per string.
1000 @end table"
1001
1002   (make-fret-diagram layout props marking-list))
1003
1004
1005 (define-markup-command (fret-diagram layout props definition-string)
1006   (string?) ; argument type
1007   #:category instrument-specific-markup ; markup category
1008   #:properties (fret-diagram-verbose-markup) ; properties and defaults
1009   "Make a (guitar) fret diagram.  For example, say
1010
1011 @example
1012 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1013 @end example
1014
1015 @noindent
1016 for fret spacing 3/4 of staff space, D chord diagram
1017
1018 Syntax rules for @var{definition-string}:
1019 @itemize @minus
1020
1021 @item
1022 Diagram items are separated by semicolons.
1023
1024 @item
1025 Possible items:
1026
1027 @itemize @bullet
1028 @item
1029 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1030 spaces).
1031 Default:@tie{}1.
1032
1033 @item
1034 @code{t:}@var{number} -- Set the line thickness (relative to normal
1035 line thickness).
1036 Default:@tie{}0.5.
1037
1038 @item
1039 @code{h:}@var{number} -- Set the height of the diagram in frets.
1040 Default:@tie{}4.
1041
1042 @item
1043 @code{w:}@var{number} -- Set the width of the diagram in strings.
1044 Default:@tie{}6.
1045
1046 @item
1047 @code{f:}@var{number} -- Set fingering label type
1048  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1049 Default:@tie{}0.
1050
1051 @item
1052 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1053 Default:@tie{}0.25.
1054
1055 @item
1056 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1057 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1058 Default:@tie{}0.6.
1059
1060 @item
1061 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1062 barre mark from @var{string1} to @var{string2} on @var{fret}.
1063
1064 @item
1065 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1066 If @var{fret} is @samp{o}, @var{string} is identified as open.
1067 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1068
1069 @item
1070 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1071 @var{string} at @var{fret}, and label with @var{fingering} as defined
1072 by the @code{f:} code.
1073 @end itemize
1074
1075 @item
1076 Note: There is no limit to the number of fret indications per string.
1077 @end itemize"
1078   (let ((definition-list
1079           (fret-parse-definition-string props definition-string)))
1080     (fret-diagram-verbose-markup
1081      layout (car definition-list) (cdr definition-list))))
1082
1083 (define-markup-command
1084   (fret-diagram-terse layout props definition-string)
1085   (string?) ; argument type
1086   #:category instrument-specific-markup ; markup category
1087   #:properties (fret-diagram-verbose-markup) ; properties
1088   "Make a fret diagram markup using terse string-based syntax.
1089
1090 Here is an example
1091
1092 @example
1093 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1094 @end example
1095
1096 @noindent
1097 for a D@tie{}chord diagram.
1098
1099 Syntax rules for @var{definition-string}:
1100
1101 @itemize @bullet
1102
1103 @item
1104 Strings are terminated by semicolons; the number of semicolons
1105 is the number of strings in the diagram.
1106
1107 @item
1108 Mute strings are indicated by @samp{x}.
1109
1110 @item
1111 Open strings are indicated by @samp{o}.
1112
1113 @item
1114 A number indicates a fret indication at that fret.
1115
1116 @item
1117 If there are multiple fret indicators desired on a string, they
1118 should be separated by spaces.
1119
1120 @item
1121 Fingerings are given by following the fret number with a @w{@code{-},}
1122 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1123 fret with the second finger.
1124
1125 @item
1126 Where a barre indicator is desired, follow the fret (or fingering) symbol
1127 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1128
1129 @end itemize"
1130   ;; TODO -- change syntax to fret\string-finger
1131   (let ((definition-list
1132           (fret-parse-terse-definition-string props definition-string)))
1133     (fret-diagram-verbose-markup layout
1134                                  (car definition-list)
1135                                  (cdr definition-list))))
1136
1137