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