; Utility functions
;
;
-
+
(define (string-x-extent start-point end-point)
"Return the x-extent of a string that goes from start-point
to end-point."
(third this-list)))
(subtract-base-fret base-fret (cdr dot-list))))))
-(define (make-bezier-sandwich-list start stop base height
- half-thickness orientation)
- "Make the argument list for a bezier sandwich from
-string coordinate @var{start} to string-coordinate @var{stop} with a
-baseline at fret coordinate @var{base}, a height of
-@var{height}, and a half thickness of @var{half-thickness}."
- (let* ((width (+ (- stop start) 1))
- (cp-left-width (+ (* width half-thickness) start))
- (cp-right-width (- stop (* width half-thickness)))
- (bottom-control-point-height
- (- base (- height half-thickness)))
- (top-control-point-height
- (- base height))
- (left-end-point
- (stencil-coordinates base start orientation))
- (right-end-point
- (stencil-coordinates base stop orientation))
- (left-upper-control-point
- (stencil-coordinates
- top-control-point-height cp-left-width orientation))
- (left-lower-control-point
- (stencil-coordinates
- bottom-control-point-height cp-left-width orientation))
- (right-upper-control-point
- (stencil-coordinates
- top-control-point-height cp-right-width orientation))
- (right-lower-control-point
- (stencil-coordinates
- bottom-control-point-height cp-right-width orientation)))
- ; order of bezier control points is:
- ; left cp low, right cp low, right end low, left end low
- ; right cp high, left cp high, left end high, right end high.
- ;
- (list left-lower-control-point
- right-lower-control-point
- right-end-point
- left-end-point
- right-upper-control-point
- left-upper-control-point
- left-end-point
- right-end-point)))
-
(define (drop-paren item-list)
"Drop a final parentheses from a fret indication list
@code{item-list} resulting from a terse string specification of barre."
;
; Conversions between fret/string coordinate system and x-y coordinate
; system.
-;
+;
; Fret coordinates are measured down the fretboard from the nut,
; starting at 0.
;
(cons (- (cdr extent)) (- (car extent))))
(define (stencil-fretboard-extent stencil fretboard-axis orientation)
- "Return the extent of @code{stencil} in the @code{fretboard-axis}
+ "Return the extent of @code{stencil} in the @code{fretboard-axis}
direction."
(if (eq? fretboard-axis 'fret)
(cond ((eq? orientation 'landscape)
(define (stencil-fretboard-offset stencil fretboard-axis orientation)
"Return a the stencil coordinates of the center of @code{stencil}
in the @code{fretboard-axis} direction."
- (* 0.5 (interval-length
+ (* 0.5 (interval-length
(stencil-fretboard-extent stencil fretboard-axis orientation))))
-(define (stencil-coordinates fret-coordinate string-coordinate orientation)
- "Return a pair @code{(x-coordinate . y-coordinate)} in stencil coordinate
-system."
- (cond
- ((eq? orientation 'landscape)
- (cons fret-coordinate string-coordinate))
- ((eq? orientation 'opposing-landscape)
- (cons (- fret-coordinate) (- string-coordinate)))
- (else
- (cons string-coordinate (- fret-coordinate)))))
-
+
(define (string-thickness string thickness-factor)
(expt (1+ thickness-factor) (1- string)))
-
+
;
; Functions that create stencils used in the fret diagram
;
(prepend-alist-chain 'font-family 'sans props))))
(interpret-markup layout my-props text)))
-
-(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-coordinate (- string-count string))
- (current-string-thickness
- (* th size (string-thickness string thickness-factor)))
- (fret-half-thickness (* size th 0.5))
- (half-string (* current-string-thickness 0.5))
- (start-coordinates
- (stencil-coordinates
- (- fret-half-thickness)
- (- (* size string-coordinate) half-string)
- orientation))
- (end-coordinates
- (stencil-coordinates
- (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
- (+ half-string (* size string-coordinate))
- orientation)))
- (ly:round-filled-box (string-x-extent start-coordinates end-coordinates)
- (string-y-extent start-coordinates end-coordinates)
- (* th size))))
-
-(define (fret-stencil fret string-count th
- thickness-factor size orientation)
- "Make a stencil for @code{fret}, given the fret-diagram overall parameters."
- (let* ((low-string-half-thickness
- (* 0.5 size th (string-thickness string-count thickness-factor)))
- (fret-half-thickness (* 0.5 size th))
- (start-coordinates
- (stencil-coordinates
- (* size fret)
- (- fret-half-thickness low-string-half-thickness)
- orientation))
- (end-coordinates
- (stencil-coordinates
- (* size fret)
- (* size (1- string-count))
- orientation)))
- (make-line-stencil
- (* size 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
- thickness-factor 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) string-count th thickness-factor
- size orientation)
- (ly:stencil-add
- (fret-stencil
- (car x) string-count th thickness-factor
- size orientation)
- (helper (cdr x)))))
-
- (let* ( (fret-list (iota (1+ fret-count))))
- (helper fret-list)))
-
-(define (draw-thick-zero-fret details string-count th
- thickness-factor size orientation)
- "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
- (let* ((sth (* th size))
- (half-lowest-string-thickness
- (* 0.5 th (string-thickness string-count thickness-factor)))
- (half-thick (* 0.5 sth))
- (top-fret-thick
- (* sth (assoc-get 'top-fret-thickness details 3.0)))
- (start-string-coordinate (- half-lowest-string-thickness))
- (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)))
- (ly:round-filled-box
- (cons (car lower-left) (car upper-right))
- (cons (cdr lower-left) (cdr upper-right))
- sth)))
-
-
-(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* ((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
- thickness-factor 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 thickness-factor 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))))
-
;;
;;
;; markup commands and associated functions
(set! dot-list (cons* (cdr my-item) dot-list))))
(parse-item (cdr mylist)))))
;; calculate fret-range
- (let ((maxfret 0)
+ (let ((maxfret 0)
(minfret (if (> capo-fret 0) capo-fret 99)))
(let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION?
(if (null? fret-list)
(acons 'fret-range fret-range
(acons 'barre-list barre-list
(acons 'dot-list dot-list
- (acons 'xo-list xo-list
+ (acons 'xo-list xo-list
(acons 'capo-fret capo-fret '())))))))
(define (make-fret-diagram layout props marking-list)
; called from this routine. If they're only used in one of the
; sub-procedure, they're obtained in that procedure
(size (chain-assoc-get 'size props 1.0)) ; needed for everything
-;TODO -- get string-count directly from length of stringTunings;
-; from FretBoard engraver, but not from markup call
+ ;TODO -- get string-count directly from length of stringTunings;
+ ; from FretBoard engraver, but not from markup call
(details (merge-details 'fret-diagram-details props '()))
(string-count
- (assoc-get 'string-count details 6)) ; needed for everything
+ (assoc-get 'string-count details 6)) ; needed for everything
(my-fret-count
- (assoc-get 'fret-count details 4)) ; needed for everything
+ (assoc-get 'fret-count details 4)) ; needed for everything
(orientation
- (assoc-get 'orientation details 'normal)) ; needed for everything
+ (assoc-get 'orientation details 'normal)) ; needed for everything
(finger-code
- (assoc-get
- 'finger-code details 'none)) ; needed for draw-dots and draw-barre
+ (assoc-get
+ 'finger-code details 'none)) ; needed for draw-dots and draw-barre
(default-dot-radius
(if (eq? finger-code 'in-dot) 0.425 0.25)) ; bigger dots if labeled
(default-dot-position
(if (eq? finger-code 'in-dot)
- (- 0.95 default-dot-radius)
- 0.6)) ; move up to make room for bigger if labeled
+ (- 0.95 default-dot-radius)
+ 0.6)) ; move up to make room for bigger dot if labeled
(dot-radius
- (assoc-get
- 'dot-radius details default-dot-radius)) ; needed for draw-dots
- ; and draw-barre
+ (assoc-get
+ 'dot-radius details default-dot-radius)) ; needed for draw-dots
+ ; and draw-barre
(dot-position
- (assoc-get
- 'dot-position details default-dot-position)) ; needed for draw-dots
- ; and draw-barre
+ (assoc-get
+ 'dot-position details default-dot-position)) ; needed for draw-dots
+ ; and draw-barre
(th
- (* (ly:output-def-lookup layout 'line-thickness)
- (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
- ; and draw-strings
+ (* (ly:output-def-lookup layout 'line-thickness)
+ (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets
+ ; and draw-strings
+ (sth (* size th))
(thickness-factor (assoc-get 'string-thickness-factor details 0))
(alignment
- (chain-assoc-get 'align-dir props -0.4)) ; needed only here
+ (chain-assoc-get 'align-dir props -0.4)) ; needed only here
(xo-padding
- (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
+ (* size (assoc-get 'xo-padding details 0.2))) ; needed only here
(parameters (fret-parse-marking-list marking-list my-fret-count))
(capo-fret (assoc-get 'capo-fret parameters 0))
(dot-list (cdr (assoc 'dot-list parameters)))
(my-fret-count (fret-count fret-range))
(barre-list (cdr (assoc 'barre-list parameters)))
(barre-type
- (assoc-get 'barre-type details 'curved))
- (fret-diagram-stencil
+ (assoc-get 'barre-type details 'curved))
+ (fret-diagram-stencil '()))
+ ;
+ ;; Here are the fret diagram helper functions that depend on the
+ ;; fret diagram parameters. The functions are here because the
+ ;; diagram parameters are part of the lexical scope here.
+
+ (define (stencil-coordinates fret-coordinate string-coordinate)
+ "Return a pair @code{(x-coordinate . y-coordinate)}
+ in stencil coordinate system."
+ (cond
+ ((eq? orientation 'landscape)
+ (cons fret-coordinate string-coordinate))
+ ((eq? orientation 'opposing-landscape)
+ (cons (- fret-coordinate) (- string-coordinate)))
+ (else
+ (cons string-coordinate (- fret-coordinate)))))
+
+ (define (make-bezier-sandwich-list start stop base height
+ half-thickness)
+ "Make the argument list for a bezier sandwich from
+string coordinate @var{start} to string-coordinate @var{stop} with a
+baseline at fret coordinate @var{base}, a height of
+@var{height}, and a half thickness of @var{half-thickness}."
+ (let* ((width (+ (- stop start) 1))
+ (cp-left-width (+ (* width half-thickness) start))
+ (cp-right-width (- stop (* width half-thickness)))
+ (bottom-control-point-height
+ (- base (- height half-thickness)))
+ (top-control-point-height
+ (- base height))
+ (left-end-point
+ (stencil-coordinates base start))
+ (right-end-point
+ (stencil-coordinates base stop))
+ (left-upper-control-point
+ (stencil-coordinates
+ top-control-point-height cp-left-width))
+ (left-lower-control-point
+ (stencil-coordinates
+ bottom-control-point-height cp-left-width))
+ (right-upper-control-point
+ (stencil-coordinates
+ top-control-point-height cp-right-width))
+ (right-lower-control-point
+ (stencil-coordinates
+ bottom-control-point-height cp-right-width)))
+ ; order of bezier control points is:
+ ; left cp low, right cp low, right end low, left end low
+ ; right cp high, left cp high, left end high, right end high.
+ ;
+ (list left-lower-control-point
+ right-lower-control-point
+ right-end-point
+ left-end-point
+ right-upper-control-point
+ left-upper-control-point
+ left-end-point
+ right-end-point)))
+
+ (define (draw-strings)
+ "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))
(ly:stencil-add
- (draw-strings
- string-count fret-range th thickness-factor size orientation)
- (draw-frets
- fret-range string-count th thickness-factor size orientation))))
+ (string-stencil (car x))
+ (helper (cdr x)))))
+
+ (let* ( (string-list (map 1+ (iota string-count))))
+ (helper string-list)))
+
+ (define (string-stencil string)
+ "Make a stencil for @code{string}, given the fret-diagram
+ overall parameters."
+ (let* ((string-coordinate (- string-count string))
+ (current-string-thickness
+ (* th size (string-thickness string thickness-factor)))
+ (fret-half-thickness (* size th 0.5))
+ (half-string (* current-string-thickness 0.5))
+ (start-coordinates
+ (stencil-coordinates
+ (- fret-half-thickness)
+ (- (* size string-coordinate) half-string)))
+ (end-coordinates
+ (stencil-coordinates
+ (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
+ (+ half-string (* size string-coordinate)))))
+ (ly:round-filled-box
+ (string-x-extent start-coordinates end-coordinates)
+ (string-y-extent start-coordinates end-coordinates)
+ (* th size))))
+
+ (define (draw-frets)
+ "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}."
+ (define (helper x)
+ (if (null? (cdr x))
+ (fret-stencil (car x))
+ (ly:stencil-add
+ (fret-stencil (car x))
+ (helper (cdr x)))))
+
+ (let ((fret-list (iota (1+ my-fret-count))))
+ (helper fret-list)))
+
+ (define (fret-stencil fret)
+ "Make a stencil for @code{fret}, given the
+fret-diagram overall parameters."
+ (let* ((low-string-half-thickness
+ (* 0.5
+ size
+ th
+ (string-thickness string-count thickness-factor)))
+ (fret-half-thickness (* 0.5 size th))
+ (start-coordinates
+ (stencil-coordinates
+ (* size fret)
+ (- fret-half-thickness low-string-half-thickness)))
+ (end-coordinates
+ (stencil-coordinates
+ (* size fret)
+ (* size (1- string-count)))))
+ (make-line-stencil
+ (* size th)
+ (car start-coordinates) (cdr start-coordinates)
+ (car end-coordinates) (cdr end-coordinates))))
+
+ (define (draw-barre barre-list)
+ "Create barre indications for a fret diagram"
+ (if (not (null? barre-list))
+ (let* ((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
+ barre-fret-coordinate
+ barre-start-string-coordinate
+ barre-end-string-coordinate
+ scale-dot-radius))
+ ((eq? barre-type 'curved)
+ (make-curved-barre-stencil
+ barre-fret-coordinate
+ barre-start-string-coordinate
+ barre-end-string-coordinate
+ scale-dot-radius)))))
+ (if (not (null? (cdr barre-list)))
+ (ly:stencil-add
+ barre-stencil
+ (draw-barre (cdr barre-list)))
+ barre-stencil ))))
+
+ (define (make-straight-barre-stencil
+ fret-coordinate
+ start-string-coordinate
+ end-string-coordinate
+ half-thickness)
+ "Create a straight barre stencil."
+ (let ((start-point
+ (stencil-coordinates
+ (* size fret-coordinate)
+ (* size start-string-coordinate)))
+ (end-point
+ (stencil-coordinates
+ (* size fret-coordinate)
+ (* size end-string-coordinate))))
+ (make-line-stencil
+ half-thickness
+ (car start-point)
+ (cdr start-point)
+ (car end-point)
+ (cdr end-point))))
+
+ (define (make-curved-barre-stencil
+ fret-coordinate
+ start-string-coordinate
+ end-string-coordinate
+ half-thickness)
+ "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)))
+ (box-lower-left
+ (stencil-coordinates
+ (+ (* size fret-coordinate) half-thickness)
+ (- (* size start-string-coordinate) half-thickness)))
+ (box-upper-right
+ (stencil-coordinates
+ (- (* size fret-coordinate)
+ (* size bezier-height)
+ half-thickness)
+ (+ (* size end-string-coordinate) half-thickness)))
+ (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)))
+
+ (define (draw-dots dot-list)
+ "Make dots for fret diagram."
+
+ (let* ( (scale-dot-radius (* size dot-radius))
+ (scale-dot-thick (* size th))
+ (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))
+ (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 my-fret-count finger-label-padding))
+ label-fret-offset))
+ (label-string-coordinate string-coordinate)
+ (label-translation
+ (stencil-coordinates
+ label-fret-coordinate
+ label-string-coordinate)))
+ (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 restlist)
+ labeled-dot-stencil))))
+
+ (define (draw-thick-zero-fret)
+ "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
+ (let* ((half-lowest-string-thickness
+ (* 0.5 th (string-thickness string-count thickness-factor)))
+ (half-thick (* 0.5 sth))
+ (top-fret-thick
+ (* sth (assoc-get 'top-fret-thickness details 3.0)))
+ (start-string-coordinate (- half-lowest-string-thickness))
+ (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))
+ (upper-right
+ (stencil-coordinates
+ end-fret-coordinate end-string-coordinate)))
+ (ly:round-filled-box
+ (cons (car lower-left) (car upper-right))
+ (cons (cdr lower-left) (cdr upper-right))
+ sth)))
+
+ (define (draw-xo xo-list)
+ "Put open and mute string indications on diagram, as contained in
+@var{xo-list}."
+ (let* ((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))
+ (positioned-glyph
+ (ly:stencil-translate
+ glyph-stencil
+ glyph-stencil-coordinates)))
+ (if (null? restlist)
+ positioned-glyph
+ (ly:stencil-add
+ (draw-xo restlist)))))
+
+ (define (draw-capo fret)
+ "Draw a capo indicator across the full width of the fret-board
+at @var{fret}."
+ (let* ((capo-thick
+ (* size (assoc-get 'capo-thickness details 0.5)))
+ (half-thick (* capo-thick 0.5))
+ (last-string-position 0)
+ (first-string-position (* size (- string-count 1)))
+ (fret-position ( * size (1- (+ dot-position fret))))
+ (start-point
+ (stencil-coordinates
+ fret-position
+ first-string-position))
+ (end-point
+ (stencil-coordinates
+ fret-position
+ last-string-position)))
+ (make-line-stencil
+ capo-thick
+ (car start-point) (cdr start-point)
+ (car end-point) (cdr end-point))))
+
+ (define (label-fret fret-range)
+ "Label the base fret on a fret diagram"
+ (let* ((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))))))
+
+
+ ; Here is the body of make-fret-diagram
+ ;
+
+ (set! fret-diagram-stencil
+ (ly:stencil-add (draw-strings) (draw-frets)))
(if (and (not (null? barre-list))
(not (eq? 'none barre-type)))
- (set! fret-diagram-stencil
- (ly:stencil-add
- (draw-barre layout props string-count fret-range size
- finger-code dot-position dot-radius
- barre-list orientation)
- fret-diagram-stencil)))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ (draw-barre barre-list)
+ fret-diagram-stencil)))
(if (not (null? dot-list))
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-dots layout props string-count my-fret-count
- size finger-code dot-position dot-radius
- th dot-list orientation))))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (draw-dots dot-list))))
(if (= (car fret-range) 1)
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-thick-zero-fret
- details string-count th
- thickness-factor size orientation))))
- (if (not (null? xo-list))
- (let* ((diagram-fret-top
- (car (stencil-fretboard-extent
- fret-diagram-stencil
- 'fret
- orientation)))
- (xo-stencil
- (draw-xo layout props string-count fret-range
- size xo-list orientation))
- (xo-fret-offset
- (stencil-fretboard-offset
- xo-stencil 'fret orientation)))
(set! fret-diagram-stencil
(ly:stencil-add
fret-diagram-stencil
- (ly:stencil-translate
- xo-stencil
- (stencil-coordinates
- (- diagram-fret-top
- xo-fret-offset
- (* size xo-padding))
- 0 ; no string offset
- orientation))))))
-
- (if (> capo-fret 0)
+ (draw-thick-zero-fret))))
+ (if (not (null? xo-list))
+ (let* ((diagram-fret-top
+ (car (stencil-fretboard-extent
+ fret-diagram-stencil
+ 'fret
+ orientation)))
+ (xo-stencil (draw-xo xo-list))
+ (xo-fret-offset
+ (stencil-fretboard-offset
+ xo-stencil 'fret orientation)))
(set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-capo details string-count capo-fret my-fret-count
- th size dot-position orientation))))
+ (ly:stencil-add
+ fret-diagram-stencil
+ (ly:stencil-translate
+ xo-stencil
+ (stencil-coordinates
+ (- diagram-fret-top
+ xo-fret-offset
+ (* size xo-padding))
+ 0)))))) ; no string offset
+
+ (if (> capo-fret 0)
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (draw-capo capo-fret))))
(if (> (car fret-range) 1)
(set! fret-diagram-stencil
(ly:stencil-add
- fret-diagram-stencil
- (label-fret
- layout props string-count fret-range size orientation))))
- (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
+ fret-diagram-stencil
+ (label-fret fret-range))))
+ (ly:stencil-aligned-to fret-diagram-stencil X alignment)))
(define (fret-parse-definition-string props definition-string)
"Parse a fret diagram string and return a pair containing:
(prepend-alist-chain 'fret-diagram-details details props))
`(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
-(define-public
+(define-public
(fret-parse-terse-definition-string props definition-string)
- "Parse a fret diagram string that uses terse syntax;
+ "Parse a fret diagram string that uses terse syntax;
return a pair containing:
@var{props}, modified to include the string-count determined by the
definition-string, and
`(,props . ,output-list))) ; ugh -- hard coded; proc is better
-(define-builtin-markup-command
+(define-builtin-markup-command
(fret-diagram-verbose layout props marking-list)
(pair?) ; argument type (list, but use pair? for speed)
instrument-specific-markup ; markup type
projects / lilypond.git / commitdiff