X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffret-diagrams.scm;h=3a0ffe53cef846688989b6c2575e27a0d8b44864;hb=0e5d83a9ceb4a143f83d22406d7eb816314ff9f7;hp=a305d944e6c04ec9d336af7ec024edb8a284d1ee;hpb=a2193e1a9fec193aec6f91437ec8c699fe78f2d1;p=lilypond.git diff --git a/scm/fret-diagrams.scm b/scm/fret-diagrams.scm index a305d944e6..3a0ffe53ce 100644 --- a/scm/fret-diagrams.scm +++ b/scm/fret-diagrams.scm @@ -2,10 +2,11 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004--2007 Carl D. Sorensen +;;;; (c) 2004--2009 Carl D. Sorensen (define (fret-parse-marking-list marking-list fret-count) (let* ((fret-range (list 1 fret-count)) + (capo-fret 0) (barre-list '()) (dot-list '()) (xo-list '()) @@ -18,11 +19,14 @@ (set! xo-list (cons* my-item xo-list))) ((eq? my-code 'barre) (set! barre-list (cons* (cdr my-item) barre-list))) + ((eq? my-code 'capo) + (set! capo-fret (cadr my-item))) ((eq? my-code 'place-fret) (set! dot-list (cons* (cdr my-item) dot-list)))) (parse-item (cdr mylist))))) ;; calculate fret-range - (let ((maxfret 0) (minfret 99)) + (let ((maxfret 0) + (minfret (if (> capo-fret 0) capo-fret 99))) (let updatemax ((fret-list dot-list)) (if (null? fret-list) '() @@ -35,12 +39,14 @@ (list minfret (let ((upfret (- (+ minfret fret-count) 1))) (if (> maxfret upfret) maxfret upfret))))) + (set! capo-fret (1+ (- capo-fret minfret))) ; subtract fret from dots (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-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 (subtract-base-fret base-fret dot-list) "Subtract @var{base-fret} from every fret in @var{dot-list}" @@ -54,7 +60,7 @@ (subtract-base-fret base-fret (cdr dot-list)))))) (define (sans-serif-stencil layout props mag text) - "create a stencil in sans-serif font based on @var{layout} and @var{props} + "Create a stencil in sans-serif font based on @var{layout} and @var{props} with magnification @var{mag} of the string @var{text}." (let* ((my-props (prepend-alist-chain @@ -70,18 +76,11 @@ Line thickness is given by @var{th}, fret & string spacing by (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1)) (sl (* (+ fret-count 1) size)) (sth (* size th)) - (half-thickness (* sth 0.5)) (gap (- size sth)) (string-stencil (if (eq? orientation 'normal) - (ly:make-stencil - (list 'draw-line sth 0 0 0 sl) - (cons (- half-thickness) half-thickness) - (cons (- half-thickness) (+ sl half-thickness))) - (ly:make-stencil - (list 'draw-line sth 0 0 sl 0) - (cons (- half-thickness) (+ sl half-thickness)) - (cons (- half-thickness) half-thickness))))) + (make-line-stencil sth 0 0 0 sl) + (make-line-stencil sth 0 0 sl 0)))) (if (= string-count 1) string-stencil (if (eq? orientation 'normal) @@ -125,16 +124,10 @@ fret & string spacing by @var{size}. Orientation is given by @var{orientation}" (sth (* size th)) (half-thickness (* sth 0.5))) (if (eq? orientation 'normal) - (ly:make-stencil - (list 'draw-line sth half-thickness size + (make-line-stencil sth half-thickness size (- fret-length half-thickness) size) - (cons 0 fret-length) - (cons (- half-thickness) half-thickness)) - (ly:make-stencil - (list 'draw-line sth 0 half-thickness - 0 (- fret-length half-thickness)) - (cons (- half-thickness) half-thickness) - (cons 0 fret-length))))) + (make-line-stencil sth 0 half-thickness + 0 (- fret-length half-thickness))))) (define (draw-thick-zero-fret details string-count th size orientation) "Draw a thick zeroth fret for a fret diagram whose base fret is not 1." @@ -147,13 +140,33 @@ fret & string spacing by @var{size}. Orientation is given by @var{orientation}" (y1 (- half-thick)) (y2 (+ top-fret-thick half-thick)) (x-extent (cons (- x1) x2)) - (y-extent (cons 0 y2))) + (y-extent (cons sth top-fret-thick))) (if (eq? orientation 'normal) (ly:make-stencil (list 'round-filled-box x1 x2 y1 y2 sth) x-extent y-extent) (ly:make-stencil (list 'round-filled-box y1 y2 x1 x2 sth) y-extent x-extent)))) +(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 fret capo-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 (if (eq? orientation 'normal) + (+ 2 (- fret-count fret dot-pos)) + (1- (+ dot-pos fret)))))) + (if (eq? orientation 'normal) + (make-line-stencil capo-thick + last-string-pos fret-pos first-string-pos fret-pos) + (make-line-stencil capo-thick + fret-pos last-string-pos fret-pos first-string-pos)))) + + (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}. @@ -176,7 +189,7 @@ Line thickness is given by @var{th}, fret & string spacing by (- size th))))) (define (draw-dots layout props string-count fret-count - fret-range size finger-code + size finger-code dot-position dot-radius dot-thickness dot-list orientation) "Make dots for fret diagram." @@ -185,7 +198,7 @@ Line thickness is given by @var{th}, fret & string spacing by (scale-dot-thick (* size dot-thickness)) (dot-color (assoc-get 'dot-color details 'black)) (finger-xoffset -0.25) - (finger-yoffset (- (* size 0.5))) + (finger-yoffset (* -0.5 size )) (dot-label-font-mag (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0))) (string-label-font-mag @@ -259,7 +272,7 @@ Line thickness is given by @var{th}, fret & string spacing by labeled-dot-stencil (ly:stencil-add (draw-dots - layout props string-count fret-count fret-range size finger-code + layout props string-count fret-count size finger-code dot-position dot-radius dot-thickness restlist orientation) labeled-dot-stencil)))) @@ -295,7 +308,7 @@ Line thickness is given by @var{th}, fret & string spacing by glyph-stencil)))) (define (make-bezier-sandwich-list start stop base height thickness orientation) - " Make the argument list for a bezier sandwich from + "Make the argument list for a bezier sandwich from @var{start} to @var{stop} with a baseline at @var{base}, a height of @var{height}, and a thickness of @var{thickness}. If @var{orientation} is @var{'normal}, @var{base} is a y coordinate, otherwise it's an x coordinate." @@ -366,7 +379,8 @@ Line thickness is given by @var{th}, fret & string spacing by (make-bezier-sandwich-list (* size barre-start-string-coordinate) (* size barre-end-string-coordinate) - (* size (+ 1 (- top-fret fret) barre-fret-coordinate)) + (* size (+ 2 (- top-fret + (+ low-fret barre-fret-coordinate)))) (* size bezier-height) (* size bezier-thick) orientation) @@ -380,25 +394,13 @@ Line thickness is given by @var{th}, fret & string spacing by (barre-stencil (if (eq? barre-type 'straight) (if (eq? orientation 'normal) - (ly:make-stencil - (list - 'draw-line (* size dot-radius) left dot-center-y - right dot-center-y) - (cons left right) - (cons (- dot-center-y scale-dot-radius) - (+ dot-center-y scale-dot-radius))) - (ly:make-stencil - (list 'draw-line (* size dot-radius) + (make-line-stencil scale-dot-radius left dot-center-y + right dot-center-y) + (make-line-stencil scale-dot-radius (* size barre-fret-coordinate) (* size barre-start-string-coordinate) (* size barre-fret-coordinate) - (* size barre-end-string-coordinate)) - (cons (- (* size barre-fret-coordinate) - scale-dot-radius) - (+ (* size barre-fret-coordinate) - scale-dot-radius)) - (cons (* size barre-start-string-coordinate) - (* size barre-end-string-coordinate)))) + (* size barre-end-string-coordinate))) (if (eq? orientation 'normal) (ly:make-stencil (list 'bezier-sandwich @@ -435,12 +437,12 @@ Line thickness is given by @var{th}, fret & string spacing by (label-text (cond ((equal? number-type 'roman-lower) - (fancy-format #f "~(~:@r~)" base-fret)) + (fancy-format #f "~(~@r~)" base-fret)) ((equal? number-type 'roman-upper) - (fancy-format #f "~:@r" base-fret)) + (fancy-format #f "~@r" base-fret)) ((equal? 'arabic number-type) (fancy-format #f "~d" base-fret)) - (else (fancy-format #f "~(~:@r~)" base-fret))))) + (else (fancy-format #f "~(~@r~)" base-fret))))) (if (eq? orientation 'normal) (ly:stencil-translate-axis (sans-serif-stencil layout props (* size label-font-mag) label-text) @@ -450,8 +452,8 @@ Line thickness is given by @var{th}, fret & string spacing by (* size (+ 1 label-vertical-offset)) X)))) (define-builtin-markup-command (fret-diagram-verbose layout props marking-list) - (list?) ; argument type - fret-diagram ; markup type + (pair?) ; argument type (list, but use pair? for speed) + instrument-specific-markup ; markup type ((align-dir -0.4) ; properties and defaults (size 1.0) (fret-diagram-details) @@ -482,6 +484,11 @@ Place a small @q{o} at the top of string @var{string-number}. Place a barre indicator (much like a tie) from string @var{start-string} to string @var{end-string} at fret @var{fret-number}. +@item (capo @var{fret-number}) +Place a capo indicator (a large solid bar) across the entire fretboard +at fret location @var{fret-number}. Also, set fret @var{fret-number} +to be the lowest fret on the fret diagram. + @item (place-fret @var{string-number} @var{fret-number} @var{finger-value}) Place a fret playing indication on string @var{string-number} at fret @var{fret-number} with an optional fingering label @var{finger-value}. @@ -496,7 +503,7 @@ indications per string. (make-fret-diagram layout props marking-list)) (define (make-fret-diagram layout props marking-list) - " Make a fret diagram markup" + "Make a fret diagram markup" (let* ( ; note: here we get items from props that are needed in this routine, ; or that are needed in more than one of the procedures @@ -543,15 +550,20 @@ indications per string. (label-space (* 0.25 size)) (label-dir (assoc-get 'label-dir details RIGHT)) (parameters (fret-parse-marking-list marking-list fret-count)) + (capo-fret (assoc-get 'capo-fret parameters 0)) (dot-list (cdr (assoc 'dot-list parameters))) (xo-list (cdr (assoc 'xo-list parameters))) (fret-range (cdr (assoc 'fret-range parameters))) + (fret-count (1+ (- (cadr fret-range) (car fret-range)))) (barre-list (cdr (assoc 'barre-list parameters))) + (barre-type + (assoc-get 'barre-type details 'curved)) (fret-diagram-stencil (ly:stencil-add (draw-strings string-count fret-range th size orientation) (draw-frets fret-range string-count th size orientation)))) - (if (not (null? barre-list)) + (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 @@ -562,7 +574,7 @@ indications per string. (set! fret-diagram-stencil (ly:stencil-add fret-diagram-stencil - (draw-dots layout props string-count fret-count fret-range + (draw-dots layout props string-count fret-count size finger-code dot-position dot-radius th dot-list orientation)))) (if (= (car fret-range) 1) @@ -589,6 +601,12 @@ indications per string. (draw-xo layout props string-count fret-range size xo-list orientation) xo-padding)))) + (if (> capo-fret 0) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (draw-capo details string-count capo-fret fret-count + th size dot-position orientation)))) (if (> (car fret-range) 1) (set! fret-diagram-stencil (if (eq? orientation 'normal) @@ -606,7 +624,7 @@ indications per string. (define-builtin-markup-command (fret-diagram layout props definition-string) (string?) ; argument type - fret-diagram ; markup category + instrument-specific-markup ; markup category (fret-diagram-verbose-markup) ; properties and defaults "Make a (guitar) fret diagram. For example, say @@ -682,7 +700,7 @@ Note: There is no limit to the number of fret indications per string. layout (car definition-list) (cdr definition-list)))) (define (fret-parse-definition-string props definition-string) - "parse a fret diagram string and return a pair containing: + "Parse a fret diagram string and return a pair containing: props, modified as necessary by the definition-string a fret-indication list with the appropriate values" (let* ((fret-count 4) @@ -750,7 +768,7 @@ Note: There is no limit to the number of fret indications per string. `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better (define (cons-fret new-value old-list) - " Put together a fret-list in the format desired by parse-string " + "Put together a fret-list in the format desired by parse-string" (if (eq? old-list '()) (list new-value) (cons* new-value old-list))) @@ -772,7 +790,7 @@ Note: There is no limit to the number of fret indications per string. (define-builtin-markup-command (fret-diagram-terse layout props definition-string) (string?) ; argument type - fret-diagram ; markup category + instrument-specific-markup ; markup category (fret-diagram-verbose-markup) ; properties "Make a fret diagram markup using terse string-based syntax. @@ -823,7 +841,8 @@ with @code{-(} to start a barre and @code{-)} to end the barre. (car definition-list) (cdr definition-list)))) -(define (fret-parse-terse-definition-string props definition-string) +(define-public + (fret-parse-terse-definition-string props definition-string) "Parse a fret diagram string that uses terse syntax; return a pair containing: props, modified to include the string-count determined by the definition-string, and @@ -896,7 +915,7 @@ with @code{-(} to start a barre and @code{-)} to end the barre. `(,props . ,output-list))) ; ugh -- hard coded; proc is better (define (drop-paren item-list) - " drop a final parentheses from a fret indication list + "Drop a final parentheses from a fret indication list resulting from a terse string specification of barre." (if (> (length item-list) 0) (let* ((max-index (- (length item-list) 1)) @@ -907,7 +926,7 @@ with @code{-(} to start a barre and @code{-)} to end the barre. item-list)) (define (get-sub-list value master-list) - " Get a sub-list whose cadr is equal to @var{value} from @var{master-list}" + "Get a sub-list whose cadr is equal to @var{value} from @var{master-list}" (if (eq? master-list '()) #f (let ((sublist (car master-list)))