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              ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
 825                            (finger-id (case finger-code
 826                                         ((0) 'none)
 827                                         ((1) 'in-dot)
 828                                         ((2) 'below-string))))
 829                       (set! details
 830                             (acons 'finger-code finger-id details))))
 831              ((#\c) (set! output-list
 832                           (cons-fret
 833                            (cons
 834                             'barre
 835                             (numerify
 836                              (string-split (substring test-string 2) #\-)))
 837                            output-list)))
 838              ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
 839                       (set! details
 840                             (acons 'fret-count fret-count details))))
 841              ((#\w) (let ((string-count (get-numeric-from-key test-string)))
 842                       (set! details
 843                             (acons 'string-count string-count details))))
 844              ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
 845                       (set! details
 846                             (acons 'dot-radius dot-size details))))
 847              ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
 848                       (set! details
 849                             (acons 'dot-position dot-position details))))
 850              (else
 851               (let ((this-list (string-split test-string #\-)))
 852                 (if (string->number (cadr this-list))
 853                     (set! output-list
 854                           (cons-fret
 855                            (cons 'place-fret (numerify this-list))
 856                            output-list))
 857                     (if (equal? (cadr this-list) "x" )
 858                         (set! output-list
 859                               (cons-fret
 860                                (list 'mute (string->number (car this-list)))
 861                                output-list))
 862                         (set! output-list
 863                               (cons-fret
 864                                (list 'open (string->number (car this-list)))
 865                                output-list)))))))
 866            (parse-item (cdr myitems)))))
 867    ;  add the modified details
 868    (set! props
 869          (prepend-alist-chain 'fret-diagram-details details props))
 870    `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
 871
 872 (define-public
 873   (fret-parse-terse-definition-string props definition-string)
 874   "Parse a fret diagram string that uses terse syntax;
 875 return a pair containing:
 876 @var{props}, modified to include the string-count determined by the
 877 definition-string, and
 878 a fret-indication list with the appropriate values"
 879 ;TODO -- change syntax to fret\string-finger
 880
 881   (let* ((details (merge-details 'fret-diagram-details props '()))
 882          (barre-start-list '())
 883          (output-list '())
 884          (new-props '())
 885          (items (string-split definition-string #\;))
 886          (string-count (- (length items) 1)))
 887     (let parse-item ((myitems items))
 888       (if (not (null? (cdr myitems)))
 889           (let* ((test-string (car myitems))
 890                  (current-string (- (length myitems) 1))
 891                  (indicators (string-split test-string #\ )))
 892             (let parse-indicators ((myindicators indicators))
 893               (if (not (eq? '() myindicators))
 894                   (let* ((this-list (string-split (car myindicators) #\-))
 895                          (max-element-index (- (length this-list) 1))
 896                          (last-element
 897                           (car (list-tail this-list max-element-index)))
 898                          (fret
 899                           (if (string->number (car this-list))
 900                               (string->number (car this-list))
 901                               (car this-list))))
 902                     (if (equal? last-element "(")
 903                         (begin
 904                           (set! barre-start-list
 905                                 (cons-fret (list current-string fret)
 906                                            barre-start-list))
 907                           (set! this-list
 908                                 (list-head this-list max-element-index))))
 909                     (if (equal? last-element ")")
 910                         (let* ((this-barre
 911                                 (get-sub-list fret barre-start-list))
 912                                (insert-index (- (length this-barre) 1)))
 913                           (set! output-list
 914                                 (cons-fret (cons* 'barre
 915                                                   (car this-barre)
 916                                                   current-string
 917                                                   (cdr this-barre))
 918                                            output-list))
 919                           (set! this-list
 920                                 (list-head this-list max-element-index))))
 921                     (if (number? fret)
 922                         (set!
 923                          output-list
 924                          (cons-fret (cons*
 925                                      'place-fret
 926                                      current-string
 927                                      (drop-paren (numerify this-list)))
 928                                     output-list))
 929                         (if (equal? (car this-list) "x" )
 930                             (set!
 931                              output-list
 932                              (cons-fret
 933                               (list 'mute current-string)
 934                               output-list))
 935                             (set!
 936                              output-list
 937                              (cons-fret
 938                               (list 'open current-string)
 939                               output-list))))
 940                     (parse-indicators (cdr myindicators)))))
 941             (parse-item (cdr myitems)))))
 942     (set! details (acons 'string-count string-count details))
 943     (set! props (prepend-alist-chain 'fret-diagram-details details props))
 944     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
 945
 946
 947 (define-markup-command
 948   (fret-diagram-verbose layout props marking-list)
 949   (pair?) ; argument type (list, but use pair? for speed)
 950   #:category instrument-specific-markup ; markup type
 951   #:properties ((align-dir -0.4) ; properties and defaults
 952                 (size 1.0)
 953                 (fret-diagram-details)
 954                 (thickness 0.5))
 955   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
 956
 957   For example,
 958
 959 @example
 960 \\markup \\fret-diagram-verbose
 961   #'((mute 6) (mute 5) (open 4)
 962      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
 963 @end example
 964
 965 @noindent
 966 produces a standard D@tie{}chord diagram without fingering indications.
 967
 968 Possible elements in @var{marking-list}:
 969
 970 @table @code
 971 @item (mute @var{string-number})
 972 Place a small @q{x} at the top of string @var{string-number}.
 973
 974 @item (open @var{string-number})
 975 Place a small @q{o} at the top of string @var{string-number}.
 976
 977 @item (barre @var{start-string} @var{end-string} @var{fret-number})
 978 Place a barre indicator (much like a tie) from string @var{start-string}
 979 to string @var{end-string} at fret @var{fret-number}.
 980
 981 @item (capo @var{fret-number})
 982 Place a capo indicator (a large solid bar) across the entire fretboard
 983 at fret location @var{fret-number}.  Also, set fret @var{fret-number}
 984 to be the lowest fret on the fret diagram.
 985
 986 @item (place-fret @var{string-number} @var{fret-number} [@var{finger-value} [@var{color-modifier}]])
 987 Place a fret playing indication on string @var{string-number} at fret
 988 @var{fret-number} with an optional fingering label @var{finger-value},
 989 and an optional color modifier @var{color-modifier}.
 990 By default, the fret playing indicator is a solid dot.  This can be
 991 globally changed by setting the value of the variable @var{dot-color}.
 992 Setting @var{color-modifier} to @code{inverted} inverts the dot color
 993 for a specific fingering.
 994 If the @var{finger} part of the @code{place-fret} element is present,
 995 @var{finger-value} will be displayed according to the setting of the
 996 variable @var{finger-code}.  There is no limit to the number of fret
 997 indications per string.
 998 @end table"
 999
1000   (make-fret-diagram layout props marking-list))
1001
1002
1003 (define-markup-command (fret-diagram layout props definition-string)
1004   (string?) ; argument type
1005   #:category instrument-specific-markup ; markup category
1006   #:properties (fret-diagram-verbose-markup) ; properties and defaults
1007   "Make a (guitar) fret diagram.  For example, say
1008
1009 @example
1010 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1011 @end example
1012
1013 @noindent
1014 for fret spacing 3/4 of staff space, D chord diagram
1015
1016 Syntax rules for @var{definition-string}:
1017 @itemize @minus
1018
1019 @item
1020 Diagram items are separated by semicolons.
1021
1022 @item
1023 Possible items:
1024
1025 @itemize @bullet
1026 @item
1027 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1028 spaces).
1029 Default:@tie{}1.
1030
1031 @item
1032 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
1033 Default:@tie{}0.05.
1034
1035 @item
1036 @code{h:}@var{number} -- Set the height of the diagram in frets.
1037 Default:@tie{}4.
1038
1039 @item
1040 @code{w:}@var{number} -- Set the width of the diagram in strings.
1041 Default:@tie{}6.
1042
1043 @item
1044 @code{f:}@var{number} -- Set fingering label type
1045  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1046 Default:@tie{}0.
1047
1048 @item
1049 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1050 Default:@tie{}0.25.
1051
1052 @item
1053 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1054 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1055 Default:@tie{}0.6.
1056
1057 @item
1058 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1059 barre mark from @var{string1} to @var{string2} on @var{fret}.
1060
1061 @item
1062 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1063 If @var{fret} is @samp{o}, @var{string} is identified as open.
1064 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1065
1066 @item
1067 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1068 @var{string} at @var{fret}, and label with @var{fingering} as defined
1069 by the @code{f:} code.
1070 @end itemize
1071
1072 @item
1073 Note: There is no limit to the number of fret indications per string.
1074 @end itemize"
1075   (let ((definition-list
1076           (fret-parse-definition-string props definition-string)))
1077     (fret-diagram-verbose-markup
1078      layout (car definition-list) (cdr definition-list))))
1079
1080 (define-markup-command
1081   (fret-diagram-terse layout props definition-string)
1082   (string?) ; argument type
1083   #:category instrument-specific-markup ; markup category
1084   #:properties (fret-diagram-verbose-markup) ; properties
1085   "Make a fret diagram markup using terse string-based syntax.
1086
1087 Here is an example
1088
1089 @example
1090 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1091 @end example
1092
1093 @noindent
1094 for a D@tie{}chord diagram.
1095
1096 Syntax rules for @var{definition-string}:
1097
1098 @itemize @bullet
1099
1100 @item
1101 Strings are terminated by semicolons; the number of semicolons
1102 is the number of strings in the diagram.
1103
1104 @item
1105 Mute strings are indicated by @samp{x}.
1106
1107 @item
1108 Open strings are indicated by @samp{o}.
1109
1110 @item
1111 A number indicates a fret indication at that fret.
1112
1113 @item
1114 If there are multiple fret indicators desired on a string, they
1115 should be separated by spaces.
1116
1117 @item
1118 Fingerings are given by following the fret number with a @w{@code{-},}
1119 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1120 fret with the second finger.
1121
1122 @item
1123 Where a barre indicator is desired, follow the fret (or fingering) symbol
1124 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1125
1126 @end itemize"
1127   ;; TODO -- change syntax to fret\string-finger
1128   (let ((definition-list
1129           (fret-parse-terse-definition-string props definition-string)))
1130     (fret-diagram-verbose-markup layout
1131                                  (car definition-list)
1132                                  (cdr definition-list))))
1133
1134