;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2003--2023 Han-Wen Nienhuys <hanwen@xs4all.nl>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; LilyPond is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (ice-9 match))

(define (make-bezier-sandwich-stencil coords thick)
  (make-path-stencil
   (match coords
     (((x1 . y1) (x2 . y2) (x3 . y3) (x4 . y4) (x5 . y5) (x6 . y6))
      `(moveto ,x1 ,y1
               curveto ,x2 ,y2 ,x3 ,y3 ,x4 ,y4
               curveto ,x5 ,y5 ,x6 ,y6 ,x1 ,y1
               closepath)))
   thick
   1
   1
   #t))

(define-public (make-bow-stencil
                start stop thickness angularity bow-height orientation)
  "Create a bow stencil.
It starts at point @var{start}, ends at point @var{stop}.
@var{thickness} is the thickness of the bow.
The higher the value of number @var{angularity}, the more angular the shape of
the bow.
@var{bow-height} determines the height of the bow.
@var{orientation} determines whether the bow is concave or convex.
Both variables are supplied to support independent usage.

Done by calculating a horizontal unit bow first, then moving all control points
to the correct positions.
Limitation: s-curves are currently not supported.
"

;;;; Coding steps:
;;;; (1) calculate control-points for a "unit"-bow from '(0 . 0) to '(1 . 0)
;;;;     user settable `bow-height' and `thickness' are scaled down.
;;;; (2) move control-points to match `start' and `stop'

  (let* (;; we use a fixed line-width as border for different behaviour
         ;; for larger and (very) small lengths
         (line-width 0.1)
         ;; `start'-`stop' distances
         (dx (- (car stop) (car start)))
         (dy (- (cdr stop) (cdr start)))
         (length-to-print (magnitude (make-rectangular dx dy))))

    (if (= 0 length-to-print)
        empty-stencil
        (let* (
          ;;;; (1) calculate control-points for the horizontal unit-bow,
               ;; y-values for 2nd/3rd control-points
               (outer-control
                (* 4/3 (sign orientation) (/ bow-height length-to-print)))
               (inner-control
                (* (sign orientation)
                   (- (abs outer-control) (/ thickness length-to-print))))
               ;; x-values for 2nd/3rd control-points depending on `angularity'
               (offset-index
                (- (* 0.6 angularity) 0.8))
               (left-control
                (+ 0.1 (* 0.3 angularity)))
               (right-control
                (- 1 left-control))
               ;; defining 2nd and 3rd outer control-points
               (left-outer-control-point
                (cons left-control outer-control))
               (right-outer-control-point
                (cons right-control outer-control))
               ;; defining 2nd and 3rd inner control-points
               (left-inner-control-point
                (cons left-control inner-control))
               (right-inner-control-point
                (cons right-control inner-control))
               (coord-list
                (list
                 '(0 . 0)
                 left-outer-control-point
                 right-outer-control-point
                 '(1 . 0)
                 right-inner-control-point
                 left-inner-control-point))
               ;;;; (2) move control-points to match `start' and `stop'
               (moved-coord-list
                (map
                 (lambda (p)
                   (cons
                    (+ (car start) (- (* (car p) dx) (* (cdr p) dy)))
                    (+ (cdr start) (+ (* (car p) dy) (* (cdr p) dx)))))
                 coord-list)))

          ;; final stencil
          (make-bezier-sandwich-stencil
           moved-coord-list
           (min (* 2 thickness) line-width))))))

(define*-public (make-tie-stencil
                 start stop thickness orientation
                 #:optional (height-limit 1.0)(ratio 0.33)(angularity 0.5))
  (let* (;; taken from bezier-bow.cc
         (F0_1
          (lambda (x) (* (/ 2 PI) (atan (* PI x 0.5)))))
         (slur-height
          (lambda (w h_inf r_0) (* (F0_1 (/ (* w r_0) h_inf)) h_inf)))
         (width (abs (- (car start) (car stop))))
         (height (slur-height width height-limit ratio)))
    (make-bow-stencil start stop thickness angularity height orientation)))

(define-public (stack-stencils axis dir padding stils)
  "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
@var{padding}."
  (reduce
   (lambda (next front)
     (ly:stencil-stack front axis dir next padding))
   empty-stencil
   stils))

(define-public (stack-stencils-padding-list axis dir paddings stils)
  "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
a list of @var{paddings}."
  (if (null? stils)
      empty-stencil
      (fold
       (lambda (next padding front)
         (let ((offset (+ (- (interval-end (ly:stencil-extent front axis))
                             (interval-start (ly:stencil-extent next axis)))
                          padding)))
           (ly:stencil-add
            front
            (ly:stencil-translate-axis next offset axis))))
       (car stils)
       (cdr stils)
       paddings)))

(define-public (centered-stencil stencil)
  "Center stencil @var{stencil} in both the x and y@tie{}directions."
  (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))

(define-public (stack-lines dir padding baseline stils)
  "Stack stencils vertically with a baseline skip."
  (reduce-right
   (lambda (next back) (ly:stencil-stack next Y dir back padding baseline))
   empty-stencil
   (map
    (lambda (s)
      ;; X-empty stencils may add vertical space.  A stencil that is
      ;; merely Y-empty counts as horizontal spacing.  Since we want
      ;; those to register as lines of their own (is this a good
      ;; idea?), we make them a separately visible line.
      (if (and (ly:stencil-empty? s Y)
               (not (ly:stencil-empty? s X)))
          (ly:make-stencil (ly:stencil-expr s) (ly:stencil-extent s X) '(0 . 0))
          s))
    stils)))

(define-public (bracketify-stencil stil axis thick protrusion padding)
  "Add brackets around @var{stil}, producing a new stencil."

  (let* ((ext (ly:stencil-extent stil axis))
         (lb (ly:bracket axis ext thick protrusion))
         (rb (ly:bracket axis ext thick (- protrusion))))
    (set! stil
          (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
    (set! stil
          (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
    stil))

(define (make-parenthesis-stencil
         y-extent thickness width angularity orientation)
  "Create a parenthesis stencil.
@var{y-extent} is the Y extent of the markup inside the parenthesis.
@var{half-thickness} is the half thickness of the parenthesis.
@var{width} is the width of a parenthesis.
@var{orientation} is the orientation of a parenthesis.
The higher the value of number @var{angularity},
the more angular the shape of the parenthesis."
  (let* ((start (cons 0 (car y-extent)))
         (stop (cons 0 (cdr y-extent)))
         (line-width 0.1)
         (bow-stil
          (make-bow-stencil
           start stop thickness angularity width orientation))
         (x-extent (ly:stencil-extent bow-stil X)))
    (ly:make-stencil
     (ly:stencil-expr bow-stil)
     (interval-widen x-extent (/ line-width 2))
     (interval-widen y-extent (/ line-width 2)))))

(define-public (parenthesize-stencil
                stencil half-thickness width angularity padding)
  "Add parentheses around @var{stencil}, returning a new stencil."
  (let* ((y-extent (ly:stencil-extent stencil Y))
         (lp (make-parenthesis-stencil
              y-extent half-thickness width angularity 1))
         (rp (make-parenthesis-stencil
              y-extent half-thickness width angularity -1)))
    (set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding))
    (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
    stencil))

(define-public (make-line-stencil width startx starty endx endy)
  "Make a line stencil of given line width and set its extents accordingly."
  (let ((xext (cons (min startx endx) (max startx endx)))
        (yext (cons (min starty endy) (max starty endy))))
    (ly:make-stencil
     (list 'draw-line width startx starty endx endy)
     ;; Since the line has rounded edges, we have to / can safely add half the
     ;; width to all coordinates!
     (interval-widen xext (/ width 2))
     (interval-widen yext (/ width 2)))))

(define-public (make-transparent-box-stencil xext yext)
  "Make a transparent box."
  (ly:stencil-outline empty-stencil (make-filled-box-stencil xext yext)))

(define-public (make-filled-box-stencil xext yext)
  "Make a filled box."

  (ly:make-stencil
   (list 'round-filled-box (- (car xext)) (cdr xext)
         (- (car yext)) (cdr yext) 0.0)
   xext yext))

(define-public (make-circle-stencil radius thickness fill)
  "Make a circle of radius @var{radius} and thickness @var{thickness}."
  (let*
      ((out-radius (+ radius (/ thickness 2.0))))

    (ly:make-stencil
     (list 'circle radius thickness fill)
     (cons (- out-radius) out-radius)
     (cons (- out-radius) out-radius))))

(define-public (make-oval-stencil x-radius y-radius thickness fill)
  "Make an oval from two Bézier curves, of x@tie{}radius @var{x-radius},
y@tie{}radius @var{y-radius}, and thickness @var{thickness} with fill
defined by @var{fill}."
  (let*
      ((x-out-radius (+ x-radius (/ thickness 2.0)))
       (y-out-radius (+ y-radius (/ thickness 2.0)))
       (x-max x-radius)
       (x-min (- x-radius))
       (y-max y-radius)
       (y-min (- y-radius))
       (commands `(,(list 'moveto x-max 0)
                   ,(list 'curveto x-max y-max x-min y-max x-min 0)
                   ,(list 'curveto x-min y-min x-max y-min x-max 0)
                   ,(list 'closepath)))
       (command-list (fold-right append '() commands)))
    (ly:make-stencil
     `(path ,thickness ,command-list round round ,fill)
     (cons (- x-out-radius) x-out-radius)
     (cons (- y-out-radius) y-out-radius))))

(define-public (make-partial-ellipse-stencil
                x-radius y-radius start-angle end-angle thick connect fill)
  "Create an elliptical arc.
@var{x-radius} is the x@tie{}radius of the arc.
@var{y-radius} is the y@tie{}radius of the arc.
@var{start-angle} is the starting angle of the arc (in degrees).
@var{end-angle} is the ending angle of the arc (in degrees).
@var{thick} is the thickness of the line.
@var{connect} is a boolean flag indicating whether the end should
be connected to the start by a line.
@var{fill} is a boolean flag indicating whether the shape should be filled."
  (define (make-radius-list x-radius y-radius)
    "Makes a list of angle/radius pairs at intervals of PI/2 for
the partial ellipse until 7*PI/2.  For example, in pseudo-code:
> (make-radius-list 2 3)\
\n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
\n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
"
    (append-map
     (lambda (adder)
       (map (lambda (quadrant)
              (cons (+ adder (car quadrant))
                    (cdr quadrant)))
            `((0.0 . (,x-radius . 0.0))
              (,PI-OVER-TWO . (0.0 . ,y-radius))
              (,PI . (,(- x-radius) . 0.0))
              (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
     `(0.0 ,TWO-PI)))

  (define
    (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
    "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
the same way but for the right side. For example:
> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
'(1 2 3 4 6 7)
> (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
'(4 6 7)
> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
'(1 2 3 4)
"
    (define
      (helper ordering-function value left-list right-list cutl? cutr?)
      (if (null? right-list)
          (append
           (if cutl? '() left-list)
           (list value)
           (if cutr? '() right-list))
          (if (ordering-function value (car right-list))
              (append
               (if cutl? '() left-list)
               (list value)
               (if cutr? '() right-list))
              (helper
               ordering-function
               value
               (append left-list (list (car right-list)))
               (cdr right-list)
               cutl?
               cutr?))))
    (helper ordering-function value '() inlist cutl? cutr?))

  (define (ordering-function-1 a b) (car< a b))

  (define (ordering-function-2 a b) (car<= a b))

  (define (min-max-crawler min-max side l)
    "Apply function @var{side} to each member of list and
then reduce using @var{min-max}:
> (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
-1
> (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
2
"
    (reduce min-max
            (if (eq? min-max min) 100000 -100000)
            (map side l)))

  (let*
      (;; the outside limit of the x-radius
       (x-out-radius (+ x-radius (/ thick 2.0)))
       ;; the outside limit of the y-radius
       (y-out-radius (+ y-radius (/ thick 2.0)))
       ;; end angle to radians
       (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
       ;; length of the radius at the end angle
       (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
       ;; start angle to radians
       (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
       ;; length of the radius at the start angle
       (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
       ;; points that the arc passes through at 90 degree intervals
       (radius-list (make-radius-list x-out-radius y-out-radius))
       ;; rectangular coordinates of arc endpoint
       (rectangular-end-radius (polar->rectangular end-radius end-angle))
       ;; rectangular coordinates of arc begin point
       (rectangular-start-radius (polar->rectangular start-radius start-angle))
       ;; we want the end angle to always be bigger than the start angle
       ;; so we redefine it here just in case it is less
       (new-end-angle
        (if (<= new-end-angle new-start-angle)
            (+ TWO-PI new-end-angle)
            new-end-angle))
       ;; all the points that may be extrema of the arc
       ;; this is the 90 degree points plus the beginning and end points
       ;; we use this to calculate extents
       (possible-extrema
        (insert-in-ordered-list
         ordering-function-2
         (cons new-end-angle rectangular-end-radius)
         (insert-in-ordered-list
          ordering-function-1
          (cons new-start-angle rectangular-start-radius)
          radius-list
          #t
          #f)
         #f
         #t)))
    (ly:make-stencil
     (list
      'partial-ellipse
      x-radius
      y-radius
      start-angle
      end-angle
      thick
      connect
      fill)
     ;; we know the extrema points by crawling through the
     ;; list of possible extrema and finding the min and max
     ;; for x and y
     (cons (min-max-crawler min cadr possible-extrema)
           (min-max-crawler max cadr possible-extrema))
     (cons (min-max-crawler min cddr possible-extrema)
           (min-max-crawler max cddr possible-extrema)))))


(define*-public (make-path-stencil path thickness x-scale y-scale fill
                                   #:key (line-cap-style 'round)
                                   (line-join-style 'round))
  "Make a stencil based on the path described by the list @var{path}, with
thickness @var{thickness}, and scaled by @var{x-scale} in the x@tie{}direction
and @var{y-scale} in the y@tie{}direction (the difference with scaling the
resulting stencil using @code{ly:stencil-scale} is that this scaling does not
change the thickness).  @var{fill} is a boolean argument that specifies whether
the path should be filled.  Valid path commands are

@example
moveto rmoveto lineto rlineto curveto rcurveto closepath
@end example

and their standard SVG single-letter equivalents

@example
M m L l C c Z z
@end example"
  ;; Convert coordinates to absolute, so we can compute the extents.  We leave
  ;; them as absolute in the result (TODO: this probably means some bits of code
  ;; can be removed in the output backends.)
  (let loop ((path
              ;; A path must begin with a moveto.
              (match path
                ((moveto . _)
                 path)
                (_
                 (cons* 'moveto 0 0 path))))
             ;; The start of the current path.  Changed by moveto commands, used
             ;; for closepath.
             (origin-x 0)
             (origin-y 0)
             ;; The point at which the previous command left us.
             (previous-x 0)
             (previous-y 0)
             ;; Extents of the path so far.
             (X-extent empty-interval)
             (Y-extent empty-interval)
             ;; Absolute path.
             (acc '()))
    (define (handle-moveto x y rest)
      (loop rest
            ;; Reset origin.
            x
            y
            ;; Also reset previous point.
            x
            y
            ;; Extents are unchanged.
            X-extent
            Y-extent
            (cons `(moveto ,x ,y)
                  acc)))
    (define (handle-lineto x y rest)
      (loop rest
            origin-x
            origin-y
            ;; End point of the line becomes the new previous point.
            x y
            ;; Account for the line's extents.
            (interval-union X-extent (ordered-cons previous-x x))
            (interval-union Y-extent (ordered-cons previous-y y))
            (cons `(lineto ,x ,y)
                  acc)))
    (define (handle-curveto x2 y2 x3 y3 x4 y4 rest)
      (let ((bezier `((,previous-x . ,previous-y) (,x2 . ,y2) (,x3 . ,y3) (,x4 . ,y4))))
        (loop rest
              origin-x
              origin-y
              ;; End point of the curve becomes the new previous point.
              x4
              y4
              ;; Account for the curve's extents.
              (interval-union X-extent (ly:bezier-extent bezier X))
              (interval-union Y-extent (ly:bezier-extent bezier Y))
              (cons `(curveto ,x2 ,y2 ,x3 ,y3 ,x4 ,y4)
                    acc))))
    (define (handle-closepath rest)
      (loop rest
            origin-x
            origin-y
            ;; Origin becomes the new previous point again.
            origin-x
            origin-y
            ;; Account for the line's extents.
            (interval-union X-extent (ordered-cons previous-x origin-x))
            (interval-union Y-extent (ordered-cons previous-y origin-y))
            (cons '(closepath)
                  acc)))
    (match path
      (((or 'moveto 'M) x y . rest)
       (handle-moveto (* x x-scale)
                      (* y y-scale)
                      rest))
      (((or 'rmoveto 'm) x y . rest)
       (handle-moveto (+ previous-x (* x x-scale))
                      (+ previous-y (* y y-scale))
                      rest))
      (((or 'lineto 'L) x y . rest)
       (handle-lineto (* x x-scale)
                      (* y y-scale)
                      rest))
      (((or 'rlineto 'l) x y . rest)
       (handle-lineto (+ previous-x (* x x-scale))
                      (+ previous-y (* y y-scale))
                      rest))
      (((or 'curveto 'C) x2 y2 x3 y3 x4 y4 . rest)
       ;; Conceptually, x1 and y1 are the current point.
       (handle-curveto (* x2 x-scale)
                       (* y2 y-scale)
                       (* x3 x-scale)
                       (* y3 y-scale)
                       (* x4 x-scale)
                       (* y4 y-scale)
                       rest))
      (((or 'rcurveto 'c) x2 y2 x3 y3 x4 y4 . rest)
       (handle-curveto (+ previous-x (* x2 x-scale))
                       (+ previous-y (* y2 y-scale))
                       (+ previous-x (* x3 x-scale))
                       (+ previous-y (* y3 y-scale))
                       (+ previous-x (* x4 x-scale))
                       (+ previous-y (* y4 y-scale))
                       rest))
      (((or 'closepath 'Z 'z) . rest)
       (handle-closepath rest))
      (()
       (let ((half-thickness (/ thickness 2)))
         (ly:make-stencil
          `(path ,thickness
                 ;; TODO: a nested internal representation '((moveto x y) (lineto x y))
                 ;; might be better than this flat representation '(moveto x y lineto x y).
                 ,(apply append (reverse! acc))
                 ,line-cap-style
                 ,line-join-style
                 ,fill)
          (interval-widen X-extent half-thickness)
          (interval-widen Y-extent half-thickness)))))))

(define-public (make-connected-path-stencil pointlist thickness
                                            x-scale y-scale connect fill)
  "Make a connected path described by the list @var{pointlist}, beginning
at point @w{(0, 0)}, with thickness @var{thickness}, and scaled by
@var{x-scale} in the x@tie{}direction and @var{y-scale} in the
y@tie{}direction.  @var{connect} and @var{fill} are boolean arguments that
specify whether the path should be connected or filled, respectively."
  (make-path-stencil
   (concatenate
    (append
     (map (lambda (path-unit)
            (case (length path-unit)
              ((2) (append (list 'lineto) path-unit))
              ((6) (append (list 'curveto) path-unit))))
          pointlist)
     ;; if this path is connected, add closepath to the end
     (if connect (list '(closepath)) '())))
   thickness x-scale y-scale fill))

(define-public (make-ellipse-stencil x-radius y-radius thickness fill)
  "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
@code{y-radius}, and thickness @var{thickness} with fill defined by
@code{fill}."
  (let*
      ((x-out-radius (+ x-radius (/ thickness 2.0)))
       (y-out-radius (+ y-radius (/ thickness 2.0))) )

    (ly:make-stencil
     (list 'ellipse x-radius y-radius thickness fill)
     (cons (- x-out-radius) x-out-radius)
     (cons (- y-out-radius) y-out-radius))))

(define-public (box-grob-stencil grob)
  "Make a box of exactly the extents of the grob.  The box precisely
encloses the contents."
  (let* ((xext (ly:grob-extent grob grob 0))
         (yext (ly:grob-extent grob grob 1))
         (thick 0.01))

    (ly:stencil-add
     (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
     (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
     (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
     (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))

(define-public (box-stencil stencil thickness padding)
  "Add a box around @var{stencil}, producing a new stencil.

The spacing characteristics are preserved if either a @code{\\hspace} or a
@code{\\vspace} command (with either positive or negative values) gets boxed.
This means that @var{padding} and @var{thickness} added to an empty extent will
not participate in spacing and is not recognized by skylines."
  (let* ((normalize-ext
          (lambda (i)
            ;; Replace +/-inf.0 by zero; do not reorder if car > cdr.
            (cons (if (inf? (car i)) 0.0 (car i))
                  (if (inf? (cdr i)) 0.0 (cdr i)))))
         (ext-translate
          (lambda (ext amount)
            (cons (+ (car ext) amount) (+ (cdr ext) amount))))
         (negative-ext?
          (lambda (ext)
            (> (car ext) (cdr ext))))

         (raw-x-ext (ly:stencil-extent stencil X))
         (raw-y-ext (ly:stencil-extent stencil Y))
         (x-ext (normalize-ext raw-x-ext))
         (y-ext (normalize-ext raw-y-ext))
         (negative-x? (negative-ext? raw-x-ext))
         (negative-y? (negative-ext? raw-y-ext))
         (x-thick (if negative-x? (- thickness) thickness))
         (y-thick (if negative-y? (- thickness) thickness))
         (thick-x-ext (cons 0 x-thick))
         (thick-y-ext (cons 0 y-thick))
         (pad-x-ext
          (interval-widen x-ext (if negative-x? (- padding) padding)))
         (pad-y-ext
          (interval-widen y-ext (if negative-y? (- padding) padding)))
         (width-ext (interval-widen pad-x-ext x-thick))
         (height-ext (interval-widen pad-y-ext y-thick))

         (boxed-stencil
          (ly:stencil-add
           stencil
           (make-filled-box-stencil     ; left/right
            (ext-translate thick-x-ext (car width-ext))
            height-ext)
           (make-filled-box-stencil     ; right/left
            (ext-translate thick-x-ext (cdr pad-x-ext))
            height-ext)
           (make-filled-box-stencil     ; top/bottom
            width-ext
            (ext-translate thick-y-ext (car height-ext)))
           (make-filled-box-stencil     ; bottom/top
            width-ext
            (ext-translate thick-y-ext (cdr pad-y-ext)))))

         (h-space? (ly:stencil-empty? stencil Y))
         (v-space? (ly:stencil-empty? stencil X)))
    (ly:make-stencil
     (ly:stencil-expr boxed-stencil)
     (if (or h-space? v-space? negative-x?)
         raw-x-ext
         (ly:stencil-extent boxed-stencil X))
     (if (or h-space? v-space? negative-y?)
         raw-y-ext
         (ly:stencil-extent boxed-stencil Y)))))

(define*-public (circle-stencil stencil thickness padding
                                #:optional (bbox #f))
  "Add a circle around @var{stencil}, producing a new stencil.

If optional argument @var{bbox} is set to @code{#t}, use the bounding box of
@var{stencil} as the circle's diameter.  Otherwise, use either the width or
height of @var{stencil} (whatever is larger)."
  (let* ((x-ext (ly:stencil-extent stencil X))
         (y-ext (ly:stencil-extent stencil Y))
         (x-length (interval-length x-ext))
         (y-length (interval-length y-ext))
         (diameter (if bbox
                       (ly:length x-length y-length)
                       (max x-length y-length)))
         (radius (+ (/ diameter 2) padding thickness))
         (circle (make-circle-stencil radius thickness #f)))
    (ly:stencil-add
     stencil
     (ly:stencil-translate circle
                           (cons
                            (interval-center x-ext)
                            (interval-center y-ext))))))

(define-public (oval-stencil stencil thickness x-padding y-padding)
  "Add an oval around @code{stencil}, padded by the padding pair,
producing a new stencil."
  (let* ((x-ext (ly:stencil-extent stencil X))
         (y-ext (ly:stencil-extent stencil Y))
         (x-length (+ (interval-length x-ext) x-padding thickness))
         (y-length (+ (interval-length y-ext) y-padding thickness))
         (x-radius (* 0.707 x-length) )
         (y-radius (* 0.707 y-length) )
         (oval (make-oval-stencil x-radius y-radius thickness #f)))

    (ly:stencil-add
     stencil
     (ly:stencil-translate oval
                           (cons
                            (interval-center x-ext)
                            (interval-center y-ext))))))

(define-public (ellipse-stencil stencil thickness x-padding y-padding)
  "Add an ellipse around @var{stencil}, padded by the padding pair,
producing a new stencil."
  (let* ((x-ext (ly:stencil-extent stencil X))
         (y-ext (ly:stencil-extent stencil Y))
         (x-length (+ (interval-length x-ext) x-padding thickness))
         (y-length (+ (interval-length y-ext) y-padding thickness))
         ;; (aspect-ratio (/ x-length y-length))
         (x-radius (* 0.707 x-length) )
         (y-radius (* 0.707 y-length) )
         ;; (diameter (max (- (cdr x-ext) (car x-ext))
         ;;             (- (cdr y-ext) (car y-ext))))
         ;; radius (+ (/ diameter 2) padding thickness))
         (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))

    (ly:stencil-add
     stencil
     (ly:stencil-translate ellipse
                           (cons
                            (interval-center x-ext)
                            (interval-center y-ext))))))

(define-public (rounded-box-stencil stencil thickness padding blot)
  "Add a rounded box around @var{stencil}, producing a new stencil."

  (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
         (yext (interval-widen (ly:stencil-extent stencil 1) padding))
         (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
         (ideal-blot (min blot (/ min-ext 2)))
         (ideal-thickness (min thickness (/ min-ext 2)))
         (outer (ly:round-filled-box
                 (interval-widen xext ideal-thickness)
                 (interval-widen yext ideal-thickness)
                 ideal-blot))
         (inner (ly:stencil-in-color
                 (ly:round-filled-box
                  xext yext (- ideal-blot ideal-thickness))
                 "white")))
    (ly:stencil-add outer inner stencil)))

(define-public (flip-stencil axis stil)
  "Flip stencil @var{stil} in the direction of @var{axis}.
Value @code{X} (or @code{0}) for @var{axis} flips it horizontally.
Value @code{Y} (or @code{1}) flips it vertically.  @var{stil} is
flipped in place; its position, the coordinates of its bounding
box, remains the same."
  (let* (
         ;; scale stencil using -1 to flip it and
         ;; then restore it to its original position
         (xy (if (= axis X) '(-1 . 1) '(1 . -1)))
         (flipped-stil (ly:stencil-scale stil (car xy) (cdr xy)))
         (flipped-ext (ly:stencil-extent flipped-stil axis))
         (original-ext (ly:stencil-extent stil axis))
         (offset (- (car original-ext) (car flipped-ext)))
         (replaced-stil (ly:stencil-translate-axis flipped-stil offset axis)))
    replaced-stil))

(define-public (stencil-with-color stencil color)
  "Return a modified version of the given stencil that is colored
with the given color.  See @code{normalize-color} for possible
color formats."
  (if color
      (let* ((expr (ly:stencil-expr stencil))
             (xext (ly:stencil-extent stencil X))
             (yext (ly:stencil-extent stencil Y))
             (rgba (normalize-color color)))
        (ly:make-stencil `(color ,rgba ,expr) xext yext))
      ;; FIXME: why accept #f for `color`?
      stencil))

;; For historical reasons, we have two inconsistent functions for coloring a
;; stencil, with inconsistent calling conventions.  We could try to deprecate
;; this one.
(define-public (ly:stencil-in-color stencil . color-args)
  (if (string? (car color-args))
      (stencil-with-color stencil (car color-args))
      (stencil-with-color stencil color-args)))

(define*-public (stencil-whiteout-outline
                 stil #:optional (thickness 0.3) (color white)
                 (angle-increments 16) (radial-increments 1))
  "White-out stencil @var{stil} by surrounding its outline with white.

This function works by creating a series of white stencils radially offset from
the original stencil with angles from 0° to 360°.

Optional argument @var{thickness} (default value 0.3) specifies how big the
white outline is.

The number of angle increments can be controlled with optional argument
@var{angle-increments}, defaulting to value 16 (corresponding to 22.5°).  The
number of radius increments (from zero to @var{thickness}) can be controlled
with optional argument @var{radial-increments}, defaulting to value@tie{}1.
Thus @var{radial-increments} specifies how many copies of the white stencil we
make on our way out to @var{thickness}, and @var{angle-increments} how many
copies of the white stencil we make between 0° and 360°.  In total,
@var{radial-increments}*@var{angle-increments} copies are drawn.

Optional argument @var{color} changes the white-out color (defaulting to white)."
  (if (or (not (positive? angle-increments))
          (not (positive? radial-increments)))
      (begin
        (ly:warning (G_ "Both angle-increments and radial-increments must be positive numbers."))
        stil)
      (let* ((angle-inc (/ 360 angle-increments))
             (radial-inc (/ thickness radial-increments)))

        (define (circle-plot ang dec radius original-stil new-stil)
          ;; ang (angle) and dec (decrement) are in degrees, not radians
          (if (<= ang 0)
              new-stil
              (circle-plot (- ang dec) dec radius original-stil
                           (ly:stencil-add
                            new-stil
                            (ly:stencil-translate original-stil
                                                  (ly:directed ang radius))))))

        (define (radial-plot radius original-stil new-stil)
          (if (<= radius 0)
              new-stil
              (ly:stencil-add new-stil
                              (radial-plot
                               (- radius radial-inc)
                               original-stil
                               (circle-plot 360 angle-inc
                                            radius original-stil empty-stencil)))))

        (let ((whiteout-expr
               (ly:stencil-expr
                (stencil-with-color
                 (radial-plot thickness stil empty-stencil)
                 color))))
          (ly:stencil-add
           (ly:make-stencil
            `(delay-stencil-evaluation ,(delay whiteout-expr)))
           stil)))))

(define*-public (stencil-whiteout-box stil
                                      #:optional (thickness 0) (blot 0)
                                      (color white))
  "White-out stencil @var{stil} by printing it on top of a white rectangle.

By default, the white background rectangle encloses @var{stil} without any
borders; this can be changed by setting optional argument @var{thickness}
(defaulting to value zero).  Optional argument @var{blot} gives the blot
diameter for rounding the corners of the background rectangle (default value is
zero, making sharp corners).  Optional argument @var{color} changes the
background color (defaulting to white)."
  (let*
      ((x-ext (interval-widen (ly:stencil-extent stil X) thickness))
       (y-ext (interval-widen (ly:stencil-extent stil Y) thickness)))

    (ly:stencil-add
     (stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
     stil)))

(define*-public (stencil-whiteout stil
                                  #:optional style thickness
                                  (line-thickness 0.1)
                                  (color white))
  "White-out stencil @var{stil} (i.e., add a white background around it).

If set, optional argument @var{style} determines the shape of the white
background: value @code{'outline} makes the function use
@code{stencil-whiteout-outline} to produce the white background, value
@code{'rounded-box} applies @code{stencil-whiteout-box} to produce a white
background with rounded corners.  If other values are given (e.g., @code{'box})
or when unspecified, @code{stencil-whiteout-box} is used to produce a white
background with square corners.

If optional argument @var{thickness} is specified it determines how far, as a
multiple of @var{line-thickness} (which is an optional argument, too, defaulting
to value 0.1), the white background extends past the extents of @var{stil}.  If
@var{thickness} is not specified, an appropriate default is chosen based on
@var{style}.

Optional argument @var{color} sets the color of the white-out, defaulting to
white."
  (let ((thick (* line-thickness
                  (if (number? thickness)
                      thickness
                      (cond
                       ((eq? style 'outline) 3)
                       ((eq? style 'rounded-box) 3)
                       (else 0))))))
    (cond
     ((eq? style 'special) stil)
     ((eq? style 'outline) (stencil-whiteout-outline stil thick color))
     ((eq? style 'rounded-box) (stencil-whiteout-box
                                stil thick (* 2 thick) color))
     (else (stencil-whiteout-box stil thick 0 color)))))

(define-public (arrow-stencil-maker start? end?)
  "Return a function drawing a line from current point to @code{destination},
with optional arrows of @code{max-size} on start and end controlled by
@var{start?} and @var{end?}."
  (lambda (destination max-size)
    (let*
        ((e_x 1+0i)
         (e_y 0+1i)
         (distance (sqrt (+ (* (car destination) (car destination))
                            (* (cdr destination) (cdr destination)))))
         (size (min max-size (/ distance 3)))
         (rotate (lambda (z ang)
                   (* (make-polar 1 ang)
                      z)))
         (complex-to-offset (lambda (z)
                              (list (real-part z) (imag-part z))))

         (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
         (e_z (/ z-dest (magnitude z-dest)))
         (triangle-points (list
                           (* size -1+0.25i)
                           0
                           (* size -1-0.25i)))
         (p1s (map (lambda (z)
                     (+ z-dest (rotate z (angle z-dest))))
                   triangle-points))
         (p2s (map (lambda (z)
                     (rotate z (angle (- z-dest))))
                   triangle-points))
         (null (cons 0 0))
         (arrow-1
          (ly:make-stencil
           `(polygon  ,(append-map complex-to-offset p1s)
                      0.0
                      #t) null null))
         (arrow-2
          (ly:make-stencil
           `(polygon ,(append-map complex-to-offset p2s)
                     0.0
                     #t) null null ) )
         (thickness (min (/ distance 12) 0.1))
         (shorten-line (min (/ distance 3) 0.5))
         (start (complex-to-offset (/ (* e_z shorten-line) 2)))
         (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))

         (line (ly:make-stencil
                `(draw-line ,thickness
                            ,(car start) ,(cadr start)
                            ,(car end) ,(cadr end)
                            )
                (cons (min 0 (car destination))
                      (min 0 (cdr destination)))
                (cons (max 0 (car destination))
                      (max 0 (cdr destination)))))

         (result
          (ly:stencil-add
           (if start? arrow-2 empty-stencil)
           (if end? arrow-1 empty-stencil)
           line)))

      result)))

(define-public dimension-arrows (arrow-stencil-maker #t #t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ANNOTATIONS
;;
;; annotations are arrows indicating the numerical value of
;; spacing variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define*-public (annotate-y-interval layout name extent is-length
                                     #:key (color darkblue))
  (let ((text-props (cons '((font-size . -3)
                            (font-family . typewriter))
                          (layout-extract-page-properties layout)))
        (annotation #f))
    (define (center-stencil-on-extent stil)
      (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
                            (cons 0 (interval-center extent))))
    ;; do something sensible for 0,0 intervals.
    (set! extent (interval-widen extent 0.001))
    (if (not (interval-sane? extent))
        (set! annotation (interpret-markup
                          layout text-props
                          (simple-format #f "~a: NaN/inf" name)))
        (let ((text-stencil (interpret-markup
                             layout text-props
                             (make-whiteout-markup name)))
              (dim-stencil (interpret-markup
                            layout text-props
                            (make-whiteout-markup
                             (cond
                              ((interval-empty? extent)
                               "empty")
                              (is-length
                               (ice9-format #f "~,2f" (interval-length extent)))
                              (else
                               (ice9-format #f "(~,2f,~,2f)"
                                            (car extent) (cdr extent)))))))
              (arrows (ly:stencil-translate-axis
                       (dimension-arrows (cons 0 (interval-length extent)) 1.0)
                       (interval-start extent) Y)))
          (set! annotation
                (center-stencil-on-extent text-stencil))
          (set! annotation
                (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
          (set! annotation
                (ly:stencil-combine-at-edge annotation X LEFT
                                            (center-stencil-on-extent dim-stencil)
                                            0.5))
          (set! annotation
                (stencil-with-color annotation color))))
    annotation))


;; TODO: figure out how to annotate padding nicely
;; TODO: emphasize either padding or min-dist depending on which constraint was active
(define*-public (annotate-spacing-spec layout name spacing-spec
                                       start-Y-offset next-staff-Y
                                       #:key (base-color blue))
  (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
         (space (get-spacing-var 'basic-distance))
         (padding (get-spacing-var 'padding))
         (min-dist (get-spacing-var 'minimum-distance))
         (contrast-color (append (cdr base-color) (list (car base-color))))
         (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
         (min-dist-color (if min-dist-blocks contrast-color base-color))
         (name-string (if (string-null? name)
                          ""
                          (simple-format #f " (~a)" name)))
         (basic-annotation
          (annotate-y-interval layout
                               (simple-format #f "basic-dist~a" name-string)
                               (cons (- start-Y-offset space) start-Y-offset)
                               #t
                               #:color (map (lambda (x) (* x 0.25)) base-color)))
         (min-annotation
          (annotate-y-interval layout
                               (simple-format #f "min-dist~a" name-string)
                               (cons (- start-Y-offset min-dist) start-Y-offset)
                               #t
                               #:color min-dist-color))
         (extra-annotation
          (annotate-y-interval layout
                               (simple-format #f "extra dist~a" name-string)
                               (cons next-staff-Y (- start-Y-offset min-dist))
                               #t
                               #:color (map (lambda (x) (* x 0.5)) min-dist-color))))

    (stack-stencils X RIGHT 0.0
                    (list
                     basic-annotation
                     (if min-dist-blocks
                         min-annotation
                         (ly:stencil-add min-annotation extra-annotation))))))

(define-public (eps-file->stencil axis size file-name)
  (ly:note-extra-source-file file-name)
  (let*
      ((contents (ly:gulp-file file-name))
       (bbox (get-postscript-bbox (car (string-split contents #\nul))))
       (bbox-size (if (= axis X)
                      (- (list-ref bbox 2) (list-ref bbox 0))
                      (- (list-ref bbox 3) (list-ref bbox 1))
                      ))
       (factor (if (< 0 bbox-size)
                   (exact->inexact (/ size bbox-size))
                   0))
       (scaled-bbox
        (map (lambda (x) (* factor x)) bbox)))

    (if bbox
        (ly:make-stencil
         (list
          'eps-file
          file-name
          contents
          bbox
          factor)
         ;; Stencil starts at (0,0), since we have shifted the eps, and its
         ;; size is exactly the size of the scaled bounding box
         (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
         (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))

        (ly:make-stencil "" '(0 . 0) '(0 . 0)))
    ))


(define-public (stencil-true-extent stencil axis)
  "Return the extent of the actual printed ink of @var{stencil}
on @var{axis}."
  ;; Simple strategy: compute skylines, take their max height.
  ;; If this becomes performance-critical, it can be rewritten
  ;; to inspect the stencil expressions and compute their extents
  ;; directly without building full skylines -- at the cost of
  ;; a lot more code.
  (let ((skyp (ly:skylines-for-stencil stencil (other-axis axis))))
    (cons (ly:skyline-max-height (car skyp))
          (ly:skyline-max-height (cdr skyp)))))

(define-public (stencil-pad-around amount stencil)
  "Add a padding of @var{amount} around @var{stencil}, returning a
new stencil."
  (let* ((x (interval-widen (ly:stencil-extent stencil X) amount))
         (y (interval-widen (ly:stencil-extent stencil Y) amount)))
    (ly:stencil-add stencil (make-transparent-box-stencil x y))))
