]> git.donarmstrong.com Git - lilypond.git/blob - scm/fret-diagrams.scm
Merge remote-tracking branch 'origin/translation' into staging
[lilypond.git] / scm / fret-diagrams.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2004--2014 Carl D. Sorensen <c_sorensen@byu.edu>
4 ;;;;
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
9 ;;;;
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;;  Utility functions
19
20 (define (string-x-extent start-point end-point)
21   "Return the x-extent of a string that goes from start-point
22 to end-point."
23   (let ((x1 (car start-point))
24         (x2 (car end-point)))
25     (if (> x1 x2)
26         (cons x2 x1)
27         (cons x1 x2))))
28
29 (define (string-y-extent start-point end-point)
30   "Return the y-extent of a string that goes from start-point
31 to end-point."
32   (let ((y1 (cdr start-point))
33         (y2 (cdr end-point)))
34     (if (> y1 y2)
35         (cons y2 y1)
36         (cons y1 y2))))
37
38
39 (define (cons-fret new-value old-list)
40   "Put together a fret-list in the format desired by parse-string"
41   (if (eq? old-list '())
42       (list new-value)
43       (cons* new-value old-list)))
44
45 (define (get-numeric-from-key keystring)
46   "Get the numeric value from a key of the form k:val"
47   (string->number (substring keystring 2 (string-length keystring))))
48
49 (define (numerify mylist)
50   "Convert string values to numeric or character"
51   (if (null? mylist)
52       '()
53       (let ((numeric-value (string->number (car mylist))))
54         (if numeric-value
55             (cons* numeric-value (numerify (cdr mylist)))
56             (cons* (car (string->list (car mylist)))
57                    (numerify (cdr mylist)))))))
58
59 (define (stepmag mag)
60   "Calculate the font step necessary to get a desired magnification"
61   (* 6 (/ (log mag) (log 2))))
62
63 (define (fret-count fret-range)
64   "Calculate the fret count for the diagram given the range of frets in the diagram."
65   (1+ (- (cdr fret-range) (car fret-range))))
66
67 (define (subtract-base-fret base-fret dot-list)
68   "Subtract @var{base-fret} from every fret in @var{dot-list}"
69   (if (null? dot-list)
70       '()
71       (let ((this-list (car dot-list)))
72         (cons* (list
73                 ;; string
74                 (car this-list)
75                 ;; fret
76                 (- (second this-list) base-fret)
77                 ;; finger
78                 (if (null? (cddr this-list))
79                     '()
80                     (third this-list))
81                 ;; color modifier
82                 (if (or (null? (cddr this-list))
83                         (null? (cdddr this-list)))
84                     '()
85                     (fourth this-list)))
86                (subtract-base-fret base-fret (cdr dot-list))))))
87
88 (define (drop-paren item-list)
89   "Drop a final parentheses from a fret indication list
90 @code{item-list} resulting from a terse string specification of barre."
91   (if (> (length item-list) 0)
92       (let* ((max-index (- (length item-list) 1))
93              (last-element (car (list-tail item-list max-index))))
94         (if (or (equal? last-element ")") (equal? last-element "("))
95             (list-head item-list max-index)
96             item-list))
97       item-list))
98
99 (define (get-sub-list value master-list)
100   "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}"
101   (if (eq? master-list '())
102       #f
103       (let ((sublist (car master-list)))
104         (if (equal? (cadr sublist) value)
105             sublist
106             (get-sub-list value (cdr master-list))))))
107
108 (define (merge-details key alist-list . default)
109   "Return @code{alist-list} entries for @code{key}, in one combined alist.
110 There can be two @code{alist-list} entries for a given key.  The first
111 comes from the override-markup function, the second comes
112 from property settings during a regular override.
113 This is necessary because some details can be set in one
114 place, while others are set in the other.  Both details
115 lists must be merged into a single alist.
116 Return @code{default} (optional, else #f) if not
117 found."
118
119   (define (helper key alist-list default)
120     (if (null? alist-list)
121         default
122         (let* ((entry (assoc-get key (car alist-list))))
123           (if entry
124               (append entry (chain-assoc-get key (cdr alist-list) '()))
125               (helper key (cdr alist-list) default)))))
126
127   (helper key alist-list
128           (if (pair? default) (car default) #f)))
129
130 ;;  Conversions between fret/string coordinate system and x-y coordinate
131 ;;  system.
132 ;;
133 ;;  Fret coordinates are measured down the fretboard from the nut,
134 ;;   starting at 0.
135 ;;
136 ;; String coordinates are measured from the lowest string, starting at 0.
137 ;;
138 ;; The x-y origin is at the intersection of the nut and the lowest string.
139 ;;
140 ;; X coordinates are positive to the right.
141 ;; Y coordinates are positive up.
142
143 (define (negate-extent extent)
144   "Return the extent in an axis opposite to the axis of @code{extent}."
145   (cons (- (cdr extent)) (- (car extent))))
146
147 (define (stencil-fretboard-extent stencil fretboard-axis orientation)
148   "Return the extent of @code{stencil} in the @code{fretboard-axis}
149 direction."
150   (if (eq? fretboard-axis 'fret)
151       (cond ((eq? orientation 'landscape)
152              (ly:stencil-extent stencil X))
153             ((eq? orientation 'opposing-landscape)
154              (negate-extent (ly:stencil-extent stencil X)))
155             (else
156              (negate-extent (ly:stencil-extent stencil Y))))
157       ;; else -- eq? fretboard-axis 'string
158       (cond ((eq? orientation 'landscape)
159              (ly:stencil-extent stencil Y))
160             ((eq? orientation 'opposing-landscape)
161              (negate-extent (ly:stencil-extent stencil Y)))
162             (else
163              (ly:stencil-extent stencil Y)))))
164
165
166 (define (stencil-fretboard-offset stencil fretboard-axis orientation)
167   "Return a the stencil coordinates of the center of @code{stencil}
168 in the @code{fretboard-axis} direction."
169   (* 0.5 (interval-length
170           (stencil-fretboard-extent stencil fretboard-axis orientation))))
171
172
173 (define (string-thickness string thickness-factor)
174   (expt (1+ thickness-factor) (1- string)))
175
176 ;;  Functions that create stencils used in the fret diagram
177
178 (define (sans-serif-stencil layout props mag text)
179   "Create a stencil in sans-serif font based on @var{layout} and @var{props}
180 with magnification @var{mag} of the string @var{text}."
181   (let* ((my-props
182           (prepend-alist-chain
183            'font-size (stepmag mag)
184            (prepend-alist-chain 'font-family 'sans props))))
185     (interpret-markup layout my-props text)))
186
187 ;;  markup commands and associated functions
188
189 (define (fret-parse-marking-list marking-list my-fret-count)
190   "Parse a fret-diagram-verbose marking list into component sublists"
191   (let* ((fret-range (cons 1 my-fret-count))
192          (capo-fret 0)
193          (barre-list '())
194          (dot-list '())
195          (xo-list '())
196          (output-alist '()))
197     (let parse-item ((mylist marking-list))
198       (if (not (null? mylist))
199           (let* ((my-item (car mylist)) (my-code (car my-item)))
200             (cond
201              ((or (eq? my-code 'open)(eq? my-code 'mute))
202               (set! xo-list (cons* my-item xo-list)))
203              ((eq? my-code 'barre)
204               (set! barre-list (cons* (cdr my-item) barre-list)))
205              ((eq? my-code 'capo)
206               (set! capo-fret (cadr my-item)))
207              ((eq? my-code 'place-fret)
208               (set! dot-list (cons* (cdr my-item) dot-list))))
209             (parse-item (cdr mylist)))))
210     ;; calculate fret-range
211     (let ((maxfret 0)
212           (minfret (if (> capo-fret 0) capo-fret 99)))
213       (let updatemax ((fret-list dot-list))  ;CHANGE THIS TO HELPER FUNCTION?
214         (if (null? fret-list)
215             '()
216             (let ((fretval (second (car fret-list))))
217               (if (> fretval maxfret) (set! maxfret fretval))
218               (if (< fretval minfret) (set! minfret fretval))
219               (updatemax (cdr fret-list)))))
220       (if (or (> maxfret my-fret-count) (> capo-fret 1))
221           (set! fret-range
222                 (cons minfret
223                       (let ((upfret (- (+ minfret my-fret-count) 1)))
224                         (if (> maxfret upfret) maxfret upfret)))))
225       (set! capo-fret (1+ (- capo-fret minfret)))
226       ;; subtract fret from dots
227       (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
228     (acons 'fret-range fret-range
229            (acons 'barre-list barre-list
230                   (acons 'dot-list dot-list
231                          (acons 'xo-list xo-list
232                                 (acons 'capo-fret capo-fret '())))))))
233
234 (define (make-fret-diagram layout props marking-list)
235   "Make a fret diagram markup"
236   (let* (
237          ;; note: here we get items from props that are needed in this routine,
238          ;; or that are needed in more than one of the procedures
239          ;; called from this routine.  If they're only used in one of the
240          ;; sub-procedure, they're obtained in that procedure
241          (size (chain-assoc-get 'size props 1.0)) ; needed for everything
242          ;;TODO -- get string-count directly from length of stringTunings;
243          ;;         from FretBoard engraver, but not from markup call
244          (details (merge-details 'fret-diagram-details props '()))
245          (string-count
246           (assoc-get 'string-count details 6)) ;; needed for everything
247          (my-fret-count
248           (assoc-get 'fret-count details 4)) ;; needed for everything
249          (orientation
250           (assoc-get 'orientation details 'normal)) ;; needed for everything
251          (finger-code
252           (assoc-get
253            'finger-code details 'none)) ;; needed for draw-dots and draw-barre
254          (default-dot-radius
255            (if (eq? finger-code 'in-dot) 0.425 0.25)) ;; bigger dots if labeled
256          (default-dot-position
257            (if (eq? finger-code 'in-dot)
258                (- 0.95 default-dot-radius)
259                0.6)) ; move up to make room for bigger dot if labeled
260          (dot-radius
261           (assoc-get
262            'dot-radius details default-dot-radius))
263          ;; needed for draw-dots and draw-barre
264          (dot-position
265           (assoc-get
266            'dot-position details default-dot-position))
267          ;; needed for draw-dots and draw-barre
268          (th
269           (* (ly:output-def-lookup layout 'line-thickness)
270              (chain-assoc-get 'thickness props 0.5)))
271          ;; needed for draw-frets and draw-strings
272          (sth (* size th))
273          (thickness-factor (assoc-get 'string-thickness-factor details 0))
274          (alignment
275           (chain-assoc-get 'align-dir props -0.4)) ;; needed only here
276          (xo-padding (assoc-get 'xo-padding details 0.2)) ;; needed only here
277          (parameters (fret-parse-marking-list marking-list my-fret-count))
278          (capo-fret (assoc-get 'capo-fret parameters 0))
279          (dot-list (assoc-get 'dot-list parameters))
280          (xo-list (assoc-get 'xo-list parameters))
281          (fret-range (assoc-get 'fret-range parameters))
282          (my-fret-count (fret-count fret-range))
283          (barre-list (assoc-get 'barre-list parameters))
284          (barre-type
285           (assoc-get 'barre-type details 'curved))
286          (fret-diagram-stencil '()))
287
288     ;;  Here are the fret diagram helper functions that depend on the
289     ;;  fret diagram parameters.  The functions are here because the
290     ;;  diagram parameters are part of the lexical scope here.
291
292     (define (stencil-coordinates fret-coordinate string-coordinate)
293       "Return a pair @code{(x-coordinate . y-coordinate)}
294       in stencil coordinate system."
295       (cond
296        ((eq? orientation 'landscape)
297         (cons fret-coordinate
298               (- string-coordinate (1- string-count))))
299        ((eq? orientation 'opposing-landscape)
300         (cons (- fret-coordinate) (- string-coordinate)))
301        (else
302         (cons string-coordinate (- fret-coordinate)))))
303
304     (define (stencil-coordinate-offset fret-offset string-offset)
305       "Return a pair @code{(x-offset . y-offset)}
306       for translation in stencil coordinate system."
307       (cond
308        ((eq? orientation 'landscape)
309         (cons fret-offset (- string-offset)))
310        ((eq? orientation 'opposing-landscape)
311         (cons (- fret-offset) string-offset))
312        (else
313         (cons string-offset (- fret-offset)))))
314
315
316
317     (define (make-bezier-sandwich-list start stop base height
318                                        half-thickness)
319       "Make the argument list for a bezier sandwich from
320 string coordinate @var{start} to string-coordinate @var{stop} with a
321 baseline at fret coordinate @var{base}, a height of
322 @var{height}, and a half thickness of @var{half-thickness}."
323       (let* ((width (+ (- stop start) 1))
324              (cp-left-width (+ (* width half-thickness) start))
325              (cp-right-width (- stop (* width half-thickness)))
326              (bottom-control-point-height
327               (- base (- height half-thickness)))
328              (top-control-point-height
329               (- base height))
330              (left-end-point
331               (stencil-coordinates base start))
332              (right-end-point
333               (stencil-coordinates base stop))
334              (left-upper-control-point
335               (stencil-coordinates
336                top-control-point-height cp-left-width))
337              (left-lower-control-point
338               (stencil-coordinates
339                bottom-control-point-height cp-left-width))
340              (right-upper-control-point
341               (stencil-coordinates
342                top-control-point-height cp-right-width))
343              (right-lower-control-point
344               (stencil-coordinates
345                bottom-control-point-height cp-right-width)))
346
347         ;; order of bezier control points is:
348         ;;    left cp low, right cp low, right end low, left end low
349         ;;   right cp high, left cp high, left end high, right end high.
350
351         (list left-lower-control-point
352               right-lower-control-point
353               right-end-point
354               left-end-point
355               right-upper-control-point
356               left-upper-control-point
357               left-end-point
358               right-end-point)))
359
360     (define (draw-strings)
361       "Draw the string lines for a fret diagram with
362 @var{string-count} strings and frets as indicated in @var{fret-range}.
363 Line thickness is given by @var{th}, fret & string spacing by
364 @var{size}.  Orientation is determined by @var{orientation}."
365
366       (define (helper x)
367         (if (null? (cdr x))
368             (string-stencil (car x))
369             (ly:stencil-add
370              (string-stencil (car x))
371              (helper (cdr x)))))
372
373       (let* ( (string-list (map 1+ (iota string-count))))
374         (helper string-list)))
375
376     (define (string-stencil string)
377       "Make a stencil for @code{string}, given the fret-diagram
378       overall parameters."
379       (let* ((string-coordinate (- string-count string))
380              (current-string-thickness
381               (* th size (string-thickness string thickness-factor)))
382              (fret-half-thickness (* size th 0.5))
383              (half-string (* current-string-thickness 0.5))
384              (start-coordinates
385               (stencil-coordinates
386                (- fret-half-thickness)
387                (- (* size string-coordinate) half-string)))
388              (end-coordinates
389               (stencil-coordinates
390                (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
391                (+ half-string (* size string-coordinate)))))
392         (ly:round-filled-box
393          (string-x-extent start-coordinates end-coordinates)
394          (string-y-extent start-coordinates end-coordinates)
395          (* th size))))
396
397     (define (draw-frets)
398       "Draw the fret lines for a fret diagram with
399 @var{string-count} strings and frets as indicated in @var{fret-range}.
400 Line thickness is given by @var{th}, fret & string spacing by
401 @var{size}.  Orientation is given by @var{orientation}."
402       (define (helper x)
403         (if (null? (cdr x))
404             (fret-stencil (car x))
405             (ly:stencil-add
406              (fret-stencil (car x))
407              (helper (cdr x)))))
408
409       (let ((fret-list (iota (1+ my-fret-count))))
410         (helper fret-list)))
411
412     (define (fret-stencil fret)
413       "Make a stencil for @code{fret}, given the
414 fret-diagram overall parameters."
415       (let* ((low-string-half-thickness
416               (* 0.5
417                  size
418                  th
419                  (string-thickness string-count thickness-factor)))
420              (fret-half-thickness (* 0.5 size th))
421              (start-coordinates
422               (stencil-coordinates
423                (* size fret)
424                (- fret-half-thickness low-string-half-thickness)))
425              (end-coordinates
426               (stencil-coordinates
427                (* size fret)
428                (* size (1- string-count)))))
429         (make-line-stencil
430          (* size th)
431          (car start-coordinates) (cdr start-coordinates)
432          (car end-coordinates) (cdr end-coordinates))))
433
434     (define (draw-barre barre-list)
435       "Create barre indications for a fret diagram"
436       (if (not (null? barre-list))
437           (let* ((string1 (caar barre-list))
438                  (string2 (cadar barre-list))
439                  (barre-fret (caddar barre-list))
440                  (top-fret (cdr fret-range))
441                  (low-fret (car fret-range))
442                  (fret (1+ (- barre-fret low-fret)))
443                  (barre-vertical-offset 0.5)
444                  (dot-center-fret-coordinate (+ (1- fret) dot-position))
445                  (barre-fret-coordinate
446                   (+ dot-center-fret-coordinate
447                      (* (- barre-vertical-offset 0.5) dot-radius)))
448                  (barre-start-string-coordinate (- string-count string1))
449                  (barre-end-string-coordinate (- string-count string2))
450                  (scale-dot-radius (* size dot-radius))
451                  (barre-type (assoc-get 'barre-type details 'curved))
452                  (barre-stencil
453                   (cond
454                    ((eq? barre-type 'straight)
455                     (make-straight-barre-stencil
456                      barre-fret-coordinate
457                      barre-start-string-coordinate
458                      barre-end-string-coordinate
459                      scale-dot-radius))
460                    ((eq? barre-type 'curved)
461                     (make-curved-barre-stencil
462                      barre-fret-coordinate
463                      barre-start-string-coordinate
464                      barre-end-string-coordinate
465                      scale-dot-radius)))))
466             (if (not (null? (cdr barre-list)))
467                 (ly:stencil-add
468                  barre-stencil
469                  (draw-barre (cdr barre-list)))
470                 barre-stencil ))))
471
472     (define (make-straight-barre-stencil
473              fret-coordinate
474              start-string-coordinate
475              end-string-coordinate
476              half-thickness)
477       "Create a straight barre stencil."
478       (let ((start-point
479              (stencil-coordinates
480               (* size fret-coordinate)
481               (* size start-string-coordinate)))
482             (end-point
483              (stencil-coordinates
484               (* size fret-coordinate)
485               (* size end-string-coordinate))))
486         (make-line-stencil
487          half-thickness
488          (car start-point)
489          (cdr start-point)
490          (car end-point)
491          (cdr end-point))))
492
493     (define (make-curved-barre-stencil
494              fret-coordinate
495              start-string-coordinate
496              end-string-coordinate
497              half-thickness)
498       "Create a curved barre stencil."
499       (let* ((bezier-thick 0.1)
500              (bezier-height 0.5)
501              (bezier-list
502               (make-bezier-sandwich-list
503                (* size start-string-coordinate)
504                (* size end-string-coordinate)
505                (* size fret-coordinate)
506                (* size bezier-height)
507                (* size bezier-thick)))
508              (box-lower-left
509               (stencil-coordinates
510                (+ (* size fret-coordinate) half-thickness)
511                (- (* size start-string-coordinate) half-thickness)))
512              (box-upper-right
513               (stencil-coordinates
514                (- (* size fret-coordinate)
515                   (* size bezier-height)
516                   half-thickness)
517                (+ (* size end-string-coordinate) half-thickness)))
518              (x-extent (cons (car box-lower-left) (car box-upper-right)))
519              (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
520         (make-bezier-sandwich-stencil
521          bezier-list
522          (* size bezier-thick)
523          x-extent
524          y-extent)))
525
526     (define (draw-dots dot-list)
527       "Make dots for fret diagram."
528
529       (let* ( (scale-dot-radius (* size dot-radius))
530               (scale-dot-thick (* size th))
531               (default-dot-color (assoc-get 'dot-color details 'black))
532               (finger-label-padding 0.3)
533               (dot-label-font-mag
534                (* scale-dot-radius
535                   (assoc-get 'dot-label-font-mag details 1.0)))
536               (string-label-font-mag
537                (* size
538                   (assoc-get
539                    'string-label-font-mag details
540                    (cond ((or (eq? orientation 'landscape)
541                               (eq? orientation 'opposing-landscape))
542                           0.5)
543                          (else  0.6)))))
544               (mypair (car dot-list))
545               (restlist (cdr dot-list))
546               (string (car mypair))
547               (fret (cadr mypair))
548               (fret-coordinate (* size (+ (1- fret) dot-position)))
549               (string-coordinate (* size (- string-count string)))
550               (dot-coordinates
551                (stencil-coordinates fret-coordinate string-coordinate))
552               (extent (cons (- scale-dot-radius) scale-dot-radius))
553               (finger (caddr mypair))
554               (finger (if (number? finger) (number->string finger) finger))
555               (inverted-color (eq? 'inverted (cadddr mypair)))
556               (dot-color (if (or (and (eq? default-dot-color 'black) inverted-color)
557                                  (and (eq? default-dot-color 'white) (not inverted-color)))
558                              'white
559                              'black))
560               (dot-stencil (if (eq? dot-color 'white)
561                                (ly:stencil-add
562                                 (make-circle-stencil
563                                  scale-dot-radius scale-dot-thick #t)
564                                 (ly:stencil-in-color
565                                  (make-circle-stencil
566                                   (- scale-dot-radius (* 0.5 scale-dot-thick))
567                                   0  #t)
568                                  1 1 1))
569                                (make-circle-stencil
570                                 scale-dot-radius scale-dot-thick #t)))
571               (positioned-dot
572                (ly:stencil-translate dot-stencil dot-coordinates))
573               (labeled-dot-stencil
574                (cond
575                 ((or (eq? finger '())(eq? finger-code 'none))
576                  positioned-dot)
577                 ((eq? finger-code 'in-dot)
578                  (let ((finger-label
579                         (centered-stencil
580                          (sans-serif-stencil
581                           layout props dot-label-font-mag finger))))
582                    (ly:stencil-translate
583                     (ly:stencil-add
584                      dot-stencil
585                      (if (eq? dot-color 'white)
586                          finger-label
587                          (ly:stencil-in-color finger-label 1 1 1)))
588                     dot-coordinates)))
589                 ((eq? finger-code 'below-string)
590                  (let* ((label-stencil
591                          (centered-stencil
592                           (sans-serif-stencil
593                            layout props string-label-font-mag
594                            finger)))
595                         (label-fret-offset
596                          (stencil-fretboard-offset
597                           label-stencil 'fret orientation))
598                         (label-fret-coordinate
599                          (+ (* size
600                                (+ 1 my-fret-count finger-label-padding))
601                             label-fret-offset))
602                         (label-string-coordinate string-coordinate)
603                         (label-translation
604                          (stencil-coordinates
605                           label-fret-coordinate
606                           label-string-coordinate)))
607                    (ly:stencil-add
608                     positioned-dot
609                     (ly:stencil-translate
610                      label-stencil
611                      label-translation))))
612                 (else ;unknown finger-code
613                  positioned-dot))))
614         (if (null? restlist)
615             labeled-dot-stencil
616             (ly:stencil-add
617              (draw-dots restlist)
618              labeled-dot-stencil))))
619
620     (define (draw-thick-zero-fret)
621       "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
622       (let* ((half-lowest-string-thickness
623               (* 0.5 th (string-thickness string-count thickness-factor)))
624              (half-thick (* 0.5 sth))
625              (top-fret-thick
626               (* sth (assoc-get 'top-fret-thickness details 3.0)))
627              (start-string-coordinate (- half-lowest-string-thickness))
628              (end-string-coordinate (+ (* size (1- string-count)) half-thick))
629              (start-fret-coordinate half-thick)
630              (end-fret-coordinate (- half-thick top-fret-thick))
631              (lower-left
632               (stencil-coordinates
633                start-fret-coordinate start-string-coordinate))
634              (upper-right
635               (stencil-coordinates
636                end-fret-coordinate end-string-coordinate)))
637         (ly:round-filled-box
638          ;; Put limits in order, or else the intervals are considered empty
639          (ordered-cons (car lower-left) (car upper-right))
640          (ordered-cons (cdr lower-left) (cdr upper-right))
641          sth)))
642
643     (define (draw-xo xo-list)
644       "Put open and mute string indications on diagram, as contained in
645 @var{xo-list}."
646       (let* ((xo-font-mag
647               (assoc-get 'xo-font-magnification details
648                          (cond ((or (eq? orientation 'landscape)
649                                     (eq? orientation 'opposing-landscape))
650                                 0.4)
651                                (else 0.4))))
652              (mypair (car xo-list))
653              (restlist (cdr xo-list))
654              (glyph-string (if (eq? (car mypair) 'mute)
655                                (assoc-get 'mute-string details "X")
656                                (assoc-get 'open-string details "O")))
657              (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
658              (glyph-stencil
659               (centered-stencil
660                (sans-serif-stencil
661                 layout props (* size xo-font-mag) glyph-string)))
662              (glyph-stencil-coordinates
663               (stencil-coordinates 0 glyph-string-coordinate))
664              (positioned-glyph
665               (ly:stencil-translate
666                glyph-stencil
667                glyph-stencil-coordinates)))
668         (if (null? restlist)
669             positioned-glyph
670             (ly:stencil-add
671              positioned-glyph
672              (draw-xo restlist)))))
673
674     (define (draw-capo fret)
675       "Draw a capo indicator across the full width of the fret-board
676 at @var{fret}."
677       (let* ((capo-thick
678               (* size (assoc-get 'capo-thickness details 0.5)))
679              (half-thick (* capo-thick 0.5))
680              (last-string-position 0)
681              (first-string-position (* size (- string-count 1)))
682              (fret-position ( * size (1- (+ dot-position fret))))
683              (start-point
684               (stencil-coordinates
685                fret-position
686                first-string-position))
687              (end-point
688               (stencil-coordinates
689                fret-position
690                last-string-position)))
691         (make-line-stencil
692          capo-thick
693          (car start-point) (cdr start-point)
694          (car end-point) (cdr end-point))))
695
696     (define (label-fret fret-range)
697       "Label the base fret on a fret diagram"
698       (let* ((base-fret (car fret-range))
699              (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
700              (label-space (* 0.5 size))
701              (label-dir (assoc-get 'label-dir details RIGHT))
702              (label-vertical-offset
703               (assoc-get 'fret-label-vertical-offset details 0))
704              (number-type
705               (assoc-get 'number-type details 'roman-lower))
706              (label-text
707               (cond
708                ((equal? number-type 'roman-lower)
709                 (fancy-format #f "~(~@r~)" base-fret))
710                ((equal? number-type 'roman-upper)
711                 (fancy-format #f "~@r" base-fret))
712                ((equal? 'arabic number-type)
713                 (fancy-format #f "~d" base-fret))
714                ((equal? 'custom number-type)
715                 (fancy-format #f
716                               (assoc-get 'fret-label-custom-format
717                                          details "~a")
718                               base-fret))
719                (else (fancy-format #f "~(~@r~)" base-fret))))
720              (label-stencil
721               (centered-stencil
722                (sans-serif-stencil
723                 layout props (* size label-font-mag) label-text)))
724              (label-half-width
725               (stencil-fretboard-offset
726                label-stencil
727                'string
728                orientation))
729              (label-outside-diagram (+ label-space label-half-width)))
730         (ly:stencil-translate
731          label-stencil
732          (stencil-coordinates
733           (* size (+ 1.0 label-vertical-offset))
734           (if (eq? label-dir LEFT)
735               (- label-outside-diagram)
736               (+ (* size (1- string-count)) label-outside-diagram))))))
737
738     ;; Here is the body of make-fret-diagram
739
740     (set! fret-diagram-stencil
741           (ly:stencil-add (draw-strings) (draw-frets)))
742     (if (and (not (null? barre-list))
743              (not (eq? 'none barre-type)))
744         (set! fret-diagram-stencil
745               (ly:stencil-add
746                (draw-barre barre-list)
747                fret-diagram-stencil)))
748     (if (not (null? dot-list))
749         (set! fret-diagram-stencil
750               (ly:stencil-add
751                fret-diagram-stencil
752                (draw-dots dot-list))))
753     (if (= (car fret-range) 1)
754         (set! fret-diagram-stencil
755               (ly:stencil-add
756                fret-diagram-stencil
757                (draw-thick-zero-fret))))
758     (if (not (null? xo-list))
759         (let* ((diagram-fret-top
760                 (car (stencil-fretboard-extent
761                       fret-diagram-stencil
762                       'fret
763                       orientation)))
764                (xo-stencil (draw-xo xo-list))
765                (xo-fret-offset
766                 (stencil-fretboard-offset
767                  xo-stencil 'fret orientation))
768                (xo-stencil-offset
769                 (stencil-coordinate-offset
770                  (- diagram-fret-top
771                     xo-fret-offset
772                     (* size xo-padding))
773                  0)))
774           (set! fret-diagram-stencil
775                 (ly:stencil-add
776                  fret-diagram-stencil
777                  (ly:stencil-translate
778                   xo-stencil
779                   xo-stencil-offset)))))
780     (if (> capo-fret 0)
781         (set! fret-diagram-stencil
782               (ly:stencil-add
783                fret-diagram-stencil
784                (draw-capo capo-fret))))
785     (if (> (car fret-range) 1)
786         (set! fret-diagram-stencil
787               (ly:stencil-add
788                fret-diagram-stencil
789                (label-fret fret-range))))
790     (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
791
792 (define (fret-parse-definition-string props definition-string)
793   "Parse a fret diagram string and return a pair containing:
794 @var{props}, modified as necessary by the definition-string
795 a fret-indication list with the appropriate values"
796   (let* ((fret-count 4)
797          (string-count 6)
798          (fret-range (cons 1 fret-count))
799          (barre-list '())
800          (dot-list '())
801          (xo-list '())
802          (output-list '())
803          (new-props '())
804          (details (merge-details 'fret-diagram-details props '()))
805          (items (string-split definition-string #\;)))
806     (let parse-item ((myitems items))
807       (if (not (null? (cdr myitems)))
808           (let ((test-string (car myitems)))
809             (case (car (string->list (substring test-string 0 1)))
810               ((#\s) (let ((size (get-numeric-from-key test-string)))
811                        (set! props (prepend-alist-chain 'size size props))))
812               ((#\t) (let ((th (get-numeric-from-key test-string)))
813                        (set! props (prepend-alist-chain 'thickness th props))))
814               ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
815                             (finger-id (case finger-code
816                                          ((0) 'none)
817                                          ((1) 'in-dot)
818                                          ((2) 'below-string))))
819                        (set! details
820                              (acons 'finger-code finger-id details))))
821               ((#\c) (set! output-list
822                            (cons-fret
823                             (cons
824                              'barre
825                              (numerify
826                               (string-split (substring test-string 2) #\-)))
827                             output-list)))
828               ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
829                        (set! details
830                              (acons 'fret-count fret-count details))))
831               ((#\w) (let ((string-count (get-numeric-from-key test-string)))
832                        (set! details
833                              (acons 'string-count string-count details))))
834               ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
835                        (set! details
836                              (acons 'dot-radius dot-size details))))
837               ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
838                        (set! details
839                              (acons 'dot-position dot-position details))))
840               (else
841                (let ((this-list (string-split test-string #\-)))
842                  (if (string->number (cadr this-list))
843                      (set! output-list
844                            (cons-fret
845                             (cons 'place-fret (numerify this-list))
846                             output-list))
847                      (if (equal? (cadr this-list) "x" )
848                          (set! output-list
849                                (cons-fret
850                                 (list 'mute (string->number (car this-list)))
851                                 output-list))
852                          (set! output-list
853                                (cons-fret
854                                 (list 'open (string->number (car this-list)))
855                                 output-list)))))))
856             (parse-item (cdr myitems)))))
857     ;; add the modified details
858     (set! props
859           (prepend-alist-chain 'fret-diagram-details details props))
860     `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
861
862 (define-public
863   (fret-parse-terse-definition-string props definition-string)
864   "Parse a fret diagram string that uses terse syntax;
865 return a pair containing:
866 @var{props}, modified to include the string-count determined by the
867 definition-string, and
868 a fret-indication list with the appropriate values"
869   ;; TODO -- change syntax to fret\string-finger
870
871   (let* ((details (merge-details 'fret-diagram-details props '()))
872          (barre-start-list '())
873          (output-list '())
874          (new-props '())
875          (items (string-split definition-string #\;))
876          (string-count (- (length items) 1)))
877     (let parse-item ((myitems items))
878       (if (not (null? (cdr myitems)))
879           (let* ((test-string (car myitems))
880                  (current-string (- (length myitems) 1))
881                  (indicators (string-split test-string #\ )))
882             (let parse-indicators ((myindicators indicators))
883               (if (not (eq? '() myindicators))
884                   (let* ((this-list (string-split (car myindicators) #\-))
885                          (max-element-index (- (length this-list) 1))
886                          (last-element
887                           (car (list-tail this-list max-element-index)))
888                          (fret
889                           (if (string->number (car this-list))
890                               (string->number (car this-list))
891                               (car this-list))))
892                     (if (equal? last-element "(")
893                         (begin
894                           (set! barre-start-list
895                                 (cons-fret (list current-string fret)
896                                            barre-start-list))
897                           (set! this-list
898                                 (list-head this-list max-element-index))))
899                     (if (equal? last-element ")")
900                         (let* ((this-barre
901                                 (get-sub-list fret barre-start-list))
902                                (insert-index (- (length this-barre) 1)))
903                           (set! output-list
904                                 (cons-fret (cons* 'barre
905                                                   (car this-barre)
906                                                   current-string
907                                                   (cdr this-barre))
908                                            output-list))
909                           (set! this-list
910                                 (list-head this-list max-element-index))))
911                     (if (number? fret)
912                         (set!
913                          output-list
914                          (cons-fret (cons*
915                                      'place-fret
916                                      current-string
917                                      (drop-paren (numerify this-list)))
918                                     output-list))
919                         (if (equal? (car this-list) "x" )
920                             (set!
921                              output-list
922                              (cons-fret
923                               (list 'mute current-string)
924                               output-list))
925                             (set!
926                              output-list
927                              (cons-fret
928                               (list 'open current-string)
929                               output-list))))
930                     (parse-indicators (cdr myindicators)))))
931             (parse-item (cdr myitems)))))
932     (set! details (acons 'string-count string-count details))
933     (set! props (prepend-alist-chain 'fret-diagram-details details props))
934     `(,props . ,output-list))) ; ugh -- hard coded; proc is better
935
936
937 (define-markup-command
938   (fret-diagram-verbose layout props marking-list)
939   (pair?) ; argument type (list, but use pair? for speed)
940   #:category instrument-specific-markup ; markup type
941   #:properties ((align-dir -0.4) ; properties and defaults
942                 (size 1.0)
943                 (fret-diagram-details)
944                 (thickness 0.5))
945   "Make a fret diagram containing the symbols indicated in @var{marking-list}.
946
947   For example,
948
949 @example
950 \\markup \\fret-diagram-verbose
951   #'((mute 6) (mute 5) (open 4)
952      (place-fret 3 2) (place-fret 2 3) (place-fret 1 2))
953 @end example
954
955 @noindent
956 produces a standard D@tie{}chord diagram without fingering indications.
957
958 Possible elements in @var{marking-list}:
959
960 @table @code
961 @item (mute @var{string-number})
962 Place a small @q{x} at the top of string @var{string-number}.
963
964 @item (open @var{string-number})
965 Place a small @q{o} at the top of string @var{string-number}.
966
967 @item (barre @var{start-string} @var{end-string} @var{fret-number})
968 Place a barre indicator (much like a tie) from string @var{start-string}
969 to string @var{end-string} at fret @var{fret-number}.
970
971 @item (capo @var{fret-number})
972 Place a capo indicator (a large solid bar) across the entire fretboard
973 at fret location @var{fret-number}.  Also, set fret @var{fret-number}
974 to be the lowest fret on the fret diagram.
975
976 @item (place-fret @var{string-number} @var{fret-number} [@var{finger-value} [@var{color-modifier}]])
977 Place a fret playing indication on string @var{string-number} at fret
978 @var{fret-number} with an optional fingering label @var{finger-value},
979 and an optional color modifier @var{color-modifier}.
980 By default, the fret playing indicator is a solid dot.  This can be
981 globally changed by setting the value of the variable @var{dot-color}.
982 Setting @var{color-modifier} to @code{inverted} inverts the dot color
983 for a specific fingering.
984 If the @var{finger} part of the @code{place-fret} element is present,
985 @var{finger-value} will be displayed according to the setting of the
986 variable @var{finger-code}.  There is no limit to the number of fret
987 indications per string.
988 @end table"
989
990   (make-fret-diagram layout props marking-list))
991
992
993 (define-markup-command (fret-diagram layout props definition-string)
994   (string?) ; argument type
995   #:category instrument-specific-markup ; markup category
996   #:properties (fret-diagram-verbose-markup) ; properties and defaults
997   "Make a (guitar) fret diagram.  For example, say
998
999 @example
1000 \\markup \\fret-diagram #\"s:0.75;6-x;5-x;4-o;3-2;2-3;1-2;\"
1001 @end example
1002
1003 @noindent
1004 for fret spacing 3/4 of staff space, D chord diagram
1005
1006 Syntax rules for @var{definition-string}:
1007 @itemize @minus
1008
1009 @item
1010 Diagram items are separated by semicolons.
1011
1012 @item
1013 Possible items:
1014
1015 @itemize @bullet
1016 @item
1017 @code{s:}@var{number} -- Set the fret spacing of the diagram (in staff
1018 spaces).
1019 Default:@tie{}1.
1020
1021 @item
1022 @code{t:}@var{number} -- Set the line thickness (relative to normal
1023 line thickness).
1024 Default:@tie{}0.5.
1025
1026 @item
1027 @code{h:}@var{number} -- Set the height of the diagram in frets.
1028 Default:@tie{}4.
1029
1030 @item
1031 @code{w:}@var{number} -- Set the width of the diagram in strings.
1032 Default:@tie{}6.
1033
1034 @item
1035 @code{f:}@var{number} -- Set fingering label type
1036  (0@tie{}= none, 1@tie{}= in circle on string, 2@tie{}= below string).
1037 Default:@tie{}0.
1038
1039 @item
1040 @code{d:}@var{number} -- Set radius of dot, in terms of fret spacing.
1041 Default:@tie{}0.25.
1042
1043 @item
1044 @code{p:}@var{number} -- Set the position of the dot in the fret space.
1045 0.5 is centered; 1@tie{}is on lower fret bar, 0@tie{}is on upper fret bar.
1046 Default:@tie{}0.6.
1047
1048 @item
1049 @code{c:}@var{string1}@code{-}@var{string2}@code{-}@var{fret} -- Include a
1050 barre mark from @var{string1} to @var{string2} on @var{fret}.
1051
1052 @item
1053 @var{string}@code{-}@var{fret} -- Place a dot on @var{string} at @var{fret}.
1054 If @var{fret} is @samp{o}, @var{string} is identified as open.
1055 If @var{fret} is @samp{x}, @var{string} is identified as muted.
1056
1057 @item
1058 @var{string}@code{-}@var{fret}@code{-}@var{fingering} -- Place a dot on
1059 @var{string} at @var{fret}, and label with @var{fingering} as defined
1060 by the @code{f:} code.
1061 @end itemize
1062
1063 @item
1064 Note: There is no limit to the number of fret indications per string.
1065 @end itemize"
1066   (let ((definition-list
1067           (fret-parse-definition-string props definition-string)))
1068     (fret-diagram-verbose-markup
1069      layout (car definition-list) (cdr definition-list))))
1070
1071 (define-markup-command
1072   (fret-diagram-terse layout props definition-string)
1073   (string?) ; argument type
1074   #:category instrument-specific-markup ; markup category
1075   #:properties (fret-diagram-verbose-markup) ; properties
1076   "Make a fret diagram markup using terse string-based syntax.
1077
1078 Here is an example
1079
1080 @example
1081 \\markup \\fret-diagram-terse #\"x;x;o;2;3;2;\"
1082 @end example
1083
1084 @noindent
1085 for a D@tie{}chord diagram.
1086
1087 Syntax rules for @var{definition-string}:
1088
1089 @itemize @bullet
1090
1091 @item
1092 Strings are terminated by semicolons; the number of semicolons
1093 is the number of strings in the diagram.
1094
1095 @item
1096 Mute strings are indicated by @samp{x}.
1097
1098 @item
1099 Open strings are indicated by @samp{o}.
1100
1101 @item
1102 A number indicates a fret indication at that fret.
1103
1104 @item
1105 If there are multiple fret indicators desired on a string, they
1106 should be separated by spaces.
1107
1108 @item
1109 Fingerings are given by following the fret number with a @w{@code{-},}
1110 followed by the finger indicator, e.g. @samp{3-2} for playing the third
1111 fret with the second finger.
1112
1113 @item
1114 Where a barre indicator is desired, follow the fret (or fingering) symbol
1115 with @w{@code{-(}} to start a barre and @w{@code{-)}} to end the barre.
1116
1117 @end itemize"
1118   ;; TODO -- change syntax to fret\string-finger
1119   (let ((definition-list
1120           (fret-parse-terse-definition-string props definition-string)))
1121     (fret-diagram-verbose-markup layout
1122                                  (car definition-list)
1123                                  (cdr definition-list))))