\version "2.17.21"

% Uncomment the following line to show the skylines.
%#(ly:set-option 'debug-skylines)

\paper {
  indent = #0
}

% Note: In order to prevent "bleed-over" from one session to another, it is
% recommended that .ly files using the following functions be processed
% individually (rather than in a batch).

%%%%%%%%%%%%%%%%%%%%%%%%%%% CREATE NEW EVENT CLASSES %%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define my-event-classes (ly:make-context-mod))

defineEventClass =
#(define-void-function (parser location class parent)
   (symbol? symbol?)
   (ly:add-context-mod
    my-event-classes
    `(apply
      ,(lambda (context class parent)
         (ly:context-set-property!
          context
          'EventClasses
          (event-class-cons
           class
           parent
           (ly:context-property context 'EventClasses '()))))
      ,class ,parent)))

\defineEventClass #'frame-event #'span-event

\defineEventClass #'frame-extender-event #'span-event

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% MUSIC DESCRIPTIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define frame-types
   '(
     (FrameEvent
      . ((description . "Signals where a frame starts and stops.")
         (types . (general-music frame-event span-event event))
         ))
     ))

#(set!
  frame-types
  (map (lambda (x)
         (set-object-property! (car x)
                               'music-description
                               (cdr (assq 'description (cdr x))))
         (let ((lst (cdr x)))
           (set! lst (assoc-set! lst 'name (car x)))
           (set! lst (assq-remove! lst 'description))
           (hashq-set! music-name-to-property-table (car x) lst)
           (cons (car x) lst)))
       frame-types))

#(define frame-extender-types
  '(
     (FrameExtenderEvent
      . ((description . "Signals where a frame extender line stops.")
         (types . (general-music frame-extender-event span-event event))
         ))
     ))

#(set!
  frame-extender-types
  (map (lambda (x)
         (set-object-property! (car x)
                               'music-description
                               (cdr (assq 'description (cdr x))))
         (let ((lst (cdr x)))
           (set! lst (assoc-set! lst 'name (car x)))
           (set! lst (assq-remove! lst 'description))
           (hashq-set! music-name-to-property-table (car x) lst)
           (cons (car x) lst)))
       frame-extender-types))

#(set! music-descriptions
       (append frame-types music-descriptions))

#(set! music-descriptions
       (sort music-descriptions alist<?))

%%%%%%%%%%%%%%%%%%%%%%%%% ADD NEW GROB INTERFACES %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(ly:add-interface
  'frame-interface
  "A box for frame notation."
  '(frame-elements))

#(ly:add-interface
  'frame-extender-interface
  "An extender line (with arrow) for frame notation."
  '())

#(ly:add-interface
  'frame-bracket-interface
  "A bracket with text (possibly to indicate duration) for frame notation."
  '(bracket-elements side-support-elements))

%%%%%%%%%%%%%%%%%%%%%%%%% CREATE NEW GROB PROPERTIES %%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define (define-grob-property symbol type? description)
  (if (not (equal? (object-property symbol 'backend-doc) #f))
      (ly:error (_ "symbol ~S redefined") symbol))

  (set-object-property! symbol 'backend-type? type?)
  (set-object-property! symbol 'backend-doc description)
  symbol)

#(map
  (lambda (x)
    (apply define-grob-property x))

  `(
    (extender-Y-offset ,number?
      "Vertical displacement of extender line from center staff line")
  ))

%%%%%%%%%%%%%%%%%%%%%%%% DIMENSIONS OF STENCILS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The following functions calculate dimensions for those grobs which have
% stencils: Frame, FrameExtender, and FrameBracket.  Grobs with stencils
% should not use the 'axis-group-interface for calculating height and width.
% Relevant grobs have been stored in arrays other than 'elements, which
% is the grob-array used by the axis-group-interface for its calculations.
% Thanks to Mike Solomon for explanations and code.

