-
-(define (string-stencil string string-count fret-range
- th thickness-factor size orientation)
- "Make a stencil for @code{string}, given the fret-diagram
-overall parameters."
- (let* ((string-thickness (* th (expt (1+ thickness-factor) string)))
- (start-coordinates
- (stencil-coordinates
- 0
- (* size (1- string))
- orientation))
- (end-coordinates
- (stencil-coordinates
- (* size (1+ (fret-count fret-range)))
- (* size (1- string))
- orientation)))
- (make-line-stencil
- string-thickness
- (car start-coordinates) (cdr start-coordinates)
- (car end-coordinates) (cdr end-coordinates))))
-
-(define (fret-stencil fret fret-range string-count th size orientation)
- "Make a stencil for @code{fret}, given the fret-diagram overall parameters."
- (let* ((start-coordinates
- (stencil-coordinates
- (* size fret)
- 0
- orientation))
- (end-coordinates
- (stencil-coordinates
- (* size fret)
- (* size (1- string-count))
- orientation)))
- (make-line-stencil
- th
- (car start-coordinates) (cdr start-coordinates)
- (car end-coordinates) (cdr end-coordinates))))
-
-(define (make-straight-barre-stencil
- size half-thickness fret-coordinate
- start-string-coordinate end-string-coordinate orientation)
- "Create a straight barre stencil."
- (let ((start-point
- (stencil-coordinates
- (* size fret-coordinate)
- (* size start-string-coordinate)
- orientation))
- (end-point
- (stencil-coordinates
- (* size fret-coordinate)
- (* size end-string-coordinate)
- orientation)))
- (make-line-stencil
- half-thickness
- (car start-point)
- (cdr start-point)
- (car end-point)
- (cdr end-point))))
-
-(define (make-curved-barre-stencil
- size half-thickness fret-coordinate
- start-string-coordinate end-string-coordinate orientation)
- "Create a curved barre stencil."
- (let* ((bezier-thick 0.1)
- (bezier-height 0.5)
- (bezier-list
- (make-bezier-sandwich-list
- (* size start-string-coordinate)
- (* size end-string-coordinate)
- (* size fret-coordinate)
- (* size bezier-height)
- (* size bezier-thick)
- orientation))
- (box-lower-left
- (stencil-coordinates
- (+ (* size fret-coordinate) half-thickness)
- (- (* size start-string-coordinate) half-thickness)
- orientation))
- (box-upper-right
- (stencil-coordinates
- (- (* size fret-coordinate) (* size bezier-height) half-thickness)
- (+ (* size end-string-coordinate) half-thickness)
- orientation))
- (x-extent (cons (car box-lower-left) (car box-upper-right)))
- (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
- (ly:make-stencil
- (list 'bezier-sandwich
- `(quote ,bezier-list)
- (* size bezier-thick))
- x-extent
- y-extent)))
-
-
-;
-;
-; Functions used to draw fret-diagram elements
-;
-;
-
-(define (draw-strings string-count fret-range th
- thickness-factor size orientation)
- "Draw the string lines for a fret diagram with
-@var{string-count} strings and frets as indicated in @var{fret-range}.
-Line thickness is given by @var{th}, fret & string spacing by
-@var{size}. Orientation is determined by @var{orientation}. "
-
- (define (helper x)
- (if (null? (cdr x))
- (string-stencil
- (car x) string-count fret-range th
- thickness-factor size orientation)
- (ly:stencil-add
- (string-stencil
- (car x) string-count fret-range th
- thickness-factor size orientation)
- (helper (cdr x)))))
-
- (let* ( (string-list (map 1+ (iota string-count))))
- (helper string-list)))
-
-(define (draw-fret-lines fret-count string-count th size orientation)
- "Draw @var{fret-count} fret lines for a fret diagram
-with @var{string-count} strings. Line thickness is given by @var{th},
-fret & string spacing by @var{size}. Orientation is given by @var{orientation}"
- (define (helper x)
- (if (null? (cdr x))
- (fret-stencil
- (car x) fret-count string-count th
- size orientation)
- (ly:stencil-add
- (fret-stencil
- (car x) fret-count string-count th
- size orientation)
- (helper (cdr x)))))
-
- (let* ((fret-list (iota (1+ fret-count))))
- (helper fret-list)))
-
-(define (draw-thick-zero-fret details string-count th size orientation)
- "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
- (let* ((sth (* th size))
- (half-thick (* 0.5 sth))
- (top-fret-thick
- (* sth (assoc-get 'top-fret-thickness details 3.0)))
- (start-string-coordinate (- half-thick))
- (end-string-coordinate (+ (* size (1- string-count)) half-thick))
- (start-fret-coordinate half-thick)
- (end-fret-coordinate (- half-thick top-fret-thick))
- (lower-left
- (stencil-coordinates
- start-fret-coordinate start-string-coordinate orientation))
- (upper-right
- (stencil-coordinates
- end-fret-coordinate end-string-coordinate orientation)))
- (make-filled-box-stencil
- (cons (car lower-left) (car upper-right))
- (cons (cdr lower-left) (cdr upper-right)))))
-
-
-(define (draw-capo details string-count fret fret-count th size
- dot-pos orientation)
- "Draw a capo indicator across the full width of the fret-board
-at @var{fret}."
-(let* (;(sth (* th size))
- (capo-thick
- (* size (assoc-get 'capo-thickness details 0.5)))
- (half-thick (* capo-thick 0.5))
- (last-string-pos 0)
- (first-string-pos (* size (- string-count 1)))
- (fret-pos ( * size (1- (+ dot-pos fret))))
- (start-point
- (stencil-coordinates fret-pos first-string-pos orientation))
- (end-point
- (stencil-coordinates fret-pos last-string-pos orientation)))
- (make-line-stencil
- capo-thick
- (car start-point) (cdr start-point)
- (car end-point) (cdr end-point))))
-
-(define (draw-frets fret-range string-count th size orientation)
- "Draw the fret lines for a fret diagram with
-@var{string-count} strings and frets as indicated in @var{fret-range}.
-Line thickness is given by @var{th}, fret & string spacing by
-@var{size}. Orientation is given by @var{orientation}."
- (let* ((my-fret-count (fret-count fret-range)))
- (draw-fret-lines my-fret-count string-count th size orientation)))
-
-(define (draw-dots layout props string-count fret-count
- size finger-code
- dot-position dot-radius dot-thickness dot-list orientation)
- "Make dots for fret diagram."
-
- (let* ((details (merge-details 'fret-diagram-details props '()))
- (scale-dot-radius (* size dot-radius))
- (scale-dot-thick (* size dot-thickness))
- (dot-color (assoc-get 'dot-color details 'black))
- (finger-label-padding 0.3)
- (dot-label-font-mag
- (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0)))
- (string-label-font-mag
- (* size
- (assoc-get 'string-label-font-mag details
- (cond ((or (eq? orientation 'landscape)
- (eq? orientation 'opposing-landscape))
- 0.5)
- (else 0.6)))))
- (mypair (car dot-list))
- (restlist (cdr dot-list))
- (string (car mypair))
- (fret (cadr mypair))
- (fret-coordinate (* size (+ (1- fret) dot-position)))
- (string-coordinate (* size (- string-count string)))
- (dot-coordinates
- (stencil-coordinates fret-coordinate string-coordinate orientation))
- (extent (cons (- scale-dot-radius) scale-dot-radius))
- (finger (caddr mypair))
- (finger (if (number? finger) (number->string finger) finger))
- (dot-stencil (if (eq? dot-color 'white)
- (ly:stencil-add
- (make-circle-stencil
- scale-dot-radius scale-dot-thick #t)
- (ly:stencil-in-color
- (make-circle-stencil
- (- scale-dot-radius (* 0.5 scale-dot-thick))
- 0 #t)
- 1 1 1))
- (make-circle-stencil
- scale-dot-radius scale-dot-thick #t)))
- (positioned-dot (ly:stencil-translate dot-stencil dot-coordinates))
- (labeled-dot-stencil
- (cond
- ((or (eq? finger '())(eq? finger-code 'none))
- positioned-dot)
- ((eq? finger-code 'in-dot)
- (let ((finger-label
- (centered-stencil
- (sans-serif-stencil
- layout props dot-label-font-mag finger))))
- (ly:stencil-translate
- (ly:stencil-add
- dot-stencil
- (if (eq? dot-color 'white)
- finger-label
- (ly:stencil-in-color finger-label 1 1 1)))
- dot-coordinates)))
- ((eq? finger-code 'below-string)
- (let* ((label-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props string-label-font-mag
- finger)))
- (label-fret-offset
- (stencil-fretboard-offset
- label-stencil 'fret orientation))
- (label-fret-coordinate
- (+ (* size (+ 1 fret-count finger-label-padding))
- label-fret-offset))
- (label-string-coordinate string-coordinate)
- (label-translation
- (stencil-coordinates
- label-fret-coordinate
- label-string-coordinate
- orientation)))
- (ly:stencil-add
- positioned-dot
- (ly:stencil-translate label-stencil label-translation))))
- (else ;unknown finger-code
- positioned-dot))))
- (if (null? restlist)
- labeled-dot-stencil
- (ly:stencil-add
- (draw-dots
- layout props string-count fret-count size finger-code
- dot-position dot-radius dot-thickness restlist orientation)
- labeled-dot-stencil))))
-
-(define (draw-xo
- layout props string-count fret-range size xo-list orientation)
- "Put open and mute string indications on diagram, as contained in
-@var{xo-list}."
- (let* ((details (merge-details 'fret-diagram-details props '()))
- (xo-font-mag
- (* size (assoc-get
- 'xo-font-magnification details
- (cond ((or (eq? orientation 'landscape)
- (eq? orientation 'opposing-landscape))
- 0.4)
- (else 0.4)))))
- (mypair (car xo-list))
- (restlist (cdr xo-list))
- (glyph-string (if (eq? (car mypair) 'mute)
- (assoc-get 'mute-string details "X")
- (assoc-get 'open-string details "O")))
- (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
- (glyph-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props (* size xo-font-mag) glyph-string)))
- (glyph-stencil-coordinates
- (stencil-coordinates 0 glyph-string-coordinate orientation))
- (positioned-glyph
- (ly:stencil-translate glyph-stencil glyph-stencil-coordinates)))
- (if (null? restlist)
- positioned-glyph
- (ly:stencil-add
- (draw-xo
- layout props string-count fret-range size restlist orientation)
- positioned-glyph))))
-
-(define (draw-barre layout props string-count fret-range
- size finger-code dot-position dot-radius
- barre-list orientation)
- "Create barre indications for a fret diagram"
- (if (not (null? barre-list))
- (let* ((details (merge-details 'fret-diagram-details props '()))
- (string1 (caar barre-list))
- (string2 (cadar barre-list))
- (barre-fret (caddar barre-list))
- (top-fret (cdr fret-range))
- (low-fret (car fret-range))
- (fret (1+ (- barre-fret low-fret)))
- (barre-vertical-offset 0.5)
- (dot-center-fret-coordinate (+ (1- fret) dot-position))
- (barre-fret-coordinate
- (+ dot-center-fret-coordinate
- (* (- barre-vertical-offset 0.5) dot-radius)))
- (barre-start-string-coordinate (- string-count string1))
- (barre-end-string-coordinate (- string-count string2))
- (scale-dot-radius (* size dot-radius))
- (barre-type (assoc-get 'barre-type details 'curved))
- (barre-stencil
- (cond
- ((eq? barre-type 'straight)
- (make-straight-barre-stencil size scale-dot-radius
- barre-fret-coordinate barre-start-string-coordinate
- barre-end-string-coordinate orientation))
- ((eq? barre-type 'curved)
- (make-curved-barre-stencil size scale-dot-radius
- barre-fret-coordinate barre-start-string-coordinate
- barre-end-string-coordinate orientation)))))
-(if (not (null? (cdr barre-list)))
- (ly:stencil-add
- barre-stencil
- (draw-barre layout props string-count fret-range size finger-code
- dot-position dot-radius (cdr barre-list) orientation))
- barre-stencil ))))
-
-(define (label-fret layout props string-count fret-range size orientation)
- "Label the base fret on a fret diagram"
- (let* ((details (merge-details 'fret-diagram-details props '()))
- (base-fret (car fret-range))
- (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
- (label-space (* 0.5 size))
- (label-dir (assoc-get 'label-dir details RIGHT))
- (label-vertical-offset
- (assoc-get 'fret-label-vertical-offset details 0))
- (number-type
- (assoc-get 'number-type details 'roman-lower))
- (label-text
- (cond
- ((equal? number-type 'roman-lower)
- (fancy-format #f "~(~@r~)" base-fret))
- ((equal? number-type 'roman-upper)
- (fancy-format #f "~@r" base-fret))
- ((equal? 'arabic number-type)
- (fancy-format #f "~d" base-fret))
- (else (fancy-format #f "~(~@r~)" base-fret))))
- (label-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props (* size label-font-mag) label-text)))
- (label-half-width
- (stencil-fretboard-offset label-stencil 'string orientation))
- (label-outside-diagram (+ label-space label-half-width)))
- (ly:stencil-translate
- label-stencil
- (stencil-coordinates
- (1+ (* size label-vertical-offset))
- (if (eq? label-dir LEFT)
- (- label-outside-diagram)
- (+ (* size (1- string-count)) label-outside-diagram))
- orientation))))
-