\version "2.22.0"

#(define-markup-command (general-ps-path layout props path)
                        (list?)
   #:properties ((path-type "stroke")
                 (thickness 0.2)
                 (dash-len #f)
                 (blank-len #f)
                 (dash-start 0))
   (define (format-ps-value x)
     (format #f "~a"
             (if (number? x)
                 (exact->inexact x)
                 x)))
   (define (format-ps-command command)
     (string-join
       (map format-ps-value
            (append (cdr command)
                    (list (car command))))
       " "))
   (let* ((commands (map format-ps-command path))
          (command-part (string-join commands "\n"))
          (dash-command
            (if dash-len
                (if blank-len
                    (format #f "[~a ~a] ~a setdash" dash-len blank-len dash-start)
                    (begin
                      (ly:warning "dash-len without blank-len")
                      ""))
                ""))
          (ps-string
            (format #f
"
newpath
~a
~a setlinewidth
~a
~a
"
            command-part
            thickness
            dash-command
            path-type)))
     (interpret-markup layout props
       (make-postscript-markup ps-string))))

#(define-macro (unpack-interval start end interval expression)
   `(let* ((internal-interval ,interval)
           (,start (interval-start internal-interval))
           (,end (interval-end internal-interval)))
      ,expression))

#(define (make-box-path x-extent y-extent blot-radius)
   (unpack-interval x-start x-end x-extent
     (unpack-interval interior-x-start interior-x-end
                      (interval-widen x-extent (- blot-radius))
       (unpack-interval y-start y-end y-extent
         (unpack-interval interior-y-start interior-y-end
                          (interval-widen y-extent (- blot-radius))
           `((moveto ,interior-x-start ,y-start)
             (lineto ,interior-x-end ,y-start)
             (arc ,interior-x-end ,interior-y-start ,blot-radius -90 0)
             (lineto ,x-end ,interior-y-end)
             (arc ,interior-x-end ,interior-y-end ,blot-radius 0 90)
             (lineto ,interior-x-start ,y-end)
             (arc ,interior-x-start ,interior-y-end ,blot-radius 90 180)
             (lineto ,x-start ,interior-y-end)
             (arc ,interior-x-start ,interior-y-start ,blot-radius 180 270)
             (closepath)))))))

#(define-markup-command (super-filled-box layout props x-extent y-extent)
                        (number-pair? number-pair?)
   #:properties ((filled #t)
                 (framed #t)
                 (blot 0)
                 (thickness 0.2)
                 (fill-color black)
                 (frame-color black))
   (let* ((blot-radius (/ blot 2))
          (fill-shorten (- (/ thickness 2)))
          (fill-path
            (make-box-path (interval-widen x-extent fill-shorten)
                           (interval-widen y-extent fill-shorten)
                           (+ blot-radius fill-shorten)))
          (fill-markup
            (make-with-color-markup fill-color
                                    (make-override-markup
                                      '(path-type . "fill")
                                      (make-general-ps-path-markup fill-path))))
          (frame-path
            (make-box-path x-extent y-extent blot-radius))
          (frame-markup
            (make-with-color-markup frame-color
                                    (make-general-ps-path-markup frame-path))))
     (ly:stencil-outline
       (interpret-markup layout props
         (make-overlay-markup
           (filter
             (lambda (x) x)
             (list
               (and filled fill-markup)
               (and framed frame-markup)))))
       (ly:round-filled-box x-extent y-extent blot))))


% Exemple

% Tous les \override sont optionnels.

\markup
% Boîte remplie à l'intérieur ? #f par défaut, mettre #t pour activer.
\override #'(filled . #t)
% Ligne d'encadrement autour de la boîte ? #t par défaut, #f pour enlever.
% \override #'(framed . #f)
% Couleur de l'intérieur.
\override #'(fill-color . "DarkSalmon")
% Couleur du contour.
\override #'(frame-color . "LimeGreen")
% Épaisseur du contour.
\override #'(thickness . 0.1)
% Taille des coins.
\override #'(blot . 1)
% Taille d'un tiret du contour (sans ceci, il est plein).
\override #'(dash-len . 0.3)
% Distance entre deux tirets (obligatoire lorsque dash-len est défini).
\override #'(blank-len . 0.2)
% Modifier pour faire tourner les tirets.
\override #'(dash-start . 0.3)
% Les arguments sont les dimensions horizontales et verticales.
\super-filled-box #'(-1 . 2) #'(-1 . 1)