scm/fret-diagrams.scm

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