+ (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
+;;
+;;
+;;
+
+(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 thickness-factor 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
+ 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)
+ (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 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))))
+ ((#\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