#(define (dim-hack grob ax)
  (let* ((frame-elts (ly:grob-object grob 'frame-elements))
         (common (ly:grob-common-refpoint-of-array grob frame-elts ax))
         (rel (ly:relative-group-extent frame-elts common ax))
         (off (ly:grob-relative-coordinate grob common ax)))
    ;(format #t "rel-~a: ~a  off: ~a~%" ax rel off)
    (coord-translate rel (- off))))

#(define (height-hack grob)
  (dim-hack grob Y))

#(define (width-hack grob)
  (dim-hack grob X))

#(define (bracket-width grob)
  (let* ((bracket-elts (ly:grob-object grob 'bracket-elements))
         (common (ly:grob-common-refpoint-of-array grob bracket-elts X))
         (rel (ly:relative-group-extent bracket-elts common X))
         (off (ly:grob-relative-coordinate grob common X)))
    (coord-translate rel (- off))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% PRINT FUNCTIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define (frame::print grob)
"Draw a box around a group of notes for use in frame notation."
  (let* ((staff-space (ly:staff-symbol-staff-space grob))
         (box-padding (* (ly:grob-property grob 'padding) staff-space))
         (height (height-hack grob))
          ; cannot use axis-group-interface, as there are no elements
         (width (width-hack grob))
         (th (ly:grob-property grob 'thickness))
         (stencil (ly:make-stencil '() width height))
         (stencil (box-stencil stencil th box-padding)))
    stencil))

#(define (ly:frame-extender::print grob)
"Draw an extender line with arrow for use in frame notation."
  (let* ((refp (ly:grob-system grob))
         (staff-space (ly:staff-symbol-staff-space grob)) ; for scaling
         ;; NOTE: The frame grob is only available to the portion of a broken
         ;; extender which is on the same line.  The following property lookup
         ;; will return '() for siblings.  It would be nice to have the option
         ;; to center the extender vertically on the frame, and have the
         ;; siblings at the same height.  How can this be done automatically
         ;; without the frame being "remembered"?
         (frame (ly:grob-object grob 'frame))
         (left-bound (ly:spanner-bound grob LEFT))
         (right-bound (ly:spanner-bound grob RIGHT))
         (left-bound-ext (ly:grob-extent left-bound left-bound X))
         (extender-th (* (ly:grob-property grob 'thickness) staff-space))
         (half-extender-th (/ extender-th 2.0))
         ;; Calculate an offset so that extender segment is lined up with the
         ;; inside edge of the frame, or clears prefatory material if a
         ;; broken piece.
         (left-offset
           (if (ly:grob? frame)
               (* (ly:grob-property frame 'padding) staff-space)
               1.0))
         (right-bound-ext (ly:grob-extent right-bound right-bound X))
         (right-offset
           (if (interval-empty? right-bound-ext)
               0.0
               (interval-length right-bound-ext)))
         (left-bound-coord (ly:grob-relative-coordinate left-bound refp X))
         (right-bound-coord (ly:grob-relative-coordinate right-bound refp X))
         ;; By default, the line will be drawn at the center line of the staff.
         (extender-dy (ly:grob-property grob 'extender-Y-offset))
         ;; the 1.0 is a hardcoded value which ensures that there is some whitespace
         ;; between the end of the extender and what follows.  It would be nice
         ;; if the extender could actually push material that follows.
         (right-offset (+ right-offset (* 1.0 staff-space)))
         (layout (ly:grob-layout grob))
         (line-th (ly:output-def-lookup layout 'line-thickness))
         (start (+ (/ line-th 2) (cdr left-bound-ext) left-offset))
         (end (- right-bound-coord left-bound-coord right-offset))
         ;; Line is drawn as filled box because there is no rounding
         ;; of corners.  Rounded corners make alignment with frame
         ;; problematic.  For this reason, the public function
         ;; `arrow-stencil-maker' from `stencil.scm' has not been used.
         (extender
           (markup
            #:override '(filled . #t)
             #:path
               line-th
               ;; If extender is very short, do not draw arrow
               (if (<= (- end start) (* 3.5 extender-th))
                   `((moveto ,start ,(+ extender-dy half-extender-th))
                     (lineto ,end
                             ,(+ extender-dy half-extender-th))
                     (lineto ,end
                             ,(- extender-dy half-extender-th))
                     (lineto ,start ,(- extender-dy half-extender-th))
                     (closepath))
                  `(; line with arrow-head
                    (moveto ,start ,(+ extender-dy half-extender-th))
                    (lineto ,(- end (* 3 extender-th) half-extender-th)
                            ,(+ extender-dy half-extender-th))
                    (lineto ,(- end (* 3 extender-th) half-extender-th)
                            ,(- extender-dy half-extender-th))
                    (lineto ,start ,(- extender-dy half-extender-th))
                    (closepath)
                    ; the arrow-head
                    (moveto ,end ,extender-dy)
                    (curveto
                     ,end
                     ,extender-dy
                     ,(- end (* 1.5 extender-th) (/ half-extender-th 2))
                     ,extender-dy
                     ,(- end (* 3 extender-th) half-extender-th)
                     ,(+ extender-dy (* 1.5 extender-th)))
                    (lineto ,(- end (* 3 extender-th) half-extender-th)
                            ,(- extender-dy (* 1.5 extender-th)))
                    (curveto
                      ,(- end (* 3 extender-th) half-extender-th)
                      ,(- extender-dy (* 1.5 extender-th))
                      ,(- end (* 1.5 extender-th) (/ half-extender-th 2))
                      ,extender-dy
                      ,end
                      ,extender-dy)
                    (closepath)))))
         (extender (grob-interpret-markup grob extender)))
      extender))

#(define (ly:frame-bracket::print grob)
"Draw a bracket for use in frame notation."
  (let* ((orig (ly:grob-original grob))
         (staff-space (ly:staff-symbol-staff-space grob)) ; for scaling
         (layout (ly:grob-layout grob))
         (line-th (ly:output-def-lookup layout 'line-thickness))
         (siblings (ly:spanner-broken-into orig))
         (width (bracket-width grob))
         ;; We need the blot-diameter so that there is no gap between the
         ;; horizontal line and the vertical edges of the bracket
         (blot (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
         (text (ly:grob-property grob 'text))
         (text (if (null? text)
                   text
                   (markup #:scale (cons staff-space staff-space) text)))
         ;; if no text is specified, create a dummy stencil.
         (text (if (null? text)
                   point-stencil
                   (grob-interpret-markup grob text)))
         ;; center the text on its own extents and those of the bracket
         (text (ly:stencil-aligned-to text X CENTER))
         (text (ly:stencil-translate-axis text (car width) X))
         (text (ly:stencil-translate-axis text (/ (interval-length width) 2) X))
         (stil (make-line-stencil line-th
                                  (car width) 0
                                  (cdr width) 0))
         ;; create the vertical lines for bracket edges
         (protrusion (make-line-stencil line-th
                                        0 0
                                        0 (* -1 staff-space))))

  ;; Add edges and text depending on whether we have a broken bracket.

    ;; Left edge:
    (if (or
          (and (>= (length siblings) 2)
               (eq? grob (first siblings)))
          (< (length siblings) 2))
        (set! stil
              (ly:stencil-combine-at-edge stil X LEFT protrusion (- blot))))
    ;; Right edge:
    (if (or
          (and (>= (length siblings) 2)
               (eq? grob (last siblings)))
          (< (length siblings) 2))
        (set! stil
              (ly:stencil-combine-at-edge stil X RIGHT protrusion (- blot))))
    ;; Text is only added to the first piece of a broken bracket.  Possibly
    ;; the text should be added in parentheses to the pieces (as in a measure
    ;; count).  0.5 is a hardcoded padding value which controls the separation
    ;; between the text and the bracket.
    (if (or
          (and (>= (length siblings) 2) (eq? grob (first siblings)))
          (< (length siblings) 2))
        (set! stil
              (ly:stencil-combine-at-edge stil Y UP text (* 0.5 staff-space))))
    stil))

%%%%%%%%%%%%%%%%%%%%%%%%% ADD NEW GROB DEFINITIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define my-grob-descriptions '())

#(define (add-grob-definition grob-name grob-entry)
   (let* ((meta-entry   (assoc-get 'meta grob-entry))
          (class        (assoc-get 'class meta-entry))
          (ifaces-entry (assoc-get 'interfaces meta-entry)))
     (set-object-property! grob-name 'translation-type? list?)
     (set-object-property! grob-name 'is-grob? #t)
     (set! ifaces-entry (append (case class
                                  ((Item) '(item-interface))
                                  ((Spanner) '(spanner-interface))
                                  ((Paper_column) '((item-interface
                                                     paper-column-interface)))
                                  ((System) '((system-interface
                                               spanner-interface)))
                                  (else '(unknown-interface)))
                                ifaces-entry))
     (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
     (set! ifaces-entry (cons 'grob-interface ifaces-entry))
     (set! meta-entry (assoc-set! meta-entry 'name grob-name))
     (set! meta-entry (assoc-set! meta-entry 'interfaces
                                  ifaces-entry))
     (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
     (set! my-grob-descriptions
           (cons (cons grob-name grob-entry)
                 my-grob-descriptions))))

#(add-grob-definition
  'Frame
  `((padding . 0.8)
    (stencil . ,frame::print)
    (thickness . 0.3)
    (meta . ((class . Spanner)
             (interfaces . (frame-interface
                            line-interface))))))

#(add-grob-definition
  'FrameExtender
  `((extender-Y-offset . 0)
    (stencil . ,ly:frame-extender::print)
    (thickness . 0.3)
    (meta . ((class . Spanner)
             (interfaces . (frame-extender-interface
                            line-interface))))))

#(add-grob-definition
  'FrameBracket
  `((stencil . ,ly:frame-bracket::print)
    (side-axis . ,Y)
    (Y-offset . ,ly:side-position-interface::y-aligned-side)
    (padding . 1)
    (direction . ,UP)
    (outside-staff-priority . 0)
    (outside-staff-padding . 1)
    (vertical-skylines . ,ly:grob::vertical-skylines-from-stencil)
    (meta . ((class . Spanner)
             (interfaces . (frame-bracket-interface
                            line-interface
                            side-position-interface))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%% FRAME ENGRAVER %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define (add-bound-item spanner item)
  (if (null? (ly:spanner-bound spanner LEFT))
      (ly:spanner-set-bound! spanner LEFT item)
      (ly:spanner-set-bound! spanner RIGHT item)))

frameEngraver =
#(lambda (context)
  (let ((frame '()) ; the box enclosing the items to be repeated
        (extender '()) ; a horizontal line with arrow
        (event-drul (cons '() '())) ; the events which begin and end a frame
        (extender-event '()) ; the event which signals END of extender line
        (bracket '()) ; a bracket with text (i.e., timing)
        ;; In order to handle the situation when a FrameBracket begins in the
        ;; same timestep as another ends (i.e., when the user calls
        ;; \frameExtenderEnd and \frameStart together), some shuffling of
        ;; grobs between variables is necessary.  We copy the spanner held in
        ;; 'bracket' to 'finished-bracket' once it has been begun.  We will
        ;; complete it there.  This frees 'bracket' to contain the beginnings
        ;; of another FrameBracket grob.
        (finished-bracket '()))

    (make-engraver
      (listeners
        ((frame-event engraver event)
         (if (= START (ly:event-property event 'span-direction))
             (set-car! event-drul event)
             (set-cdr! event-drul event)))
        ((frame-extender-event engraver event)
         ;; The extender is begun automatically when a frame ends, so we listen
         ;; only for the extender's termination event.
         (if (= STOP (ly:event-property event 'span-direction))
             (set! extender-event event))))

      (acknowledgers
        ((note-column-interface engraver grob source-engraver)
         (if (ly:spanner? frame)
             (begin
               (ly:pointer-group-interface::add-grob frame 'frame-elements grob)
               ;; The box is attached to a note column on left and right sides.
               (add-bound-item frame grob)))
         (if (ly:spanner? extender)
             ;; The extender line is attached to a note column on the left.
             ;; A NonMusicalPaperColumn will be the right bound.
             (if (null? (ly:spanner-bound extender LEFT))
                 (ly:spanner-set-bound! extender LEFT grob)))
         (if (ly:spanner? bracket)
             (begin
               (ly:pointer-group-interface::add-grob bracket 'columns grob)
               ;; Bracket is attached to a NonMusicalPaperColumn on either side.
               (add-bound-item bracket
                               (ly:context-property context 'currentCommandColumn))))
         (if (ly:spanner? finished-bracket)
             (begin
               (ly:pointer-group-interface::add-grob finished-bracket 'columns grob))))
        ((script-interface engraver grob source-engraver)
         (if (ly:spanner? frame)
             (ly:pointer-group-interface::add-grob frame 'frame-elements grob)))
        ;((text-script-interface engraver grob source-engraver)
         ;(if (ly:spanner? frame)
          ;   (ly:pointer-group-interface::add-grob frame 'frame-elements grob)))
        ((inline-accidental-interface engraver grob source-engraver)
         ;; Frame will be sized to accommodate leading accidental.
         (if (ly:spanner? frame)
             (ly:pointer-group-interface::add-grob frame 'frame-elements grob))))

      ((process-music trans)
       ;; When the user requests a frame (with `FrameStart'), we begin a
       ;; Frame and a FrameBracket.
       ;; TODO: for horizontal spacing purposes, a FrameStub (an invisible
       ;; rectangle) will be created.
       (if (ly:stream-event? (car event-drul))
           (begin
             (set! frame (ly:engraver-make-grob trans 'Frame (car event-drul)))
             (set! bracket
                   (ly:engraver-make-grob trans 'FrameBracket (car event-drul)))
             (ly:pointer-group-interface::add-grob
               bracket 'bracket-elements frame)
             (ly:pointer-group-interface::add-grob
               bracket 'side-support-elements frame)
             (set-car! event-drul '())))
       ;; User has requested completion of Frame grob.
       (if (ly:stream-event? (cdr event-drul))
           ;; Error: user has written \frameEnd without \frameStart.
           ;; Nothing will be drawn.
           (if (null? frame)
               (ly:programming-error "No start to frame.  Nothing drawn.")
               ;; no error: finish Frame, begin FrameExtender, and add references
               ;; to the completed Frame in FrameExtender and FrameBracket
               (begin
                 (ly:engraver-announce-end-grob trans frame (cdr event-drul))
                 (set! extender
                       (ly:engraver-make-grob
                         trans 'FrameExtender (cdr event-drul)))
                 (ly:grob-set-object! extender 'frame frame)
                 ;; Store FrameBracket-in-progress in another variable
                 ;; so that new FrameBracket might be begun at same timestep.
                 (set! finished-bracket bracket)
                 (set! bracket '()))))
       ;; When we hear an extender-event, we finish both FrameExtender and
       ;; FrameBracket
       (if (ly:stream-event? extender-event)
           ;; If there is an extender to end...
           (if (ly:spanner? extender)
               (let ((col (ly:context-property context 'currentCommandColumn)))
                 (ly:spanner-set-bound! extender RIGHT col)
                 (ly:engraver-announce-end-grob trans extender extender-event)
                 (ly:spanner-set-bound! finished-bracket RIGHT col)
                 (ly:grob-set-object! finished-bracket 'extender extender)
                 (ly:pointer-group-interface::add-grob
                   finished-bracket 'bracket-elements extender)
                 (ly:pointer-group-interface::add-grob
                   finished-bracket 'side-support-elements extender)
                 (ly:engraver-announce-end-grob
                   trans finished-bracket extender-event)
                 (set! extender '())
                 (set! finished-bracket '())
                 (set! extender-event '()))
               ;; There is a request to end a non-existent extender...
               (set! extender-event '()))))

      ((stop-translation-timestep trans)
       ;; Frame is complete.
       (if (ly:stream-event? (cdr event-drul))
           (begin
             (set! frame '())
             (set-cdr! event-drul '()))))

       ((finalize trans)
        ;; If there is an incomplete extender at the end of the context, the
        ;; variable 'extender' won't be empty.  Finish the extender and bracket
        ;; with a warning.
        (if (ly:spanner? extender)
            (let ((col (ly:context-property context 'currentCommandColumn)))
              (ly:warning "You didn't finish final extender.  Completing...")
              (ly:spanner-set-bound! extender RIGHT col)
              (ly:spanner-set-bound! finished-bracket RIGHT col)
              (ly:grob-set-object! finished-bracket 'extender extender)
              (ly:pointer-group-interface::add-grob
                finished-bracket 'bracket-elements extender)
              (ly:pointer-group-interface::add-grob
                finished-bracket 'side-support-elements extender)
              (ly:engraver-announce-end-grob
                trans finished-bracket extender-event)
              (set! extender '())
              (set! extender-event '())
              (set! finished-bracket '())))))))


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% EVENT FUNCTIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

frameStart =
#(make-span-event 'FrameEvent START)

frameEnd =
#(make-span-event 'FrameEvent STOP)

frameExtenderEnd =
#(make-span-event 'FrameExtenderEvent STOP)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% EXAMPLE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\new StaffGroup <<
  \new Staff
  %{
    \with {
      fontSize = #-3
      \override StaffSymbol #'staff-space = #(magstep -3)
    }
  %}
  {
    %% increase number of reps here (and below) to see issue with vertical
    %% spacing/page breaking
    \repeat unfold 4 {
      \relative c'' {
        %% Commenting the following line demonstrates horizontal spacing issue
        %% which will be alleviated by the addition of FrameStub grobs.
        \set Timing.defaultBarType = ""
        \once \override FrameBracket.text = \markup "10''"
        \frameStart
        %% Uncomment dynamic: box is sized to accommodate, but dynamic
        %% is pushed aside.
        g8%\p
        [ es' des gis bes,
        \frameEnd
        e]
        s4
        s1*4
        \frameExtenderEnd
      }
    }
  }
  \new Staff {
    \relative c'' {
      \repeat unfold 4 {
        \once \override FrameBracket.text = \markup "6''"
        \frameStart
        %% scripts are OK
        f8%-\accent\mordent\fermata
        [ fis, a b d
        \frameEnd
        \override FrameExtender.thickness = #0.75
        c]
        s4
        s1*2
        \frameExtenderEnd
        %\once \override FrameBracket.text = \markup "4''"
        \once \override FrameBracket.text = \markup \note #"4.." #UP
        \frameStart
        fis,8[ f' a, b' c,
        %% the FrameExtender begins at the end of the Frame, so put \once
        %% \override at the same timestep as you use \frameEnd
        %\once \override FrameExtender.color = #red
        \once \override FrameExtender.extender-Y-offset = #3.5
        \frameEnd
        d']
        s4
        s1
        \frameExtenderEnd
      }
    }
  }
>>

\layout {
  %ragged-right = ##t
  \context {
    \Global
    \grobdescriptions #my-grob-descriptions
    #my-event-classes
  }
  \context {
    \Score
    \remove "Bar_number_engraver"
    proportionalNotationDuration = #(ly:make-moment 1 4)
    \override SpacingSpanner #'uniform-stretching = ##t
  }
  \context {
    \Staff
    \remove "Time_signature_engraver"
  }
  \context {
    \Voice
    %\override Beam.stencil = ##f
    %\override Stem.stencil = #point-stencil
    \consists \frameEngraver
  }
}