1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2004--2015 Carl D. Sorensen <c_sorensen@byu.edu>
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.
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.
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/>.
20 (define (string-x-extent start-point end-point)
21 "Return the x-extent of a string that goes from start-point
23 (let ((x1 (car start-point))
29 (define (string-y-extent start-point end-point)
30 "Return the y-extent of a string that goes from start-point
32 (let ((y1 (cdr start-point))
39 (define (cons-fret new-value old-list)
40 "Put together a fret-list in the format desired by parse-string"
41 (if (eq? old-list '())
43 (cons* new-value old-list)))
45 (define (get-numeric-from-key keystring)
46 "Get the numeric value from a key of the form k:val"
47 (let* ((entry (substring keystring 2 (string-length keystring)))
48 (numeric-entry (string->number entry)))
49 ;; throw an error, if `entry' can't be transformed into a number
53 "Unhandled entry in fret-diagram \"~a\" in \"~a\""
57 (define (numerify mylist)
58 "Convert string values to numeric or character"
61 (let ((numeric-value (string->number (car mylist))))
63 (cons* numeric-value (numerify (cdr mylist)))
64 (cons* (car (string->list (car mylist)))
65 (numerify (cdr mylist)))))))
68 "Calculate the font step necessary to get a desired magnification"
69 (* 6 (/ (log mag) (log 2))))
71 (define (fret-count fret-range)
72 "Calculate the fret count for the diagram given the range of frets in the diagram."
73 (1+ (- (cdr fret-range) (car fret-range))))
75 (define (dot-has-color dot-settings)
76 "Return a color-name as symbol, if found in @var{dot-settings} otherwise @code{#f}"
77 (cond ((null? dot-settings)
79 ;; Don't bother the user with quote/unquote.
80 ;; We use the name-symbol for the color, looking up in 'x11-color-list'
81 ((member (car dot-settings) (map car x11-color-list))
83 (else (dot-has-color (cdr dot-settings)))))
85 (define (dot-is-inverted dot-settings)
86 "Return @code{'inverted}, if found in @var{dot-settings} otherwise @code{'()}"
87 (let ((inverted (member 'inverted dot-settings)))
92 (define (dot-is-parenthesized dot-settings)
93 "Return @code{'parenthesized}, if found in @var{dot-settings} otherwise @code{'()}"
94 (let ((parenthesized (member 'parenthesized dot-settings)))
99 ;; If @code{'default-paren-color} is not set, the parenthesis will take their
100 ;; color from the dot.
101 ;; Setting @code{'default-paren-color} will result in taking the color from
102 ;; `what-color', see below.
103 (define (default-paren-color dot-settings)
104 "Return @code{'default-paren-color}, if found in @var{dot-settings} otherwise @code{'()}"
105 (let ((default-color (member 'default-paren-color dot-settings)))
110 (define (subtract-base-fret base-fret dot-list)
111 "Subtract @var{base-fret} from every fret in @var{dot-list}"
114 (let ((this-list (car dot-list)))
119 (- (second this-list) base-fret)
120 ;; finger-number or markup
121 (if (and (not (null? (cddr this-list)))
122 (or (markup? (caddr this-list))
123 (number? (caddr this-list))))
127 (dot-is-inverted this-list)
129 (dot-is-parenthesized this-list)
132 (default-paren-color this-list)
134 (let ((colored (dot-has-color this-list)))
138 (subtract-base-fret base-fret (cdr dot-list))))))
140 (define (drop-paren item-list)
141 "Drop a final parentheses from a fret indication list
142 @code{item-list} resulting from a terse string specification of barre."
143 (if (> (length item-list) 0)
144 (let* ((max-index (- (length item-list) 1))
145 (last-element (car (list-tail item-list max-index))))
146 (if (or (equal? last-element ")") (equal? last-element "("))
147 (list-head item-list max-index)
151 (define (get-sub-list value master-list)
152 "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
153 (if (eq? master-list '())
155 (let ((sublist (car master-list)))
156 (if (equal? (cadr sublist) value)
158 (get-sub-list value (cdr master-list))))))
160 (define (merge-details key alist-list . default)
161 "Return @code{alist-list} entries for @code{key}, in one combined alist.
162 There can be two @code{alist-list} entries for a given key. The first
163 comes from the override-markup function, the second comes
164 from property settings during a regular override.
165 This is necessary because some details can be set in one
166 place, while others are set in the other. Both details
167 lists must be merged into a single alist.
168 Return @code{default} (optional, else #f) if not
171 (define (helper key alist-list default)
172 (if (null? alist-list)
174 (let* ((entry (assoc-get key (car alist-list))))
176 (append entry (chain-assoc-get key (cdr alist-list) '()))
177 (helper key (cdr alist-list) default)))))
179 (helper key alist-list
180 (if (pair? default) (car default) #f)))
182 ;; Conversions between fret/string coordinate system and x-y coordinate
185 ;; Fret coordinates are measured down the fretboard from the nut,
188 ;; String coordinates are measured from the lowest string, starting at 0.
190 ;; The x-y origin is at the intersection of the nut and the lowest string.
192 ;; X coordinates are positive to the right.
193 ;; Y coordinates are positive up.
195 (define (negate-extent extent)
196 "Return the extent in an axis opposite to the axis of @code{extent}."
197 (cons (- (cdr extent)) (- (car extent))))
199 (define (stencil-fretboard-extent stencil fretboard-axis orientation)
200 "Return the extent of @code{stencil} in the @code{fretboard-axis}
202 (if (eq? fretboard-axis 'fret)
203 (cond ((eq? orientation 'landscape)
204 (ly:stencil-extent stencil X))
205 ((eq? orientation 'opposing-landscape)
206 (negate-extent (ly:stencil-extent stencil X)))
208 (negate-extent (ly:stencil-extent stencil Y))))
209 ;; else -- eq? fretboard-axis 'string
210 (cond ((eq? orientation 'landscape)
211 (ly:stencil-extent stencil Y))
212 ((eq? orientation 'opposing-landscape)
213 (negate-extent (ly:stencil-extent stencil Y)))
215 (ly:stencil-extent stencil Y)))))
218 (define (stencil-fretboard-offset stencil fretboard-axis orientation)
219 "Return a the stencil coordinates of the center of @code{stencil}
220 in the @code{fretboard-axis} direction."
221 (* 0.5 (interval-length
222 (stencil-fretboard-extent stencil fretboard-axis orientation))))
225 (define (string-thickness string thickness-factor)
226 (expt (1+ thickness-factor) (1- string)))
228 ;; Functions that create stencils used in the fret diagram
230 (define (sans-serif-stencil layout props mag text)
231 "Create a stencil in sans-serif font based on @var{layout} and @var{props}
232 with magnification @var{mag} of the string @var{text}."
235 'font-size (stepmag mag)
236 (prepend-alist-chain 'font-family 'sans props))))
237 (interpret-markup layout my-props text)))
239 ;; markup commands and associated functions
241 (define (fret-parse-marking-list marking-list my-fret-count)
242 "Parse a fret-diagram-verbose marking list into component sublists"
243 (let* ((fret-range (cons 1 my-fret-count))
249 (let parse-item ((mylist marking-list))
250 (if (not (null? mylist))
251 (let* ((my-item (car mylist)) (my-code (car my-item)))
253 ((or (eq? my-code 'open)(eq? my-code 'mute))
254 (set! xo-list (cons* my-item xo-list)))
255 ((eq? my-code 'barre)
256 (if (every number? (cdr my-item))
257 (set! barre-list (cons* (cdr my-item) barre-list))
259 "barre-indications should contain only numbers: ~a"
262 (set! capo-fret (cadr my-item)))
263 ((eq? my-code 'place-fret)
264 (set! dot-list (cons* (cdr my-item) dot-list))))
265 (parse-item (cdr mylist)))))
266 ;; calculate fret-range
268 (minfret (if (> capo-fret 0) capo-fret 99)))
269 (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
270 (if (null? fret-list)
272 (let ((fretval (second (car fret-list))))
273 (if (> fretval maxfret) (set! maxfret fretval))
274 (if (< fretval minfret) (set! minfret fretval))
275 (updatemax (cdr fret-list)))))
276 ;; take frets of 'barre-settings into account
277 (if (not (null? barre-list))
278 (set! minfret (apply min minfret (map last barre-list))))
279 (if (or (> maxfret my-fret-count) (> capo-fret 1))
282 (let ((upfret (- (+ minfret my-fret-count) 1)))
283 (if (> maxfret upfret) maxfret upfret)))))
284 (if (not (zero? (apply min capo-fret (map cadr dot-list))))
285 (set! capo-fret (1+ (- capo-fret minfret))))
286 ;; subtract fret from dots
287 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
288 (acons 'fret-range fret-range
289 (acons 'barre-list barre-list
290 (acons 'dot-list dot-list
291 (acons 'xo-list xo-list
292 (acons 'capo-fret capo-fret '())))))))
294 (define (make-fret-diagram layout props marking-list)
295 "Make a fret diagram markup"
297 ;; note: here we get items from props that are needed in this routine,
298 ;; or that are needed in more than one of the procedures
299 ;; called from this routine. If they're only used in one of the
300 ;; sub-procedure, they're obtained in that procedure
301 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
302 ;;TODO -- get string-count directly from length of stringTunings;
303 ;; from FretBoard engraver, but not from markup call
304 (details (merge-details 'fret-diagram-details props '()))
306 (assoc-get 'fret-distance details 1.0))
308 (assoc-get 'string-distance details 1.0))
310 (assoc-get 'string-count details 6)) ;; needed for everything
312 (assoc-get 'fret-count details 4)) ;; needed for everything
314 (assoc-get 'orientation details 'normal)) ;; needed for everything
317 'finger-code details 'none)) ;; needed for draw-dots and draw-barre
319 (if (eq? finger-code 'in-dot) 0.425 0.25)) ;; bigger dots if labeled
320 (default-dot-position
321 (if (eq? finger-code 'in-dot)
322 (- 0.95 default-dot-radius)
323 0.6)) ; move up to make room for bigger dot if labeled
326 'dot-radius details default-dot-radius))
327 ;; needed for draw-dots and draw-barre
330 'dot-position details default-dot-position))
331 ;; needed for draw-dots and draw-barre
333 (* (ly:output-def-lookup layout 'line-thickness)
334 (chain-assoc-get 'thickness props 0.5)))
335 ;; needed for draw-frets and draw-strings
337 (thickness-factor (assoc-get 'string-thickness-factor details 0))
338 (paren-padding (assoc-get 'paren-padding details 0.05))
340 (chain-assoc-get 'align-dir props -0.4)) ;; needed only here
341 (xo-padding (assoc-get 'xo-padding details 0.2)) ;; needed only here
342 (parameters (fret-parse-marking-list marking-list my-fret-count))
343 (capo-fret (assoc-get 'capo-fret parameters 0))
344 (dot-list (assoc-get 'dot-list parameters))
345 (xo-list (assoc-get 'xo-list parameters))
346 (fret-range (assoc-get 'fret-range parameters))
347 (my-fret-count (fret-count fret-range))
348 (barre-list (assoc-get 'barre-list parameters))
350 (assoc-get 'barre-type details 'curved))
351 (fret-diagram-stencil '()))
353 ;; Here are the fret diagram helper functions that depend on the
354 ;; fret diagram parameters. The functions are here because the
355 ;; diagram parameters are part of the lexical scope here.
357 (define (stencil-coordinates fret-coordinate string-coordinate)
358 "Return a pair @code{(x-coordinate . y-coordinate)}
359 in stencil coordinate system."
361 ((eq? orientation 'landscape)
362 (cons fret-coordinate
363 (- string-coordinate (1- string-count))))
364 ((eq? orientation 'opposing-landscape)
365 (cons (- fret-coordinate) (- string-coordinate)))
367 (cons string-coordinate (- fret-coordinate)))))
369 (define (stencil-coordinate-offset fret-offset string-offset)
370 "Return a pair @code{(x-offset . y-offset)}
371 for translation in stencil coordinate system."
373 ((eq? orientation 'landscape)
374 (cons fret-offset (- string-offset)))
375 ((eq? orientation 'opposing-landscape)
376 (cons (- fret-offset) string-offset))
378 (cons string-offset (- fret-offset)))))
382 (define (make-bezier-sandwich-list start stop base height
384 "Make the argument list for a bezier sandwich from
385 string coordinate @var{start} to string-coordinate @var{stop} with a
386 baseline at fret coordinate @var{base}, a height of
387 @var{height}, and a half thickness of @var{half-thickness}."
388 (let* ((width (+ (- stop start) 1))
389 (cp-left-width (+ (* width half-thickness) start))
390 (cp-right-width (- stop (* width half-thickness)))
391 (bottom-control-point-height
392 (- base (- height half-thickness)))
393 (top-control-point-height
396 (stencil-coordinates base start))
398 (stencil-coordinates base stop))
399 (left-upper-control-point
401 top-control-point-height cp-left-width))
402 (left-lower-control-point
404 bottom-control-point-height cp-left-width))
405 (right-upper-control-point
407 top-control-point-height cp-right-width))
408 (right-lower-control-point
410 bottom-control-point-height cp-right-width)))
412 ;; order of bezier control points is:
413 ;; left cp low, left cp low, right cp low, right end low
414 ;; right cp high, left cp high
418 left-lower-control-point
419 right-lower-control-point
422 right-upper-control-point
423 left-upper-control-point)))
425 (define (draw-strings)
426 "Draw the string lines for a fret diagram with
427 @var{string-count} strings and frets as indicated in @var{fret-range}.
428 Line thickness is given by @var{th}, fret & string spacing by
429 @var{size}. Orientation is determined by @var{orientation}."
433 (string-stencil (car x))
435 (string-stencil (car x))
438 (let* ((string-list (map 1+ (iota string-count))))
439 (helper string-list)))
441 (define (string-stencil string)
442 "Make a stencil for @code{string}, given the fret-diagram
444 (let* ((string-coordinate (- string-count string))
445 (current-string-thickness
446 (* th size (string-thickness string thickness-factor)))
447 (fret-half-thickness (* size th 0.5))
448 (half-string (* current-string-thickness 0.5))
451 (- fret-half-thickness)
452 (- (* size string-distance string-coordinate) half-string)))
455 (+ fret-half-thickness
456 (* size fret-distance (1+ (fret-count fret-range))))
458 (* size string-distance string-coordinate)))))
460 (string-x-extent start-coordinates end-coordinates)
461 (string-y-extent start-coordinates end-coordinates)
465 "Draw the fret lines for a fret diagram with
466 @var{string-count} strings and frets as indicated in @var{fret-range}.
467 Line thickness is given by @var{th}, fret & string spacing by
468 @var{size}. Orientation is given by @var{orientation}."
471 (fret-stencil (car x))
473 (fret-stencil (car x))
476 (let ((fret-list (iota (1+ my-fret-count))))
479 (define (fret-stencil fret)
480 "Make a stencil for @code{fret}, given the
481 fret-diagram overall parameters."
482 (let* ((low-string-half-thickness
486 (string-thickness string-count thickness-factor)))
487 (fret-half-thickness (* 0.5 size th))
490 (* fret-distance size fret)
491 (- fret-half-thickness low-string-half-thickness)))
494 (* fret-distance size fret)
495 (* size string-distance (1- string-count)))))
498 (car start-coordinates) (cdr start-coordinates)
499 (car end-coordinates) (cdr end-coordinates))))
501 (define (draw-barre barre-list)
502 "Create barre indications for a fret diagram"
503 (if (not (null? barre-list))
504 (let* ((string1 (caar barre-list))
505 (string2 (cadar barre-list))
506 (barre-fret (caddar barre-list))
507 (top-fret (cdr fret-range))
508 (low-fret (car fret-range))
509 (fret (1+ (- barre-fret low-fret)))
510 (barre-vertical-offset 0.5)
511 (dot-center-fret-coordinate (+ (1- fret) dot-position))
512 (barre-fret-coordinate
513 (+ dot-center-fret-coordinate
514 (* (- barre-vertical-offset 0.5) dot-radius)))
515 (barre-start-string-coordinate (- string-count string1))
516 (barre-end-string-coordinate (- string-count string2))
517 (scale-dot-radius (* size dot-radius))
518 (barre-type (assoc-get 'barre-type details 'curved))
521 ((eq? barre-type 'straight)
522 (make-straight-barre-stencil
523 barre-fret-coordinate
524 barre-start-string-coordinate
525 barre-end-string-coordinate
527 ((eq? barre-type 'curved)
528 (make-curved-barre-stencil
529 barre-fret-coordinate
530 barre-start-string-coordinate
531 barre-end-string-coordinate
532 scale-dot-radius)))))
533 (if (not (null? (cdr barre-list)))
536 (draw-barre (cdr barre-list)))
539 (define (make-straight-barre-stencil
541 start-string-coordinate
542 end-string-coordinate
544 "Create a straight barre stencil."
547 (* size fret-distance fret-coordinate)
548 (* size string-distance start-string-coordinate)))
551 (* size fret-distance fret-coordinate)
552 (* size string-distance end-string-coordinate))))
560 (define (make-curved-barre-stencil
562 start-string-coordinate
563 end-string-coordinate
565 "Create a curved barre stencil."
566 (let* ((bezier-thick 0.1)
569 (make-bezier-sandwich-list
570 (* size string-distance start-string-coordinate)
571 (* size string-distance end-string-coordinate)
572 (* size fret-distance fret-coordinate)
573 (* size bezier-height)
574 (* size bezier-thick))))
575 (make-bezier-sandwich-stencil
577 (* size bezier-thick))))
579 (define (draw-dots dot-list)
580 "Make dots for fret diagram."
582 (let* ( (scale-dot-radius (* size dot-radius))
583 (scale-dot-thick (* size th))
584 (default-dot-color (assoc-get 'dot-color details))
585 (finger-label-padding 0.3)
588 (assoc-get 'dot-label-font-mag details 1.0)))
589 (string-label-font-mag
592 'string-label-font-mag details
593 (cond ((or (eq? orientation 'landscape)
594 (eq? orientation 'opposing-landscape))
597 (mypair (car dot-list))
598 (restlist (cdr dot-list))
599 (string (car mypair))
602 (* size fret-distance (+ (1- fret) dot-position)))
604 (* size string-distance (- string-count string)))
606 (stencil-coordinates fret-coordinate string-coordinate))
607 (extent (cons (- scale-dot-radius) scale-dot-radius))
608 (finger (caddr mypair))
609 (finger (if (number? finger) (number->string finger) finger))
611 (if (not (null? (dot-is-parenthesized mypair)))
612 (dot-is-parenthesized mypair)
615 (if (not (null? (default-paren-color mypair)))
616 (default-paren-color mypair)
619 (if (not (null? (dot-is-inverted mypair)))
620 (dot-is-inverted mypair)
624 (and (eq? default-dot-color 'white) (not inverted))))
628 (not (dot-has-color mypair))
629 (not (eq? default-dot-color 'white)))
630 (or default-dot-color 'black))
632 (or (dot-has-color mypair) 'black))
634 (or (dot-has-color mypair)
642 scale-dot-radius scale-dot-thick #t)
646 (- scale-dot-radius (* 0.5 scale-dot-thick))
648 (x11-color 'white)))))
650 (if dot-color-is-white?
651 (inverted-stil what-color)
654 scale-dot-radius scale-dot-thick #t)
658 (if (and parenthesis-color
659 (not (eq? default-dot-color 'white)))
660 (x11-color (or default-dot-color 'black))
663 (parenthesize-stencil
664 dot-stencil ;; stencil
665 (* size th 0.75) ;; half-thickness
666 (* 0.15 size) ;;width
668 paren-padding ;; padding
676 (ly:stencil-translate final-dot-stencil dot-coordinates))
679 ((or (eq? finger '())(eq? finger-code 'none))
681 ((eq? finger-code 'in-dot)
683 (if (not (null? finger))
685 layout props dot-label-font-mag finger)
688 (interval-length (ly:stencil-extent finger-stil X)))
690 (interval-length (ly:stencil-extent finger-stil Y)))
692 (/ (interval-length (ly:stencil-extent dot-stencil Y))
695 (/ dot-stencil-radius
696 ;; Calculate the radius of the circle through the
697 ;; corners of the box containing the finger-stil.
698 ;; Give it a little padding. The value, (* 2 th),
702 (+ (expt (/ finger-stil-length 2) 2)
703 (expt (/ finger-stil-height 2) 2)))
712 scale-factor scale-factor))))
713 (ly:stencil-translate
716 (if dot-color-is-white?
720 (stencil-with-color finger-label white)))
722 ((eq? finger-code 'below-string)
723 (let* ((label-stencil
726 layout props string-label-font-mag
729 (stencil-fretboard-offset
730 label-stencil 'fret orientation))
731 (label-fret-coordinate
732 ;; (1) Move the below-string-finger-codes to the bottom
733 ;; edge of the string, i.e.
734 ;; (* (1+ my-fret-count) fret-distance)
735 ;; (2) add `finger-label-padding' (a hardcoded
736 ;; correction-value to get a bit default padding).
737 ;; TODO: make it a property?
738 ;; (3) scale this with `size'
739 ;; (4) add `label-fret-offset', to get the final
743 (+ (* (1+ my-fret-count) fret-distance)
744 finger-label-padding))
746 (label-string-coordinate string-coordinate)
749 label-fret-coordinate
750 label-string-coordinate)))
753 (ly:stencil-translate
755 label-translation))))
756 (else ;unknown finger-code
762 labeled-dot-stencil))))
764 (define (draw-thick-zero-fret)
765 "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
766 (let* ((half-lowest-string-thickness
767 (* 0.5 th (string-thickness string-count thickness-factor)))
768 (half-thick (* 0.5 sth))
770 (* sth (assoc-get 'top-fret-thickness details 3.0)))
771 (start-string-coordinate (- half-lowest-string-thickness))
772 (end-string-coordinate
773 (+ (* size string-distance (1- string-count)) half-thick))
774 (start-fret-coordinate half-thick)
775 (end-fret-coordinate (- half-thick top-fret-thick))
778 start-fret-coordinate start-string-coordinate))
781 end-fret-coordinate end-string-coordinate)))
783 ;; Put limits in order, or else the intervals are considered empty
784 (ordered-cons (car lower-left) (car upper-right))
785 (ordered-cons (cdr lower-left) (cdr upper-right))
788 (define (draw-xo xo-list)
789 "Put open and mute string indications on diagram, as contained in
792 (assoc-get 'xo-font-magnification details
793 (cond ((or (eq? orientation 'landscape)
794 (eq? orientation 'opposing-landscape))
797 (mypair (car xo-list))
798 (restlist (cdr xo-list))
799 (glyph-string (if (eq? (car mypair) 'mute)
800 (assoc-get 'mute-string details "X")
801 (assoc-get 'open-string details "O")))
802 (glyph-string-coordinate
803 (* (- string-count (cadr mypair)) string-distance size))
807 layout props (* size xo-font-mag) glyph-string)))
808 (glyph-stencil-coordinates
809 (stencil-coordinates 0 glyph-string-coordinate))
811 (ly:stencil-translate
813 glyph-stencil-coordinates)))
818 (draw-xo restlist)))))
820 (define (draw-capo fret)
821 "Draw a capo indicator across the full width of the fret-board
824 (* size (assoc-get 'capo-thickness details 0.5)))
825 (half-thick (* capo-thick 0.5))
826 (last-string-position 0)
827 (first-string-position (* size (- string-count 1)))
828 (fret-position (* size (1- (+ dot-position fret))))
831 (* fret-distance fret-position)
832 (* string-distance first-string-position)))
835 (* fret-distance fret-position)
836 last-string-position)))
839 (car start-point) (cdr start-point)
840 (car end-point) (cdr end-point))))
842 (define (label-fret fret-range)
843 "Label the base fret on a fret diagram"
844 (let* ((base-fret (car fret-range))
845 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
846 (label-space (* 0.5 size))
847 (label-dir (assoc-get 'label-dir details RIGHT))
848 (label-vertical-offset
849 (assoc-get 'fret-label-vertical-offset details 0))
850 (label-horizontal-offset
851 (assoc-get 'fret-label-horizontal-offset details 0))
853 (assoc-get 'number-type details 'roman-lower))
855 (number-format number-type base-fret
856 (assoc-get 'fret-label-custom-format
861 layout props (* size label-font-mag) label-text)))
863 (stencil-fretboard-offset
867 (label-outside-diagram
869 (* size label-horizontal-offset)
871 (ly:stencil-translate
874 (* size fret-distance (1+ label-vertical-offset))
875 (if (eqv? label-dir LEFT)
876 (- label-outside-diagram)
877 (+ (* size string-distance (1- string-count))
878 label-outside-diagram))))))
880 ;; Here is the body of make-fret-diagram
882 (set! fret-diagram-stencil
883 (ly:stencil-add (draw-strings) (draw-frets)))
884 (if (and (not (null? barre-list))
885 (not (eq? 'none barre-type)))
886 (set! fret-diagram-stencil
888 (draw-barre barre-list)
889 fret-diagram-stencil)))
890 (if (not (null? dot-list))
891 (set! fret-diagram-stencil
894 (draw-dots dot-list))))
895 (if (= (car fret-range) 1)
896 (set! fret-diagram-stencil
899 (draw-thick-zero-fret))))
900 (if (not (null? xo-list))
901 (let* ((diagram-fret-top
902 (car (stencil-fretboard-extent
906 (xo-stencil (draw-xo xo-list))
908 (stencil-fretboard-offset
909 xo-stencil 'fret orientation))
911 (stencil-coordinate-offset
916 (set! fret-diagram-stencil
919 (ly:stencil-translate
921 xo-stencil-offset)))))
923 (set! fret-diagram-stencil
926 (draw-capo capo-fret))))
927 (if (> (car fret-range) 1)
928 (set! fret-diagram-stencil
931 (label-fret fret-range))))
932 (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
934 (define (fret-parse-definition-string props definition-string)
935 "Parse a fret diagram string and return a pair containing:
936 @var{props}, modified as necessary by the definition-string
937 a fret-indication list with the appropriate values"
938 (let* ((fret-count 4)
940 (fret-range (cons 1 fret-count))
946 (details (merge-details 'fret-diagram-details props '()))
947 ;; remove whitespace-characters from definition-string
948 (cleared-string (remove-whitespace definition-string))
949 (items (string-split cleared-string #\;)))
950 (let parse-item ((myitems items))
951 (if (not (null? (cdr myitems)))
952 (let ((test-string (car myitems)))
953 (case (car (string->list (substring test-string 0 1)))
954 ((#\s) (let ((size (get-numeric-from-key test-string)))
955 (set! props (prepend-alist-chain 'size size props))))
956 ((#\t) (let ((th (get-numeric-from-key test-string)))
957 (set! props (prepend-alist-chain 'thickness th props))))
958 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
959 (finger-id (case finger-code
962 ((2) 'below-string))))
964 (acons 'finger-code finger-id details))))
965 ((#\c) (set! output-list
970 (string-split (substring test-string 2) #\-)))
972 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
974 (acons 'fret-count fret-count details))))
975 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
977 (acons 'string-count string-count details))))
978 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
980 (acons 'dot-radius dot-size details))))
981 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
983 (acons 'dot-position dot-position details))))
985 (let* ((this-list (string-split test-string #\-))
986 (fret-number (string->number (car this-list))))
987 ;; If none of the above applies, `fret-number' needs to be a
988 ;; number. Throw an error, if not.
989 (if (not fret-number)
991 "Unhandled entry in fret-diagrams \"~a\" in \"~a\""
994 (if (string->number (cadr this-list))
997 (cons 'place-fret (numerify this-list))
999 (if (equal? (cadr this-list) "x" )
1002 (list 'mute fret-number)
1006 (list 'open fret-number)
1008 (parse-item (cdr myitems)))))
1009 ;; add the modified details
1011 (prepend-alist-chain 'fret-diagram-details details props))
1012 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
1015 (fret-parse-terse-definition-string props definition-string)
1016 "Parse a fret diagram string that uses terse syntax;
1017 return a pair containing:
1018 @var{props}, modified to include the string-count determined by the
1019 definition-string, and
1020 a fret-indication list with the appropriate values"
1021 ;; TODO -- change syntax to fret\string-finger
1023 (let* ((details (merge-details 'fret-diagram-details props '()))
1024 (barre-start-list '())
1027 (items (string-split definition-string #\;))
1028 (string-count (- (length items) 1)))
1029 (let parse-item ((myitems items))
1030 (if (not (null? (cdr myitems)))
1031 (let* ((test-string (car myitems))
1032 (current-string (- (length myitems) 1))
1033 (indicators (string-split test-string #\ )))
1034 (let parse-indicators ((myindicators indicators))
1035 (if (not (eq? '() myindicators))
1036 (let* ((this-list (string-split (car myindicators) #\-))
1037 (max-element-index (- (length this-list) 1))
1039 (car (list-tail this-list max-element-index)))
1041 (if (string->number (car this-list))
1042 (string->number (car this-list))
1044 (if (equal? last-element "(")
1046 (set! barre-start-list
1047 (cons-fret (list current-string fret)
1050 (list-head this-list max-element-index))))
1051 (if (equal? last-element ")")
1053 (get-sub-list fret barre-start-list))
1054 (insert-index (- (length this-barre) 1)))
1056 (cons-fret (cons* 'barre
1062 (list-head this-list max-element-index))))
1069 (drop-paren (numerify this-list)))
1071 (if (equal? (car this-list) "x" )
1075 (list 'mute current-string)
1080 (list 'open current-string)
1082 (parse-indicators (cdr myindicators)))))
1083 (parse-item (cdr myitems)))))
1084 (set! details (acons 'string-count string-count details))
1085 (set! props (prepend-alist-chain 'fret-diagram-details details props))
1086 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
1089 (define-markup-command
1090 (fret-diagram-verbose layout props marking-list)
1091 (pair?) ; argument type (list, but use pair? for speed)
1092 #:category instrument-specific-markup ; markup type
1093 #:properties ((align-dir -0.4) ; properties and defaults
1095 (fret-diagram-details)
1097 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
1102 \\markup \\fret-diagram-verbose
1103 #'((mute 6) (mute 5) (open 4)
1104 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
1108 produces a standard D@tie{}chord diagram without fingering indications.
1110 Possible elements in @var{marking-list}:
1113 @item (mute @var{string-number})
1114 Place a small @q{x} at the top of string @var{string-number}.
1116 @item (open @var{string-number})
1117 Place a small @q{o} at the top of string @var{string-number}.
1119 @item (barre @var{start-string} @var{end-string} @var{fret-number})
1120 Place a barre indicator (much like a tie) from string @var{start-string}
1121 to string @var{end-string} at fret @var{fret-number}.
1123 @item (capo @var{fret-number})
1124 Place a capo indicator (a large solid bar) across the entire fretboard
1125 at fret location @var{fret-number}. Also, set fret @var{fret-number}
1126 to be the lowest fret on the fret diagram.
1128 (place-fret @var{string-number}
1130 [@var{finger-value}]
1131 [@var{color-modifier}]
1133 [@code{'parenthesized} [@code{'default-paren-color}]])
1134 Place a fret playing indication on string @var{string-number} at fret
1135 @var{fret-number} with an optional fingering label @var{finger-value},
1136 an optional color modifier @var{color-modifier}, an optional color
1137 @var{color}, an optional parenthesis @code{'parenthesized} and an
1138 optional paranthesis color @code{'default-paren-color}.
1139 By default, the fret playing indicator is a solid dot. This can be
1140 globally changed by setting the value of the variable @var{dot-color}
1141 or for a single dot by setting the value of @var{color}. The dot can
1142 be parenthesized by adding @code{'parenthesized}. By default the
1143 color for the parenthesis is taken from the dot. Adding
1144 @code{'default-paren-color} will take the parenthesis-color from the
1145 global @var{dot-color}, as a fall-back black will be used.
1146 Setting @var{color-modifier} to @code{inverted} inverts the dot color
1147 for a specific fingering.
1148 The values for @var{string-number}, @var{fret-number}, and the optional
1149 @var{finger} should be entered first in that order.
1150 The order of the other optional arguments does not matter.
1151 If the @var{finger} part of the @code{place-fret} element is present,
1152 @var{finger-value} will be displayed according to the setting of the
1153 variable @var{finger-code}. There is no limit to the number of fret
1154 indications per string.
1157 (make-fret-diagram layout props marking-list))
1160 (define-markup-command (fret-diagram layout props definition-string)
1161 (string?) ; argument type
1162 #:category instrument-specific-markup ; markup category
1163 #:properties (fret-diagram-verbose-markup) ; properties and defaults
1164 "Make a (guitar) fret diagram. For example, say
1167 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1171 for fret spacing 3/4 of staff space, D chord diagram
1173 Syntax rules for @var{definition-string}:
1177 Diagram items are separated by semicolons.
1184 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1189 @code{t:}@var{number} -- Set the line thickness (relative to normal
1194 @code{h:}@var{number} -- Set the height of the diagram in frets.
1198 @code{w:}@var{number} -- Set the width of the diagram in strings.
1202 @code{f:}@var{number} -- Set fingering label type
1203 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1207 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1211 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1212 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1216 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1217 barre mark from @var{string1} to @var{string2} on @var{fret}.
1220 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1221 If @var{fret} is @samp{o}, @var{string} is identified as open.
1222 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1225 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1226 @var{string} at @var{fret}, and label with @var{fingering} as defined
1227 by the @code{f:} code.
1231 Note: There is no limit to the number of fret indications per string.
1233 (let ((definition-list
1234 (fret-parse-definition-string props definition-string)))
1235 (fret-diagram-verbose-markup
1236 layout (car definition-list) (cdr definition-list))))
1238 (define-markup-command
1239 (fret-diagram-terse layout props definition-string)
1240 (string?) ; argument type
1241 #:category instrument-specific-markup ; markup category
1242 #:properties (fret-diagram-verbose-markup) ; properties
1243 "Make a fret diagram markup using terse string-based syntax.
1248 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1252 for a D@tie{}chord diagram.
1254 Syntax rules for @var{definition-string}:
1259 Strings are terminated by semicolons; the number of semicolons
1260 is the number of strings in the diagram.
1263 Mute strings are indicated by @samp{x}.
1266 Open strings are indicated by @samp{o}.
1269 A number indicates a fret indication at that fret.
1272 If there are multiple fret indicators desired on a string, they
1273 should be separated by spaces.
1276 Fingerings are given by following the fret number with a @w{@code{-},}
1277 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1278 fret with the second finger.
1281 Where a barre indicator is desired, follow the fret (or fingering) symbol
1282 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1285 ;; TODO -- change syntax to fret\string-finger
1286 (let ((definition-list
1287 (fret-parse-terse-definition-string props definition-string)))
1288 (fret-diagram-verbose-markup layout
1289 (car definition-list)
1290 (cdr definition-list))))