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 (string->number (substring keystring 2 (string-length keystring))))
49 (define (numerify mylist)
50 "Convert string values to numeric or character"
53 (let ((numeric-value (string->number (car mylist))))
55 (cons* numeric-value (numerify (cdr mylist)))
56 (cons* (car (string->list (car mylist)))
57 (numerify (cdr mylist)))))))
60 "Calculate the font step necessary to get a desired magnification"
61 (* 6 (/ (log mag) (log 2))))
63 (define (fret-count fret-range)
64 "Calculate the fret count for the diagram given the range of frets in the diagram."
65 (1+ (- (cdr fret-range) (car fret-range))))
67 (define (dot-has-color dot-settings)
68 "Return a color-name as symbol, if found in @var{dot-settings} otherwise @code{#f}"
69 (cond ((null? dot-settings)
71 ;; Don't bother the user with quote/unquote.
72 ;; We use the name-symbol for the color, looking up in 'x11-color-list'
73 ((member (car dot-settings) (map car x11-color-list))
75 (else (dot-has-color (cdr dot-settings)))))
77 (define (dot-is-inverted dot-settings)
78 "Return @code{'inverted}, if found in @var{dot-settings} otherwise @code{'()}"
79 (let ((inverted (member 'inverted dot-settings)))
84 (define (dot-is-parenthesized dot-settings)
85 "Return @code{'parenthesized}, if found in @var{dot-settings} otherwise @code{'()}"
86 (let ((parenthesized (member 'parenthesized dot-settings)))
91 ;; If @code{'default-paren-color} is not set, the parenthesis will take their
92 ;; color from the dot.
93 ;; Setting @code{'default-paren-color} will result in taking the color from
94 ;; `what-color', see below.
95 (define (default-paren-color dot-settings)
96 "Return @code{'default-paren-color}, if found in @var{dot-settings} otherwise @code{'()}"
97 (let ((default-color (member 'default-paren-color dot-settings)))
102 (define (subtract-base-fret base-fret dot-list)
103 "Subtract @var{base-fret} from every fret in @var{dot-list}"
106 (let ((this-list (car dot-list)))
111 (- (second this-list) base-fret)
112 ;; finger-number or markup
113 (if (and (not (null? (cddr this-list)))
114 (or (markup? (caddr this-list))
115 (number? (caddr this-list))))
119 (dot-is-inverted this-list)
121 (dot-is-parenthesized this-list)
124 (default-paren-color this-list)
126 (let ((colored (dot-has-color this-list)))
130 (subtract-base-fret base-fret (cdr dot-list))))))
132 (define (drop-paren item-list)
133 "Drop a final parentheses from a fret indication list
134 @code{item-list} resulting from a terse string specification of barre."
135 (if (> (length item-list) 0)
136 (let* ((max-index (- (length item-list) 1))
137 (last-element (car (list-tail item-list max-index))))
138 (if (or (equal? last-element ")") (equal? last-element "("))
139 (list-head item-list max-index)
143 (define (get-sub-list value master-list)
144 "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
145 (if (eq? master-list '())
147 (let ((sublist (car master-list)))
148 (if (equal? (cadr sublist) value)
150 (get-sub-list value (cdr master-list))))))
152 (define (merge-details key alist-list . default)
153 "Return @code{alist-list} entries for @code{key}, in one combined alist.
154 There can be two @code{alist-list} entries for a given key. The first
155 comes from the override-markup function, the second comes
156 from property settings during a regular override.
157 This is necessary because some details can be set in one
158 place, while others are set in the other. Both details
159 lists must be merged into a single alist.
160 Return @code{default} (optional, else #f) if not
163 (define (helper key alist-list default)
164 (if (null? alist-list)
166 (let* ((entry (assoc-get key (car alist-list))))
168 (append entry (chain-assoc-get key (cdr alist-list) '()))
169 (helper key (cdr alist-list) default)))))
171 (helper key alist-list
172 (if (pair? default) (car default) #f)))
174 ;; Conversions between fret/string coordinate system and x-y coordinate
177 ;; Fret coordinates are measured down the fretboard from the nut,
180 ;; String coordinates are measured from the lowest string, starting at 0.
182 ;; The x-y origin is at the intersection of the nut and the lowest string.
184 ;; X coordinates are positive to the right.
185 ;; Y coordinates are positive up.
187 (define (negate-extent extent)
188 "Return the extent in an axis opposite to the axis of @code{extent}."
189 (cons (- (cdr extent)) (- (car extent))))
191 (define (stencil-fretboard-extent stencil fretboard-axis orientation)
192 "Return the extent of @code{stencil} in the @code{fretboard-axis}
194 (if (eq? fretboard-axis 'fret)
195 (cond ((eq? orientation 'landscape)
196 (ly:stencil-extent stencil X))
197 ((eq? orientation 'opposing-landscape)
198 (negate-extent (ly:stencil-extent stencil X)))
200 (negate-extent (ly:stencil-extent stencil Y))))
201 ;; else -- eq? fretboard-axis 'string
202 (cond ((eq? orientation 'landscape)
203 (ly:stencil-extent stencil Y))
204 ((eq? orientation 'opposing-landscape)
205 (negate-extent (ly:stencil-extent stencil Y)))
207 (ly:stencil-extent stencil Y)))))
210 (define (stencil-fretboard-offset stencil fretboard-axis orientation)
211 "Return a the stencil coordinates of the center of @code{stencil}
212 in the @code{fretboard-axis} direction."
213 (* 0.5 (interval-length
214 (stencil-fretboard-extent stencil fretboard-axis orientation))))
217 (define (string-thickness string thickness-factor)
218 (expt (1+ thickness-factor) (1- string)))
220 ;; Functions that create stencils used in the fret diagram
222 (define (sans-serif-stencil layout props mag text)
223 "Create a stencil in sans-serif font based on @var{layout} and @var{props}
224 with magnification @var{mag} of the string @var{text}."
227 'font-size (stepmag mag)
228 (prepend-alist-chain 'font-family 'sans props))))
229 (interpret-markup layout my-props text)))
231 ;; markup commands and associated functions
233 (define (fret-parse-marking-list marking-list my-fret-count)
234 "Parse a fret-diagram-verbose marking list into component sublists"
235 (let* ((fret-range (cons 1 my-fret-count))
241 (let parse-item ((mylist marking-list))
242 (if (not (null? mylist))
243 (let* ((my-item (car mylist)) (my-code (car my-item)))
245 ((or (eq? my-code 'open)(eq? my-code 'mute))
246 (set! xo-list (cons* my-item xo-list)))
247 ((eq? my-code 'barre)
248 (set! barre-list (cons* (cdr my-item) barre-list)))
250 (set! capo-fret (cadr my-item)))
251 ((eq? my-code 'place-fret)
252 (set! dot-list (cons* (cdr my-item) dot-list))))
253 (parse-item (cdr mylist)))))
254 ;; calculate fret-range
256 (minfret (if (> capo-fret 0) capo-fret 99)))
257 (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
258 (if (null? fret-list)
260 (let ((fretval (second (car fret-list))))
261 (if (> fretval maxfret) (set! maxfret fretval))
262 (if (< fretval minfret) (set! minfret fretval))
263 (updatemax (cdr fret-list)))))
264 ;; take frets of 'barre-settings into account
265 (if (not (null? barre-list))
266 (set! minfret (apply min minfret (map last barre-list))))
267 (if (or (> maxfret my-fret-count) (> capo-fret 1))
270 (let ((upfret (- (+ minfret my-fret-count) 1)))
271 (if (> maxfret upfret) maxfret upfret)))))
272 (set! capo-fret (1+ (- capo-fret minfret)))
273 ;; subtract fret from dots
274 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
275 (acons 'fret-range fret-range
276 (acons 'barre-list barre-list
277 (acons 'dot-list dot-list
278 (acons 'xo-list xo-list
279 (acons 'capo-fret capo-fret '())))))))
281 (define (make-fret-diagram layout props marking-list)
282 "Make a fret diagram markup"
284 ;; note: here we get items from props that are needed in this routine,
285 ;; or that are needed in more than one of the procedures
286 ;; called from this routine. If they're only used in one of the
287 ;; sub-procedure, they're obtained in that procedure
288 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
289 ;;TODO -- get string-count directly from length of stringTunings;
290 ;; from FretBoard engraver, but not from markup call
291 (details (merge-details 'fret-diagram-details props '()))
293 (assoc-get 'string-count details 6)) ;; needed for everything
295 (assoc-get 'fret-count details 4)) ;; needed for everything
297 (assoc-get 'orientation details 'normal)) ;; needed for everything
300 'finger-code details 'none)) ;; needed for draw-dots and draw-barre
302 (if (eq? finger-code 'in-dot) 0.425 0.25)) ;; bigger dots if labeled
303 (default-dot-position
304 (if (eq? finger-code 'in-dot)
305 (- 0.95 default-dot-radius)
306 0.6)) ; move up to make room for bigger dot if labeled
309 'dot-radius details default-dot-radius))
310 ;; needed for draw-dots and draw-barre
313 'dot-position details default-dot-position))
314 ;; needed for draw-dots and draw-barre
316 (* (ly:output-def-lookup layout 'line-thickness)
317 (chain-assoc-get 'thickness props 0.5)))
318 ;; needed for draw-frets and draw-strings
320 (thickness-factor (assoc-get 'string-thickness-factor details 0))
321 (paren-padding (assoc-get 'paren-padding details 0.05))
323 (chain-assoc-get 'align-dir props -0.4)) ;; needed only here
324 (xo-padding (assoc-get 'xo-padding details 0.2)) ;; needed only here
325 (parameters (fret-parse-marking-list marking-list my-fret-count))
326 (capo-fret (assoc-get 'capo-fret parameters 0))
327 (dot-list (assoc-get 'dot-list parameters))
328 (xo-list (assoc-get 'xo-list parameters))
329 (fret-range (assoc-get 'fret-range parameters))
330 (my-fret-count (fret-count fret-range))
331 (barre-list (assoc-get 'barre-list parameters))
333 (assoc-get 'barre-type details 'curved))
334 (fret-diagram-stencil '()))
336 ;; Here are the fret diagram helper functions that depend on the
337 ;; fret diagram parameters. The functions are here because the
338 ;; diagram parameters are part of the lexical scope here.
340 (define (stencil-coordinates fret-coordinate string-coordinate)
341 "Return a pair @code{(x-coordinate . y-coordinate)}
342 in stencil coordinate system."
344 ((eq? orientation 'landscape)
345 (cons fret-coordinate
346 (- string-coordinate (1- string-count))))
347 ((eq? orientation 'opposing-landscape)
348 (cons (- fret-coordinate) (- string-coordinate)))
350 (cons string-coordinate (- fret-coordinate)))))
352 (define (stencil-coordinate-offset fret-offset string-offset)
353 "Return a pair @code{(x-offset . y-offset)}
354 for translation in stencil coordinate system."
356 ((eq? orientation 'landscape)
357 (cons fret-offset (- string-offset)))
358 ((eq? orientation 'opposing-landscape)
359 (cons (- fret-offset) string-offset))
361 (cons string-offset (- fret-offset)))))
365 (define (make-bezier-sandwich-list start stop base height
367 "Make the argument list for a bezier sandwich from
368 string coordinate @var{start} to string-coordinate @var{stop} with a
369 baseline at fret coordinate @var{base}, a height of
370 @var{height}, and a half thickness of @var{half-thickness}."
371 (let* ((width (+ (- stop start) 1))
372 (cp-left-width (+ (* width half-thickness) start))
373 (cp-right-width (- stop (* width half-thickness)))
374 (bottom-control-point-height
375 (- base (- height half-thickness)))
376 (top-control-point-height
379 (stencil-coordinates base start))
381 (stencil-coordinates base stop))
382 (left-upper-control-point
384 top-control-point-height cp-left-width))
385 (left-lower-control-point
387 bottom-control-point-height cp-left-width))
388 (right-upper-control-point
390 top-control-point-height cp-right-width))
391 (right-lower-control-point
393 bottom-control-point-height cp-right-width)))
395 ;; order of bezier control points is:
396 ;; left cp low, right cp low, right end low, left end low
397 ;; right cp high, left cp high, left end high, right end high.
399 (list left-lower-control-point
400 right-lower-control-point
403 right-upper-control-point
404 left-upper-control-point
408 (define (draw-strings)
409 "Draw the string 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 determined by @var{orientation}."
416 (string-stencil (car x))
418 (string-stencil (car x))
421 (let* ((string-list (map 1+ (iota string-count))))
422 (helper string-list)))
424 (define (string-stencil string)
425 "Make a stencil for @code{string}, given the fret-diagram
427 (let* ((string-coordinate (- string-count string))
428 (current-string-thickness
429 (* th size (string-thickness string thickness-factor)))
430 (fret-half-thickness (* size th 0.5))
431 (half-string (* current-string-thickness 0.5))
434 (- fret-half-thickness)
435 (- (* size string-coordinate) half-string)))
438 (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
439 (+ half-string (* size string-coordinate)))))
441 (string-x-extent start-coordinates end-coordinates)
442 (string-y-extent start-coordinates end-coordinates)
446 "Draw the fret lines for a fret diagram with
447 @var{string-count} strings and frets as indicated in @var{fret-range}.
448 Line thickness is given by @var{th}, fret & string spacing by
449 @var{size}. Orientation is given by @var{orientation}."
452 (fret-stencil (car x))
454 (fret-stencil (car x))
457 (let ((fret-list (iota (1+ my-fret-count))))
460 (define (fret-stencil fret)
461 "Make a stencil for @code{fret}, given the
462 fret-diagram overall parameters."
463 (let* ((low-string-half-thickness
467 (string-thickness string-count thickness-factor)))
468 (fret-half-thickness (* 0.5 size th))
472 (- fret-half-thickness low-string-half-thickness)))
476 (* size (1- string-count)))))
479 (car start-coordinates) (cdr start-coordinates)
480 (car end-coordinates) (cdr end-coordinates))))
482 (define (draw-barre barre-list)
483 "Create barre indications for a fret diagram"
484 (if (not (null? barre-list))
485 (let* ((string1 (caar barre-list))
486 (string2 (cadar barre-list))
487 (barre-fret (caddar barre-list))
488 (top-fret (cdr fret-range))
489 (low-fret (car fret-range))
490 (fret (1+ (- barre-fret low-fret)))
491 (barre-vertical-offset 0.5)
492 (dot-center-fret-coordinate (+ (1- fret) dot-position))
493 (barre-fret-coordinate
494 (+ dot-center-fret-coordinate
495 (* (- barre-vertical-offset 0.5) dot-radius)))
496 (barre-start-string-coordinate (- string-count string1))
497 (barre-end-string-coordinate (- string-count string2))
498 (scale-dot-radius (* size dot-radius))
499 (barre-type (assoc-get 'barre-type details 'curved))
502 ((eq? barre-type 'straight)
503 (make-straight-barre-stencil
504 barre-fret-coordinate
505 barre-start-string-coordinate
506 barre-end-string-coordinate
508 ((eq? barre-type 'curved)
509 (make-curved-barre-stencil
510 barre-fret-coordinate
511 barre-start-string-coordinate
512 barre-end-string-coordinate
513 scale-dot-radius)))))
514 (if (not (null? (cdr barre-list)))
517 (draw-barre (cdr barre-list)))
520 (define (make-straight-barre-stencil
522 start-string-coordinate
523 end-string-coordinate
525 "Create a straight barre stencil."
528 (* size fret-coordinate)
529 (* size start-string-coordinate)))
532 (* size fret-coordinate)
533 (* size end-string-coordinate))))
541 (define (make-curved-barre-stencil
543 start-string-coordinate
544 end-string-coordinate
546 "Create a curved barre stencil."
547 (let* ((bezier-thick 0.1)
550 (make-bezier-sandwich-list
551 (* size start-string-coordinate)
552 (* size end-string-coordinate)
553 (* size fret-coordinate)
554 (* size bezier-height)
555 (* size bezier-thick)))
558 (+ (* size fret-coordinate) half-thickness)
559 (- (* size start-string-coordinate) half-thickness)))
562 (- (* size fret-coordinate)
563 (* size bezier-height)
565 (+ (* size end-string-coordinate) half-thickness)))
566 (x-extent (cons (car box-lower-left) (car box-upper-right)))
567 (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
568 (make-bezier-sandwich-stencil
570 (* size bezier-thick)
574 (define (draw-dots dot-list)
575 "Make dots for fret diagram."
577 (let* ( (scale-dot-radius (* size dot-radius))
578 (scale-dot-thick (* size th))
579 (default-dot-color (assoc-get 'dot-color details))
580 (finger-label-padding 0.3)
583 (assoc-get 'dot-label-font-mag details 1.0)))
584 (string-label-font-mag
587 'string-label-font-mag details
588 (cond ((or (eq? orientation 'landscape)
589 (eq? orientation 'opposing-landscape))
592 (mypair (car dot-list))
593 (restlist (cdr dot-list))
594 (string (car mypair))
596 (fret-coordinate (* size (+ (1- fret) dot-position)))
597 (string-coordinate (* size (- string-count string)))
599 (stencil-coordinates fret-coordinate string-coordinate))
600 (extent (cons (- scale-dot-radius) scale-dot-radius))
601 (finger (caddr mypair))
602 (finger (if (number? finger) (number->string finger) finger))
604 (if (not (null? (dot-is-parenthesized mypair)))
605 (dot-is-parenthesized mypair)
608 (if (not (null? (default-paren-color mypair)))
609 (default-paren-color mypair)
612 (if (not (null? (dot-is-inverted mypair)))
613 (dot-is-inverted mypair)
617 (and (eq? default-dot-color 'white) (not inverted))))
621 (not (dot-has-color mypair))
622 (not (eq? default-dot-color 'white)))
623 (or default-dot-color 'black))
625 (or (dot-has-color mypair) 'black))
627 (or (dot-has-color mypair)
635 scale-dot-radius scale-dot-thick #t)
639 (- scale-dot-radius (* 0.5 scale-dot-thick))
641 (x11-color 'white)))))
643 (if dot-color-is-white?
644 (inverted-stil what-color)
647 scale-dot-radius scale-dot-thick #t)
651 (if (and parenthesis-color
652 (not (eq? default-dot-color 'white)))
653 (x11-color (or default-dot-color 'black))
656 (parenthesize-stencil
657 dot-stencil ;; stencil
658 (* size th 0.75) ;; half-thickness
659 (* 0.15 size) ;;width
661 paren-padding ;; padding
669 (ly:stencil-translate final-dot-stencil dot-coordinates))
672 ((or (eq? finger '())(eq? finger-code 'none))
674 ((eq? finger-code 'in-dot)
678 layout props dot-label-font-mag finger))))
679 (ly:stencil-translate
682 (if dot-color-is-white?
686 (stencil-with-color finger-label white)))
688 ((eq? finger-code 'below-string)
689 (let* ((label-stencil
692 layout props string-label-font-mag
695 (stencil-fretboard-offset
696 label-stencil 'fret orientation))
697 (label-fret-coordinate
699 (+ 1 my-fret-count finger-label-padding))
701 (label-string-coordinate string-coordinate)
704 label-fret-coordinate
705 label-string-coordinate)))
708 (ly:stencil-translate
710 label-translation))))
711 (else ;unknown finger-code
717 labeled-dot-stencil))))
719 (define (draw-thick-zero-fret)
720 "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
721 (let* ((half-lowest-string-thickness
722 (* 0.5 th (string-thickness string-count thickness-factor)))
723 (half-thick (* 0.5 sth))
725 (* sth (assoc-get 'top-fret-thickness details 3.0)))
726 (start-string-coordinate (- half-lowest-string-thickness))
727 (end-string-coordinate (+ (* size (1- string-count)) half-thick))
728 (start-fret-coordinate half-thick)
729 (end-fret-coordinate (- half-thick top-fret-thick))
732 start-fret-coordinate start-string-coordinate))
735 end-fret-coordinate end-string-coordinate)))
737 ;; Put limits in order, or else the intervals are considered empty
738 (ordered-cons (car lower-left) (car upper-right))
739 (ordered-cons (cdr lower-left) (cdr upper-right))
742 (define (draw-xo xo-list)
743 "Put open and mute string indications on diagram, as contained in
746 (assoc-get 'xo-font-magnification details
747 (cond ((or (eq? orientation 'landscape)
748 (eq? orientation 'opposing-landscape))
751 (mypair (car xo-list))
752 (restlist (cdr xo-list))
753 (glyph-string (if (eq? (car mypair) 'mute)
754 (assoc-get 'mute-string details "X")
755 (assoc-get 'open-string details "O")))
756 (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
760 layout props (* size xo-font-mag) glyph-string)))
761 (glyph-stencil-coordinates
762 (stencil-coordinates 0 glyph-string-coordinate))
764 (ly:stencil-translate
766 glyph-stencil-coordinates)))
771 (draw-xo restlist)))))
773 (define (draw-capo fret)
774 "Draw a capo indicator across the full width of the fret-board
777 (* size (assoc-get 'capo-thickness details 0.5)))
778 (half-thick (* capo-thick 0.5))
779 (last-string-position 0)
780 (first-string-position (* size (- string-count 1)))
781 (fret-position ( * size (1- (+ dot-position fret))))
785 first-string-position))
789 last-string-position)))
792 (car start-point) (cdr start-point)
793 (car end-point) (cdr end-point))))
795 (define (label-fret fret-range)
796 "Label the base fret on a fret diagram"
797 (let* ((base-fret (car fret-range))
798 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
799 (label-space (* 0.5 size))
800 (label-dir (assoc-get 'label-dir details RIGHT))
801 (label-vertical-offset
802 (assoc-get 'fret-label-vertical-offset details 0))
803 (label-horizontal-offset
804 (assoc-get 'fret-label-horizontal-offset details 0))
806 (assoc-get 'number-type details 'roman-lower))
808 (number-format number-type base-fret
809 (assoc-get 'fret-label-custom-format
814 layout props (* size label-font-mag) label-text)))
816 (stencil-fretboard-offset
820 (label-outside-diagram
822 (* size label-horizontal-offset)
824 (ly:stencil-translate
827 (* size (+ 1.0 label-vertical-offset))
828 (if (eq? label-dir LEFT)
829 (- label-outside-diagram)
830 (+ (* size (1- string-count)) label-outside-diagram))))))
832 ;; Here is the body of make-fret-diagram
834 (set! fret-diagram-stencil
835 (ly:stencil-add (draw-strings) (draw-frets)))
836 (if (and (not (null? barre-list))
837 (not (eq? 'none barre-type)))
838 (set! fret-diagram-stencil
840 (draw-barre barre-list)
841 fret-diagram-stencil)))
842 (if (not (null? dot-list))
843 (set! fret-diagram-stencil
846 (draw-dots dot-list))))
847 (if (= (car fret-range) 1)
848 (set! fret-diagram-stencil
851 (draw-thick-zero-fret))))
852 (if (not (null? xo-list))
853 (let* ((diagram-fret-top
854 (car (stencil-fretboard-extent
858 (xo-stencil (draw-xo xo-list))
860 (stencil-fretboard-offset
861 xo-stencil 'fret orientation))
863 (stencil-coordinate-offset
868 (set! fret-diagram-stencil
871 (ly:stencil-translate
873 xo-stencil-offset)))))
875 (set! fret-diagram-stencil
878 (draw-capo capo-fret))))
879 (if (> (car fret-range) 1)
880 (set! fret-diagram-stencil
883 (label-fret fret-range))))
884 (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
886 (define (fret-parse-definition-string props definition-string)
887 "Parse a fret diagram string and return a pair containing:
888 @var{props}, modified as necessary by the definition-string
889 a fret-indication list with the appropriate values"
890 (let* ((fret-count 4)
892 (fret-range (cons 1 fret-count))
898 (details (merge-details 'fret-diagram-details props '()))
899 (items (string-split definition-string #\;)))
900 (let parse-item ((myitems items))
901 (if (not (null? (cdr myitems)))
902 (let ((test-string (car myitems)))
903 (case (car (string->list (substring test-string 0 1)))
904 ((#\s) (let ((size (get-numeric-from-key test-string)))
905 (set! props (prepend-alist-chain 'size size props))))
906 ((#\t) (let ((th (get-numeric-from-key test-string)))
907 (set! props (prepend-alist-chain 'thickness th props))))
908 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
909 (finger-id (case finger-code
912 ((2) 'below-string))))
914 (acons 'finger-code finger-id details))))
915 ((#\c) (set! output-list
920 (string-split (substring test-string 2) #\-)))
922 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
924 (acons 'fret-count fret-count details))))
925 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
927 (acons 'string-count string-count details))))
928 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
930 (acons 'dot-radius dot-size details))))
931 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
933 (acons 'dot-position dot-position details))))
935 (let ((this-list (string-split test-string #\-)))
936 (if (string->number (cadr this-list))
939 (cons 'place-fret (numerify this-list))
941 (if (equal? (cadr this-list) "x" )
944 (list 'mute (string->number (car this-list)))
948 (list 'open (string->number (car this-list)))
950 (parse-item (cdr myitems)))))
951 ;; add the modified details
953 (prepend-alist-chain 'fret-diagram-details details props))
954 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
957 (fret-parse-terse-definition-string props definition-string)
958 "Parse a fret diagram string that uses terse syntax;
959 return a pair containing:
960 @var{props}, modified to include the string-count determined by the
961 definition-string, and
962 a fret-indication list with the appropriate values"
963 ;; TODO -- change syntax to fret\string-finger
965 (let* ((details (merge-details 'fret-diagram-details props '()))
966 (barre-start-list '())
969 (items (string-split definition-string #\;))
970 (string-count (- (length items) 1)))
971 (let parse-item ((myitems items))
972 (if (not (null? (cdr myitems)))
973 (let* ((test-string (car myitems))
974 (current-string (- (length myitems) 1))
975 (indicators (string-split test-string #\ )))
976 (let parse-indicators ((myindicators indicators))
977 (if (not (eq? '() myindicators))
978 (let* ((this-list (string-split (car myindicators) #\-))
979 (max-element-index (- (length this-list) 1))
981 (car (list-tail this-list max-element-index)))
983 (if (string->number (car this-list))
984 (string->number (car this-list))
986 (if (equal? last-element "(")
988 (set! barre-start-list
989 (cons-fret (list current-string fret)
992 (list-head this-list max-element-index))))
993 (if (equal? last-element ")")
995 (get-sub-list fret barre-start-list))
996 (insert-index (- (length this-barre) 1)))
998 (cons-fret (cons* 'barre
1004 (list-head this-list max-element-index))))
1011 (drop-paren (numerify this-list)))
1013 (if (equal? (car this-list) "x" )
1017 (list 'mute current-string)
1022 (list 'open current-string)
1024 (parse-indicators (cdr myindicators)))))
1025 (parse-item (cdr myitems)))))
1026 (set! details (acons 'string-count string-count details))
1027 (set! props (prepend-alist-chain 'fret-diagram-details details props))
1028 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
1031 (define-markup-command
1032 (fret-diagram-verbose layout props marking-list)
1033 (pair?) ; argument type (list, but use pair? for speed)
1034 #:category instrument-specific-markup ; markup type
1035 #:properties ((align-dir -0.4) ; properties and defaults
1037 (fret-diagram-details)
1039 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
1044 \\markup \\fret-diagram-verbose
1045 #'((mute 6) (mute 5) (open 4)
1046 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
1050 produces a standard D@tie{}chord diagram without fingering indications.
1052 Possible elements in @var{marking-list}:
1055 @item (mute @var{string-number})
1056 Place a small @q{x} at the top of string @var{string-number}.
1058 @item (open @var{string-number})
1059 Place a small @q{o} at the top of string @var{string-number}.
1061 @item (barre @var{start-string} @var{end-string} @var{fret-number})
1062 Place a barre indicator (much like a tie) from string @var{start-string}
1063 to string @var{end-string} at fret @var{fret-number}.
1065 @item (capo @var{fret-number})
1066 Place a capo indicator (a large solid bar) across the entire fretboard
1067 at fret location @var{fret-number}. Also, set fret @var{fret-number}
1068 to be the lowest fret on the fret diagram.
1070 (place-fret @var{string-number}
1072 [@var{finger-value}]
1073 [@var{color-modifier}]
1075 [@code{'parenthesized} [@code{'default-paren-color}]])
1076 Place a fret playing indication on string @var{string-number} at fret
1077 @var{fret-number} with an optional fingering label @var{finger-value},
1078 an optional color modifier @var{color-modifier}, an optional color
1079 @var{color}, an optional parenthesis @code{'parenthesized} and an
1080 optional paranthesis color @code{'default-paren-color}.
1081 By default, the fret playing indicator is a solid dot. This can be
1082 globally changed by setting the value of the variable @var{dot-color}
1083 or for a single dot by setting the value of @var{color}. The dot can
1084 be parenthesized by adding @code{'parenthesized}. By default the
1085 color for the parenthesis is taken from the dot. Adding
1086 @code{'default-paren-color} will take the parenthesis-color from the
1087 global @var{dot-color}, as a fall-back black will be used.
1088 Setting @var{color-modifier} to @code{inverted} inverts the dot color
1089 for a specific fingering.
1090 The values for @var{string-number}, @var{fret-number}, and the optional
1091 @var{finger} should be entered first in that order.
1092 The order of the other optional arguments does not matter.
1093 If the @var{finger} part of the @code{place-fret} element is present,
1094 @var{finger-value} will be displayed according to the setting of the
1095 variable @var{finger-code}. There is no limit to the number of fret
1096 indications per string.
1099 (make-fret-diagram layout props marking-list))
1102 (define-markup-command (fret-diagram layout props definition-string)
1103 (string?) ; argument type
1104 #:category instrument-specific-markup ; markup category
1105 #:properties (fret-diagram-verbose-markup) ; properties and defaults
1106 "Make a (guitar) fret diagram. For example, say
1109 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1113 for fret spacing 3/4 of staff space, D chord diagram
1115 Syntax rules for @var{definition-string}:
1119 Diagram items are separated by semicolons.
1126 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1131 @code{t:}@var{number} -- Set the line thickness (relative to normal
1136 @code{h:}@var{number} -- Set the height of the diagram in frets.
1140 @code{w:}@var{number} -- Set the width of the diagram in strings.
1144 @code{f:}@var{number} -- Set fingering label type
1145 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1149 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1153 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1154 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1158 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1159 barre mark from @var{string1} to @var{string2} on @var{fret}.
1162 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1163 If @var{fret} is @samp{o}, @var{string} is identified as open.
1164 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1167 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1168 @var{string} at @var{fret}, and label with @var{fingering} as defined
1169 by the @code{f:} code.
1173 Note: There is no limit to the number of fret indications per string.
1175 (let ((definition-list
1176 (fret-parse-definition-string props definition-string)))
1177 (fret-diagram-verbose-markup
1178 layout (car definition-list) (cdr definition-list))))
1180 (define-markup-command
1181 (fret-diagram-terse layout props definition-string)
1182 (string?) ; argument type
1183 #:category instrument-specific-markup ; markup category
1184 #:properties (fret-diagram-verbose-markup) ; properties
1185 "Make a fret diagram markup using terse string-based syntax.
1190 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1194 for a D@tie{}chord diagram.
1196 Syntax rules for @var{definition-string}:
1201 Strings are terminated by semicolons; the number of semicolons
1202 is the number of strings in the diagram.
1205 Mute strings are indicated by @samp{x}.
1208 Open strings are indicated by @samp{o}.
1211 A number indicates a fret indication at that fret.
1214 If there are multiple fret indicators desired on a string, they
1215 should be separated by spaces.
1218 Fingerings are given by following the fret number with a @w{@code{-},}
1219 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1220 fret with the second finger.
1223 Where a barre indicator is desired, follow the fret (or fingering) symbol
1224 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1227 ;; TODO -- change syntax to fret\string-finger
1228 (let ((definition-list
1229 (fret-parse-terse-definition-string props definition-string)))
1230 (fret-diagram-verbose-markup layout
1231 (car definition-list)
1232 (cdr definition-list))))