1 ;;;; fret-diagrams.scm --
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2009 Carl D. Sorensen <c_sorensen@byu.edu>
12 (define (string-x-extent start-point end-point)
13 "Return the x-extent of a string that goes from start-point
15 (let ((x1 (car start-point))
21 (define (string-y-extent start-point end-point)
22 "Return the y-extent of a string that goes from start-point
24 (let ((y1 (cdr start-point))
31 (define (cons-fret new-value old-list)
32 "Put together a fret-list in the format desired by parse-string"
33 (if (eq? old-list '())
35 (cons* new-value old-list)))
37 (define (get-numeric-from-key keystring)
38 "Get the numeric value from a key of the form k:val"
39 (string->number (substring keystring 2 (string-length keystring))))
41 (define (numerify mylist)
42 "Convert string values to numeric or character"
45 (let ((numeric-value (string->number (car mylist))))
47 (cons* numeric-value (numerify (cdr mylist)))
48 (cons* (car (string->list (car mylist)))
49 (numerify (cdr mylist)))))))
52 "Calculate the font step necessary to get a desired magnification"
53 (* 6 (/ (log mag) (log 2))))
55 (define (fret-count fret-range)
56 "Calculate the fret count for the diagram given the range of frets in the diagram."
57 (1+ (- (cdr fret-range) (car fret-range))))
59 (define (subtract-base-fret base-fret dot-list)
60 "Subtract @var{base-fret} from every fret in @var{dot-list}"
63 (let ((this-list (car dot-list)))
64 (cons* (list (car this-list) (- (second this-list) base-fret)
65 (if (null? (cddr this-list))
68 (subtract-base-fret base-fret (cdr dot-list))))))
70 (define (make-bezier-sandwich-list start stop base height
71 half-thickness orientation)
72 "Make the argument list for a bezier sandwich from
73 string coordinate @var{start} to string-coordinate @var{stop} with a
74 baseline at fret coordinate @var{base}, a height of
75 @var{height}, and a half thickness of @var{half-thickness}."
76 (let* ((width (+ (- stop start) 1))
77 (cp-left-width (+ (* width half-thickness) start))
78 (cp-right-width (- stop (* width half-thickness)))
79 (bottom-control-point-height
80 (- base (- height half-thickness)))
81 (top-control-point-height
84 (stencil-coordinates base start orientation))
86 (stencil-coordinates base stop orientation))
87 (left-upper-control-point
89 top-control-point-height cp-left-width orientation))
90 (left-lower-control-point
92 bottom-control-point-height cp-left-width orientation))
93 (right-upper-control-point
95 top-control-point-height cp-right-width orientation))
96 (right-lower-control-point
98 bottom-control-point-height cp-right-width orientation)))
99 ; order of bezier control points is:
100 ; left cp low, right cp low, right end low, left end low
101 ; right cp high, left cp high, left end high, right end high.
103 (list left-lower-control-point
104 right-lower-control-point
107 right-upper-control-point
108 left-upper-control-point
112 (define (drop-paren item-list)
113 "Drop a final parentheses from a fret indication list
114 @code{item-list} resulting from a terse string specification of barre."
115 (if (> (length item-list) 0)
116 (let* ((max-index (- (length item-list) 1))
117 (last-element (car (list-tail item-list max-index))))
118 (if (or (equal? last-element ")") (equal? last-element "("))
119 (list-head item-list max-index)
123 (define (get-sub-list value master-list)
124 "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
125 (if (eq? master-list '())
127 (let ((sublist (car master-list)))
128 (if (equal? (cadr sublist) value)
130 (get-sub-list value (cdr master-list))))))
132 (define (merge-details key alist-list . default)
133 "Return @code{alist-list} entries for @code{key}, in one combined alist.
134 There can be two @code{alist-list} entries for a given key. The first
135 comes from the override-markup function, the second comes
136 from property settings during a regular override.
137 This is necessary because some details can be set in one
138 place, while others are set in the other. Both details
139 lists must be merged into a single alist.
140 Return @code{default} (optional, else #f) if not
143 (define (helper key alist-list default)
144 (if (null? alist-list)
146 (let* ((handle (assoc key (car alist-list))))
148 (append (cdr handle) (chain-assoc-get key (cdr alist-list) '()))
149 (helper key (cdr alist-list) default)))))
151 (helper key alist-list
152 (if (pair? default) (car default) #f)))
155 ; Conversions between fret/string coordinate system and x-y coordinate
158 ; Fret coordinates are measured down the fretboard from the nut,
161 ; String coordinates are measured from the lowest string, starting at 0.
163 ; The x-y origin is at the intersection of the nut and the lowest string.
165 ; X coordinates are positive to the right.
166 ; Y coordinates are positive up.
169 (define (negate-extent extent)
170 "Return the extent in an axis opposite to the axis of @code{extent}."
171 (cons (- (cdr extent)) (- (car extent))))
173 (define (stencil-fretboard-extent stencil fretboard-axis orientation)
174 "Return the extent of @code{stencil} in the @code{fretboard-axis}
176 (if (eq? fretboard-axis 'fret)
177 (cond ((eq? orientation 'landscape)
178 (ly:stencil-extent stencil X))
179 ((eq? orientation 'opposing-landscape)
180 (negate-extent (ly:stencil-extent stencil X)))
182 (negate-extent (ly:stencil-extent stencil Y))))
183 ; else -- eq? fretboard-axis 'string
184 (cond ((eq? orientation 'landscape)
185 (ly:stencil-extent stencil Y))
186 ((eq? orientation 'opposing-landscape)
187 (negate-extent (ly:stencil-extent stencil Y)))
189 (ly:stencil-extent stencil Y)))))
192 (define (stencil-fretboard-offset stencil fretboard-axis orientation)
193 "Return a the stencil coordinates of the center of @code{stencil}
194 in the @code{fretboard-axis} direction."
195 (* 0.5 (interval-length
196 (stencil-fretboard-extent stencil fretboard-axis orientation))))
198 (define (stencil-coordinates fret-coordinate string-coordinate orientation)
199 "Return a pair @code{(x-coordinate . y-coordinate)} in stencil coordinate
202 ((eq? orientation 'landscape)
203 (cons fret-coordinate string-coordinate))
204 ((eq? orientation 'opposing-landscape)
205 (cons (- fret-coordinate) (- string-coordinate)))
207 (cons string-coordinate (- fret-coordinate)))))
209 (define (string-thickness string thickness-factor)
210 (expt (1+ thickness-factor) (1- string)))
213 ; Functions that create stencils used in the fret diagram
216 (define (sans-serif-stencil layout props mag text)
217 "Create a stencil in sans-serif font based on @var{layout} and @var{props}
218 with magnification @var{mag} of the string @var{text}."
221 'font-size (stepmag mag)
222 (prepend-alist-chain 'font-family 'sans props))))
223 (interpret-markup layout my-props text)))
226 (define (string-stencil string string-count fret-range
227 th thickness-factor size orientation)
228 "Make a stencil for @code{string}, given the fret-diagram
230 (let* ((string-coordinate (- string-count string))
231 (current-string-thickness
232 (* th size (string-thickness string thickness-factor)))
233 (fret-half-thickness (* size th 0.5))
234 (half-string (* current-string-thickness 0.5))
237 (- fret-half-thickness)
238 (- (* size string-coordinate) half-string)
242 (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
243 (+ half-string (* size string-coordinate))
245 (ly:round-filled-box (string-x-extent start-coordinates end-coordinates)
246 (string-y-extent start-coordinates end-coordinates)
249 (define (fret-stencil fret string-count th
250 thickness-factor size orientation)
251 "Make a stencil for @code{fret}, given the fret-diagram overall parameters."
252 (let* ((low-string-half-thickness
253 (* 0.5 size th (string-thickness string-count thickness-factor)))
254 (fret-half-thickness (* 0.5 size th))
258 (- fret-half-thickness low-string-half-thickness)
263 (* size (1- string-count))
267 (car start-coordinates) (cdr start-coordinates)
268 (car end-coordinates) (cdr end-coordinates))))
270 (define (make-straight-barre-stencil
271 size half-thickness fret-coordinate
272 start-string-coordinate end-string-coordinate orientation)
273 "Create a straight barre stencil."
276 (* size fret-coordinate)
277 (* size start-string-coordinate)
281 (* size fret-coordinate)
282 (* size end-string-coordinate)
291 (define (make-curved-barre-stencil
292 size half-thickness fret-coordinate
293 start-string-coordinate end-string-coordinate orientation)
294 "Create a curved barre stencil."
295 (let* ((bezier-thick 0.1)
298 (make-bezier-sandwich-list
299 (* size start-string-coordinate)
300 (* size end-string-coordinate)
301 (* size fret-coordinate)
302 (* size bezier-height)
303 (* size bezier-thick)
307 (+ (* size fret-coordinate) half-thickness)
308 (- (* size start-string-coordinate) half-thickness)
312 (- (* size fret-coordinate) (* size bezier-height) half-thickness)
313 (+ (* size end-string-coordinate) half-thickness)
315 (x-extent (cons (car box-lower-left) (car box-upper-right)))
316 (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
318 (list 'bezier-sandwich
319 `(quote ,bezier-list)
320 (* size bezier-thick))
327 ; Functions used to draw fret-diagram elements
331 (define (draw-strings string-count fret-range th
332 thickness-factor size orientation)
333 "Draw the string lines for a fret diagram with
334 @var{string-count} strings and frets as indicated in @var{fret-range}.
335 Line thickness is given by @var{th}, fret & string spacing by
336 @var{size}. Orientation is determined by @var{orientation}. "
341 (car x) string-count fret-range th
342 thickness-factor size orientation)
345 (car x) string-count fret-range th
346 thickness-factor size orientation)
349 (let* ( (string-list (map 1+ (iota string-count))))
350 (helper string-list)))
352 (define (draw-fret-lines fret-count string-count th
353 thickness-factor size orientation)
354 "Draw @var{fret-count} fret lines for a fret diagram
355 with @var{string-count} strings. Line thickness is given by @var{th},
356 fret & string spacing by @var{size}. Orientation is given by @var{orientation}"
360 (car x) string-count th thickness-factor
364 (car x) string-count th thickness-factor
368 (let* ( (fret-list (iota (1+ fret-count))))
371 (define (draw-thick-zero-fret details string-count th
372 thickness-factor size orientation)
373 "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
374 (let* ((sth (* th size))
375 (half-lowest-string-thickness
376 (* 0.5 th (string-thickness string-count thickness-factor)))
377 (half-thick (* 0.5 sth))
379 (* sth (assoc-get 'top-fret-thickness details 3.0)))
380 (start-string-coordinate (- half-lowest-string-thickness))
381 (end-string-coordinate (+ (* size (1- string-count)) half-thick))
382 (start-fret-coordinate half-thick)
383 (end-fret-coordinate (- half-thick top-fret-thick))
386 start-fret-coordinate start-string-coordinate orientation))
389 end-fret-coordinate end-string-coordinate orientation)))
391 (cons (car lower-left) (car upper-right))
392 (cons (cdr lower-left) (cdr upper-right))
396 (define (draw-capo details string-count fret fret-count th size
398 "Draw a capo indicator across the full width of the fret-board
400 (let* (;(sth (* th size))
402 (* size (assoc-get 'capo-thickness details 0.5)))
403 (half-thick (* capo-thick 0.5))
405 (first-string-pos (* size (- string-count 1)))
406 (fret-pos ( * size (1- (+ dot-pos fret))))
408 (stencil-coordinates fret-pos first-string-pos orientation))
410 (stencil-coordinates fret-pos last-string-pos orientation)))
413 (car start-point) (cdr start-point)
414 (car end-point) (cdr end-point))))
416 (define (draw-frets fret-range string-count th
417 thickness-factor size orientation)
418 "Draw the fret lines for a fret diagram with
419 @var{string-count} strings and frets as indicated in @var{fret-range}.
420 Line thickness is given by @var{th}, fret & string spacing by
421 @var{size}. Orientation is given by @var{orientation}."
422 (let* ((my-fret-count (fret-count fret-range)))
424 my-fret-count string-count th thickness-factor size orientation)))
426 (define (draw-dots layout props string-count fret-count
428 dot-position dot-radius dot-thickness dot-list orientation)
429 "Make dots for fret diagram."
431 (let* ((details (merge-details 'fret-diagram-details props '()))
432 (scale-dot-radius (* size dot-radius))
433 (scale-dot-thick (* size dot-thickness))
434 (dot-color (assoc-get 'dot-color details 'black))
435 (finger-label-padding 0.3)
437 (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
438 (string-label-font-mag
440 (assoc-get 'string-label-font-mag details
441 (cond ((or (eq? orientation 'landscape)
442 (eq? orientation 'opposing-landscape))
445 (mypair (car dot-list))
446 (restlist (cdr dot-list))
447 (string (car mypair))
449 (fret-coordinate (* size (+ (1- fret) dot-position)))
450 (string-coordinate (* size (- string-count string)))
452 (stencil-coordinates fret-coordinate string-coordinate orientation))
453 (extent (cons (- scale-dot-radius) scale-dot-radius))
454 (finger (caddr mypair))
455 (finger (if (number? finger) (number->string finger) finger))
456 (dot-stencil (if (eq? dot-color 'white)
459 scale-dot-radius scale-dot-thick #t)
462 (- scale-dot-radius (* 0.5 scale-dot-thick))
466 scale-dot-radius scale-dot-thick #t)))
467 (positioned-dot (ly:stencil-translate dot-stencil dot-coordinates))
470 ((or (eq? finger '())(eq? finger-code 'none))
472 ((eq? finger-code 'in-dot)
476 layout props dot-label-font-mag finger))))
477 (ly:stencil-translate
480 (if (eq? dot-color 'white)
482 (ly:stencil-in-color finger-label 1 1 1)))
484 ((eq? finger-code 'below-string)
485 (let* ((label-stencil
488 layout props string-label-font-mag
491 (stencil-fretboard-offset
492 label-stencil 'fret orientation))
493 (label-fret-coordinate
494 (+ (* size (+ 1 fret-count finger-label-padding))
496 (label-string-coordinate string-coordinate)
499 label-fret-coordinate
500 label-string-coordinate
504 (ly:stencil-translate label-stencil label-translation))))
505 (else ;unknown finger-code
511 layout props string-count fret-count size finger-code
512 dot-position dot-radius dot-thickness restlist orientation)
513 labeled-dot-stencil))))
516 layout props string-count fret-range size xo-list orientation)
517 "Put open and mute string indications on diagram, as contained in
519 (let* ((details (merge-details 'fret-diagram-details props '()))
522 'xo-font-magnification details
523 (cond ((or (eq? orientation 'landscape)
524 (eq? orientation 'opposing-landscape))
527 (mypair (car xo-list))
528 (restlist (cdr xo-list))
529 (glyph-string (if (eq? (car mypair) 'mute)
530 (assoc-get 'mute-string details "X")
531 (assoc-get 'open-string details "O")))
532 (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
536 layout props (* size xo-font-mag) glyph-string)))
537 (glyph-stencil-coordinates
538 (stencil-coordinates 0 glyph-string-coordinate orientation))
540 (ly:stencil-translate glyph-stencil glyph-stencil-coordinates)))
545 layout props string-count fret-range size restlist orientation)
548 (define (draw-barre layout props string-count fret-range
549 size finger-code dot-position dot-radius
550 barre-list orientation)
551 "Create barre indications for a fret diagram"
552 (if (not (null? barre-list))
553 (let* ((details (merge-details 'fret-diagram-details props '()))
554 (string1 (caar barre-list))
555 (string2 (cadar barre-list))
556 (barre-fret (caddar barre-list))
557 (top-fret (cdr fret-range))
558 (low-fret (car fret-range))
559 (fret (1+ (- barre-fret low-fret)))
560 (barre-vertical-offset 0.5)
561 (dot-center-fret-coordinate (+ (1- fret) dot-position))
562 (barre-fret-coordinate
563 (+ dot-center-fret-coordinate
564 (* (- barre-vertical-offset 0.5) dot-radius)))
565 (barre-start-string-coordinate (- string-count string1))
566 (barre-end-string-coordinate (- string-count string2))
567 (scale-dot-radius (* size dot-radius))
568 (barre-type (assoc-get 'barre-type details 'curved))
571 ((eq? barre-type 'straight)
572 (make-straight-barre-stencil
573 size scale-dot-radius
574 barre-fret-coordinate barre-start-string-coordinate
575 barre-end-string-coordinate orientation))
576 ((eq? barre-type 'curved)
577 (make-curved-barre-stencil
578 size scale-dot-radius
579 barre-fret-coordinate barre-start-string-coordinate
580 barre-end-string-coordinate orientation)))))
581 (if (not (null? (cdr barre-list)))
584 (draw-barre layout props string-count fret-range size finger-code
585 dot-position dot-radius (cdr barre-list) orientation))
588 (define (label-fret layout props string-count fret-range size orientation)
589 "Label the base fret on a fret diagram"
590 (let* ((details (merge-details 'fret-diagram-details props '()))
591 (base-fret (car fret-range))
592 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
593 (label-space (* 0.5 size))
594 (label-dir (assoc-get 'label-dir details RIGHT))
595 (label-vertical-offset
596 (assoc-get 'fret-label-vertical-offset details 0))
598 (assoc-get 'number-type details 'roman-lower))
601 ((equal? number-type 'roman-lower)
602 (fancy-format #f "~(~@r~)" base-fret))
603 ((equal? number-type 'roman-upper)
604 (fancy-format #f "~@r" base-fret))
605 ((equal? 'arabic number-type)
606 (fancy-format #f "~d" base-fret))
607 (else (fancy-format #f "~(~@r~)" base-fret))))
611 layout props (* size label-font-mag) label-text)))
613 (stencil-fretboard-offset label-stencil 'string orientation))
614 (label-outside-diagram (+ label-space label-half-width)))
615 (ly:stencil-translate
618 (1+ (* size label-vertical-offset))
619 (if (eq? label-dir LEFT)
620 (- label-outside-diagram)
621 (+ (* size (1- string-count)) label-outside-diagram))
626 ;; markup commands and associated functions
631 (define (fret-parse-marking-list marking-list my-fret-count)
632 "Parse a fret-diagram-verbose marking list into component sublists"
633 (let* ((fret-range (cons 1 my-fret-count))
639 (let parse-item ((mylist marking-list))
640 (if (not (null? mylist))
641 (let* ((my-item (car mylist)) (my-code (car my-item)))
643 ((or (eq? my-code 'open)(eq? my-code 'mute))
644 (set! xo-list (cons* my-item xo-list)))
645 ((eq? my-code 'barre)
646 (set! barre-list (cons* (cdr my-item) barre-list)))
648 (set! capo-fret (cadr my-item)))
649 ((eq? my-code 'place-fret)
650 (set! dot-list (cons* (cdr my-item) dot-list))))
651 (parse-item (cdr mylist)))))
652 ;; calculate fret-range
654 (minfret (if (> capo-fret 0) capo-fret 99)))
655 (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
656 (if (null? fret-list)
658 (let ((fretval (second (car fret-list))))
659 (if (> fretval maxfret) (set! maxfret fretval))
660 (if (< fretval minfret) (set! minfret fretval))
661 (updatemax (cdr fret-list)))))
662 (if (> maxfret my-fret-count)
665 (let ((upfret (- (+ minfret my-fret-count) 1)))
666 (if (> maxfret upfret) maxfret upfret)))))
667 (set! capo-fret (1+ (- capo-fret minfret)))
668 ; subtract fret from dots
669 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
670 (acons 'fret-range fret-range
671 (acons 'barre-list barre-list
672 (acons 'dot-list dot-list
673 (acons 'xo-list xo-list
674 (acons 'capo-fret capo-fret '())))))))
676 (define (make-fret-diagram layout props marking-list)
677 "Make a fret diagram markup"
679 ; note: here we get items from props that are needed in this routine,
680 ; or that are needed in more than one of the procedures
681 ; called from this routine. If they're only used in one of the
682 ; sub-procedure, they're obtained in that procedure
683 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
684 ;TODO -- get string-count directly from length of stringTunings;
685 ; from FretBoard engraver, but not from markup call
686 (details (merge-details 'fret-diagram-details props '()))
688 (assoc-get 'string-count details 6)) ; needed for everything
690 (assoc-get 'fret-count details 4)) ; needed for everything
692 (assoc-get 'orientation details 'normal)) ; needed for everything
695 'finger-code details 'none)) ; needed for draw-dots and draw-barre
697 (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
698 (default-dot-position
699 (if (eq? finger-code 'in-dot)
700 (- 0.95 default-dot-radius)
701 0.6)) ; move up to make room for bigger if labeled
704 'dot-radius details default-dot-radius)) ; needed for draw-dots
708 'dot-position details default-dot-position)) ; needed for draw-dots
711 (* (ly:output-def-lookup layout 'line-thickness)
712 (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
714 (thickness-factor (assoc-get 'string-thickness-factor details 0))
716 (chain-assoc-get 'align-dir props -0.4)) ; needed only here
718 (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
719 (parameters (fret-parse-marking-list marking-list my-fret-count))
720 (capo-fret (assoc-get 'capo-fret parameters 0))
721 (dot-list (cdr (assoc 'dot-list parameters)))
722 (xo-list (cdr (assoc 'xo-list parameters)))
723 (fret-range (cdr (assoc 'fret-range parameters)))
724 (my-fret-count (fret-count fret-range))
725 (barre-list (cdr (assoc 'barre-list parameters)))
727 (assoc-get 'barre-type details 'curved))
728 (fret-diagram-stencil
731 string-count fret-range th thickness-factor size orientation)
733 fret-range string-count th thickness-factor size orientation))))
734 (if (and (not (null? barre-list))
735 (not (eq? 'none barre-type)))
736 (set! fret-diagram-stencil
738 (draw-barre layout props string-count fret-range size
739 finger-code dot-position dot-radius
740 barre-list orientation)
741 fret-diagram-stencil)))
742 (if (not (null? dot-list))
743 (set! fret-diagram-stencil
746 (draw-dots layout props string-count my-fret-count
747 size finger-code dot-position dot-radius
748 th dot-list orientation))))
749 (if (= (car fret-range) 1)
750 (set! fret-diagram-stencil
753 (draw-thick-zero-fret
754 details string-count th
755 thickness-factor size orientation))))
756 (if (not (null? xo-list))
757 (let* ((diagram-fret-top
758 (car (stencil-fretboard-extent
763 (draw-xo layout props string-count fret-range
764 size xo-list orientation))
766 (stencil-fretboard-offset
767 xo-stencil 'fret orientation)))
768 (set! fret-diagram-stencil
771 (ly:stencil-translate
781 (set! fret-diagram-stencil
784 (draw-capo details string-count capo-fret my-fret-count
785 th size dot-position orientation))))
786 (if (> (car fret-range) 1)
787 (set! fret-diagram-stencil
791 layout props string-count fret-range size orientation))))
792 (ly:stencil-aligned-to
793 (ly:stencil-aligned-to fret-diagram-stencil X alignment)
796 (define (fret-parse-definition-string props definition-string)
797 "Parse a fret diagram string and return a pair containing:
798 @var{props}, modified as necessary by the definition-string
799 a fret-indication list with the appropriate values"
800 (let* ((fret-count 4)
802 (fret-range (cons 1 fret-count))
808 (details (merge-details 'fret-diagram-details props '()))
809 (items (string-split definition-string #\;)))
810 (let parse-item ((myitems items))
811 (if (not (null? (cdr myitems)))
812 (let ((test-string (car myitems)))
813 (case (car (string->list (substring test-string 0 1)))
814 ((#\s) (let ((size (get-numeric-from-key test-string)))
815 (set! props (prepend-alist-chain 'size size props))))
816 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
817 (finger-id (case finger-code
820 ((2) 'below-string))))
822 (acons 'finger-code finger-id details))))
823 ((#\c) (set! output-list
828 (string-split (substring test-string 2) #\-)))
830 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
832 (acons 'fret-count fret-count details))))
833 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
835 (acons 'string-count string-count details))))
836 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
838 (acons 'dot-radius dot-size details))))
839 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
841 (acons 'dot-position dot-position details))))
843 (let ((this-list (string-split test-string #\-)))
844 (if (string->number (cadr this-list))
847 (cons 'place-fret (numerify this-list))
849 (if (equal? (cadr this-list) "x" )
852 (list 'mute (string->number (car this-list)))
856 (list 'open (string->number (car this-list)))
858 (parse-item (cdr myitems)))))
859 ; add the modified details
861 (prepend-alist-chain 'fret-diagram-details details props))
862 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
865 (fret-parse-terse-definition-string props definition-string)
866 "Parse a fret diagram string that uses terse syntax;
867 return a pair containing:
868 @var{props}, modified to include the string-count determined by the
869 definition-string, and
870 a fret-indication list with the appropriate values"
871 ;TODO -- change syntax to fret\string-finger
873 (let* ((details (merge-details 'fret-diagram-details props '()))
874 (barre-start-list '())
877 (items (string-split definition-string #\;))
878 (string-count (- (length items) 1)))
879 (let parse-item ((myitems items))
880 (if (not (null? (cdr myitems)))
881 (let* ((test-string (car myitems))
882 (current-string (- (length myitems) 1))
883 (indicators (string-split test-string #\ )))
884 (let parse-indicators ((myindicators indicators))
885 (if (not (eq? '() myindicators))
886 (let* ((this-list (string-split (car myindicators) #\-))
887 (max-element-index (- (length this-list) 1))
889 (car (list-tail this-list max-element-index)))
891 (if (string->number (car this-list))
892 (string->number (car this-list))
894 (if (equal? last-element "(")
896 (set! barre-start-list
897 (cons-fret (list current-string fret)
900 (list-head this-list max-element-index))))
901 (if (equal? last-element ")")
903 (get-sub-list fret barre-start-list))
904 (insert-index (- (length this-barre) 1)))
906 (cons-fret (cons* 'barre
912 (list-head this-list max-element-index))))
919 (drop-paren (numerify this-list)))
921 (if (equal? (car this-list) "x" )
925 (list 'mute current-string)
930 (list 'open current-string)
932 (parse-indicators (cdr myindicators)))))
933 (parse-item (cdr myitems)))))
934 (set! details (acons 'string-count string-count details))
935 (set! props (prepend-alist-chain 'fret-diagram-details details props))
936 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
939 (define-builtin-markup-command
940 (fret-diagram-verbose layout props marking-list)
941 (pair?) ; argument type (list, but use pair? for speed)
942 instrument-specific-markup ; markup type
943 ((align-dir -0.4) ; properties and defaults
945 (fret-diagram-details)
947 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
952 \\markup \\fret-diagram-verbose
953 #'((mute 6) (mute 5) (open 4)
954 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
958 produces a standard D@tie{}chord diagram without fingering indications.
960 Possible elements in @var{marking-list}:
963 @item (mute @var{string-number})
964 Place a small @q{x} at the top of string @var{string-number}.
966 @item (open @var{string-number})
967 Place a small @q{o} at the top of string @var{string-number}.
969 @item (barre @var{start-string} @var{end-string} @var{fret-number})
970 Place a barre indicator (much like a tie) from string @var{start-string}
971 to string @var{end-string} at fret @var{fret-number}.
973 @item (capo @var{fret-number})
974 Place a capo indicator (a large solid bar) across the entire fretboard
975 at fret location @var{fret-number}. Also, set fret @var{fret-number}
976 to be the lowest fret on the fret diagram.
978 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
979 Place a fret playing indication on string @var{string-number} at fret
980 @var{fret-number} with an optional fingering label @var{finger-value}.
981 By default, the fret playing indicator is a solid dot. This can be
982 changed by setting the value of the variable @var{dot-color}. If the
983 @var{finger} part of the @code{place-fret} element is present,
984 @var{finger-value} will be displayed according to the setting of the
985 variable @var{finger-code}. There is no limit to the number of fret
986 indications per string.
989 (make-fret-diagram layout props marking-list))
992 (define-builtin-markup-command (fret-diagram layout props definition-string)
993 (string?) ; argument type
994 instrument-specific-markup ; markup category
995 (fret-diagram-verbose-markup) ; properties and defaults
996 "Make a (guitar) fret diagram. For example, say
999 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1003 for fret spacing 3/4 of staff space, D chord diagram
1005 Syntax rules for @var{definition-string}:
1009 Diagram items are separated by semicolons.
1016 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1021 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
1025 @code{h:}@var{number} -- Set the height of the diagram in frets.
1029 @code{w:}@var{number} -- Set the width of the diagram in strings.
1033 @code{f:}@var{number} -- Set fingering label type
1034 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1038 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1042 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1043 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1047 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1048 barre mark from @var{string1} to @var{string2} on @var{fret}.
1051 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1052 If @var{fret} is @samp{o}, @var{string} is identified as open.
1053 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1056 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1057 @var{string} at @var{fret}, and label with @var{fingering} as defined
1058 by the @code{f:} code.
1062 Note: There is no limit to the number of fret indications per string.
1064 (let ((definition-list
1065 (fret-parse-definition-string props definition-string)))
1066 (fret-diagram-verbose-markup
1067 layout (car definition-list) (cdr definition-list))))
1069 (define-builtin-markup-command
1070 (fret-diagram-terse layout props definition-string)
1071 (string?) ; argument type
1072 instrument-specific-markup ; markup category
1073 (fret-diagram-verbose-markup) ; properties
1074 "Make a fret diagram markup using terse string-based syntax.
1079 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1083 for a D@tie{}chord diagram.
1085 Syntax rules for @var{definition-string}:
1090 Strings are terminated by semicolons; the number of semicolons
1091 is the number of strings in the diagram.
1094 Mute strings are indicated by @samp{x}.
1097 Open strings are indicated by @samp{o}.
1100 A number indicates a fret indication at that fret.
1103 If there are multiple fret indicators desired on a string, they
1104 should be separated by spaces.
1107 Fingerings are given by following the fret number with a @code{-},
1108 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1109 fret with the second finger.
1112 Where a barre indicator is desired, follow the fret (or fingering) symbol
1113 with @code{-(} to start a barre and @code{-)} to end the barre.
1116 ;; TODO -- change syntax to fret\string-finger
1117 (let ((definition-list
1118 (fret-parse-terse-definition-string props definition-string)))
1119 (fret-diagram-verbose-markup layout
1120 (car definition-list)
1121 (cdr definition-list))))