+ positioned-glyph
+ (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))
+ (label-horizontal-offset
+ (assoc-get 'fret-label-horizontal-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))
+ ((equal? 'custom number-type)
+ (fancy-format #f
+ (assoc-get 'fret-label-custom-format
+ details "~a")
+ 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
+ (* size label-horizontal-offset)
+ label-half-width)))
+ (ly:stencil-translate
+ label-stencil
+ (stencil-coordinates
+ (* size (+ 1.0 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 barre-list)
+ fret-diagram-stencil)))
+ (if (not (null? dot-list))
+ (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))))
+ (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))
+ (xo-stencil-offset
+ (stencil-coordinate-offset
+ (- diagram-fret-top
+ xo-fret-offset
+ (* size xo-padding))
+ 0)))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (ly:stencil-translate
+ xo-stencil
+ xo-stencil-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 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:
+@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))))
+ ((#\t) (let ((th (get-numeric-from-key test-string)))
+ (set! props (prepend-alist-chain 'thickness th 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