\version "2.11. 55"

% The following defines a new markup command 
%      \harp-pedal #"^-v|--v^" 
% for harp pedal diagrams. Possible values in the string are:
%   ^ ... pedal is up
%   - ... pedal is neutral
%   v ... pedal is down
%   | ... vertical divider line
%   o ... the following pedal should be circled (indicating a change)
% The function also checks if the string has the typical form of three
% pedals, then the divider and then the remaining four pedals. If not it
% prints out a warning. However, in any case, it will also print each symbol 
% in the order as given. This means you can place the divider (even multiple 
% dividers) anywhere you want, but you'll have to live with the warnings.
% 
% There is also a \harp-pedal-verbose version, which 
% takes a list of directions and a possible |. Unfortunately, it has some
% caveats:
%   1) the | cannot be given as a string "|", but as a character #\|. Similarly,
%      the "o" has to be given as #\o.
%   2) if one wants to use directions like UP, CENTER or DOWN, one cannot use
%      '(UP DOWN CENTER #\| ....), because the contents of that list are 
%      never evaluated. Instead one has to explicitly create a list like
%      (list UP DOWN CENTER #\| ....)

#(define-markup-command (harp-pedal-verbose layout props pedal-list) (list?)
  "Make a harp pedal diagram containing the directions indicated in @var{pedal-list}.

  For example,

@example
\\markup \\pedal-diagram-verbose #'(1 0 -1 #\\| 0 0 1 1)
\\markup \\pedal-diagram-verbose #(list UP CENTER DOWN #\\| CENTER CENTER UP UP)
@end example
"
  (make-harp-pedal layout props pedal-list))


#(define-markup-command (harp-pedal layout props definition-string) (string?)
  "Make a harp pedal diagram.  For example, say

@example
\\markup \\harp-pedal #\"^-v|^^^^\"
@end example
"
  (make-harp-pedal layout props (harp-pedals-parse-string definition-string)))


#(define (harp-pedals-parse-string definition-string)
 "Parse a harp pedals diagram string and return a list containing 1, 0, -1 or #\\|"
  (map (lambda (c) 
    (case c
      ((#\^) 1)
      ((#\v) -1)
      ((#\-) 0)
      ((#\| #\o) c)
      (else c)))
    (string->list definition-string)))

#(define (harp-pedal-info pedal-list)
  (let check ((pedals pedal-list)
              (pedalcount 0) 
              (dividerpositions '()))
    (if (null? pedals)
      (cons pedalcount (reverse dividerpositions))
      
      (case (car pedals)
        ((-1 0 1) (check (cdr pedals) (+ pedalcount 1) dividerpositions))
        ((#\|)    (check (cdr pedals) pedalcount (cons pedalcount dividerpositions)))
        (else     (check (cdr pedals) pedalcount dividerpositions))))))

#(define (harp-pedal-check pedal-list)
  "Perform some sanity checks for harp pedals (7 pedals, divider after third)"
  (let ((info (harp-pedal-info pedal-list)))
    ; 7 pedals:
    (if (not (equal? (car info) 7))
      (ly:warning "Harp pedal diagram contains ~a pedals rather than the usual 7." (car info)))
    ; One divider after third pedal:
    (if (null? (cdr info))
      (ly:warning "Harp pedal diagram does not contain a divider (usually after third pedal).")
      (if (not (equal? (cdr info) '(3)))
        (ly:warning "Harp pedal diagram contains dividers at positions ~a. Normally, there is only one divider after the third pedal." (cdr info))))))
      

#(define (make-harp-pedal layout props pedal-list)
  "Make a harp pedals diagram markup"
       
  
  ; FIXME the size variable should be defined by a prop. lookup
  (define sz 1.2)
  (harp-pedal-check pedal-list)
       
  ; TODO is it worth adding a thickness variable here?
  (let* ((x (* sz 4))
        (dy (* sz 0.8)) ; offset of the box center from the line 
        (line-width 0.1)
        (box-width (* sz 0.4))
        (box-hheight (* sz 0.5)) ; half the box-height, saves some divisions by 2
        (spaceafterdivider (* sz 0.8)) ; full space between boxes
        ;(spacebeforedivider (/ (+ box-width (* 8 spaceafterdivider)) 8))
        (spacebeforedivider spaceafterdivider)
        (box-x-dimensions (lambda (prev-x p space) (cons (+ prev-x space) 
                                                   (+ prev-x space box-width))))
        (box-y-dimensions (lambda (prev-x p space) (cons (- (* p dy) box-hheight) 
                                                         (+ (* p dy) box-hheight))))
        (circle-x-dimensions (lambda (prev-x p space) (cons (+ prev-x space) 
                                                   (+ prev-x space box-width))))
        (circle-y-dimensions (lambda (prev-x p space) (cons (+ (* p dy) box-hheight) 
                                                         (- (* p dy) box-hheight))))
        (divider-command-stencil (lambda (xpos) (make-line-stencil line-width xpos (- 0 dy box-hheight) xpos (+ dy box-hheight))))
        (result (let process-pedal  ((remaining pedal-list)
                                     (prev-x 0)
                                     (stencils '())
                                     (circled #f)
                                     (space spacebeforedivider))
          (if (null? remaining)
            (cons (+ prev-x space) stencils) 
      
            (case (car remaining)
              ((1 0 -1) 
                  (let* ((p (car remaining))
                        (stencil (make-filled-box-stencil
                                   (box-x-dimensions prev-x p space) 
                                   (box-y-dimensions prev-x p space)))
                                   ;(circle-stencil (if circled (rounded-box-stencil stencil 0.05 0.3 0.1 ) stencil))
                                   (circle-stencil (if circled (circle-stencil stencil 0.05 0.2 ) stencil))
                        (new-prev-x (+ prev-x space box-width)))
                      (process-pedal (cdr remaining) new-prev-x (cons circle-stencil stencils) #f space)))
              ((#\|)
                  (let* ((xpos (+ prev-x space))
                         ;(box (divider-command-box xpos))
                         (stencil (divider-command-stencil xpos))
                         (new-prev-x (+ prev-x space)))
                    (process-pedal (cdr remaining) new-prev-x (cons stencil stencils) circled spaceafterdivider)))
              ((#\o)
                  (process-pedal (cdr remaining) prev-x stencils #t space))
              (else
                  (ly:warning "Unhandled entry in harp-pedal: ~a" (car remaining))
                  (process-pedal (cdr remaining) prev-x stencils circled space))))))
        (final-x (car result))
        (stencils (reverse (cdr result))))
    ; Add the horizontal line and combine all stencils:
    (apply ly:stencil-add
      (cons
        (make-line-stencil line-width 0 0 final-x 0)
        stencils))))



\relative c'' {
  c1^\markup \harp-pedal #"^v-|vv-^"
  c1_\markup \harp-pedal-verbose #'(1 -1 0 #\| -1 -1 0 1)
  c1^\markup \harp-pedal-verbose #(list UP DOWN CENTER #\| DOWN DOWN CENTER UP)
  % invalid pedal specifications, which still should be handled gracefully:
  c1^\markup \harp-pedal #""
  c1^\markup \harp-pedal #"asfdvx" %\break
  % Sanity checks: #pedals != 7:
  c1^\markup \harp-pedal #"^-v|--"
  % Sanity checks: no divider, multiple dividers, divider on wrong position:
  c1^\markup \harp-pedal #"^-v--v^"
  c1^\markup \harp-pedal #"^|-v|--|v^"
  c1^\markup \harp-pedal #"^-v-|-v^"
  % circled boxes:
  c1^\markup \harp-pedal #"o^ovo-|vovo-o^"
}