+ ;; Add string-count from string-tunings to fret-diagram-details.
+ (set! (ly:grob-property grob 'fret-diagram-details)
+ (acons 'string-count my-string-count details))
+ ;; Create the dot-placement list for the grob
+ (set! (ly:grob-property grob 'dot-placement-list) placement-list)))
+
+(define-public
+ (determine-frets context notes specified-info . rest)
+ "Determine string numbers and frets for playing @var{notes}
+as a chord, given specified information @var{specified-info}.
+@var{specified-info} is a list with two list elements,
+specified strings @code{defined-strings} and
+specified fingerings @code{defined-fingers}. Only a fingering of@tie{}0
+will affect the fret selection, as it specifies an open string.
+If @code{defined-strings} is @code{'()}, the context property
+@code{defaultStrings} will be used as a list of defined strings.
+Will look for predefined fretboards if @code{predefinedFretboardTable}
+is not @code {#f}. If @var{rest} is present, it contains the
+@code{FretBoard} grob, and a fretboard will be
+created. Otherwise, a list of @code{(string fret finger)} lists will
+be returned."
+
+ ;; helper functions
+
+ (define (string-frets->placement-list string-frets string-count)
+ "Convert @var{string-frets} to @code{fret-diagram-verbose}
+dot placement entries."
+ (let* ((placements (list->vector
+ (map (lambda (x) (list 'mute (1+ x)))
+ (iota string-count)))))
+
+ (for-each (lambda (sf)
+ (let* ((string (car sf))
+ (fret (cadr sf))
+ (finger (caddr sf)))
+ (vector-set!
+ placements (1- string)
+ (if (= 0 fret)
+ (list 'open string)
+ (if finger
+ (list 'place-fret string fret finger)
+ (list 'place-fret string fret))))))
+ string-frets)
+ (vector->list placements)))
+
+ (define (placement-list->string-frets placement-list)
+ "Convert @var{placement-list} to string-fret list."
+ (map (lambda (x) (if (eq? (car x) 'place-fret)
+ (cdr x)
+ (list (cadr x) 0)))
+ (filter (lambda (l) (or (eq? (car l) 'place-fret)
+ (eq? (car l) 'open)))
+ placement-list)))
+
+ (define (entry-count art-list)
+ (length (filter (lambda (x) (not (null? x)))
+ art-list)))
+
+ (define (get-predefined-fretboard predefined-fret-table tuning pitches)
+ "Search through @var{predefined-fret-table} looking for a predefined
+fretboard with a key of @var{(tuning . pitches)}. The search will check
+both up and down an octave in order to accomodate transposition of the
+chords. Returns a placement-list."
+
+ (define (get-fretboard key)
+ (let ((hash-handle
+ (hash-get-handle predefined-fret-table key)))
+ (if hash-handle
+ (cdr hash-handle) ; return table entry
+ '())))
+
+ ;; body of get-predefined-fretboard
+ (let ((test-fretboard (get-fretboard (cons tuning pitches))))
+ (if (not (null? test-fretboard))
+ test-fretboard
+ (let ((test-fretboard
+ (get-fretboard
+ (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
+ (if (not (null? test-fretboard))
+ test-fretboard
+ (get-fretboard
+ (cons tuning (map (lambda (x) (shift-octave x -1))
+ pitches))))))))
+
+ ;; body of determine-frets
+ (let* ((predefined-fret-table
+ (ly:context-property context 'predefinedDiagramTable))
+ (tunings (ly:context-property context 'stringTunings))
+ (string-count (length tunings))
+ (grob (if (null? rest) '() (car rest)))
+ (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
+ (defined-strings (map (lambda (x)
+ (if (null? x)
+ x
+ (ly:event-property x 'string-number)))
+ (car specified-info)))
+ (defined-fingers (map (lambda (x)
+ (if (null? x)
+ x
+ (ly:event-property x 'digit)))
+ (cadr specified-info)))
+ (default-strings (ly:context-property context 'defaultStrings '()))
+ (strings-used (if (and (zero? (entry-count defined-strings))
+ (not (zero? (entry-count default-strings))))
+ default-strings
+ defined-strings))
+ (predefined-fretboard
+ (if predefined-fret-table
+ (get-predefined-fretboard
+ predefined-fret-table
+ tunings
+ pitches)
+ '())))
+ (if (null? predefined-fretboard)
+ (let ((string-frets
+ (determine-frets-and-strings
+ notes
+ strings-used
+ defined-fingers
+ (ly:context-property context 'minimumFret 0)
+ (ly:context-property context 'maximumFretStretch 4)
+ tunings)))
+ (if (null? grob)
+ string-frets
+ (create-fretboard
+ context grob (string-frets->placement-list
+ string-frets string-count))))
+ (if (null? grob)
+ (placement-list->string-frets predefined-fretboard)
+ (create-fretboard context grob predefined-fretboard)))))
+
+
+(define (determine-frets-and-strings
+ notes
+ defined-strings
+ defined-fingers
+ minimum-fret
+ maximum-stretch
+ tuning)