| blob | 0bf9d6bda717f42ca4ca07c32c3679599836b516 |
1 ;;;; fret-diagrams.scm --
2 ;;;;
3 ;;;; source file of the GNU LilyPond music typesetter
4 ;;;;
5 ;;;; (c) 2004--2009 Carl D. Sorensen <c_sorensen@byu.edu>
7 ;
8 ; Utility functions
9 ;
10 ;
12 (define (string-x-extent start-point end-point)
13 "Return the x-extent of a string that goes from start-point
14 to end-point."
15 (let ((x1 (car start-point))
16 (x2 (car end-point)))
17 (if (> x1 x2)
18 (cons x2 x1)
19 (cons x1 x2))))
21 (define (string-y-extent start-point end-point)
22 "Return the y-extent of a string that goes from start-point
23 to end-point."
24 (let ((y1 (cdr start-point))
25 (y2 (cdr end-point)))
26 (if (> y1 y2)
27 (cons y2 y1)
28 (cons y1 y2))))
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 '())
34 (list new-value)
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"
43 (if (null? mylist)
44 '()
45 (let ((numeric-value (string->number (car mylist))))
46 (if numeric-value
47 (cons* numeric-value (numerify (cdr mylist)))
48 (cons* (car (string->list (car mylist)))
49 (numerify (cdr mylist)))))))
51 (define (stepmag mag)
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}"
61 (if (null? dot-list)
62 '()
63 (let ((this-list (car dot-list)))
64 (cons* (list (car this-list) (- (second this-list) base-fret)
65 (if (null? (cddr this-list))
66 '()
67 (third 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
82 (- base height))
83 (left-end-point
84 (stencil-coordinates base start orientation))
85 (right-end-point
86 (stencil-coordinates base stop orientation))
87 (left-upper-control-point
88 (stencil-coordinates
89 top-control-point-height cp-left-width orientation))
90 (left-lower-control-point
91 (stencil-coordinates
92 bottom-control-point-height cp-left-width orientation))
93 (right-upper-control-point
94 (stencil-coordinates
95 top-control-point-height cp-right-width orientation))
96 (right-lower-control-point
97 (stencil-coordinates
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.
102 ;
103 (list left-lower-control-point
104 right-lower-control-point
105 right-end-point
106 left-end-point
107 right-upper-control-point
108 left-upper-control-point
109 left-end-point
110 right-end-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)
120 item-list))
121 item-list))
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 '())
126 #f
127 (let ((sublist (car master-list)))
128 (if (equal? (cadr sublist) value)
129 sublist
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
141 found."
143 (define (helper key alist-list default)
144 (if (null? alist-list)
145 default
146 (let* ((handle (assoc key (car alist-list))))
147 (if (pair? handle)
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)))
154 ;
155 ; Conversions between fret/string coordinate system and x-y coordinate
156 ; system.
157 ;
158 ; Fret coordinates are measured down the fretboard from the nut,
159 ; starting at 0.
160 ;
161 ; String coordinates are measured from the lowest string, starting at 0.
162 ;
163 ; The x-y origin is at the intersection of the nut and the lowest string.
164 ;
165 ; X coordinates are positive to the right.
166 ; Y coordinates are positive up.
167 ;
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}
175 direction."
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)))
181 (else
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)))
188 (else
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
200 system."
201 (cond
202 ((eq? orientation 'landscape)
203 (cons fret-coordinate string-coordinate))
204 ((eq? orientation 'opposing-landscape)
205 (cons (- fret-coordinate) (- string-coordinate)))
206 (else
207 (cons string-coordinate (- fret-coordinate)))))
209 (define (string-thickness string thickness-factor)
210 (expt (1+ thickness-factor) (1- string)))
212 ;
213 ; Functions that create stencils used in the fret diagram
214 ;
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}."
219 (let* ((my-props
220 (prepend-alist-chain
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
229 overall parameters."
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))
235 (start-coordinates
236 (stencil-coordinates
237 (- fret-half-thickness)
238 (- (* size string-coordinate) half-string)
239 orientation))
240 (end-coordinates
241 (stencil-coordinates
242 (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
243 (+ half-string (* size string-coordinate))
244 orientation)))
245 (ly:round-filled-box (string-x-extent start-coordinates end-coordinates)
246 (string-y-extent start-coordinates end-coordinates)
247 (* th size))))
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))
255 (start-coordinates
256 (stencil-coordinates
257 (* size fret)
258 (- fret-half-thickness low-string-half-thickness)
259 orientation))
260 (end-coordinates
261 (stencil-coordinates
262 (* size fret)
263 (* size (1- string-count))
264 orientation)))
265 (make-line-stencil
266 (* size th)
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."
274 (let ((start-point
275 (stencil-coordinates
276 (* size fret-coordinate)
277 (* size start-string-coordinate)
278 orientation))
279 (end-point
280 (stencil-coordinates
281 (* size fret-coordinate)
282 (* size end-string-coordinate)
283 orientation)))
284 (make-line-stencil
285 half-thickness
286 (car start-point)
287 (cdr start-point)
288 (car end-point)
289 (cdr end-point))))
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)
296 (bezier-height 0.5)
297 (bezier-list
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)
304 orientation))
305 (box-lower-left
306 (stencil-coordinates
307 (+ (* size fret-coordinate) half-thickness)
308 (- (* size start-string-coordinate) half-thickness)
309 orientation))
310 (box-upper-right
311 (stencil-coordinates
312 (- (* size fret-coordinate) (* size bezier-height) half-thickness)
313 (+ (* size end-string-coordinate) half-thickness)
314 orientation))
315 (x-extent (cons (car box-lower-left) (car box-upper-right)))
316 (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
317 (ly:make-stencil
318 (list 'bezier-sandwich
319 `(quote ,bezier-list)
320 (* size bezier-thick))
321 x-extent
322 y-extent)))
325 ;
326 ;
327 ; Functions used to draw fret-diagram elements
328 ;
329 ;
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}. "
338 (define (helper x)
339 (if (null? (cdr x))
340 (string-stencil
341 (car x) string-count fret-range th
342 thickness-factor size orientation)
343 (ly:stencil-add
344 (string-stencil
345 (car x) string-count fret-range th
346 thickness-factor size orientation)
347 (helper (cdr x)))))
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}"
357 (define (helper x)
358 (if (null? (cdr x))
359 (fret-stencil
360 (car x) string-count th thickness-factor
361 size orientation)
362 (ly:stencil-add
363 (fret-stencil
364 (car x) string-count th thickness-factor
365 size orientation)
366 (helper (cdr x)))))
368 (let* ( (fret-list (iota (1+ fret-count))))
369 (helper fret-list)))
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))
378 (top-fret-thick
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))
384 (lower-left
385 (stencil-coordinates
386 start-fret-coordinate start-string-coordinate orientation))
387 (upper-right
388 (stencil-coordinates
389 end-fret-coordinate end-string-coordinate orientation)))
390 (ly:round-filled-box
391 (cons (car lower-left) (car upper-right))
392 (cons (cdr lower-left) (cdr upper-right))
393 sth)))
396 (define (draw-capo details string-count fret fret-count th size
397 dot-pos orientation)
398 "Draw a capo indicator across the full width of the fret-board
399 at @var{fret}."
400 (let* ((capo-thick
401 (* size (assoc-get 'capo-thickness details 0.5)))
402 (half-thick (* capo-thick 0.5))
403 (last-string-pos 0)
404 (first-string-pos (* size (- string-count 1)))
405 (fret-pos ( * size (1- (+ dot-pos fret))))
406 (start-point
407 (stencil-coordinates fret-pos first-string-pos orientation))
408 (end-point
409 (stencil-coordinates fret-pos last-string-pos orientation)))
410 (make-line-stencil
411 capo-thick
412 (car start-point) (cdr start-point)
413 (car end-point) (cdr end-point))))
415 (define (draw-frets fret-range string-count th
416 thickness-factor size orientation)
417 "Draw the fret lines for a fret diagram with
418 @var{string-count} strings and frets as indicated in @var{fret-range}.
419 Line thickness is given by @var{th}, fret & string spacing by
420 @var{size}. Orientation is given by @var{orientation}."
421 (let* ((my-fret-count (fret-count fret-range)))
422 (draw-fret-lines
423 my-fret-count string-count th thickness-factor size orientation)))
425 (define (draw-dots layout props string-count fret-count
426 size finger-code
427 dot-position dot-radius dot-thickness dot-list orientation)
428 "Make dots for fret diagram."
430 (let* ((details (merge-details 'fret-diagram-details props '()))
431 (scale-dot-radius (* size dot-radius))
432 (scale-dot-thick (* size dot-thickness))
433 (dot-color (assoc-get 'dot-color details 'black))
434 (finger-label-padding 0.3)
435 (dot-label-font-mag
436 (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
437 (string-label-font-mag
438 (* size
439 (assoc-get 'string-label-font-mag details
440 (cond ((or (eq? orientation 'landscape)
441 (eq? orientation 'opposing-landscape))
442 0.5)
443 (else 0.6)))))
444 (mypair (car dot-list))
445 (restlist (cdr dot-list))
446 (string (car mypair))
447 (fret (cadr mypair))
448 (fret-coordinate (* size (+ (1- fret) dot-position)))
449 (string-coordinate (* size (- string-count string)))
450 (dot-coordinates
451 (stencil-coordinates fret-coordinate string-coordinate orientation))
452 (extent (cons (- scale-dot-radius) scale-dot-radius))
453 (finger (caddr mypair))
454 (finger (if (number? finger) (number->string finger) finger))
455 (dot-stencil (if (eq? dot-color 'white)
456 (ly:stencil-add
457 (make-circle-stencil
458 scale-dot-radius scale-dot-thick #t)
459 (ly:stencil-in-color
460 (make-circle-stencil
461 (- scale-dot-radius (* 0.5 scale-dot-thick))
462 0 #t)
463 1 1 1))
464 (make-circle-stencil
465 scale-dot-radius scale-dot-thick #t)))
466 (positioned-dot (ly:stencil-translate dot-stencil dot-coordinates))
467 (labeled-dot-stencil
468 (cond
469 ((or (eq? finger '())(eq? finger-code 'none))
470 positioned-dot)
471 ((eq? finger-code 'in-dot)
472 (let ((finger-label
473 (centered-stencil
474 (sans-serif-stencil
475 layout props dot-label-font-mag finger))))
476 (ly:stencil-translate
477 (ly:stencil-add
478 dot-stencil
479 (if (eq? dot-color 'white)
480 finger-label
481 (ly:stencil-in-color finger-label 1 1 1)))
482 dot-coordinates)))
483 ((eq? finger-code 'below-string)
484 (let* ((label-stencil
485 (centered-stencil
486 (sans-serif-stencil
487 layout props string-label-font-mag
488 finger)))
489 (label-fret-offset
490 (stencil-fretboard-offset
491 label-stencil 'fret orientation))
492 (label-fret-coordinate
493 (+ (* size (+ 1 fret-count finger-label-padding))
494 label-fret-offset))
495 (label-string-coordinate string-coordinate)
496 (label-translation
497 (stencil-coordinates
498 label-fret-coordinate
499 label-string-coordinate
500 orientation)))
501 (ly:stencil-add
502 positioned-dot
503 (ly:stencil-translate label-stencil label-translation))))
504 (else ;unknown finger-code
505 positioned-dot))))
506 (if (null? restlist)
507 labeled-dot-stencil
508 (ly:stencil-add
509 (draw-dots
510 layout props string-count fret-count size finger-code
511 dot-position dot-radius dot-thickness restlist orientation)
512 labeled-dot-stencil))))
514 (define (draw-xo
515 layout props string-count fret-range size xo-list orientation)
516 "Put open and mute string indications on diagram, as contained in
517 @var{xo-list}."
518 (let* ((details (merge-details 'fret-diagram-details props '()))
519 (xo-font-mag
520 (* size (assoc-get
521 'xo-font-magnification details
522 (cond ((or (eq? orientation 'landscape)
523 (eq? orientation 'opposing-landscape))
524 0.4)
525 (else 0.4)))))
526 (mypair (car xo-list))
527 (restlist (cdr xo-list))
528 (glyph-string (if (eq? (car mypair) 'mute)
529 (assoc-get 'mute-string details "X")
530 (assoc-get 'open-string details "O")))
531 (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
532 (glyph-stencil
533 (centered-stencil
534 (sans-serif-stencil
535 layout props (* size xo-font-mag) glyph-string)))
536 (glyph-stencil-coordinates
537 (stencil-coordinates 0 glyph-string-coordinate orientation))
538 (positioned-glyph
539 (ly:stencil-translate glyph-stencil glyph-stencil-coordinates)))
540 (if (null? restlist)
541 positioned-glyph
542 (ly:stencil-add
543 (draw-xo
544 layout props string-count fret-range size restlist orientation)
545 positioned-glyph))))
547 (define (draw-barre layout props string-count fret-range
548 size finger-code dot-position dot-radius
549 barre-list orientation)
550 "Create barre indications for a fret diagram"
551 (if (not (null? barre-list))
552 (let* ((details (merge-details 'fret-diagram-details props '()))
553 (string1 (caar barre-list))
554 (string2 (cadar barre-list))
555 (barre-fret (caddar barre-list))
556 (top-fret (cdr fret-range))
557 (low-fret (car fret-range))
558 (fret (1+ (- barre-fret low-fret)))
559 (barre-vertical-offset 0.5)
560 (dot-center-fret-coordinate (+ (1- fret) dot-position))
561 (barre-fret-coordinate
562 (+ dot-center-fret-coordinate
563 (* (- barre-vertical-offset 0.5) dot-radius)))
564 (barre-start-string-coordinate (- string-count string1))
565 (barre-end-string-coordinate (- string-count string2))
566 (scale-dot-radius (* size dot-radius))
567 (barre-type (assoc-get 'barre-type details 'curved))
568 (barre-stencil
569 (cond
570 ((eq? barre-type 'straight)
571 (make-straight-barre-stencil
572 size scale-dot-radius
573 barre-fret-coordinate barre-start-string-coordinate
574 barre-end-string-coordinate orientation))
575 ((eq? barre-type 'curved)
576 (make-curved-barre-stencil
577 size scale-dot-radius
578 barre-fret-coordinate barre-start-string-coordinate
579 barre-end-string-coordinate orientation)))))
580 (if (not (null? (cdr barre-list)))
581 (ly:stencil-add
582 barre-stencil
583 (draw-barre layout props string-count fret-range size finger-code
584 dot-position dot-radius (cdr barre-list) orientation))
585 barre-stencil ))))
587 (define (label-fret layout props string-count fret-range size orientation)
588 "Label the base fret on a fret diagram"
589 (let* ((details (merge-details 'fret-diagram-details props '()))
590 (base-fret (car fret-range))
591 (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
592 (label-space (* 0.5 size))
593 (label-dir (assoc-get 'label-dir details RIGHT))
594 (label-vertical-offset
595 (assoc-get 'fret-label-vertical-offset details 0))
596 (number-type
597 (assoc-get 'number-type details 'roman-lower))
598 (label-text
599 (cond
600 ((equal? number-type 'roman-lower)
601 (fancy-format #f "~(~@r~)" base-fret))
602 ((equal? number-type 'roman-upper)
603 (fancy-format #f "~@r" base-fret))
604 ((equal? 'arabic number-type)
605 (fancy-format #f "~d" base-fret))
606 (else (fancy-format #f "~(~@r~)" base-fret))))
607 (label-stencil
608 (centered-stencil
609 (sans-serif-stencil
610 layout props (* size label-font-mag) label-text)))
611 (label-half-width
612 (stencil-fretboard-offset label-stencil 'string orientation))
613 (label-outside-diagram (+ label-space label-half-width)))
614 (ly:stencil-translate
615 label-stencil
616 (stencil-coordinates
617 (1+ (* size label-vertical-offset))
618 (if (eq? label-dir LEFT)
619 (- label-outside-diagram)
620 (+ (* size (1- string-count)) label-outside-diagram))
621 orientation))))
623 ;;
624 ;;
625 ;; markup commands and associated functions
626 ;;
627 ;;
628 ;;
630 (define (fret-parse-marking-list marking-list my-fret-count)
631 "Parse a fret-diagram-verbose marking list into component sublists"
632 (let* ((fret-range (cons 1 my-fret-count))
633 (capo-fret 0)
634 (barre-list '())
635 (dot-list '())
636 (xo-list '())
637 (output-alist '()))
638 (let parse-item ((mylist marking-list))
639 (if (not (null? mylist))
640 (let* ((my-item (car mylist)) (my-code (car my-item)))
641 (cond
642 ((or (eq? my-code 'open)(eq? my-code 'mute))
643 (set! xo-list (cons* my-item xo-list)))
644 ((eq? my-code 'barre)
645 (set! barre-list (cons* (cdr my-item) barre-list)))
646 ((eq? my-code 'capo)
647 (set! capo-fret (cadr my-item)))
648 ((eq? my-code 'place-fret)
649 (set! dot-list (cons* (cdr my-item) dot-list))))
650 (parse-item (cdr mylist)))))
651 ;; calculate fret-range
652 (let ((maxfret 0)
653 (minfret (if (> capo-fret 0) capo-fret 99)))
654 (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
655 (if (null? fret-list)
656 '()
657 (let ((fretval (second (car fret-list))))
658 (if (> fretval maxfret) (set! maxfret fretval))
659 (if (< fretval minfret) (set! minfret fretval))
660 (updatemax (cdr fret-list)))))
661 (if (> maxfret my-fret-count)
662 (set! fret-range
663 (cons minfret
664 (let ((upfret (- (+ minfret my-fret-count) 1)))
665 (if (> maxfret upfret) maxfret upfret)))))
666 (set! capo-fret (1+ (- capo-fret minfret)))
667 ; subtract fret from dots
668 (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
669 (acons 'fret-range fret-range
670 (acons 'barre-list barre-list
671 (acons 'dot-list dot-list
672 (acons 'xo-list xo-list
673 (acons 'capo-fret capo-fret '())))))))
675 (define (make-fret-diagram layout props marking-list)
676 "Make a fret diagram markup"
677 (let* (
678 ; note: here we get items from props that are needed in this routine,
679 ; or that are needed in more than one of the procedures
680 ; called from this routine. If they're only used in one of the
681 ; sub-procedure, they're obtained in that procedure
682 (size (chain-assoc-get 'size props 1.0)) ; needed for everything
683 ;TODO -- get string-count directly from length of stringTunings;
684 ; from FretBoard engraver, but not from markup call
685 (details (merge-details 'fret-diagram-details props '()))
686 (string-count
687 (assoc-get 'string-count details 6)) ; needed for everything
688 (my-fret-count
689 (assoc-get 'fret-count details 4)) ; needed for everything
690 (orientation
691 (assoc-get 'orientation details 'normal)) ; needed for everything
692 (finger-code
693 (assoc-get
694 'finger-code details 'none)) ; needed for draw-dots and draw-barre
695 (default-dot-radius
696 (if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
697 (default-dot-position
698 (if (eq? finger-code 'in-dot)
699 (- 0.95 default-dot-radius)
700 0.6)) ; move up to make room for bigger if labeled
701 (dot-radius
702 (assoc-get
703 'dot-radius details default-dot-radius)) ; needed for draw-dots
704 ; and draw-barre
705 (dot-position
706 (assoc-get
707 'dot-position details default-dot-position)) ; needed for draw-dots
708 ; and draw-barre
709 (th
710 (* (ly:output-def-lookup layout 'line-thickness)
711 (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
712 ; and draw-strings
713 (thickness-factor (assoc-get 'string-thickness-factor details 0))
714 (alignment
715 (chain-assoc-get 'align-dir props -0.4)) ; needed only here
716 (xo-padding
717 (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
718 (parameters (fret-parse-marking-list marking-list my-fret-count))
719 (capo-fret (assoc-get 'capo-fret parameters 0))
720 (dot-list (cdr (assoc 'dot-list parameters)))
721 (xo-list (cdr (assoc 'xo-list parameters)))
722 (fret-range (cdr (assoc 'fret-range parameters)))
723 (my-fret-count (fret-count fret-range))
724 (barre-list (cdr (assoc 'barre-list parameters)))
725 (barre-type
726 (assoc-get 'barre-type details 'curved))
727 (fret-diagram-stencil
728 (ly:stencil-add
729 (draw-strings
730 string-count fret-range th thickness-factor size orientation)
731 (draw-frets
732 fret-range string-count th thickness-factor size orientation))))
733 (if (and (not (null? barre-list))
734 (not (eq? 'none barre-type)))
735 (set! fret-diagram-stencil
736 (ly:stencil-add
737 (draw-barre layout props string-count fret-range size
738 finger-code dot-position dot-radius
739 barre-list orientation)
740 fret-diagram-stencil)))
741 (if (not (null? dot-list))
742 (set! fret-diagram-stencil
743 (ly:stencil-add
744 fret-diagram-stencil
745 (draw-dots layout props string-count my-fret-count
746 size finger-code dot-position dot-radius
747 th dot-list orientation))))
748 (if (= (car fret-range) 1)
749 (set! fret-diagram-stencil
750 (ly:stencil-add
751 fret-diagram-stencil
752 (draw-thick-zero-fret
753 details string-count th
754 thickness-factor size orientation))))
755 (if (not (null? xo-list))
756 (let* ((diagram-fret-top
757 (car (stencil-fretboard-extent
758 fret-diagram-stencil
759 'fret
760 orientation)))
761 (xo-stencil
762 (draw-xo layout props string-count fret-range
763 size xo-list orientation))
764 (xo-fret-offset
765 (stencil-fretboard-offset
766 xo-stencil 'fret orientation)))
767 (set! fret-diagram-stencil
768 (ly:stencil-add
769 fret-diagram-stencil
770 (ly:stencil-translate
771 xo-stencil
772 (stencil-coordinates
773 (- diagram-fret-top
774 xo-fret-offset
775 (* size xo-padding))
776 0 ; no string offset
777 orientation))))))
779 (if (> capo-fret 0)
780 (set! fret-diagram-stencil
781 (ly:stencil-add
782 fret-diagram-stencil
783 (draw-capo details string-count capo-fret my-fret-count
784 th size dot-position orientation))))
785 (if (> (car fret-range) 1)
786 (set! fret-diagram-stencil
787 (ly:stencil-add
788 fret-diagram-stencil
789 (label-fret
790 layout props string-count fret-range size orientation))))
791 (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
793 (define (fret-parse-definition-string props definition-string)
794 "Parse a fret diagram string and return a pair containing:
795 @var{props}, modified as necessary by the definition-string
796 a fret-indication list with the appropriate values"
797 (let* ((fret-count 4)
798 (string-count 6)
799 (fret-range (cons 1 fret-count))
800 (barre-list '())
801 (dot-list '())
802 (xo-list '())
803 (output-list '())
804 (new-props '())
805 (details (merge-details 'fret-diagram-details props '()))
806 (items (string-split definition-string #\;)))
807 (let parse-item ((myitems items))
808 (if (not (null? (cdr myitems)))
809 (let ((test-string (car myitems)))
810 (case (car (string->list (substring test-string 0 1)))
811 ((#\s) (let ((size (get-numeric-from-key test-string)))
812 (set! props (prepend-alist-chain 'size size props))))
813 ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
814 (finger-id (case finger-code
815 ((0) 'none)
816 ((1) 'in-dot)
817 ((2) 'below-string))))
818 (set! details
819 (acons 'finger-code finger-id details))))
820 ((#\c) (set! output-list
821 (cons-fret
822 (cons
823 'barre
824 (numerify
825 (string-split (substring test-string 2) #\-)))
826 output-list)))
827 ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
828 (set! details
829 (acons 'fret-count fret-count details))))
830 ((#\w) (let ((string-count (get-numeric-from-key test-string)))
831 (set! details
832 (acons 'string-count string-count details))))
833 ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
834 (set! details
835 (acons 'dot-radius dot-size details))))
836 ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
837 (set! details
838 (acons 'dot-position dot-position details))))
839 (else
840 (let ((this-list (string-split test-string #\-)))
841 (if (string->number (cadr this-list))
842 (set! output-list
843 (cons-fret
844 (cons 'place-fret (numerify this-list))
845 output-list))
846 (if (equal? (cadr this-list) "x" )
847 (set! output-list
848 (cons-fret
849 (list 'mute (string->number (car this-list)))
850 output-list))
851 (set! output-list
852 (cons-fret
853 (list 'open (string->number (car this-list)))
854 output-list)))))))
855 (parse-item (cdr myitems)))))
856 ; add the modified details
857 (set! props
858 (prepend-alist-chain 'fret-diagram-details details props))
859 `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
861 (define-public
862 (fret-parse-terse-definition-string props definition-string)
863 "Parse a fret diagram string that uses terse syntax;
864 return a pair containing:
865 @var{props}, modified to include the string-count determined by the
866 definition-string, and
867 a fret-indication list with the appropriate values"
868 ;TODO -- change syntax to fret\string-finger
870 (let* ((details (merge-details 'fret-diagram-details props '()))
871 (barre-start-list '())
872 (output-list '())
873 (new-props '())
874 (items (string-split definition-string #\;))
875 (string-count (- (length items) 1)))
876 (let parse-item ((myitems items))
877 (if (not (null? (cdr myitems)))
878 (let* ((test-string (car myitems))
879 (current-string (- (length myitems) 1))
880 (indicators (string-split test-string #\ )))
881 (let parse-indicators ((myindicators indicators))
882 (if (not (eq? '() myindicators))
883 (let* ((this-list (string-split (car myindicators) #\-))
884 (max-element-index (- (length this-list) 1))
885 (last-element
886 (car (list-tail this-list max-element-index)))
887 (fret
888 (if (string->number (car this-list))
889 (string->number (car this-list))
890 (car this-list))))
891 (if (equal? last-element "(")
892 (begin
893 (set! barre-start-list
894 (cons-fret (list current-string fret)
895 barre-start-list))
896 (set! this-list
897 (list-head this-list max-element-index))))
898 (if (equal? last-element ")")
899 (let* ((this-barre
900 (get-sub-list fret barre-start-list))
901 (insert-index (- (length this-barre) 1)))
902 (set! output-list
903 (cons-fret (cons* 'barre
904 (car this-barre)
905 current-string
906 (cdr this-barre))
907 output-list))
908 (set! this-list
909 (list-head this-list max-element-index))))
910 (if (number? fret)
911 (set!
912 output-list
913 (cons-fret (cons*
914 'place-fret
915 current-string
916 (drop-paren (numerify this-list)))
917 output-list))
918 (if (equal? (car this-list) "x" )
919 (set!
920 output-list
921 (cons-fret
922 (list 'mute current-string)
923 output-list))
924 (set!
925 output-list
926 (cons-fret
927 (list 'open current-string)
928 output-list))))
929 (parse-indicators (cdr myindicators)))))
930 (parse-item (cdr myitems)))))
931 (set! details (acons 'string-count string-count details))
932 (set! props (prepend-alist-chain 'fret-diagram-details details props))
933 `(,props . ,output-list))) ; ugh -- hard coded; proc is better
936 (define-builtin-markup-command
937 (fret-diagram-verbose layout props marking-list)
938 (pair?) ; argument type (list, but use pair? for speed)
939 instrument-specific-markup ; markup type
940 ((align-dir -0.4) ; properties and defaults
941 (size 1.0)
942 (fret-diagram-details)
943 (thickness 0.5))
944 "Make a fret diagram containing the symbols indicated in @var{marking-list}.
946 For example,
948 @example
949 \\markup \\fret-diagram-verbose
950 #'((mute 6) (mute 5) (open 4)
951 (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
952 @end example
954 @noindent
955 produces a standard D@tie{}chord diagram without fingering indications.
957 Possible elements in @var{marking-list}:
959 @table @code
960 @item (mute @var{string-number})
961 Place a small @q{x} at the top of string @var{string-number}.
963 @item (open @var{string-number})
964 Place a small @q{o} at the top of string @var{string-number}.
966 @item (barre @var{start-string} @var{end-string} @var{fret-number})
967 Place a barre indicator (much like a tie) from string @var{start-string}
968 to string @var{end-string} at fret @var{fret-number}.
970 @item (capo @var{fret-number})
971 Place a capo indicator (a large solid bar) across the entire fretboard
972 at fret location @var{fret-number}. Also, set fret @var{fret-number}
973 to be the lowest fret on the fret diagram.
975 @item (place-fret @var{string-number} @var{fret-number} @var{finger-value})
976 Place a fret playing indication on string @var{string-number} at fret
977 @var{fret-number} with an optional fingering label @var{finger-value}.
978 By default, the fret playing indicator is a solid dot. This can be
979 changed by setting the value of the variable @var{dot-color}. If the
980 @var{finger} part of the @code{place-fret} element is present,
981 @var{finger-value} will be displayed according to the setting of the
982 variable @var{finger-code}. There is no limit to the number of fret
983 indications per string.
984 @end table"
986 (make-fret-diagram layout props marking-list))
989 (define-builtin-markup-command (fret-diagram layout props definition-string)
990 (string?) ; argument type
991 instrument-specific-markup ; markup category
992 (fret-diagram-verbose-markup) ; properties and defaults
993 "Make a (guitar) fret diagram. For example, say
995 @example
996 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
997 @end example
999 @noindent
1000 for fret spacing 3/4 of staff space, D chord diagram
1002 Syntax rules for @var{definition-string}:
1003 @itemize @minus
1005 @item
1006 Diagram items are separated by semicolons.
1008 @item
1009 Possible items:
1011 @itemize @bullet
1012 @item
1013 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1014 spaces).
1015 Default:@tie{}1.
1017 @item
1018 @code{t:}@var{number} -- Set the line thickness (in staff spaces).
1019 Default:@tie{}0.05.
1021 @item
1022 @code{h:}@var{number} -- Set the height of the diagram in frets.
1023 Default:@tie{}4.
1025 @item
1026 @code{w:}@var{number} -- Set the width of the diagram in strings.
1027 Default:@tie{}6.
1029 @item
1030 @code{f:}@var{number} -- Set fingering label type
1031 (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1032 Default:@tie{}0.
1034 @item
1035 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1036 Default:@tie{}0.25.
1038 @item
1039 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1040 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1041 Default:@tie{}0.6.
1043 @item
1044 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1045 barre mark from @var{string1} to @var{string2} on @var{fret}.
1047 @item
1048 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1049 If @var{fret} is @samp{o}, @var{string} is identified as open.
1050 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1052 @item
1053 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1054 @var{string} at @var{fret}, and label with @var{fingering} as defined
1055 by the @code{f:} code.
1056 @end itemize
1058 @item
1059 Note: There is no limit to the number of fret indications per string.
1060 @end itemize"
1061 (let ((definition-list
1062 (fret-parse-definition-string props definition-string)))
1063 (fret-diagram-verbose-markup
1064 layout (car definition-list) (cdr definition-list))))
1066 (define-builtin-markup-command
1067 (fret-diagram-terse layout props definition-string)
1068 (string?) ; argument type
1069 instrument-specific-markup ; markup category
1070 (fret-diagram-verbose-markup) ; properties
1071 "Make a fret diagram markup using terse string-based syntax.
1073 Here is an example
1075 @example
1076 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1077 @end example
1079 @noindent
1080 for a D@tie{}chord diagram.
1082 Syntax rules for @var{definition-string}:
1084 @itemize @bullet
1086 @item
1087 Strings are terminated by semicolons; the number of semicolons
1088 is the number of strings in the diagram.
1090 @item
1091 Mute strings are indicated by @samp{x}.
1093 @item
1094 Open strings are indicated by @samp{o}.
1096 @item
1097 A number indicates a fret indication at that fret.
1099 @item
1100 If there are multiple fret indicators desired on a string, they
1101 should be separated by spaces.
1103 @item
1104 Fingerings are given by following the fret number with a @code{-},
1105 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1106 fret with the second finger.
1108 @item
1109 Where a barre indicator is desired, follow the fret (or fingering) symbol
1110 with @code{-(} to start a barre and @code{-)} to end the barre.
1112 @end itemize"
1113 ;; TODO -- change syntax to fret\string-finger
1114 (let ((definition-list
1115 (fret-parse-terse-definition-string props definition-string)))
1116 (fret-diagram-verbose-markup layout
1117 (car definition-list)
1118 (cdr definition-list))))