From: Carl Sorensen Date: Fri, 9 Jan 2009 04:37:59 +0000 (-0700) Subject: Merge branch 'master' of carldsorensen@git.sv.gnu.org:/srv/git/lilypond into fret... X-Git-Tag: release/2.12.2-1~42 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=a9d9433bc7b95cb2d4b3d96eefce7a8437c0d44e;hp=-c;p=lilypond.git Merge branch 'master' of carldsorensen@git.sv.gnu.org:/srv/git/lilypond into fret-update --- a9d9433bc7b95cb2d4b3d96eefce7a8437c0d44e diff --combined scm/define-grob-properties.scm index 33c21171ac,e7e37995a2..302f26f1a7 --- a/scm/define-grob-properties.scm +++ b/scm/define-grob-properties.scm @@@ -2,7 -2,7 +2,7 @@@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; - ;;;; (c) 1998--2008 Han-Wen Nienhuys + ;;;; (c) 1998--2009 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen (define (define-grob-property symbol type? description) @@@ -79,6 -79,14 +79,14 @@@ specifies which beams to make. @code{0 @code{1}@tie{}is the next beam toward the note, etc. This information is used to determine how to connect the beaming patterns from stem to stem inside a beam.") + (beamlet-default-length ,pair? "A pair of numbers. The first number + specifies the default length of a beamlet that sticks out of the left hand + side of this stem; the second number specifies the default length of the + beamlet to the right. The actual length of a beamlet is determined by + taking either the default length or the length specified by + @code{beamlet-max-length-proportion}, whichever is smaller.") + (beamlet-max-length-proportion ,pair? "The maximum length of a beamlet, + as a proportion of the distance between two adjacent stems.") (before-line-breaking ,boolean? "Dummy property, used to trigger a callback function.") (between-cols ,pair? "Where to attach a loose column to.") @@@ -267,10 -275,6 +275,10 @@@ multiples of fret-space. Default valu @code{dot-label-font-mag} -- Magnification for font used to label fret dots. Default value 1. @item +@code{dot-position} -- Location of dot in fret space. Default +0.6 for dots without labels, 0.95-@code{dot-radius} for dots with +labels. +@item @code{dot-radius} -- Radius of dots, in terms of fret spaces. Default value 0.425 for labeled dots, 0.25 for unlabeled dots. @item @@@ -284,8 -288,8 +292,8 @@@ Options include @code{none}, @code{in-d @code{fret-label-font-mag} -- The magnification of the font used to label the lowest fret number. Default 0.5 @item -@code{fret-label-vertical-offset} -- The vertical offset of the fret label -from the fret. Default -0.2 +@code{fret-label-vertical-offset} -- The offset of the fret label +from the center of the fret in direction parallel to strings. Default 0. @item @code{label-dir} -- Side to which the fret label is attached. @code{-1}, @code{#LEFT}, or @code{#DOWN} for left or down; @@@ -303,15 -307,12 +311,15 @@@ include @code{roman-lower}, @code{roman string. Default \"o\". @item @code{orientation} -- Orientation of fret-diagram. Options include -@code{normal} and @code{landscape}. Default @code{normal}. +@code{normal}, @code{landscape}, and @code{opposing-landscape}. +Default @code{normal}. @item @code{string-count} -- The number of strings. Default 6. @item @code{string-label-font-mag} -- The magnification of the font used to label -fingerings at the string, rather than in the dot. Default value 0.6. +fingerings at the string, rather than in the dot. Default value 0.6 for +@code{normal} orientation, 0.5 for @code{landscape} and +@code{opposing-landscape}. @item @code{top-fret-thickness} -- The thickness of the top fret line, as a multiple of the standard thickness. Default value 3. diff --combined scm/fret-diagrams.scm index ebd79049a1,3a0ffe53ce..fab6868fd3 --- a/scm/fret-diagrams.scm +++ b/scm/fret-diagrams.scm @@@ -2,40 -2,51 +2,40 @@@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; - ;;;; (c) 2004--2008 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 '()) - (output-alist '())) - (let parse-item ((mylist marking-list)) - (if (not (null? mylist)) - (let* ((my-item (car mylist)) (my-code (car my-item))) - (cond - ((or (eq? my-code 'open)(eq? my-code 'mute)) - (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 (if (> capo-fret 0) capo-fret 99))) - (let updatemax ((fret-list dot-list)) - (if (null? fret-list) - '() - (let ((fretval (second (car fret-list)))) - (if (> fretval maxfret) (set! maxfret fretval)) - (if (< fretval minfret) (set! minfret fretval)) - (updatemax (cdr fret-list))))) - (if (> maxfret fret-count) - (set! fret-range - (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 'capo-fret capo-fret '()))))))) +; +; Utility functions +; +; + +(define (cons-fret new-value old-list) + "Put together a fret-list in the format desired by parse-string" + (if (eq? old-list '()) + (list new-value) + (cons* new-value old-list))) + +(define (get-numeric-from-key keystring) + "Get the numeric value from a key of the form k:val" + (string->number (substring keystring 2 (string-length keystring)))) + +(define (numerify mylist) + "Convert string values to numeric or character" + (if (null? mylist) + '() + (let ((numeric-value (string->number (car mylist)))) + (if numeric-value + (cons* numeric-value (numerify (cdr mylist))) + (cons* (car (string->list (car mylist))) + (numerify (cdr mylist))))))) + +(define (stepmag mag) + "Calculate the font step necessary to get a desired magnification" + (* 6 (/ (log mag) (log 2)))) + +(define (fret-count fret-range) + "Calculate the fret count for the diagram given the range of frets in the diagram." + (1+ (- (cdr fret-range) (car fret-range)))) (define (subtract-base-fret base-fret dot-list) "Subtract @var{base-fret} from every fret in @var{dot-list}" @@@ -48,149 -59,6 +48,149 @@@ (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." + (if (> (length item-list) 0) + (let* ((max-index (- (length item-list) 1)) + (last-element (car (list-tail item-list max-index)))) + (if (or (equal? last-element ")") (equal? last-element "(")) + (list-head item-list max-index) + item-list)) + item-list)) + +(define (get-sub-list value 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))) + (if (equal? (cadr sublist) value) + sublist + (get-sub-list value (cdr master-list)))))) + +(define (merge-details key alist-list . default) + "Return @code{alist-list} entries for @code{key}, in one combined alist. +There can be two @code{alist-list} entries for a given key. The first +comes from the override-markup function, the second comes +from property settings during a regular override. +This is necessary because some details can be set in one +place, while others are set in the other. Both details +lists must be merged into a single alist. +Return @code{default} (optional, else #f) if not +found." + + (define (helper key alist-list default) + (if (null? alist-list) + default + (let* ((handle (assoc key (car alist-list)))) + (if (pair? handle) + (append (cdr handle) (chain-assoc-get key (cdr alist-list) '())) + (helper key (cdr alist-list) default))))) + + (helper key alist-list + (if (pair? default) (car default) #f))) + +; +; Conversions between fret/string coordinate system and x-y coordinate +; system. +; +; Fret coordinates are measured down the fretboard from the nut, +; starting at 0. +; +; String coordinates are measured from the lowest string, starting at 0. +; +; The x-y origin is at the intersection of the nut and the lowest string. +; +; X coordinates are positive to the right. +; Y coordinates are positive up. +; + +(define (negate-extent extent) + "Return the extent in an axis opposite to the axis of @code{extent}." + (cons (- (cdr extent)) (- (car extent)))) + +(define (stencil-fretboard-extent stencil fretboard-axis orientation) + "Return the extent of @code{stencil} in the @code{fretboard-axis} +direction." + (if (eq? fretboard-axis 'fret) + (cond ((eq? orientation 'landscape) + (ly:stencil-extent stencil X)) + ((eq? orientation 'opposing-landscape) + (negate-extent (ly:stencil-extent stencil X))) + (else + (negate-extent (ly:stencil-extent stencil Y)))) + ; else -- eq? fretboard-axis 'string + (cond ((eq? orientation 'landscape) + (ly:stencil-extent stencil Y)) + ((eq? orientation 'opposing-landscape) + (negate-extent (ly:stencil-extent stencil Y))) + (else + (ly:stencil-extent stencil Y))))) + + +(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 + (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))))) + +; +; Functions that create stencils used in the fret diagram +; + (define (sans-serif-stencil layout props mag text) "Create a stencil in sans-serif font based on @var{layout} and @var{props} with magnification @var{mag} of the string @var{text}." @@@ -200,704 -68,390 +200,704 @@@ (prepend-alist-chain 'font-family 'sans props)))) (interpret-markup layout my-props text))) -(define (draw-strings string-count fret-range th size orientation) + +(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}. " - (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1)) - (sl (* (+ fret-count 1) size)) - (sth (* size th)) - (gap (- size sth)) - (string-stencil - (if (eq? orientation 'normal) - (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) - (ly:stencil-combine-at-edge - (draw-strings (- string-count 1) fret-range th size orientation) - X RIGHT - string-stencil - gap) - (ly:stencil-combine-at-edge - (draw-strings (- string-count 1) fret-range th size orientation) - Y UP - string-stencil - gap))))) + + (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}" - (let* ((sth (* size th)) - (gap (- size sth)) - (fret-line (draw-fret-line string-count th size orientation))) - (if (= fret-count 1) - fret-line - (if (eq? orientation 'normal) - (ly:stencil-combine-at-edge - (draw-fret-lines - (- fret-count 1) string-count th size orientation) - Y UP - fret-line - gap 0) - (ly:stencil-combine-at-edge - (draw-fret-lines - (- fret-count 1) string-count th size orientation) - X RIGHT - fret-line - gap 0))))) - -(define (draw-fret-line string-count th size orientation) - "Draw a fret line for a fret diagram." - (let* ((fret-length (* (- string-count 1) size)) - (sth (* size th)) - (half-thickness (* sth 0.5))) - (if (eq? orientation 'normal) - (make-line-stencil sth half-thickness size - (- fret-length half-thickness) size) - (make-line-stencil sth 0 half-thickness - 0 (- fret-length half-thickness))))) + (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 not 1." + "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))) - (half-thick (* sth 0.5)) - (x1 half-thick) - (x2 (+ half-thick (* size (- string-count 1)))) - (y1 (- half-thick)) - (y2 (+ top-fret-thick half-thick)) - (x-extent (cons (- x1) x2)) - (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)))) + (* 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 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)))) - +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* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1)) - (fret-length (* (- string-count 1) size)) - (half-thickness (* th 0.5)) - (base-fret (car fret-range)) - (fret-zero (draw-fret-line string-count th size orientation))) - (if (eq? orientation 'normal) - (ly:stencil-combine-at-edge - (draw-fret-lines fret-count string-count th size orientation) - Y UP - fret-zero - (- size th)) - (ly:stencil-combine-at-edge - fret-zero X RIGHT - (draw-fret-lines fret-count string-count th size orientation) - (- size th))))) + (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 (chain-assoc-get 'fret-diagram-details props '())) + (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-xoffset -0.25) - (finger-yoffset (* -0.5 size )) + (finger-label-padding 0.3) (dot-label-font-mag - (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0))) + (* scale-dot-radius (assoc-get 'dot-label-font-mag details 1.0))) (string-label-font-mag - (* size (assoc-get 'string-label-font-mag details 0.6))) + (* 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)) - (xpos (* size (if (eq? orientation 'normal) - (- string-count string) - (+ (- fret 1 ) dot-position)))) - (ypos (* size (if (eq? orientation 'normal) - (+ 2 (- fret-count fret dot-position )) - (- string-count string)))) + (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)) - (dotstencil (if (eq? dot-color 'white) - (ly:stencil-add - (make-circle-stencil + (dot-stencil (if (eq? dot-color 'white) + (ly:stencil-add + (make-circle-stencil scale-dot-radius scale-dot-thick #t) - (ly:stencil-in-color + (ly:stencil-in-color (make-circle-stencil - (- scale-dot-radius (* 0.5 scale-dot-thick)) - 0 #t) + (- 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 (begin - (ly:stencil-translate-axis - (ly:stencil-translate-axis dotstencil xpos X) - ypos Y))) - (labeled-dot-stencil - (if (or (eq? finger '())(eq? finger-code 'none)) - positioned-dot - (if (eq? finger-code 'in-dot) - (let* ((finger-label - (centered-stencil - (sans-serif-stencil - layout props dot-label-font-mag finger)))) - (ly:stencil-translate-axis - (ly:stencil-translate-axis - (ly:stencil-add - dotstencil - (if (eq? dot-color 'white) - finger-label - (ly:stencil-in-color finger-label 1 1 1))) - xpos X) - ypos Y)) - (if (eq? finger-code 'below-string) - (ly:stencil-add - positioned-dot - (if (eq? orientation 'normal) - (ly:stencil-translate-axis - (ly:stencil-translate-axis - (centered-stencil - (sans-serif-stencil - layout props string-label-font-mag finger)) - xpos X) - (* size finger-yoffset) Y) - (ly:stencil-translate-axis - (ly:stencil-translate-axis - (centered-stencil - (sans-serif-stencil - layout props string-label-font-mag finger)) - (* size (+ 2 fret-count finger-yoffset)) X) - ypos Y))) - ;unknown finger-code - positioned-dot))))) + (make-circle-stencil + scale-dot-radius scale-dot-thick #t))) + (positioned-dot (translate-stencil 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)))) + (translate-stencil + (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 + (translate-stencil label-stencil label-translation)))) + (else ;unknown finger-code + positioned-dot)))) (if (null? restlist) - labeled-dot-stencil - (ly:stencil-add - (draw-dots + 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)))) + labeled-dot-stencil)))) -(define (draw-xo layout props string-count fret-range size xo-list orientation) +(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 (chain-assoc-get 'fret-diagram-details props '())) - (fret-count (+ (- (cadr fret-range) (car fret-range) 1))) + (let* ((details (merge-details 'fret-diagram-details props '())) (xo-font-mag - (* size (assoc-get 'xo-font-magnification details 0.5))) - (xo-horizontal-offset (* size -0.35)) + (* 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"))) - (xpos - (+ (* (- string-count (cadr mypair)) size) xo-horizontal-offset )) - (glyph-stencil (if (eq? orientation 'normal) - (ly:stencil-translate-axis - (sans-serif-stencil - layout props (* size xo-font-mag) glyph-string) - xpos X) - (ly:stencil-translate-axis - (sans-serif-stencil - layout props (* size xo-font-mag) glyph-string) - xpos Y)))) + (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 + (translate-stencil glyph-stencil glyph-stencil-coordinates))) (if (null? restlist) - glyph-stencil + positioned-glyph (ly:stencil-add (draw-xo layout props string-count fret-range size restlist orientation) - glyph-stencil)))) - -(define (make-bezier-sandwich-list start stop base height thickness orientation) - "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." - (let* ((width (+ (- stop start) 1)) - (x1 (+ (* width thickness) start)) - (x2 (- stop (* width thickness))) - (bottom-control-point-height - (if (eq? orientation 'normal) - (+ base (- height thickness)) - (- base (- height thickness)))) - (top-control-point-height - (if (eq? orientation 'normal) - (+ base height) - (- base height)))) - ; 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. - (if (eq? orientation 'normal) - (list (cons x1 bottom-control-point-height) - (cons x2 bottom-control-point-height) - (cons stop base) - (cons start base) - (cons x2 top-control-point-height) - (cons x1 top-control-point-height) - (cons start base) - (cons stop base)) - (list (cons bottom-control-point-height x1) - (cons bottom-control-point-height x2) - (cons base stop) - (cons base start) - (cons top-control-point-height x2) - (cons top-control-point-height x1) - (cons base start) - (cons base stop))))) + positioned-glyph)))) (define (draw-barre layout props string-count fret-range - size finger-code dot-position dot-radius - barre-list orientation) + size finger-code dot-position dot-radius + barre-list orientation) "Create barre indications for a fret diagram" (if (not (null? barre-list)) - (let* ((details (chain-assoc-get 'fret-diagram-details props '())) - (string1 (caar barre-list)) - (string2 (cadar barre-list)) - (fret (caddar barre-list)) - (top-fret (cadr fret-range)) - (low-fret (car fret-range)) - (barre-type (assoc-get 'barre-type details 'curved)) - (scale-dot-radius (* size dot-radius)) - (barre-vertical-offset 0.5) - ;; 2 is 1 for empty fret at bottom of figure + 1 for interval - ;; (top-fret - fret + 1) -- not an arbitrary constant - (dot-center-y - (* size (- (+ 2 (- (cadr fret-range) fret)) dot-position))) - (dot-center-fret-coordinate (+ (- fret low-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)) - (bottom - (+ dot-center-y (* barre-vertical-offset scale-dot-radius))) - (left (* size (- string-count string1))) - (right (* size (- string-count string2))) - (bezier-thick 0.1) - (bezier-height 0.5) - (bezier-list - (if (eq? orientation 'normal) - (make-bezier-sandwich-list - (* size barre-start-string-coordinate) - (* size barre-end-string-coordinate) - (* size (+ 2 (- top-fret - (+ low-fret barre-fret-coordinate)))) - (* size bezier-height) - (* size bezier-thick) - orientation) - (make-bezier-sandwich-list - (* size barre-start-string-coordinate) - (* size barre-end-string-coordinate) - (* size barre-fret-coordinate) - (* size bezier-height) - (* size bezier-thick) - orientation))) + (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 - (if (eq? barre-type 'straight) - (if (eq? orientation 'normal) - (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))) - (if (eq? orientation 'normal) - (ly:make-stencil - (list 'bezier-sandwich - `(quote ,bezier-list) - (* size bezier-thick)) - (cons left right) - (cons bottom (+ bottom (* size bezier-height)))) - (ly:make-stencil - (list 'bezier-sandwich - `(quote ,bezier-list) - (* size bezier-thick)) - (cons bottom (+ bottom (* size bezier-height))) - (cons left right)))))) - (if (not (null? (cdr barre-list))) + (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))) + barre-stencil + (draw-barre layout props string-count fret-range size finger-code + dot-position dot-radius (cdr barre-list) orientation)) barre-stencil )))) -(define (stepmag mag) - "Calculate the font step necessary to get a desired magnification" - (* 6 (/ (log mag) (log 2)))) - (define (label-fret layout props string-count fret-range size orientation) "Label the base fret on a fret diagram" - (let* ((details (chain-assoc-get 'fret-diagram-details props '())) - (base-fret (car fret-range)) - (label-font-mag (assoc-get 'fret-label-font-mag details 0.5)) - (label-vertical-offset - (assoc-get 'fret-label-vertical-offset details -0.2)) - (number-type (assoc-get 'number-type details 'roman-lower)) - (fret-count (+ (- (cadr fret-range) (car fret-range)) 1)) - (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))))) - (if (eq? orientation 'normal) - (ly:stencil-translate-axis - (sans-serif-stencil layout props (* size label-font-mag) label-text) - (* size (+ fret-count label-vertical-offset)) Y) - (ly:stencil-translate-axis - (sans-serif-stencil layout props (* size label-font-mag) label-text) - (* size (+ 1 label-vertical-offset)) X)))) - -(define-builtin-markup-command (fret-diagram-verbose layout props marking-list) + (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))) + (translate-stencil + 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 +;; +;; +;; + +(define (fret-parse-marking-list marking-list my-fret-count) + "Parse a fret-diagram-verbose marking list into component sublists" + (let* ((fret-range (cons 1 my-fret-count)) + (capo-fret 0) + (barre-list '()) + (dot-list '()) + (xo-list '()) + (output-alist '())) + (let parse-item ((mylist marking-list)) + (if (not (null? mylist)) + (let* ((my-item (car mylist)) (my-code (car my-item))) + (cond + ((or (eq? my-code 'open)(eq? my-code 'mute)) + (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 (if (> capo-fret 0) capo-fret 99))) + (let updatemax ((fret-list dot-list)) ;CHANGE THIS TO HELPER FUNCTION? + (if (null? fret-list) + '() + (let ((fretval (second (car fret-list)))) + (if (> fretval maxfret) (set! maxfret fretval)) + (if (< fretval minfret) (set! minfret fretval)) + (updatemax (cdr fret-list))))) + (if (> maxfret my-fret-count) + (set! fret-range + (cons minfret + (let ((upfret (- (+ minfret my-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 'capo-fret capo-fret '()))))))) + +(define (make-fret-diagram layout props marking-list) + "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 + ; 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 + (details (merge-details 'fret-diagram-details props '())) + (string-count + (assoc-get 'string-count details 6)) ; needed for everything + (my-fret-count + (assoc-get 'fret-count details 4)) ; needed for everything + (orientation + (assoc-get 'orientation details 'normal)) ; needed for everything + (finger-code + (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 + (dot-radius + (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 + (th + (* (ly:output-def-lookup layout 'line-thickness) + (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets + ; and draw-strings + (thickness-factor (assoc-get 'string-thickness-factor details 0)) + (alignment + (chain-assoc-get 'align-dir props -0.4)) ; needed only here + (xo-padding + (* 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))) + (xo-list (cdr (assoc 'xo-list parameters))) + (fret-range (cdr (assoc 'fret-range 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 + (ly:stencil-add + (draw-strings + string-count fret-range th thickness-factor size orientation) + (draw-frets fret-range string-count th size orientation)))) + (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))) + (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)))) + (if (= (car fret-range) 1) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (draw-thick-zero-fret + details string-count th 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 + (translate-stencil + xo-stencil + (stencil-coordinates + (- diagram-fret-top + xo-fret-offset + (* size xo-padding)) + 0 ; no string offset + orientation)))))) + + (if (> capo-fret 0) + (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)))) + (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 + (ly:stencil-aligned-to fret-diagram-stencil X alignment) + Y 0))) + +(define (fret-parse-definition-string props definition-string) + "Parse a fret diagram string and return a pair containing: +@var{props}, modified as necessary by the definition-string +a fret-indication list with the appropriate values" + (let* ((fret-count 4) + (string-count 6) + (fret-range (cons 1 fret-count)) + (barre-list '()) + (dot-list '()) + (xo-list '()) + (output-list '()) + (new-props '()) + (details (merge-details 'fret-diagram-details props '())) + (items (string-split definition-string #\;))) + (let parse-item ((myitems items)) + (if (not (null? (cdr myitems))) + (let ((test-string (car myitems))) + (case (car (string->list (substring test-string 0 1))) + ((#\s) (let ((size (get-numeric-from-key test-string))) + (set! props (prepend-alist-chain 'size size props)))) + ((#\f) (let* ((finger-code (get-numeric-from-key test-string)) + (finger-id (case finger-code + ((0) 'none) + ((1) 'in-dot) + ((2) 'below-string)))) + (set! details + (acons 'finger-code finger-id details)))) + ((#\c) (set! output-list + (cons-fret + (cons + 'barre + (numerify + (string-split (substring test-string 2) #\-))) + output-list))) + ((#\h) (let ((fret-count (get-numeric-from-key test-string))) + (set! details + (acons 'fret-count fret-count details)))) + ((#\w) (let ((string-count (get-numeric-from-key test-string))) + (set! details + (acons 'string-count string-count details)))) + ((#\d) (let ((dot-size (get-numeric-from-key test-string))) + (set! details + (acons 'dot-radius dot-size details)))) + ((#\p) (let ((dot-position (get-numeric-from-key test-string))) + (set! details + (acons 'dot-position dot-position details)))) + (else + (let ((this-list (string-split test-string #\-))) + (if (string->number (cadr this-list)) + (set! output-list + (cons-fret + (cons 'place-fret (numerify this-list)) + output-list)) + (if (equal? (cadr this-list) "x" ) + (set! output-list + (cons-fret + (list 'mute (string->number (car this-list))) + output-list)) + (set! output-list + (cons-fret + (list 'open (string->number (car this-list))) + output-list))))))) + (parse-item (cdr myitems))))) + ; add the modified details + (set! props + (prepend-alist-chain 'fret-diagram-details details props)) + `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better + +(define-public + (fret-parse-terse-definition-string props definition-string) + "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 +a fret-indication list with the appropriate values" +;TODO -- change syntax to fret\string-finger + + (let* ((details (merge-details 'fret-diagram-details props '())) + (barre-start-list '()) + (output-list '()) + (new-props '()) + (items (string-split definition-string #\;)) + (string-count (- (length items) 1))) + (let parse-item ((myitems items)) + (if (not (null? (cdr myitems))) + (let* ((test-string (car myitems)) + (current-string (- (length myitems) 1)) + (indicators (string-split test-string #\ ))) + (let parse-indicators ((myindicators indicators)) + (if (not (eq? '() myindicators)) + (let* ((this-list (string-split (car myindicators) #\-)) + (max-element-index (- (length this-list) 1)) + (last-element + (car (list-tail this-list max-element-index))) + (fret + (if (string->number (car this-list)) + (string->number (car this-list)) + (car this-list)))) + (if (equal? last-element "(") + (begin + (set! barre-start-list + (cons-fret (list current-string fret) + barre-start-list)) + (set! this-list + (list-head this-list max-element-index)))) + (if (equal? last-element ")") + (let* ((this-barre + (get-sub-list fret barre-start-list)) + (insert-index (- (length this-barre) 1))) + (set! output-list + (cons-fret (cons* 'barre + (car this-barre) + current-string + (cdr this-barre)) + output-list)) + (set! this-list + (list-head this-list max-element-index)))) + (if (number? fret) + (set! + output-list + (cons-fret (cons* + 'place-fret + current-string + (drop-paren (numerify this-list))) + output-list)) + (if (equal? (car this-list) "x" ) + (set! + output-list + (cons-fret + (list 'mute current-string) + output-list)) + (set! + output-list + (cons-fret + (list 'open current-string) + output-list)))) + (parse-indicators (cdr myindicators))))) + (parse-item (cdr myitems))))) + (set! details (acons 'string-count string-count details)) + (set! props (prepend-alist-chain 'fret-diagram-details details props)) + `(,props . ,output-list))) ; ugh -- hard coded; proc is better + + +(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 ((align-dir -0.4) ; properties and defaults @@@ -948,6 -502,125 +948,6 @@@ indications per string (make-fret-diagram layout props marking-list)) -(define (make-fret-diagram layout props marking-list) - "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 - ; 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 -- adjust padding for fret label? it appears to be too close to dots - (details - (chain-assoc-get - 'fret-diagram-details props '())) ; fret diagram details - (string-count - (assoc-get 'string-count details 6)) ; needed for everything - (fret-count - (assoc-get 'fret-count details 4)) ; needed for everything - (orientation - (assoc-get 'orientation details 'normal)) ; needed for everything - (finger-code - (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 - (dot-radius - (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 - (th - (* (ly:output-def-lookup layout 'line-thickness) - (chain-assoc-get 'thickness props 0.5))) ; needed for draw-frets - ; and draw-strings - (alignment - (chain-assoc-get 'align-dir props -0.4)) ; needed only here - (xo-padding - (* size (assoc-get 'xo-padding details 0.2))) ; needed only here - (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 (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))) - (if (not (null? dot-list)) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (draw-dots layout props string-count fret-count - size finger-code dot-position dot-radius - th dot-list orientation)))) - (if (= (car fret-range) 1) - (set! fret-diagram-stencil - (if (eq? orientation 'normal) - (ly:stencil-combine-at-edge - fret-diagram-stencil Y UP - (draw-thick-zero-fret - props string-count th size orientation)) - (ly:stencil-combine-at-edge - fret-diagram-stencil X LEFT - (draw-thick-zero-fret - props string-count th size orientation))))) - (if (not (null? xo-list)) - (set! fret-diagram-stencil - (if (eq? orientation 'normal) - (ly:stencil-combine-at-edge - fret-diagram-stencil Y UP - (draw-xo layout props string-count fret-range - size xo-list orientation) - xo-padding ) - (ly:stencil-combine-at-edge - fret-diagram-stencil X LEFT - (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) - (ly:stencil-combine-at-edge - fret-diagram-stencil X label-dir - (label-fret layout props string-count fret-range - size orientation) - label-space) - (ly:stencil-combine-at-edge - fret-diagram-stencil Y label-dir - (label-fret layout props string-count fret-range - size orientation) - label-space)))) - (ly:stencil-aligned-to fret-diagram-stencil X alignment))) (define-builtin-markup-command (fret-diagram layout props definition-string) (string?) ; argument type @@@ -1022,10 -695,98 +1022,10 @@@ by the @code{f:} code Note: There is no limit to the number of fret indications per string. @end itemize" (let ((definition-list - (fret-parse-definition-string props definition-string))) + (fret-parse-definition-string props definition-string))) (fret-diagram-verbose-markup 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: - props, modified as necessary by the definition-string - a fret-indication list with the appropriate values" - (let* ((fret-count 4) - (string-count 6) - (fret-range (list 1 fret-count)) - (barre-list '()) - (dot-list '()) - (xo-list '()) - (output-list '()) - (new-props '()) - (details (merge-details 'fret-diagram-details props '())) - (items (string-split definition-string #\;))) - (let parse-item ((myitems items)) - (if (not (null? (cdr myitems))) - (let ((test-string (car myitems))) - (case (car (string->list (substring test-string 0 1))) - ((#\s) (let ((size (get-numeric-from-key test-string))) - (set! props (prepend-alist-chain 'size size props)))) - ((#\f) (let* ((finger-code (get-numeric-from-key test-string)) - (finger-id (case finger-code - ((0) 'none) - ((1) 'in-dot) - ((2) 'below-string)))) - (set! details - (acons 'finger-code finger-id details)))) - ((#\c) (set! output-list - (cons-fret - (cons - 'barre - (numerify - (string-split (substring test-string 2) #\-))) - output-list))) - ((#\h) (let ((fret-count (get-numeric-from-key test-string))) - (set! details - (acons 'fret-count fret-count details)))) - ((#\w) (let ((string-count (get-numeric-from-key test-string))) - (set! details - (acons 'string-count string-count details)))) - ((#\d) (let ((dot-size (get-numeric-from-key test-string))) - (set! details - (acons 'dot-radius dot-size details)))) - ((#\p) (let ((dot-position (get-numeric-from-key test-string))) - (set! details - (acons 'dot-position dot-position details)))) - (else - (let ((this-list (string-split test-string #\-))) - (if (string->number (cadr this-list)) - (set! output-list - (cons-fret - (cons 'place-fret (numerify this-list)) - output-list)) - (if (equal? (cadr this-list) "x" ) - (set! output-list - (cons-fret - (list 'mute (string->number (car this-list))) - output-list)) - (set! output-list - (cons-fret - (list 'open (string->number (car this-list))) - output-list))))))) - (parse-item (cdr myitems))))) - ; add the modified details - (set! props - (prepend-alist-chain 'fret-diagram-details details props)) - `(,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" - (if (eq? old-list '()) - (list new-value) - (cons* new-value old-list))) - -(define (get-numeric-from-key keystring) - "Get the numeric value from a key of the form k:val" - (string->number (substring keystring 2 (string-length keystring)))) - -(define (numerify mylist) - "Convert string values to numeric or character" - (if (null? mylist) - '() - (let ((numeric-value (string->number (car mylist)))) - (if numeric-value - (cons* numeric-value (numerify (cdr mylist))) - (cons* (car (string->list (car mylist))) - (numerify (cdr mylist))))))) - (define-builtin-markup-command (fret-diagram-terse layout props definition-string) (string?) ; argument type @@@ -1075,9 -836,122 +1075,9 @@@ with @code{-(} to start a barre and @co @end itemize" ;; TODO -- change syntax to fret\string-finger (let ((definition-list - (fret-parse-terse-definition-string props definition-string))) + (fret-parse-terse-definition-string props definition-string))) (fret-diagram-verbose-markup layout - (car definition-list) - (cdr definition-list)))) + (car definition-list) + (cdr definition-list)))) -(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 - a fret-indication list with the appropriate values" -;TODO -- change syntax to fret\string-finger - - (let* ((details (merge-details 'fret-diagram-details props '())) - (barre-start-list '()) - (output-list '()) - (new-props '()) - (items (string-split definition-string #\;)) - (string-count (- (length items) 1))) - (let parse-item ((myitems items)) - (if (not (null? (cdr myitems))) - (let* ((test-string (car myitems)) - (current-string (- (length myitems) 1)) - (indicators (string-split test-string #\ ))) - (let parse-indicators ((myindicators indicators)) - (if (not (eq? '() myindicators)) - (let* ((this-list (string-split (car myindicators) #\-)) - (max-element-index (- (length this-list) 1)) - (last-element - (car (list-tail this-list max-element-index))) - (fret - (if (string->number (car this-list)) - (string->number (car this-list)) - (car this-list)))) - (if (equal? last-element "(") - (begin - (set! barre-start-list - (cons-fret (list current-string fret) - barre-start-list)) - (set! this-list - (list-head this-list max-element-index)))) - (if (equal? last-element ")") - (let* ((this-barre - (get-sub-list fret barre-start-list)) - (insert-index (- (length this-barre) 1))) - (set! output-list - (cons-fret (cons* 'barre - (car this-barre) - current-string - (cdr this-barre)) - output-list)) - (set! this-list - (list-head this-list max-element-index)))) - (if (number? fret) - (set! - output-list - (cons-fret (cons* - 'place-fret - current-string - (drop-paren (numerify this-list))) - output-list)) - (if (equal? (car this-list) "x" ) - (set! - output-list - (cons-fret - (list 'mute current-string) - output-list)) - (set! - output-list - (cons-fret - (list 'open current-string) - output-list)))) - (parse-indicators (cdr myindicators))))) - (parse-item (cdr myitems))))) - (set! details (acons 'string-count string-count details)) - (set! props (prepend-alist-chain 'fret-diagram-details details props)) - `(,props . ,output-list))) ; ugh -- hard coded; proc is better -(define (drop-paren item-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)) - (last-element (car (list-tail item-list max-index)))) - (if (or (equal? last-element ")") (equal? last-element "(")) - (list-head item-list max-index) - item-list)) - item-list)) - -(define (get-sub-list value 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))) - (if (equal? (cadr sublist) value) - sublist - (get-sub-list value (cdr master-list)))))) - -(define (merge-details key alist-list . default) - "Return ALIST-LIST entries for key, in one combined alist. - There can be two ALIST-LIST entries for a given key. The first - comes from the override-markup function, the second comes - from property settings during a regular override. - This is necessary because some details can be set in one - place, while others are set in the other. Both details - lists must be merged into a single alist. - Return DEFAULT (optional, else #f) if not - found." - - (define (helper key alist-list default) - (if (null? alist-list) - default - (let* ((handle (assoc key (car alist-list)))) - (if (pair? handle) - (append (cdr handle) (chain-assoc-get key (cdr alist-list) '())) - (helper key (cdr alist-list) default))))) - - (helper key alist-list - (if (pair? default) (car default) #f))) diff --combined scm/stencil.scm index 9067e0974e,aeea39a288..8513c6389a --- a/scm/stencil.scm +++ b/scm/stencil.scm @@@ -2,15 -2,8 +2,15 @@@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; - ;;;; (c) 2003--2008 Han-Wen Nienhuys + ;;;; (c) 2003--2009 Han-Wen Nienhuys +(define-public (translate-stencil stencil coordinate-pair) + "Translate @code{stencil} by the distances specified in +@code{coordinate-pair}." + (ly:stencil-translate-axis + (ly:stencil-translate-axis stencil (cdr coordinate-pair) Y) + (car coordinate-pair) X)) + (define-public (stack-stencils axis dir padding stils) "Stack stencils STILS in direction AXIS, DIR, using PADDING." (cond @@@ -88,14 -81,6 +88,14 @@@ (interval-widen xext (/ width 2)) (interval-widen yext (/ width 2))))) +(define-public (make-round-filled-box-stencil xext yext blot-diameter) + "Make a filled rounded box." + + (ly:make-stencil + (list 'round-filled-box (- (car xext)) (cdr xext) + (- (car yext)) (cdr yext) blot-diameter) + xext yext)) + (define-public (make-filled-box-stencil xext yext) "Make a filled box."