1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2004--2012 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/>.
23 (define (string-x-extent start-point end-point)
24 "Return the x-extent of a string that goes from start-point
26 (let ((x1 (car start-point))
32 (define (string-y-extent start-point end-point)
33 "Return the y-extent of a string that goes from start-point
35 (let ((y1 (cdr start-point))
42 (define (cons-fret new-value old-list)
43 "Put together a fret-list in the format desired by parse-string"
44 (if (eq? old-list '())
46 (cons* new-value old-list)))
48 (define (get-numeric-from-key keystring)
49 "Get the numeric value from a key of the form k:val"
50 (string->number (substring keystring 2 (string-length keystring))))
52 (define (numerify mylist)
53 "Convert string values to numeric or character"
56 (let ((numeric-value (string->number (car mylist))))
58 (cons* numeric-value (numerify (cdr mylist)))
59 (cons* (car (string->list (car mylist)))
60 (numerify (cdr mylist)))))))
63 "Calculate the font step necessary to get a desired magnification"
64 (* 6 (/ (log mag) (log 2))))
66 (define (fret-count fret-range)
67 "Calculate the fret count for the diagram given the range of frets in the diagram."
68 (1+ (- (cdr fret-range) (car fret-range))))
70 (define (subtract-base-fret base-fret dot-list)
71 "Subtract @var{base-fret} from every fret in @var{dot-list}"
74 (let ((this-list (car dot-list)))
79 (- (second this-list) base-fret)
81 (if (null? (cddr this-list))
85 (if (or (null? (cddr this-list))
86 (null? (cdddr this-list)))
89 (subtract-base-fret base-fret (cdr dot-list))))))
91 (define (drop-paren item-list)
92 "Drop a final parentheses from a fret indication list
93 @code{item-list} resulting from a terse string specification of barre."
94 (if (> (length item-list) 0)
95 (let* ((max-index (- (length item-list) 1))
96 (last-element (car (list-tail item-list max-index))))
97 (if (or (equal? last-element ")") (equal? last-element "("))
98 (list-head item-list max-index)
102 (define (get-sub-list value master-list)
103 "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
104 (if (eq? master-list '())
106 (let ((sublist (car master-list)))
107 (if (equal? (cadr sublist) value)
109 (get-sub-list value (cdr master-list))))))
111 (define (merge-details key alist-list . default)
112 "Return @code{alist-list} entries for @code{key}, in one combined alist.
113 There can be two @code{alist-list} entries for a given key. The first
114 comes from the override-markup function, the second comes
115 from property settings during a regular override.
116 This is necessary because some details can be set in one
117 place, while others are set in the other. Both details
118 lists must be merged into a single alist.
119 Return @code{default} (optional, else #f) if not
122 (define (helper key alist-list default)
123 (if (null? alist-list)
125 (let* ((entry (assoc-get key (car alist-list))))
127 (append entry (chain-assoc-get key (cdr alist-list) '()))
128 (helper key (cdr alist-list) default)))))
130 (helper key alist-list
131 (if (pair? default) (car default) #f)))
134 ; Conversions between fret/string coordinate system and x-y coordinate
137 ; Fret coordinates are measured down the fretboard from the nut,
140 ; String coordinates are measured from the lowest string, starting at 0.
142 ; The x-y origin is at the intersection of the nut and the lowest string.
144 ; X coordinates are positive to the right.
145 ; Y coordinates are positive up.
148 (define (negate-extent extent)
149 "Return the extent in an axis opposite to the axis of @code{extent}."
150 (cons (- (cdr extent)) (- (car extent))))
152 (define (stencil-fretboard-extent stencil fretboard-axis orientation)
153 "Return the extent of @code{stencil} in the @code{fretboard-axis}
155 (if (eq? fretboard-axis 'fret)
156 (cond ((eq? orientation 'landscape)
157 (ly:stencil-extent stencil X))
158 ((eq? orientation 'opposing-landscape)
159 (negate-extent (ly:stencil-extent stencil X)))
161 (negate-extent (ly:stencil-extent stencil Y))))
162 ; else -- eq? fretboard-axis 'string
163 (cond ((eq? orientation 'landscape)
164 (ly:stencil-extent stencil Y))
165 ((eq? orientation 'opposing-landscape)
166 (negate-extent (ly:stencil-extent stencil Y)))
168 (ly:stencil-extent stencil Y)))))
171 (define (stencil-fretboard-offset stencil fretboard-axis orientation)
172 "Return a the stencil coordinates of the center of @code{stencil}
173 in the @code{fretboard-axis} direction."
174 (* 0.5 (interval-length
175 (stencil-fretboard-extent stencil fretboard-axis orientation))))
178 (define (string-thickness string thickness-factor)
179 (expt (1+ thickness-factor) (1- string)))
182 ; Functions that create stencils used in the fret diagram
185 (define (sans-serif-stencil layout props mag text)
186 "Create a stencil in sans-serif font based on @var{layout} and @var{props}
187 with magnification @var{mag} of the string @var{text}."
190 'font-size (stepmag mag)
191 (prepend-alist-chain 'font-family 'sans props))))
192 (interpret-markup layout my-props text)))
196 ;; markup commands and associated functions
201 (define (fret-parse-marking-list marking-list my-fret-count)
202 "Parse a fret-diagram-verbose marking list into component sublists"
203 (let* ((fret-range (cons 1 my-fret-count))
209 (let parse-item ((mylist marking-list))
210 (if (not (null? mylist))
211 (let* ((my-item (car mylist)) (my-code (car my-item)))
213 ((or (eq? my-code 'open)(eq? my-code 'mute))
214 (set! xo-list (cons* my-item xo-list)))
215 ((eq? my-code 'barre)
216 (set! barre-list (cons* (cdr my-item) barre-list)))
218 (set! capo-fret (cadr my-item)))
219 ((eq? my-code 'place-fret)
220 (set! dot-list (cons* (cdr my-item) dot-list))))
221 (parse-item (cdr mylist)))))
222 ;; calculate fret-range
224 (minfret (if (> capo-fret 0) capo-fret 99)))
225 (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
226 (if (null? fret-list)
228 (let ((fretval (second (car fret-list))))
229 (if (> fretval maxfret) (set! maxfret fretval))
230 (if (< fretval minfret) (set! minfret fretval))
231 (updatemax (cdr fret-list)))))
232 (if (> maxfret my-fret-count)
235 (let ((upfret (- (+ minfret my-fret-count) 1)))
236 (if (> maxfret upfret) maxfret upfret)))))
237 (set! capo-fret (1+ (- capo-fret minfret)))
238 ; subtract fret from dots
239 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
240 (acons 'fret-range fret-range
241 (acons 'barre-list barre-list
242 (acons 'dot-list dot-list
243 (acons 'xo-list xo-list
244 (acons 'capo-fret capo-fret '())))))))
246 (define (make-fret-diagram layout props marking-list)
247 "Make a fret diagram markup"
249 ; note: here we get items from props that are needed in this routine,
250 ; or that are needed in more than one of the procedures
251 ; called from this routine. If they're only used in one of the
252 ; sub-procedure, they're obtained in that procedure
253 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
254 ;TODO -- get string-count directly from length of stringTunings;
255 ; from FretBoard engraver, but not from markup call
256 (details (merge-details 'fret-diagram-details props '()))
258 (assoc-get 'string-count details 6)) ; needed for everything
260 (assoc-get 'fret-count details 4)) ; needed for everything
262 (assoc-get 'orientation details 'normal)) ; needed for everything
265 'finger-code details 'none)) ; needed for draw-dots and draw-barre
267 (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
268 (default-dot-position
269 (if (eq? finger-code 'in-dot)
270 (- 0.95 default-dot-radius)
271 0.6)) ; move up to make room for bigger dot if labeled
274 'dot-radius details default-dot-radius)) ; needed for draw-dots
278 'dot-position details default-dot-position)) ; needed for
279 ; draw-dots and draw-barre
281 (* (ly:output-def-lookup layout 'line-thickness)
282 (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
285 (thickness-factor (assoc-get 'string-thickness-factor details 0))
287 (chain-assoc-get 'align-dir props -0.4)) ; needed only here
288 (xo-padding (assoc-get 'xo-padding details 0.2)) ; needed only here
289 (parameters (fret-parse-marking-list marking-list my-fret-count))
290 (capo-fret (assoc-get 'capo-fret parameters 0))
291 (dot-list (assoc-get 'dot-list parameters))
292 (xo-list (assoc-get 'xo-list parameters))
293 (fret-range (assoc-get 'fret-range parameters))
294 (my-fret-count (fret-count fret-range))
295 (barre-list (assoc-get 'barre-list parameters))
297 (assoc-get 'barre-type details 'curved))
298 (fret-diagram-stencil '()))
300 ;; Here are the fret diagram helper functions that depend on the
301 ;; fret diagram parameters. The functions are here because the
302 ;; diagram parameters are part of the lexical scope here.
304 (define (stencil-coordinates fret-coordinate string-coordinate)
305 "Return a pair @code{(x-coordinate . y-coordinate)}
306 in stencil coordinate system."
308 ((eq? orientation 'landscape)
309 (cons fret-coordinate
310 (- string-coordinate (1- string-count))))
311 ((eq? orientation 'opposing-landscape)
312 (cons (- fret-coordinate) (- string-coordinate)))
314 (cons string-coordinate (- fret-coordinate)))))
316 (define (stencil-coordinate-offset fret-offset string-offset)
317 "Return a pair @code{(x-offset . y-offset)}
318 for translation in stencil coordinate system."
320 ((eq? orientation 'landscape)
321 (cons fret-offset (- string-offset)))
322 ((eq? orientation 'opposing-landscape)
323 (cons (- fret-offset) string-offset))
325 (cons string-offset (- fret-offset)))))
329 (define (make-bezier-sandwich-list start stop base height
331 "Make the argument list for a bezier sandwich from
332 string coordinate @var{start} to string-coordinate @var{stop} with a
333 baseline at fret coordinate @var{base}, a height of
334 @var{height}, and a half thickness of @var{half-thickness}."
335 (let* ((width (+ (- stop start) 1))
336 (cp-left-width (+ (* width half-thickness) start))
337 (cp-right-width (- stop (* width half-thickness)))
338 (bottom-control-point-height
339 (- base (- height half-thickness)))
340 (top-control-point-height
343 (stencil-coordinates base start))
345 (stencil-coordinates base stop))
346 (left-upper-control-point
348 top-control-point-height cp-left-width))
349 (left-lower-control-point
351 bottom-control-point-height cp-left-width))
352 (right-upper-control-point
354 top-control-point-height cp-right-width))
355 (right-lower-control-point
357 bottom-control-point-height cp-right-width)))
358 ; order of bezier control points is:
359 ; left cp low, right cp low, right end low, left end low
360 ; right cp high, left cp high, left end high, right end high.
362 (list left-lower-control-point
363 right-lower-control-point
366 right-upper-control-point
367 left-upper-control-point
371 (define (draw-strings)
372 "Draw the string lines for a fret diagram with
373 @var{string-count} strings and frets as indicated in @var{fret-range}.
374 Line thickness is given by @var{th}, fret & string spacing by
375 @var{size}. Orientation is determined by @var{orientation}."
379 (string-stencil (car x))
381 (string-stencil (car x))
384 (let* ( (string-list (map 1+ (iota string-count))))
385 (helper string-list)))
387 (define (string-stencil string)
388 "Make a stencil for @code{string}, given the fret-diagram
390 (let* ((string-coordinate (- string-count string))
391 (current-string-thickness
392 (* th size (string-thickness string thickness-factor)))
393 (fret-half-thickness (* size th 0.5))
394 (half-string (* current-string-thickness 0.5))
397 (- fret-half-thickness)
398 (- (* size string-coordinate) half-string)))
401 (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
402 (+ half-string (* size string-coordinate)))))
404 (string-x-extent start-coordinates end-coordinates)
405 (string-y-extent start-coordinates end-coordinates)
409 "Draw the fret lines for a fret diagram with
410 @var{string-count} strings and frets as indicated in @var{fret-range}.
411 Line thickness is given by @var{th}, fret & string spacing by
412 @var{size}. Orientation is given by @var{orientation}."
415 (fret-stencil (car x))
417 (fret-stencil (car x))
420 (let ((fret-list (iota (1+ my-fret-count))))
423 (define (fret-stencil fret)
424 "Make a stencil for @code{fret}, given the
425 fret-diagram overall parameters."
426 (let* ((low-string-half-thickness
430 (string-thickness string-count thickness-factor)))
431 (fret-half-thickness (* 0.5 size th))
435 (- fret-half-thickness low-string-half-thickness)))
439 (* size (1- string-count)))))
442 (car start-coordinates) (cdr start-coordinates)
443 (car end-coordinates) (cdr end-coordinates))))
445 (define (draw-barre barre-list)
446 "Create barre indications for a fret diagram"
447 (if (not (null? barre-list))
448 (let* ((string1 (caar barre-list))
449 (string2 (cadar barre-list))
450 (barre-fret (caddar barre-list))
451 (top-fret (cdr fret-range))
452 (low-fret (car fret-range))
453 (fret (1+ (- barre-fret low-fret)))
454 (barre-vertical-offset 0.5)
455 (dot-center-fret-coordinate (+ (1- fret) dot-position))
456 (barre-fret-coordinate
457 (+ dot-center-fret-coordinate
458 (* (- barre-vertical-offset 0.5) dot-radius)))
459 (barre-start-string-coordinate (- string-count string1))
460 (barre-end-string-coordinate (- string-count string2))
461 (scale-dot-radius (* size dot-radius))
462 (barre-type (assoc-get 'barre-type details 'curved))
465 ((eq? barre-type 'straight)
466 (make-straight-barre-stencil
467 barre-fret-coordinate
468 barre-start-string-coordinate
469 barre-end-string-coordinate
471 ((eq? barre-type 'curved)
472 (make-curved-barre-stencil
473 barre-fret-coordinate
474 barre-start-string-coordinate
475 barre-end-string-coordinate
476 scale-dot-radius)))))
477 (if (not (null? (cdr barre-list)))
480 (draw-barre (cdr barre-list)))
483 (define (make-straight-barre-stencil
485 start-string-coordinate
486 end-string-coordinate
488 "Create a straight barre stencil."
491 (* size fret-coordinate)
492 (* size start-string-coordinate)))
495 (* size fret-coordinate)
496 (* size end-string-coordinate))))
504 (define (make-curved-barre-stencil
506 start-string-coordinate
507 end-string-coordinate
509 "Create a curved barre stencil."
510 (let* ((bezier-thick 0.1)
513 (make-bezier-sandwich-list
514 (* size start-string-coordinate)
515 (* size end-string-coordinate)
516 (* size fret-coordinate)
517 (* size bezier-height)
518 (* size bezier-thick)))
521 (+ (* size fret-coordinate) half-thickness)
522 (- (* size start-string-coordinate) half-thickness)))
525 (- (* size fret-coordinate)
526 (* size bezier-height)
528 (+ (* size end-string-coordinate) half-thickness)))
529 (x-extent (cons (car box-lower-left) (car box-upper-right)))
530 (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
531 (make-bezier-sandwich-stencil
533 (* size bezier-thick)
537 (define (draw-dots dot-list)
538 "Make dots for fret diagram."
540 (let* ( (scale-dot-radius (* size dot-radius))
541 (scale-dot-thick (* size th))
542 (default-dot-color (assoc-get 'dot-color details 'black))
543 (finger-label-padding 0.3)
546 (assoc-get 'dot-label-font-mag details 1.0)))
547 (string-label-font-mag
550 'string-label-font-mag details
551 (cond ((or (eq? orientation 'landscape)
552 (eq? orientation 'opposing-landscape))
555 (mypair (car dot-list))
556 (restlist (cdr dot-list))
557 (string (car mypair))
559 (fret-coordinate (* size (+ (1- fret) dot-position)))
560 (string-coordinate (* size (- string-count string)))
562 (stencil-coordinates fret-coordinate string-coordinate))
563 (extent (cons (- scale-dot-radius) scale-dot-radius))
564 (finger (caddr mypair))
565 (finger (if (number? finger) (number->string finger) finger))
566 (inverted-color (eq? 'inverted (cadddr mypair)))
567 (dot-color (if (or (and (eq? default-dot-color 'black) inverted-color)
568 (and (eq? default-dot-color 'white) (not inverted-color)))
571 (dot-stencil (if (eq? dot-color 'white)
574 scale-dot-radius scale-dot-thick #t)
577 (- scale-dot-radius (* 0.5 scale-dot-thick))
581 scale-dot-radius scale-dot-thick #t)))
583 (ly:stencil-translate dot-stencil dot-coordinates))
586 ((or (eq? finger '())(eq? finger-code 'none))
588 ((eq? finger-code 'in-dot)
592 layout props dot-label-font-mag finger))))
593 (ly:stencil-translate
596 (if (eq? dot-color 'white)
598 (ly:stencil-in-color finger-label 1 1 1)))
600 ((eq? finger-code 'below-string)
601 (let* ((label-stencil
604 layout props string-label-font-mag
607 (stencil-fretboard-offset
608 label-stencil 'fret orientation))
609 (label-fret-coordinate
611 (+ 1 my-fret-count finger-label-padding))
613 (label-string-coordinate string-coordinate)
616 label-fret-coordinate
617 label-string-coordinate)))
620 (ly:stencil-translate
622 label-translation))))
623 (else ;unknown finger-code
629 labeled-dot-stencil))))
631 (define (draw-thick-zero-fret)
632 "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
633 (let* ((half-lowest-string-thickness
634 (* 0.5 th (string-thickness string-count thickness-factor)))
635 (half-thick (* 0.5 sth))
637 (* sth (assoc-get 'top-fret-thickness details 3.0)))
638 (start-string-coordinate (- half-lowest-string-thickness))
639 (end-string-coordinate (+ (* size (1- string-count)) half-thick))
640 (start-fret-coordinate half-thick)
641 (end-fret-coordinate (- half-thick top-fret-thick))
644 start-fret-coordinate start-string-coordinate))
647 end-fret-coordinate end-string-coordinate)))
649 (cons (car lower-left) (car upper-right))
650 (cons (cdr lower-left) (cdr upper-right))
653 (define (draw-xo xo-list)
654 "Put open and mute string indications on diagram, as contained in
657 (assoc-get 'xo-font-magnification details
658 (cond ((or (eq? orientation 'landscape)
659 (eq? orientation 'opposing-landscape))
662 (mypair (car xo-list))
663 (restlist (cdr xo-list))
664 (glyph-string (if (eq? (car mypair) 'mute)
665 (assoc-get 'mute-string details "X")
666 (assoc-get 'open-string details "O")))
667 (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
671 layout props (* size xo-font-mag) glyph-string)))
672 (glyph-stencil-coordinates
673 (stencil-coordinates 0 glyph-string-coordinate))
675 (ly:stencil-translate
677 glyph-stencil-coordinates)))
682 (draw-xo restlist)))))
684 (define (draw-capo fret)
685 "Draw a capo indicator across the full width of the fret-board
688 (* size (assoc-get 'capo-thickness details 0.5)))
689 (half-thick (* capo-thick 0.5))
690 (last-string-position 0)
691 (first-string-position (* size (- string-count 1)))
692 (fret-position ( * size (1- (+ dot-position fret))))
696 first-string-position))
700 last-string-position)))
703 (car start-point) (cdr start-point)
704 (car end-point) (cdr end-point))))
706 (define (label-fret fret-range)
707 "Label the base fret on a fret diagram"
708 (let* ((base-fret (car fret-range))
709 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
710 (label-space (* 0.5 size))
711 (label-dir (assoc-get 'label-dir details RIGHT))
712 (label-vertical-offset
713 (assoc-get 'fret-label-vertical-offset details 0))
715 (assoc-get 'number-type details 'roman-lower))
718 ((equal? number-type 'roman-lower)
719 (fancy-format #f "~(~@r~)" base-fret))
720 ((equal? number-type 'roman-upper)
721 (fancy-format #f "~@r" base-fret))
722 ((equal? 'arabic number-type)
723 (fancy-format #f "~d" base-fret))
724 ((equal? 'custom number-type)
726 (assoc-get 'fret-label-custom-format
729 (else (fancy-format #f "~(~@r~)" base-fret))))
733 layout props (* size label-font-mag) label-text)))
735 (stencil-fretboard-offset
739 (label-outside-diagram (+ label-space label-half-width)))
740 (ly:stencil-translate
743 (* size (+ 1.0 label-vertical-offset))
744 (if (eq? label-dir LEFT)
745 (- label-outside-diagram)
746 (+ (* size (1- string-count)) label-outside-diagram))))))
749 ; Here is the body of make-fret-diagram
752 (set! fret-diagram-stencil
753 (ly:stencil-add (draw-strings) (draw-frets)))
754 (if (and (not (null? barre-list))
755 (not (eq? 'none barre-type)))
756 (set! fret-diagram-stencil
758 (draw-barre barre-list)
759 fret-diagram-stencil)))
760 (if (not (null? dot-list))
761 (set! fret-diagram-stencil
764 (draw-dots dot-list))))
765 (if (= (car fret-range) 1)
766 (set! fret-diagram-stencil
769 (draw-thick-zero-fret))))
770 (if (not (null? xo-list))
771 (let* ((diagram-fret-top
772 (car (stencil-fretboard-extent
776 (xo-stencil (draw-xo xo-list))
778 (stencil-fretboard-offset
779 xo-stencil 'fret orientation))
781 (stencil-coordinate-offset
786 (set! fret-diagram-stencil
789 (ly:stencil-translate
791 xo-stencil-offset)))))
793 (set! fret-diagram-stencil
796 (draw-capo capo-fret))))
797 (if (> (car fret-range) 1)
798 (set! fret-diagram-stencil
801 (label-fret fret-range))))
802 (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
804 (define (fret-parse-definition-string props definition-string)
805 "Parse a fret diagram string and return a pair containing:
806 @var{props}, modified as necessary by the definition-string
807 a fret-indication list with the appropriate values"
808 (let* ((fret-count 4)
810 (fret-range (cons 1 fret-count))
816 (details (merge-details 'fret-diagram-details props '()))
817 (items (string-split definition-string #\;)))
818 (let parse-item ((myitems items))
819 (if (not (null? (cdr myitems)))
820 (let ((test-string (car myitems)))
821 (case (car (string->list (substring test-string 0 1)))
822 ((#\s) (let ((size (get-numeric-from-key test-string)))
823 (set! props (prepend-alist-chain 'size size props))))
824 ((#\t) (let ((th (get-numeric-from-key test-string)))
825 (set! props (prepend-alist-chain 'thickness th props))))
826 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
827 (finger-id (case finger-code
830 ((2) 'below-string))))
832 (acons 'finger-code finger-id details))))
833 ((#\c) (set! output-list
838 (string-split (substring test-string 2) #\-)))
840 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
842 (acons 'fret-count fret-count details))))
843 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
845 (acons 'string-count string-count details))))
846 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
848 (acons 'dot-radius dot-size details))))
849 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
851 (acons 'dot-position dot-position details))))
853 (let ((this-list (string-split test-string #\-)))
854 (if (string->number (cadr this-list))
857 (cons 'place-fret (numerify this-list))
859 (if (equal? (cadr this-list) "x" )
862 (list 'mute (string->number (car this-list)))
866 (list 'open (string->number (car this-list)))
868 (parse-item (cdr myitems)))))
869 ; add the modified details
871 (prepend-alist-chain 'fret-diagram-details details props))
872 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
875 (fret-parse-terse-definition-string props definition-string)
876 "Parse a fret diagram string that uses terse syntax;
877 return a pair containing:
878 @var{props}, modified to include the string-count determined by the
879 definition-string, and
880 a fret-indication list with the appropriate values"
881 ;TODO -- change syntax to fret\string-finger
883 (let* ((details (merge-details 'fret-diagram-details props '()))
884 (barre-start-list '())
887 (items (string-split definition-string #\;))
888 (string-count (- (length items) 1)))
889 (let parse-item ((myitems items))
890 (if (not (null? (cdr myitems)))
891 (let* ((test-string (car myitems))
892 (current-string (- (length myitems) 1))
893 (indicators (string-split test-string #\ )))
894 (let parse-indicators ((myindicators indicators))
895 (if (not (eq? '() myindicators))
896 (let* ((this-list (string-split (car myindicators) #\-))
897 (max-element-index (- (length this-list) 1))
899 (car (list-tail this-list max-element-index)))
901 (if (string->number (car this-list))
902 (string->number (car this-list))
904 (if (equal? last-element "(")
906 (set! barre-start-list
907 (cons-fret (list current-string fret)
910 (list-head this-list max-element-index))))
911 (if (equal? last-element ")")
913 (get-sub-list fret barre-start-list))
914 (insert-index (- (length this-barre) 1)))
916 (cons-fret (cons* 'barre
922 (list-head this-list max-element-index))))
929 (drop-paren (numerify this-list)))
931 (if (equal? (car this-list) "x" )
935 (list 'mute current-string)
940 (list 'open current-string)
942 (parse-indicators (cdr myindicators)))))
943 (parse-item (cdr myitems)))))
944 (set! details (acons 'string-count string-count details))
945 (set! props (prepend-alist-chain 'fret-diagram-details details props))
946 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
949 (define-markup-command
950 (fret-diagram-verbose layout props marking-list)
951 (pair?) ; argument type (list, but use pair? for speed)
952 #:category instrument-specific-markup ; markup type
953 #:properties ((align-dir -0.4) ; properties and defaults
955 (fret-diagram-details)
957 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
962 \\markup \\fret-diagram-verbose
963 #'((mute 6) (mute 5) (open 4)
964 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
968 produces a standard D@tie{}chord diagram without fingering indications.
970 Possible elements in @var{marking-list}:
973 @item (mute @var{string-number})
974 Place a small @q{x} at the top of string @var{string-number}.
976 @item (open @var{string-number})
977 Place a small @q{o} at the top of string @var{string-number}.
979 @item (barre @var{start-string} @var{end-string} @var{fret-number})
980 Place a barre indicator (much like a tie) from string @var{start-string}
981 to string @var{end-string} at fret @var{fret-number}.
983 @item (capo @var{fret-number})
984 Place a capo indicator (a large solid bar) across the entire fretboard
985 at fret location @var{fret-number}. Also, set fret @var{fret-number}
986 to be the lowest fret on the fret diagram.
988 @item (place-fret @var{string-number} @var{fret-number} [@var{finger-value} [@var{color-modifier}]])
989 Place a fret playing indication on string @var{string-number} at fret
990 @var{fret-number} with an optional fingering label @var{finger-value},
991 and an optional color modifier @var{color-modifier}.
992 By default, the fret playing indicator is a solid dot. This can be
993 globally changed by setting the value of the variable @var{dot-color}.
994 Setting @var{color-modifier} to @code{inverted} inverts the dot color
995 for a specific fingering.
996 If the @var{finger} part of the @code{place-fret} element is present,
997 @var{finger-value} will be displayed according to the setting of the
998 variable @var{finger-code}. There is no limit to the number of fret
999 indications per string.
1002 (make-fret-diagram layout props marking-list))
1005 (define-markup-command (fret-diagram layout props definition-string)
1006 (string?) ; argument type
1007 #:category instrument-specific-markup ; markup category
1008 #:properties (fret-diagram-verbose-markup) ; properties and defaults
1009 "Make a (guitar) fret diagram. For example, say
1012 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1016 for fret spacing 3/4 of staff space, D chord diagram
1018 Syntax rules for @var{definition-string}:
1022 Diagram items are separated by semicolons.
1029 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1034 @code{t:}@var{number} -- Set the line thickness (relative to normal
1039 @code{h:}@var{number} -- Set the height of the diagram in frets.
1043 @code{w:}@var{number} -- Set the width of the diagram in strings.
1047 @code{f:}@var{number} -- Set fingering label type
1048 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1052 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1056 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1057 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1061 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1062 barre mark from @var{string1} to @var{string2} on @var{fret}.
1065 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1066 If @var{fret} is @samp{o}, @var{string} is identified as open.
1067 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1070 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1071 @var{string} at @var{fret}, and label with @var{fingering} as defined
1072 by the @code{f:} code.
1076 Note: There is no limit to the number of fret indications per string.
1078 (let ((definition-list
1079 (fret-parse-definition-string props definition-string)))
1080 (fret-diagram-verbose-markup
1081 layout (car definition-list) (cdr definition-list))))
1083 (define-markup-command
1084 (fret-diagram-terse layout props definition-string)
1085 (string?) ; argument type
1086 #:category instrument-specific-markup ; markup category
1087 #:properties (fret-diagram-verbose-markup) ; properties
1088 "Make a fret diagram markup using terse string-based syntax.
1093 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1097 for a D@tie{}chord diagram.
1099 Syntax rules for @var{definition-string}:
1104 Strings are terminated by semicolons; the number of semicolons
1105 is the number of strings in the diagram.
1108 Mute strings are indicated by @samp{x}.
1111 Open strings are indicated by @samp{o}.
1114 A number indicates a fret indication at that fret.
1117 If there are multiple fret indicators desired on a string, they
1118 should be separated by spaces.
1121 Fingerings are given by following the fret number with a @w{@code{-},}
1122 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1123 fret with the second finger.
1126 Where a barre indicator is desired, follow the fret (or fingering) symbol
1127 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1130 ;; TODO -- change syntax to fret\string-finger
1131 (let ((definition-list
1132 (fret-parse-terse-definition-string props definition-string)))
1133 (fret-diagram-verbose-markup layout
1134 (car definition-list)
1135 (cdr definition-list))))