1 ;;;; fret-diagrams.scm --
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2007 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)))))
25 ;; calculate fret-range
26 (let ((maxfret 0) (minfret 99))
27 (let updatemax ((fret-list dot-list))
30 (let ((fretval (second (car fret-list))))
31 (if (> fretval maxfret) (set! maxfret fretval))
32 (if (< fretval minfret) (set! minfret fretval))
33 (updatemax (cdr fret-list)))))
34 (if (> maxfret fret-count)
35 (set! fret-range (list minfret
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 '()))))))
47 (define (subtract-base-fret base-fret dot-list)
48 "Subtract @var{base-fret} from every fret in @var{dot-list}"
51 (let ((this-list (car dot-list)))
52 (cons* (list (car this-list) (- (second this-list) base-fret) (if (null? (cddr this-list))
55 (subtract-base-fret base-fret (cdr dot-list))))))
57 (define (sans-serif-stencil layout props mag text)
58 "create a stencil in sans-serif font based on @var{layout} and @var{props}
59 with magnification @varr{mag} of the string @var{text}."
60 (let* ((my-props (prepend-alist-chain 'font-size (stepmag mag)
61 (prepend-alist-chain 'font-family 'sans props))))
62 (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)
77 (ly:make-stencil (list 'draw-line sth 0 0 0 sl)
78 (cons (- half-thickness) half-thickness)
79 (cons (- half-thickness) (+ sl half-thickness)))
80 (ly:make-stencil (list 'draw-line sth 0 0 sl 0)
81 (cons (- half-thickness) (+ sl half-thickness))
82 (cons (- half-thickness) half-thickness)))))
83 (if (= string-count 1)
85 (if (eq? orientation 'normal)
86 (ly:stencil-combine-at-edge
87 (draw-strings (- string-count 1) fret-range th size orientation) X RIGHT
90 (ly:stencil-combine-at-edge
91 (draw-strings (- string-count 1) fret-range th size orientation) Y UP
95 (define (draw-fret-lines fret-count string-count th size orientation)
96 "Draw @var{fret-count} fret lines for a fret diagram
97 with @var{string-count} strings. Line thickness is given by @var{th},
98 fret & string spacing by @var{size}. Orientation is given by @var{orientation}"
99 (let* (;(fret-length (* (- string-count 1) size))
101 ;(half-thickness (* sth 0.5))
103 (fret-line (draw-fret-line string-count th size orientation)))
106 (if (eq? orientation 'normal)
107 (ly:stencil-combine-at-edge (draw-fret-lines (- fret-count 1) string-count th size orientation) Y UP
110 (ly:stencil-combine-at-edge (draw-fret-lines (- fret-count 1) string-count th size orientation) X RIGHT
114 (define (draw-fret-line string-count th size orientation)
115 "Draw a fret line for a fret diagram."
116 (let* ((fret-length (* (- string-count 1) size))
118 (half-thickness (* sth 0.5)))
119 (if (eq? orientation 'normal)
120 (ly:make-stencil (list 'draw-line sth half-thickness size
121 (- fret-length half-thickness) size)
123 (cons (- half-thickness) half-thickness))
124 (ly:make-stencil (list 'draw-line sth 0 half-thickness
125 0 (- fret-length half-thickness))
126 (cons (- half-thickness) half-thickness)
127 (cons 0 fret-length)))))
129 (define (draw-thick-zero-fret props string-count th size orientation)
130 "Draw a thick zeroth fret for a fret diagram whose base fret is not 1."
131 (let* ((sth (* th size))
132 ; (top-fret-thick (* sth (chain-assoc-get 'top-fret-thickness props 3.0)))
133 (top-fret-thick (* sth 3.0))
134 ; (top-half-thick (* top-fret-thick 0.5))
135 (half-thick (* sth 0.5))
137 (x2 (+ half-thick (* size (- string-count 1))))
139 (y2 (+ top-fret-thick half-thick))
140 (x-extent (cons (- x1) x2))
141 (y-extent (cons 0 y2)))
142 (if (eq? orientation 'normal)
143 (ly:make-stencil (list 'round-filled-box x1 x2 y1 y2 sth)
145 (ly:make-stencil (list 'round-filled-box y1 y2 x1 x2 sth)
146 y-extent x-extent))))
149 (define (draw-frets layout props fret-range string-count th size orientation)
150 "Draw the fret lines for a fret diagram with
151 @var{string-count} strings and frets as indicated in @var{fret-range}.
152 Line thickness is given by @var{th}, fret & string spacing by
153 @var{size}. Orientation is given by @var{orientation}."
154 (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
155 (fret-length (* (- string-count 1) size))
156 (half-thickness (* th 0.5))
157 (base-fret (car fret-range))
158 (fret-zero (draw-fret-line string-count th size orientation)))
159 (if (eq? orientation 'normal)
160 (ly:stencil-combine-at-edge
161 (draw-fret-lines fret-count string-count th size orientation) Y UP
164 (ly:stencil-combine-at-edge
166 (draw-fret-lines fret-count string-count th size orientation)
170 (define (draw-dots layout props string-count fret-count fret-range size finger-code
171 dot-position dot-radius dot-thickness dot-list orientation)
172 "Make dots for fret diagram."
174 (let* ((scale-dot-radius (* size dot-radius))
175 (scale-dot-thick (* size dot-thickness))
176 (dot-color (chain-assoc-get 'dot-color props 'black))
177 ; (finger-xoffset (chain-assoc-get 'finger-xoffset props -0.25))
178 ; (finger-yoffset (chain-assoc-get 'finger-yoffset props (- size)))
179 (finger-xoffset -0.25)
180 (finger-yoffset (- (* size 0.5)))
181 ; (dot-label-font-mag (* scale-dot-radius (chain-assoc-get 'dot-label-font-mag props 1.0)))
182 (dot-label-font-mag scale-dot-radius)
183 ; (string-label-font-mag (* size (chain-assoc-get 'label-font-mag props 0.7)))
184 (string-label-font-mag (* size 0.6))
185 ; (fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
186 (mypair (car dot-list))
187 (restlist (cdr dot-list))
188 (string (car mypair))
190 (xpos (* size (if (eq? orientation 'normal)
191 (- string-count string)
192 (+ (- fret 1 ) dot-position))))
193 ;TODO -- figure out what 4 is and get rid of it
195 (ypos (* size (if (eq? orientation 'normal)
196 (+ 2 (- fret-count fret dot-position ))
197 (- string-count string))))
198 (extent (cons (- scale-dot-radius) scale-dot-radius))
199 (finger (caddr mypair))
200 (finger (if (number? finger) (number->string finger) finger))
201 (dotstencil (if (eq? dot-color 'white)
203 (make-circle-stencil scale-dot-radius scale-dot-thick #t)
206 (- scale-dot-radius (* 0.5 scale-dot-thick)) 0 #t)
208 (make-circle-stencil scale-dot-radius scale-dot-thick #t)))
209 (positioned-dot (begin
210 ;(display dotstencil)
211 (ly:stencil-translate-axis
212 (ly:stencil-translate-axis dotstencil xpos X)
216 (if (or (eq? finger '())(eq? finger-code 'none))
218 (if (eq? finger-code 'in-dot)
219 (let* ((finger-label (centered-stencil
220 (sans-serif-stencil layout props
221 dot-label-font-mag finger))))
222 (ly:stencil-translate-axis
223 (ly:stencil-translate-axis
226 (if (eq? dot-color 'white)
228 (ly:stencil-in-color finger-label 1 1 1)))
231 (if (eq? finger-code 'below-string)
234 (if (eq? orientation 'normal)
235 (ly:stencil-translate-axis
236 (ly:stencil-translate-axis
237 (centered-stencil (sans-serif-stencil layout props
238 string-label-font-mag finger))
240 (* size finger-yoffset) Y)
241 (ly:stencil-translate-axis
242 (ly:stencil-translate-axis
243 (centered-stencil (sans-serif-stencil layout props
244 string-label-font-mag finger))
245 (* size (+ 2 fret-count finger-yoffset)) X)
252 (draw-dots layout props string-count fret-count fret-range size finger-code
253 dot-position dot-radius dot-thickness restlist orientation)
254 labeled-dot-stencil))))
256 (define (draw-xo layout props string-count fret-range size xo-list orientation)
257 "Put open and mute string indications on diagram, as contained in @var{xo-list}."
258 (let* ((fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
259 (xo-font-mag (* size (chain-assoc-get 'xo-font-magnification props 0.5)))
260 ; (xo-font-mag (* size 0.5))
261 ; (xo-horizontal-offset (* size (chain-assoc-get 'xo-horizontal-offset props -0.35)))
262 (xo-horizontal-offset (* size -0.35))
263 (mypair (car xo-list))
264 (restlist (cdr xo-list))
265 (glyph-string (if (eq? (car mypair) 'mute)
266 (chain-assoc-get 'mute-string props "X")
267 (chain-assoc-get 'open-string props "O")))
268 (xpos (+ (* (- string-count (cadr mypair)) size) xo-horizontal-offset ))
269 (glyph-stencil (if (eq? orientation 'normal)
270 (ly:stencil-translate-axis
271 (sans-serif-stencil layout props (* size xo-font-mag) glyph-string)
273 (ly:stencil-translate-axis
274 (sans-serif-stencil layout props (* size xo-font-mag) glyph-string)
276 ;(display "def-xo-mag" default-xo-magnification)
280 (draw-xo layout props string-count fret-range size restlist orientation)
283 (define (make-bezier-sandwich-list start stop base height thickness orientation)
284 " Make the argument list for a bezier sandwich from
285 @var{start} to @var{stop} with a baseline at @var{base}, a height of
286 @var{height}, and a thickness of @var{thickness}. If @var{orientation} is
287 @var{'normal}, @var{base} is a y coordinate, otherwise it's an x coordinate."
288 (let* ((width (+ (- stop start) 1))
289 (x1 (+ (* width thickness) start))
290 (x2 (- stop (* width thickness)))
291 (bottom-control-point-height (if (eq? orientation 'normal)
292 (+ base (- height thickness))
293 (- base (- height thickness))))
294 (top-control-point-height (if (eq? orientation 'normal)
297 ; order of points is: left cp low, right cp low, right end low, left end low
298 ; right cp high, left cp high, left end high, right end high.
299 (if (eq? orientation 'normal)
300 (list (cons x1 bottom-control-point-height)
301 (cons x2 bottom-control-point-height)
304 (cons x2 top-control-point-height)
305 (cons x1 top-control-point-height)
308 (list (cons bottom-control-point-height x1)
309 (cons bottom-control-point-height x2)
312 (cons top-control-point-height x2)
313 (cons top-control-point-height x1)
317 (define (draw-barre layout props string-count fret-range size finger-code dot-position dot-radius barre-list orientation)
318 "Create barre indications for a fret diagram"
319 (if (not (null? barre-list))
320 (let* ((string1 (caar barre-list))
321 (string2 (cadar barre-list))
322 (fret (caddar barre-list))
323 (top-fret (cadr fret-range))
324 (low-fret (car fret-range))
325 (barre-type (chain-assoc-get 'barre-type props 'curved))
326 (scale-dot-radius (* size dot-radius))
327 (barre-vertical-offset 0.5)
328 ; (barre-vertical-offset (chain-assoc-get 'barre-vertical-offset props 0.5))
329 ;; 2 is 1 for empty fret at bottom of figure + 1 for interval (top-fret - fret + 1) -- not an arbitrary constant
330 (dot-center-y (* size
331 (- (+ 2 (- (cadr fret-range) fret)) dot-position)))
332 (dot-center-fret-coordinate (+ (- fret low-fret) dot-position))
333 (barre-fret-coordinate (+ dot-center-fret-coordinate (* (- barre-vertical-offset 0.5) dot-radius)))
334 (barre-start-string-coordinate (- string-count string1))
335 (barre-end-string-coordinate (- string-count string2))
336 (bottom (+ dot-center-y (* barre-vertical-offset scale-dot-radius)))
337 (left (* size (- string-count string1)))
338 (right (* size (- string-count string2)))
339 ;; (bezier-thick (chain-assoc-get 'bezier-thickness props 0.1))
341 ;; (bezier-height (chain-assoc-get 'bezier-height props 0.5))
343 (bezier-list (if (eq? orientation 'normal)
344 (make-bezier-sandwich-list
345 (* size barre-start-string-coordinate)
346 (* size barre-end-string-coordinate)
347 (* size (+ 1 (- top-fret fret) barre-fret-coordinate))
348 (* size bezier-height)
349 (* size bezier-thick)
351 (make-bezier-sandwich-list
352 (* size barre-start-string-coordinate)
353 (* size barre-end-string-coordinate)
354 (* size barre-fret-coordinate)
355 (* size bezier-height)
356 (* size bezier-thick)
358 (barre-stencil (if (eq? barre-type 'straight)
359 (if (eq? orientation 'normal)
360 (ly:make-stencil (list 'draw-line (* size dot-radius) left dot-center-y right dot-center-y)
362 (cons (- dot-center-y scale-dot-radius) (+ dot-center-y scale-dot-radius)))
363 (ly:make-stencil (list 'draw-line (* size dot-radius)
364 (* size barre-fret-coordinate)
365 (* size barre-start-string-coordinate)
366 (* size barre-fret-coordinate)
367 (* size barre-end-string-coordinate))
368 (cons (- (* size barre-fret-coordinate) scale-dot-radius)
369 (+ (* size barre-fret-coordinate) scale-dot-radius))
370 (cons (* size barre-start-string-coordinate)
371 (* size barre-end-string-coordinate))))
372 (if (eq? orientation 'normal)
373 (ly:make-stencil (list 'bezier-sandwich `(quote ,bezier-list) (* size bezier-thick))
375 (cons bottom (+ bottom (* size bezier-height))))
376 (ly:make-stencil (list 'bezier-sandwich `(quote ,bezier-list) (* size bezier-thick))
377 (cons bottom (+ bottom (* size bezier-height)))
378 (cons left right))))))
379 (if (not (null? (cdr barre-list)))
380 (ly:stencil-add barre-stencil
381 (draw-barre layout props string-count fret-range size finger-code
382 dot-position dot-radius (cdr barre-list)))
385 (define (stepmag mag)
386 "Calculate the font step necessary to get a desired magnification"
387 (* 6 (/ (log mag) (log 2))))
389 (define (label-fret layout props string-count fret-range size orientation)
390 "Label the base fret on a fret diagram"
391 (let* ((base-fret (car fret-range))
392 ; (label-font-mag (chain-assoc-get 'label-font-mag props 0.7))
394 ; (label-vertical-offset (chain-assoc-get 'fret-label-vertical-offset props -0.2))
395 (label-vertical-offset -0.2)
396 (number-type (chain-assoc-get 'number-type props 'roman-lower))
397 (fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
400 ((equal? number-type 'roman-lower) (fancy-format #f "~(~:@r~)" base-fret))
401 ((equal? number-type 'roman-upper) (fancy-format #f "~:@r" base-fret))
402 ((equal? 'arabic number-type) (fancy-format #f "~d" base-fret))
403 (else (fancy-format #f "~(~:@r~)" base-fret)))))
404 (if (eq? orientation 'normal)
405 (ly:stencil-translate-axis
406 (sans-serif-stencil layout props (* size label-font-mag) label-text)
407 (* size (+ fret-count label-vertical-offset)) Y)
408 (ly:stencil-translate-axis
409 (sans-serif-stencil layout props (* size label-font-mag) label-text)
410 (* size (+ 1 label-vertical-offset)) X))))
412 (define-builtin-markup-command (fret-diagram-verbose layout props marking-list)
414 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
419 \\markup \\fret-diagram-verbose
420 #'((mute 6) (mute 5) (open 4)
421 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
425 produces a standard D@tie{}chord diagram without fingering indications.
427 Possible elements in @var{marking-list}:
430 @item (mute @var{string-number})
431 Place a small @q{x} at the top of string @var{string-number}.
433 @item (open @var{string-number})
434 Place a small @q{o} at the top of string @var{string-number}.
436 @item (barre @var{start-string} @var{end-string} @var{fret-number})
437 Place a barre indicator (much like a tie) from string @var{start-string}
438 to string @var{end-string} at fret @var{fret-number}.
440 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
441 Place a fret playing indication on string @var{string-number} at fret
442 @var{fret-number} with an optional fingering label @var{finger-value}.
443 By default, the fret playing indicator is a solid dot. This can be
444 changed by setting the value of the variable @var{dot-color}. If the
445 @var{finger} part of the @code{place-fret} element is present,
446 @var{finger-value} will be displayed according to the setting of the
447 variable @var{finger-code}. There is no limit to the number of fret
448 indications per string.
450 (make-fret-diagram layout props marking-list))
452 (define (make-fret-diagram layout props marking-list)
453 " Make a fret diagram markup"
455 ; note: here we get items from props that are needed in this routine, or that are needed in more than one
456 ; of the procedures called from this routine. If they're only used in one of the sub-procedure, they're
457 ; obtained in that procedure
459 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
460 ;TODO -- get string-count directly from length of stringTunings; requires FretDiagram engraver, which is not yet available
461 ;TODO -- adjust padding for fret label? it appears to be too close to dots
462 (string-count (chain-assoc-get 'string-count props 6)) ; needed for everything
463 (fret-count (chain-assoc-get 'fret-count props 4)) ; needed for everything
464 (orientation (chain-assoc-get 'orientation props 'normal)) ; needed for everything
465 (finger-code (chain-assoc-get 'finger-code props 'none)) ; needed for both draw-dots and draw-barre
466 (default-dot-radius (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
467 (default-dot-position (if (eq? finger-code 'in-dot) (- 0.95 default-dot-radius) 0.6)) ; move up to make room for bigger if labeled
468 (dot-radius (chain-assoc-get 'dot-radius props default-dot-radius)) ; needed for both draw-dots and draw-barre
469 (dot-position (chain-assoc-get 'dot-position props default-dot-position)) ; needed for both draw-dots and draw-barre
470 (th (* (ly:output-def-lookup layout 'line-thickness)
471 (chain-assoc-get 'thickness props 0.5))) ; needed for both draw-frets and draw-strings
473 (alignment (chain-assoc-get 'align-dir props -0.4)) ; needed only here
474 ; (xo-padding (* th (chain-assoc-get 'padding props 2))) ; needed only here
475 (label-space (* 0.25 size))
476 (xo-padding (* th size 5))
477 (label-dir (chain-assoc-get 'label-dir props RIGHT))
478 (parameters (fret-parse-marking-list marking-list fret-count))
479 (dot-list (cdr (assoc 'dot-list parameters)))
480 (xo-list (cdr (assoc 'xo-list parameters)))
481 (fret-range (cdr (assoc 'fret-range parameters)))
482 (barre-list (cdr (assoc 'barre-list parameters)))
483 (fret-diagram-stencil (ly:stencil-add
484 (draw-strings string-count fret-range th size orientation)
485 (draw-frets layout props fret-range string-count th size orientation))))
486 (if (not (null? barre-list))
487 (set! fret-diagram-stencil (ly:stencil-add
488 (draw-barre layout props string-count fret-range size finger-code
489 dot-position dot-radius barre-list orientation)
490 fret-diagram-stencil)))
491 (if (not (null? dot-list))
492 (set! fret-diagram-stencil (ly:stencil-add
494 (draw-dots layout props string-count fret-count fret-range size finger-code
495 dot-position dot-radius th dot-list orientation))))
496 (if (= (car fret-range) 1)
497 (set! fret-diagram-stencil
498 (if (eq? orientation 'normal)
499 (ly:stencil-combine-at-edge fret-diagram-stencil Y UP
500 (draw-thick-zero-fret props string-count th size orientation))
501 (ly:stencil-combine-at-edge fret-diagram-stencil X LEFT
502 (draw-thick-zero-fret props string-count th size orientation)))))
503 (if (not (null? xo-list))
504 (set! fret-diagram-stencil
505 (if (eq? orientation 'normal)
506 (ly:stencil-combine-at-edge fret-diagram-stencil Y UP
507 (draw-xo layout props string-count fret-range size xo-list orientation) xo-padding )
508 (ly:stencil-combine-at-edge fret-diagram-stencil X LEFT
509 (draw-xo layout props string-count fret-range size xo-list orientation) xo-padding))))
510 (if (> (car fret-range) 1)
511 (set! fret-diagram-stencil
512 (if (eq? orientation 'normal)
513 (ly:stencil-combine-at-edge fret-diagram-stencil X label-dir
514 (label-fret layout props string-count fret-range size orientation) label-space)
515 (ly:stencil-combine-at-edge fret-diagram-stencil Y label-dir
516 (label-fret layout props string-count fret-range size orientation) label-space))))
518 (ly:stencil-aligned-to fret-diagram-stencil X alignment)
521 (define-builtin-markup-command (fret-diagram layout props definition-string)
523 "Make a (guitar) fret diagram. For example, say
526 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
530 for fret spacing 3/4 of staff space, D chord diagram
532 Syntax rules for @var{definition-string}:
536 Diagram items are separated by semicolons.
543 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
548 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
552 @code{h:}@var{number} -- Set the height of the diagram in frets.
556 @code{w:}@var{number} -- Set the width of the diagram in strings.
560 @code{f:}@var{number} -- Set fingering label type
561 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
565 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
569 @code{p:}@var{number} -- Set the position of the dot in the fret space.
570 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
574 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
575 barre mark from @var{string1} to @var{string2} on @var{fret}.
578 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
579 If @var{fret} is @samp{o}, @var{string} is identified as open.
580 If @var{fret} is @samp{x}, @var{string} is identified as muted.
583 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
584 @var{string} at @var{fret}, and label with @var{fingering} as defined
585 by the @code{f:} code.
589 Note: There is no limit to the number of fret indications per string.
591 (let ((definition-list (fret-parse-definition-string props definition-string)))
592 (make-fret-diagram layout (car definition-list) (cdr definition-list))))
594 (define (fret-parse-definition-string props definition-string)
595 "parse a fret diagram string and return a pair containing:
596 props, modified as necessary by the definition-string
597 a fret-indication list with the appropriate values"
598 (let* ((fret-count 4)
600 (fret-range (list 1 fret-count))
606 (items (string-split definition-string #\;)))
607 (let parse-item ((myitems items))
608 (if (not (null? (cdr myitems)))
609 (let ((test-string (car myitems)))
610 (case (car (string->list (substring test-string 0 1)))
611 ((#\s) (let ((size (get-numeric-from-key test-string)))
612 (set! new-props (acons 'size size new-props))))
613 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
614 (finger-id (case finger-code
617 ((2) 'below-string))))
619 (acons 'finger-code finger-id new-props))))
620 ((#\c) (set! output-list (cons-fret (cons 'barre (numerify (string-split (substring test-string 2) #\-)))
622 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
623 (set! new-props (acons 'fret-count fret-count new-props))))
624 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
625 (set! new-props (acons 'string-count string-count new-props))))
626 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
627 (set! new-props (acons 'dot-radius dot-size new-props))))
628 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
629 (set! new-props (acons 'dot-position dot-position new-props))))
631 (let ((this-list (string-split test-string #\-)))
632 (if (string->number (cadr this-list))
633 (set! output-list (cons-fret (cons 'place-fret (numerify this-list)) output-list))
634 (if (equal? (cadr this-list) "x" )
635 (set! output-list (cons-fret (list 'mute (string->number (car this-list))) output-list))
636 (set! output-list (cons-fret (list 'open (string->number (car this-list))) output-list)))))))
637 (parse-item (cdr myitems)))))
638 (if (eq? new-props '())
639 `(,props . ,output-list)
640 `(,(cons new-props props) . ,output-list))))
642 (define (cons-fret new-value old-list)
643 " Put together a fret-list in the format desired by parse-string "
644 (if (eq? old-list '())
646 (cons* new-value old-list)))
648 (define (get-numeric-from-key keystring)
649 "Get the numeric value from a key of the form k:val"
650 (string->number (substring keystring 2 (string-length keystring))))
652 (define (numerify mylist)
653 "Convert string values to numeric or character"
656 (let ((numeric-value (string->number (car mylist))))
658 (cons* numeric-value (numerify (cdr mylist)))
659 (cons* (car (string->list (car mylist))) (numerify (cdr mylist)))))))
661 (define-builtin-markup-command (fret-diagram-terse layout props definition-string)
663 "Make a fret diagram markup using terse string-based syntax.
668 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
672 for a D@tie{}chord diagram.
674 Syntax rules for @var{definition-string}:
679 Strings are terminated by semicolons; the number of semicolons
680 is the number of strings in the diagram.
683 Mute strings are indicated by @samp{x}.
686 Open strings are indicated by @samp{o}.
689 A number indicates a fret indication at that fret.
692 If there are multiple fret indicators desired on a string, they
693 should be separated by spaces.
696 Fingerings are given by following the fret number with a @code{-},
697 followed by the finger indicator, e.g. @samp{3-2} for playing the third
698 fret with the second finger.
701 Where a barre indicator is desired, follow the fret (or fingering) symbol
702 with @code{-(} to start a barre and @code{-)} to end the barre.
705 ;TODO -- change syntax to fret\string-finger
706 (let ((definition-list (fret-parse-terse-definition-string props definition-string)))
707 (make-fret-diagram layout (car definition-list) (cdr definition-list))))
709 (define (fret-parse-terse-definition-string props definition-string)
710 "parse a fret diagram string that uses terse syntax; return a pair containing:
711 props, modified to include the string-count determined by the definition-string
712 a fret-indication list with the appropriate values"
713 ;TODO -- change syntax to fret\string-finger
714 (let* ((barre-start-list '())
717 (items (string-split definition-string #\;))
718 (string-count (- (length items) 1)))
719 (let parse-item ((myitems items))
720 (if (not (null? (cdr myitems)))
721 (let* ((test-string (car myitems))
722 (current-string (- (length myitems) 1))
723 (indicators (string-split test-string #\ )))
724 (let parse-indicators ((myindicators indicators))
725 (if (not (eq? '() myindicators))
726 (let* ((this-list (string-split (car myindicators) #\-))
727 (max-element-index (- (length this-list) 1))
728 (last-element (car (list-tail this-list max-element-index)))
729 (fret (if (string->number (car this-list)) (string->number (car this-list)) (car this-list))))
730 (if (equal? last-element "(")
732 (set! barre-start-list (cons-fret (list current-string fret) barre-start-list))
733 (set! this-list (list-head this-list max-element-index))))
734 (if (equal? last-element ")")
735 (let* ((this-barre (get-sub-list fret barre-start-list))
736 (insert-index (- (length this-barre) 1)))
737 (set! output-list (cons-fret (cons* 'barre (car this-barre) current-string (cdr this-barre))
739 (set! this-list (list-head this-list max-element-index))))
741 (set! output-list (cons-fret (cons* 'place-fret current-string (drop-paren (numerify this-list))) output-list))
742 (if (equal? (car this-list) "x" )
743 (set! output-list (cons-fret (list 'mute current-string) output-list))
744 (set! output-list (cons-fret (list 'open current-string) output-list))))
745 (parse-indicators (cdr myindicators)))))
746 (parse-item (cdr myitems)))))
747 (set! new-props (acons 'string-count string-count new-props))
749 `(,(cons new-props props) . ,output-list)))
751 (define (drop-paren item-list)
752 " drop a final parentheses from a fret indication list resulting from a terse string specification of barre."
753 (if (> (length item-list) 0)
754 (let* ((max-index (- (length item-list) 1))
755 (last-element (car (list-tail item-list max-index))))
756 (if (or (equal? last-element ")") (equal? last-element "("))
757 (list-head item-list max-index)
761 (define (get-sub-list value master-list)
762 " Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
763 (if (eq? master-list '())
765 (let ((sublist (car master-list)))
766 (if (equal? (cadr sublist) value)
768 (get-sub-list value (cdr master-list))))))