1 ;;;; fret-diagrams.scm --
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2008 Carl D. Sorensen <c_sorensen@byu.edu>
7 (define (fret-parse-marking-list marking-list fret-count)
8 (let* ((fret-range (list 1 fret-count))
13 (let parse-item ((mylist marking-list))
14 (if (not (null? mylist))
15 (let* ((my-item (car mylist)) (my-code (car my-item)))
17 ((or (eq? my-code 'open)(eq? my-code 'mute))
18 (set! xo-list (cons* my-item xo-list)))
20 (set! barre-list (cons* (cdr my-item) barre-list)))
21 ((eq? my-code 'place-fret)
22 (set! dot-list (cons* (cdr my-item) dot-list))))
23 (parse-item (cdr mylist)))))
24 ;; calculate fret-range
25 (let ((maxfret 0) (minfret 99))
26 (let updatemax ((fret-list dot-list))
29 (let ((fretval (second (car fret-list))))
30 (if (> fretval maxfret) (set! maxfret fretval))
31 (if (< fretval minfret) (set! minfret fretval))
32 (updatemax (cdr fret-list)))))
33 (if (> maxfret fret-count)
36 (let ((upfret (- (+ minfret fret-count) 1)))
37 (if (> maxfret upfret) maxfret upfret)))))
38 ; subtract fret from dots
39 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
40 (acons 'fret-range fret-range
41 (acons 'barre-list barre-list
42 (acons 'dot-list dot-list
43 (acons 'xo-list xo-list '()))))))
45 (define (subtract-base-fret base-fret dot-list)
46 "Subtract @var{base-fret} from every fret in @var{dot-list}"
49 (let ((this-list (car dot-list)))
50 (cons* (list (car this-list) (- (second this-list) base-fret)
51 (if (null? (cddr this-list))
54 (subtract-base-fret base-fret (cdr dot-list))))))
56 (define (sans-serif-stencil layout props mag text)
57 "Create a stencil in sans-serif font based on @var{layout} and @var{props}
58 with magnification @var{mag} of the string @var{text}."
61 'font-size (stepmag mag)
62 (prepend-alist-chain 'font-family 'sans props))))
63 (interpret-markup layout my-props text)))
65 (define (draw-strings string-count fret-range th size orientation)
66 "Draw the string lines for a fret diagram with
67 @var{string-count} strings and frets as indicated in @var{fret-range}.
68 Line thickness is given by @var{th}, fret & string spacing by
69 @var{size}. Orientation is determined by @var{orientation}. "
70 (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
71 (sl (* (+ fret-count 1) size))
73 (half-thickness (* sth 0.5))
76 (if (eq? orientation 'normal)
78 (list 'draw-line sth 0 0 0 sl)
79 (cons (- half-thickness) half-thickness)
80 (cons (- half-thickness) (+ sl half-thickness)))
82 (list 'draw-line sth 0 0 sl 0)
83 (cons (- half-thickness) (+ sl half-thickness))
84 (cons (- half-thickness) half-thickness)))))
85 (if (= string-count 1)
87 (if (eq? orientation 'normal)
88 (ly:stencil-combine-at-edge
89 (draw-strings (- string-count 1) fret-range th size orientation)
93 (ly:stencil-combine-at-edge
94 (draw-strings (- string-count 1) fret-range th size orientation)
99 (define (draw-fret-lines fret-count string-count th size orientation)
100 "Draw @var{fret-count} fret lines for a fret diagram
101 with @var{string-count} strings. Line thickness is given by @var{th},
102 fret & string spacing by @var{size}. Orientation is given by @var{orientation}"
103 (let* ((sth (* size th))
105 (fret-line (draw-fret-line string-count th size orientation)))
108 (if (eq? orientation 'normal)
109 (ly:stencil-combine-at-edge
111 (- fret-count 1) string-count th size orientation)
115 (ly:stencil-combine-at-edge
117 (- fret-count 1) string-count th size orientation)
122 (define (draw-fret-line string-count th size orientation)
123 "Draw a fret line for a fret diagram."
124 (let* ((fret-length (* (- string-count 1) size))
126 (half-thickness (* sth 0.5)))
127 (if (eq? orientation 'normal)
129 (list 'draw-line sth half-thickness size
130 (- fret-length half-thickness) size)
132 (cons (- half-thickness) half-thickness))
134 (list 'draw-line sth 0 half-thickness
135 0 (- fret-length half-thickness))
136 (cons (- half-thickness) half-thickness)
137 (cons 0 fret-length)))))
139 (define (draw-thick-zero-fret details string-count th size orientation)
140 "Draw a thick zeroth fret for a fret diagram whose base fret is not 1."
141 (let* ((sth (* th size))
143 (* sth (assoc-get 'top-fret-thickness details 3.0)))
144 (half-thick (* sth 0.5))
146 (x2 (+ half-thick (* size (- string-count 1))))
148 (y2 (+ top-fret-thick half-thick))
149 (x-extent (cons (- x1) x2))
150 (y-extent (cons sth top-fret-thick)))
151 (if (eq? orientation 'normal)
152 (ly:make-stencil (list 'round-filled-box x1 x2 y1 y2 sth)
154 (ly:make-stencil (list 'round-filled-box y1 y2 x1 x2 sth)
155 y-extent x-extent))))
157 (define (draw-frets fret-range string-count th size orientation)
158 "Draw the fret lines for a fret diagram with
159 @var{string-count} strings and frets as indicated in @var{fret-range}.
160 Line thickness is given by @var{th}, fret & string spacing by
161 @var{size}. Orientation is given by @var{orientation}."
162 (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
163 (fret-length (* (- string-count 1) size))
164 (half-thickness (* th 0.5))
165 (base-fret (car fret-range))
166 (fret-zero (draw-fret-line string-count th size orientation)))
167 (if (eq? orientation 'normal)
168 (ly:stencil-combine-at-edge
169 (draw-fret-lines fret-count string-count th size orientation)
173 (ly:stencil-combine-at-edge
175 (draw-fret-lines fret-count string-count th size orientation)
178 (define (draw-dots layout props string-count fret-count
179 fret-range size finger-code
180 dot-position dot-radius dot-thickness dot-list orientation)
181 "Make dots for fret diagram."
183 (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
184 (scale-dot-radius (* size dot-radius))
185 (scale-dot-thick (* size dot-thickness))
186 (dot-color (assoc-get 'dot-color details 'black))
187 (finger-xoffset -0.25)
188 (finger-yoffset (* -0.5 size ))
190 (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
191 (string-label-font-mag
192 (* size (assoc-get 'string-label-font-mag details 0.6)))
193 (mypair (car dot-list))
194 (restlist (cdr dot-list))
195 (string (car mypair))
197 (xpos (* size (if (eq? orientation 'normal)
198 (- string-count string)
199 (+ (- fret 1 ) dot-position))))
200 (ypos (* size (if (eq? orientation 'normal)
201 (+ 2 (- fret-count fret dot-position ))
202 (- string-count string))))
203 (extent (cons (- scale-dot-radius) scale-dot-radius))
204 (finger (caddr mypair))
205 (finger (if (number? finger) (number->string finger) finger))
206 (dotstencil (if (eq? dot-color 'white)
209 scale-dot-radius scale-dot-thick #t)
212 (- scale-dot-radius (* 0.5 scale-dot-thick))
216 scale-dot-radius scale-dot-thick #t)))
217 (positioned-dot (begin
218 (ly:stencil-translate-axis
219 (ly:stencil-translate-axis dotstencil xpos X)
222 (if (or (eq? finger '())(eq? finger-code 'none))
224 (if (eq? finger-code 'in-dot)
228 layout props dot-label-font-mag finger))))
229 (ly:stencil-translate-axis
230 (ly:stencil-translate-axis
233 (if (eq? dot-color 'white)
235 (ly:stencil-in-color finger-label 1 1 1)))
238 (if (eq? finger-code 'below-string)
241 (if (eq? orientation 'normal)
242 (ly:stencil-translate-axis
243 (ly:stencil-translate-axis
246 layout props string-label-font-mag finger))
248 (* size finger-yoffset) Y)
249 (ly:stencil-translate-axis
250 (ly:stencil-translate-axis
253 layout props string-label-font-mag finger))
254 (* size (+ 2 fret-count finger-yoffset)) X)
262 layout props string-count fret-count fret-range size finger-code
263 dot-position dot-radius dot-thickness restlist orientation)
264 labeled-dot-stencil))))
266 (define (draw-xo layout props string-count fret-range size xo-list orientation)
267 "Put open and mute string indications on diagram, as contained in
269 (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
270 (fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
272 (* size (assoc-get 'xo-font-magnification details 0.5)))
273 (xo-horizontal-offset (* size -0.35))
274 (mypair (car xo-list))
275 (restlist (cdr xo-list))
276 (glyph-string (if (eq? (car mypair) 'mute)
277 (assoc-get 'mute-string details "X")
278 (assoc-get 'open-string details "O")))
280 (+ (* (- string-count (cadr mypair)) size) xo-horizontal-offset ))
281 (glyph-stencil (if (eq? orientation 'normal)
282 (ly:stencil-translate-axis
284 layout props (* size xo-font-mag) glyph-string)
286 (ly:stencil-translate-axis
288 layout props (* size xo-font-mag) glyph-string)
294 layout props string-count fret-range size restlist orientation)
297 (define (make-bezier-sandwich-list start stop base height thickness orientation)
298 "Make the argument list for a bezier sandwich from
299 @var{start} to @var{stop} with a baseline at @var{base}, a height of
300 @var{height}, and a thickness of @var{thickness}. If @var{orientation} is
301 @var{'normal}, @var{base} is a y coordinate, otherwise it's an x coordinate."
302 (let* ((width (+ (- stop start) 1))
303 (x1 (+ (* width thickness) start))
304 (x2 (- stop (* width thickness)))
305 (bottom-control-point-height
306 (if (eq? orientation 'normal)
307 (+ base (- height thickness))
308 (- base (- height thickness))))
309 (top-control-point-height
310 (if (eq? orientation 'normal)
313 ; order of bezier control points is:
314 ; left cp low, right cp low, right end low, left end low
315 ; right cp high, left cp high, left end high, right end high.
316 (if (eq? orientation 'normal)
317 (list (cons x1 bottom-control-point-height)
318 (cons x2 bottom-control-point-height)
321 (cons x2 top-control-point-height)
322 (cons x1 top-control-point-height)
325 (list (cons bottom-control-point-height x1)
326 (cons bottom-control-point-height x2)
329 (cons top-control-point-height x2)
330 (cons top-control-point-height x1)
334 (define (draw-barre layout props string-count fret-range
335 size finger-code dot-position dot-radius
336 barre-list orientation)
337 "Create barre indications for a fret diagram"
338 (if (not (null? barre-list))
339 (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
340 (string1 (caar barre-list))
341 (string2 (cadar barre-list))
342 (fret (caddar barre-list))
343 (top-fret (cadr fret-range))
344 (low-fret (car fret-range))
345 (barre-type (assoc-get 'barre-type details 'curved))
346 (scale-dot-radius (* size dot-radius))
347 (barre-vertical-offset 0.5)
348 ;; 2 is 1 for empty fret at bottom of figure + 1 for interval
349 ;; (top-fret - fret + 1) -- not an arbitrary constant
351 (* size (- (+ 2 (- (cadr fret-range) fret)) dot-position)))
352 (dot-center-fret-coordinate (+ (- fret low-fret) dot-position))
353 (barre-fret-coordinate
354 (+ dot-center-fret-coordinate
355 (* (- barre-vertical-offset 0.5) dot-radius)))
356 (barre-start-string-coordinate (- string-count string1))
357 (barre-end-string-coordinate (- string-count string2))
359 (+ dot-center-y (* barre-vertical-offset scale-dot-radius)))
360 (left (* size (- string-count string1)))
361 (right (* size (- string-count string2)))
365 (if (eq? orientation 'normal)
366 (make-bezier-sandwich-list
367 (* size barre-start-string-coordinate)
368 (* size barre-end-string-coordinate)
369 (* size (+ 2 (- top-fret
370 (+ low-fret barre-fret-coordinate))))
371 (* size bezier-height)
372 (* size bezier-thick)
374 (make-bezier-sandwich-list
375 (* size barre-start-string-coordinate)
376 (* size barre-end-string-coordinate)
377 (* size barre-fret-coordinate)
378 (* size bezier-height)
379 (* size bezier-thick)
382 (if (eq? barre-type 'straight)
383 (if (eq? orientation 'normal)
386 'draw-line (* size dot-radius) left dot-center-y
389 (cons (- dot-center-y scale-dot-radius)
390 (+ dot-center-y scale-dot-radius)))
392 (list 'draw-line (* size dot-radius)
393 (* size barre-fret-coordinate)
394 (* size barre-start-string-coordinate)
395 (* size barre-fret-coordinate)
396 (* size barre-end-string-coordinate))
397 (cons (- (* size barre-fret-coordinate)
399 (+ (* size barre-fret-coordinate)
401 (cons (* size barre-start-string-coordinate)
402 (* size barre-end-string-coordinate))))
403 (if (eq? orientation 'normal)
405 (list 'bezier-sandwich
406 `(quote ,bezier-list)
407 (* size bezier-thick))
409 (cons bottom (+ bottom (* size bezier-height))))
411 (list 'bezier-sandwich
412 `(quote ,bezier-list)
413 (* size bezier-thick))
414 (cons bottom (+ bottom (* size bezier-height)))
415 (cons left right))))))
416 (if (not (null? (cdr barre-list)))
419 (draw-barre layout props string-count fret-range size finger-code
420 dot-position dot-radius (cdr barre-list)))
423 (define (stepmag mag)
424 "Calculate the font step necessary to get a desired magnification"
425 (* 6 (/ (log mag) (log 2))))
427 (define (label-fret layout props string-count fret-range size orientation)
428 "Label the base fret on a fret diagram"
429 (let* ((details (chain-assoc-get 'fret-diagram-details props '()))
430 (base-fret (car fret-range))
431 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
432 (label-vertical-offset
433 (assoc-get 'fret-label-vertical-offset details -0.2))
434 (number-type (assoc-get 'number-type details 'roman-lower))
435 (fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
438 ((equal? number-type 'roman-lower)
439 (fancy-format #f "~(~@r~)" base-fret))
440 ((equal? number-type 'roman-upper)
441 (fancy-format #f "~@r" base-fret))
442 ((equal? 'arabic number-type)
443 (fancy-format #f "~d" base-fret))
444 (else (fancy-format #f "~(~@r~)" base-fret)))))
445 (if (eq? orientation 'normal)
446 (ly:stencil-translate-axis
447 (sans-serif-stencil layout props (* size label-font-mag) label-text)
448 (* size (+ fret-count label-vertical-offset)) Y)
449 (ly:stencil-translate-axis
450 (sans-serif-stencil layout props (* size label-font-mag) label-text)
451 (* size (+ 1 label-vertical-offset)) X))))
453 (define-builtin-markup-command (fret-diagram-verbose layout props marking-list)
454 (list?) ; argument type
455 fret-diagram ; markup type
456 ((align-dir -0.4) ; properties and defaults
458 (fret-diagram-details)
460 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
465 \\markup \\fret-diagram-verbose
466 #'((mute 6) (mute 5) (open 4)
467 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
471 produces a standard D@tie{}chord diagram without fingering indications.
473 Possible elements in @var{marking-list}:
476 @item (mute @var{string-number})
477 Place a small @q{x} at the top of string @var{string-number}.
479 @item (open @var{string-number})
480 Place a small @q{o} at the top of string @var{string-number}.
482 @item (barre @var{start-string} @var{end-string} @var{fret-number})
483 Place a barre indicator (much like a tie) from string @var{start-string}
484 to string @var{end-string} at fret @var{fret-number}.
486 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
487 Place a fret playing indication on string @var{string-number} at fret
488 @var{fret-number} with an optional fingering label @var{finger-value}.
489 By default, the fret playing indicator is a solid dot. This can be
490 changed by setting the value of the variable @var{dot-color}. If the
491 @var{finger} part of the @code{place-fret} element is present,
492 @var{finger-value} will be displayed according to the setting of the
493 variable @var{finger-code}. There is no limit to the number of fret
494 indications per string.
497 (make-fret-diagram layout props marking-list))
499 (define (make-fret-diagram layout props marking-list)
500 "Make a fret diagram markup"
502 ; note: here we get items from props that are needed in this routine,
503 ; or that are needed in more than one of the procedures
504 ; called from this routine. If they're only used in one of the
505 ; sub-procedure, they're obtained in that procedure
506 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
507 ;TODO -- get string-count directly from length of stringTunings;
508 ; from FretBoard engraver, but not from markup call
509 ;TODO -- adjust padding for fret label? it appears to be too close to dots
512 'fret-diagram-details props '())) ; fret diagram details
514 (assoc-get 'string-count details 6)) ; needed for everything
516 (assoc-get 'fret-count details 4)) ; needed for everything
518 (assoc-get 'orientation details 'normal)) ; needed for everything
521 'finger-code details 'none)) ; needed for draw-dots and draw-barre
523 (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
524 (default-dot-position
525 (if (eq? finger-code 'in-dot)
526 (- 0.95 default-dot-radius)
527 0.6)) ; move up to make room for bigger if labeled
530 'dot-radius details default-dot-radius)) ; needed for draw-dots
534 'dot-position details default-dot-position)) ; needed for draw-dots
537 (* (ly:output-def-lookup layout 'line-thickness)
538 (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
541 (chain-assoc-get 'align-dir props -0.4)) ; needed only here
543 (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
544 (label-space (* 0.25 size))
545 (label-dir (assoc-get 'label-dir details RIGHT))
546 (parameters (fret-parse-marking-list marking-list fret-count))
547 (dot-list (cdr (assoc 'dot-list parameters)))
548 (xo-list (cdr (assoc 'xo-list parameters)))
549 (fret-range (cdr (assoc 'fret-range parameters)))
550 (barre-list (cdr (assoc 'barre-list parameters)))
552 (assoc-get 'barre-type details 'curved))
553 (fret-diagram-stencil
555 (draw-strings string-count fret-range th size orientation)
556 (draw-frets fret-range string-count th size orientation))))
557 (if (and (not (null? barre-list))
558 (not (eq? 'none barre-type)))
559 (set! fret-diagram-stencil
561 (draw-barre layout props string-count fret-range size
562 finger-code dot-position dot-radius
563 barre-list orientation)
564 fret-diagram-stencil)))
565 (if (not (null? dot-list))
566 (set! fret-diagram-stencil
569 (draw-dots layout props string-count fret-count fret-range
570 size finger-code dot-position dot-radius
571 th dot-list orientation))))
572 (if (= (car fret-range) 1)
573 (set! fret-diagram-stencil
574 (if (eq? orientation 'normal)
575 (ly:stencil-combine-at-edge
576 fret-diagram-stencil Y UP
577 (draw-thick-zero-fret
578 props string-count th size orientation))
579 (ly:stencil-combine-at-edge
580 fret-diagram-stencil X LEFT
581 (draw-thick-zero-fret
582 props string-count th size orientation)))))
583 (if (not (null? xo-list))
584 (set! fret-diagram-stencil
585 (if (eq? orientation 'normal)
586 (ly:stencil-combine-at-edge
587 fret-diagram-stencil Y UP
588 (draw-xo layout props string-count fret-range
589 size xo-list orientation)
591 (ly:stencil-combine-at-edge
592 fret-diagram-stencil X LEFT
593 (draw-xo layout props string-count fret-range
594 size xo-list orientation)
596 (if (> (car fret-range) 1)
597 (set! fret-diagram-stencil
598 (if (eq? orientation 'normal)
599 (ly:stencil-combine-at-edge
600 fret-diagram-stencil X label-dir
601 (label-fret layout props string-count fret-range
604 (ly:stencil-combine-at-edge
605 fret-diagram-stencil Y label-dir
606 (label-fret layout props string-count fret-range
609 (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
611 (define-builtin-markup-command (fret-diagram layout props definition-string)
612 (string?) ; argument type
613 fret-diagram ; markup category
614 (fret-diagram-verbose-markup) ; properties and defaults
615 "Make a (guitar) fret diagram. For example, say
618 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
622 for fret spacing 3/4 of staff space, D chord diagram
624 Syntax rules for @var{definition-string}:
628 Diagram items are separated by semicolons.
635 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
640 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
644 @code{h:}@var{number} -- Set the height of the diagram in frets.
648 @code{w:}@var{number} -- Set the width of the diagram in strings.
652 @code{f:}@var{number} -- Set fingering label type
653 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
657 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
661 @code{p:}@var{number} -- Set the position of the dot in the fret space.
662 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
666 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
667 barre mark from @var{string1} to @var{string2} on @var{fret}.
670 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
671 If @var{fret} is @samp{o}, @var{string} is identified as open.
672 If @var{fret} is @samp{x}, @var{string} is identified as muted.
675 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
676 @var{string} at @var{fret}, and label with @var{fingering} as defined
677 by the @code{f:} code.
681 Note: There is no limit to the number of fret indications per string.
683 (let ((definition-list
684 (fret-parse-definition-string props definition-string)))
685 (fret-diagram-verbose-markup
686 layout (car definition-list) (cdr definition-list))))
688 (define (fret-parse-definition-string props definition-string)
689 "Parse a fret diagram string and return a pair containing:
690 props, modified as necessary by the definition-string
691 a fret-indication list with the appropriate values"
692 (let* ((fret-count 4)
694 (fret-range (list 1 fret-count))
700 (details (merge-details 'fret-diagram-details props '()))
701 (items (string-split definition-string #\;)))
702 (let parse-item ((myitems items))
703 (if (not (null? (cdr myitems)))
704 (let ((test-string (car myitems)))
705 (case (car (string->list (substring test-string 0 1)))
706 ((#\s) (let ((size (get-numeric-from-key test-string)))
707 (set! props (prepend-alist-chain 'size size props))))
708 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
709 (finger-id (case finger-code
712 ((2) 'below-string))))
714 (acons 'finger-code finger-id details))))
715 ((#\c) (set! output-list
720 (string-split (substring test-string 2) #\-)))
722 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
724 (acons 'fret-count fret-count details))))
725 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
727 (acons 'string-count string-count details))))
728 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
730 (acons 'dot-radius dot-size details))))
731 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
733 (acons 'dot-position dot-position details))))
735 (let ((this-list (string-split test-string #\-)))
736 (if (string->number (cadr this-list))
739 (cons 'place-fret (numerify this-list))
741 (if (equal? (cadr this-list) "x" )
744 (list 'mute (string->number (car this-list)))
748 (list 'open (string->number (car this-list)))
750 (parse-item (cdr myitems)))))
751 ; add the modified details
753 (prepend-alist-chain 'fret-diagram-details details props))
754 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
756 (define (cons-fret new-value old-list)
757 "Put together a fret-list in the format desired by parse-string"
758 (if (eq? old-list '())
760 (cons* new-value old-list)))
762 (define (get-numeric-from-key keystring)
763 "Get the numeric value from a key of the form k:val"
764 (string->number (substring keystring 2 (string-length keystring))))
766 (define (numerify mylist)
767 "Convert string values to numeric or character"
770 (let ((numeric-value (string->number (car mylist))))
772 (cons* numeric-value (numerify (cdr mylist)))
773 (cons* (car (string->list (car mylist)))
774 (numerify (cdr mylist)))))))
776 (define-builtin-markup-command
777 (fret-diagram-terse layout props definition-string)
778 (string?) ; argument type
779 fret-diagram ; markup category
780 (fret-diagram-verbose-markup) ; properties
781 "Make a fret diagram markup using terse string-based syntax.
786 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
790 for a D@tie{}chord diagram.
792 Syntax rules for @var{definition-string}:
797 Strings are terminated by semicolons; the number of semicolons
798 is the number of strings in the diagram.
801 Mute strings are indicated by @samp{x}.
804 Open strings are indicated by @samp{o}.
807 A number indicates a fret indication at that fret.
810 If there are multiple fret indicators desired on a string, they
811 should be separated by spaces.
814 Fingerings are given by following the fret number with a @code{-},
815 followed by the finger indicator, e.g. @samp{3-2} for playing the third
816 fret with the second finger.
819 Where a barre indicator is desired, follow the fret (or fingering) symbol
820 with @code{-(} to start a barre and @code{-)} to end the barre.
823 ;; TODO -- change syntax to fret\string-finger
824 (let ((definition-list
825 (fret-parse-terse-definition-string props definition-string)))
826 (fret-diagram-verbose-markup layout
827 (car definition-list)
828 (cdr definition-list))))
831 (fret-parse-terse-definition-string props definition-string)
832 "Parse a fret diagram string that uses terse syntax; return a pair containing:
833 props, modified to include the string-count determined by the
834 definition-string, and
835 a fret-indication list with the appropriate values"
836 ;TODO -- change syntax to fret\string-finger
838 (let* ((details (merge-details 'fret-diagram-details props '()))
839 (barre-start-list '())
842 (items (string-split definition-string #\;))
843 (string-count (- (length items) 1)))
844 (let parse-item ((myitems items))
845 (if (not (null? (cdr myitems)))
846 (let* ((test-string (car myitems))
847 (current-string (- (length myitems) 1))
848 (indicators (string-split test-string #\ )))
849 (let parse-indicators ((myindicators indicators))
850 (if (not (eq? '() myindicators))
851 (let* ((this-list (string-split (car myindicators) #\-))
852 (max-element-index (- (length this-list) 1))
854 (car (list-tail this-list max-element-index)))
856 (if (string->number (car this-list))
857 (string->number (car this-list))
859 (if (equal? last-element "(")
861 (set! barre-start-list
862 (cons-fret (list current-string fret)
865 (list-head this-list max-element-index))))
866 (if (equal? last-element ")")
868 (get-sub-list fret barre-start-list))
869 (insert-index (- (length this-barre) 1)))
871 (cons-fret (cons* 'barre
877 (list-head this-list max-element-index))))
884 (drop-paren (numerify this-list)))
886 (if (equal? (car this-list) "x" )
890 (list 'mute current-string)
895 (list 'open current-string)
897 (parse-indicators (cdr myindicators)))))
898 (parse-item (cdr myitems)))))
899 (set! details (acons 'string-count string-count details))
900 (set! props (prepend-alist-chain 'fret-diagram-details details props))
901 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
903 (define (drop-paren item-list)
904 "Drop a final parentheses from a fret indication list
905 resulting from a terse string specification of barre."
906 (if (> (length item-list) 0)
907 (let* ((max-index (- (length item-list) 1))
908 (last-element (car (list-tail item-list max-index))))
909 (if (or (equal? last-element ")") (equal? last-element "("))
910 (list-head item-list max-index)
914 (define (get-sub-list value master-list)
915 "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
916 (if (eq? master-list '())
918 (let ((sublist (car master-list)))
919 (if (equal? (cadr sublist) value)
921 (get-sub-list value (cdr master-list))))))
923 (define (merge-details key alist-list . default)
924 "Return ALIST-LIST entries for key, in one combined alist.
925 There can be two ALIST-LIST entries for a given key. The first
926 comes from the override-markup function, the second comes
927 from property settings during a regular override.
928 This is necessary because some details can be set in one
929 place, while others are set in the other. Both details
930 lists must be merged into a single alist.
931 Return DEFAULT (optional, else #f) if not
934 (define (helper key alist-list default)
935 (if (null? alist-list)
937 (let* ((handle (assoc key (car alist-list))))
939 (append (cdr handle) (chain-assoc-get key (cdr alist-list) '()))
940 (helper key (cdr alist-list) default)))))
942 (helper key alist-list
943 (if (pair? default) (car default) #f)))