\version "2.22.0"

kieren =
#(define-scheme-function
  (scalar rhythm)
  (index? ly:music?)
  (cons scalar rhythm))

#(define (kieren-fraction? arg)
  (and (pair? arg)
       (index? (car arg))
       (ly:music? (cdr arg))))

%% Borrowed non-exported procedure in define-music-properties.scm
#(define (music-property-description symbol type? description)
   (if (not (equal? #f (object-property symbol 'music-doc)))
       (ly:error (_ "symbol ~S redefined") symbol))
   (set-object-property! symbol 'music-type? type?)
   (set-object-property! symbol 'music-doc description)
   symbol)

#(set! all-music-properties (cons
  (music-property-description 'kieren-fraction kieren-fraction? "...")
  all-music-properties))

%% Borrowed non-exported procedure in define-context-properties.scm
#(define (translator-property-description symbol type? description)
  (if (not (and
            (symbol? symbol)
            (procedure? type?)
            (string? description)))
      (throw 'init-format-error))
  (if (not (equal? #f (object-property symbol 'translation-doc)))
      (ly:error (_ "symbol ~S redefined") symbol))
  (set-object-property! symbol 'translation-type? type?)
  (set-object-property! symbol 'translation-doc description)
  (set! all-translation-properties (cons symbol all-translation-properties))
  symbol)

#(translator-property-description 'kieren-fraction kieren-fraction? "...")

%% Borrowed non-exported procedure in define-grob-properties.scm
#(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)

#(set! all-user-grob-properties (cons
  (define-grob-property 'kieren-fraction kieren-fraction? "...")
  all-user-grob-properties))

%% Adapted non-exported procedure in define-music-callbacks.scm
#(define (make-kieren-time-signature-set music)
  "Set context properties for a time signature."
  (let* ((num (ly:music-property music 'numerator))
         (den (ly:music-property music 'denominator))
         (structure (ly:music-property music 'beat-structure))
         (kieren-fraction (ly:music-property music 'kieren-fraction))
         (fraction (cons num den)))
    (list (context-spec-music
           (make-apply-context
            (lambda (context)
              (let* ((time-signature-settings
                      (ly:context-property context 'timeSignatureSettings))
                     (my-base-length
                      (base-length fraction time-signature-settings))
                     (my-beat-structure
                      (if (null? structure)
                          (beat-structure my-base-length
                                          fraction
                                          time-signature-settings)
                          structure))
                     (beaming-exception
                      (beam-exceptions fraction time-signature-settings))
                     (new-measure-length (ly:make-moment num den)))
                (ly:context-set-property!
                 context 'timeSignatureFraction fraction)
                (ly:context-set-property!
                 context 'baseMoment (ly:make-moment my-base-length))
                (ly:context-set-property!
                 context 'beatStructure my-beat-structure)
                (ly:context-set-property!
                 context 'beamExceptions beaming-exception)
                (ly:context-set-property!
                 context 'measureLength new-measure-length)
                (ly:context-set-property!
                 context 'kieren-fraction kieren-fraction))))
           'Timing)
          ;; (make-music 'TimeSignatureEvent music) would always
          ;; create a Bottom context.  So instead, we just send the
          ;; event to whatever context may be currently active.  If
          ;; that is not contained within an existing context with
          ;; TimeSignatureEngraver at the time \time is iterated, it
          ;; will drop through the floor which mostly means that
          ;; point&click and tweaks are not available for any time
          ;; signatures engraved due to the Timing property changes
          ;; but without a \time of its own.  This is more a
          ;; "notification" rather than an "event" (which is always
          ;; sent to Bottom) but we don't currently have iterators for
          ;; that.
          (descend-to-context
           (make-apply-context
            (lambda (context)
              (ly:broadcast (ly:context-event-source context)
                            (ly:make-stream-event
                             (ly:make-event-class 'time-signature-event)
                             (ly:music-mutable-properties music)))))
           'Score))))

#(assoc-set!
  (ly:assoc-get 'TimeSignatureMusic music-descriptions)
  'elements-callback
  make-kieren-time-signature-set)

#(define (time-fraction? arg)
  (or (fraction? arg)
      (kieren-fraction? arg)))

time =
#(define-music-function (beat-structure fraction)
   ((number-list? '()) time-fraction?)
   (_i "Set @var{fraction} as time signature, with optional
number list @var{beat-structure} before it.")
  (if (kieren-fraction? fraction)
   (let* ((scalar (car fraction))
          (music (cdr fraction))
          (moment (ly:music-length music))
          (numerator (ly:moment-main-numerator moment))
          (denominator (ly:moment-main-denominator moment)))
    (make-music 'TimeSignatureMusic
                'numerator (* scalar numerator)
                'denominator denominator
                'beat-structure beat-structure
                'kieren-fraction (cons scalar music)))
   ;; Simple time signature.
   (make-music 'TimeSignatureMusic
               'numerator (car fraction)
               'denominator (cdr fraction)
               'beat-structure beat-structure)))

Kieren_time_translator =
#(lambda (ctxt)
  (make-engraver
   (acknowledgers
    ((time-signature-interface trans grob source)
     (ly:grob-set-property! grob 'kieren-fraction
      (ly:context-property ctxt 'kieren-fraction))))))

#(define-markup-command
  (kieren-time layout props numerator denominator)
  (index? ly:music?)
  (interpret-markup layout props #{
    \markup
    \override #'(baseline-skip . 0)
    \center-column {
      \line \number { #(number->string numerator) }
      \score {
        \new RhythmicStaff { \cadenzaOn \stemDown #denominator }
        \layout {
          \context {
            \RhythmicStaff
            \remove Clef_engraver
            \remove Time_signature_engraver
            \omit StaffSymbol
          }
          indent = 0
        }
      }
    } #}))

#(define (kieren-time-signature::print grob)
  (define (default-kieren-time-from-fraction fraction)
   (let* ((numerator (car fraction))
          (denominator (cdr fraction))
          (duration (ly:make-duration (ly:intlog2 denominator))))
   (cons numerator #{ { $duration } #})))
  (if (eq? 'kieren (ly:grob-property grob 'style 'default))
   (let* ((fraction (ly:grob-property grob 'fraction))
          (kieren-fraction
           (ly:grob-property grob 'kieren-fraction
            (default-kieren-time-from-fraction fraction)))
          (numerator (car kieren-fraction))
          (denominator (cdr kieren-fraction)))
    (grob-interpret-markup grob
     (markup #:kieren-time numerator denominator)))
   (ly:time-signature::print grob)))

\layout {
  \context {
    \Score
    \consists \Kieren_time_translator
    \override TimeSignature.stencil = #kieren-time-signature::print
  }
  indent = 0
}

\fixed c' {
  \time 3/4                  | g4 a b
  \time 7/8                  | g4 a b8 a b
  \time \kieren 5 8          | g4 a8 b a
  \time \kieren 3 4.         | g4 a8 b4. a
  \time \kieren 2 { 8[ 8.] } | g4 a16 b a b8.

  \bar "||"
  \break

  \override Score.TimeSignature.style = #'kieren

  \time 3/4                  | g4 a b
  \time 7/8                  | g4 a b8 a b
  \time \kieren 5 8          | g4 a8 b a
  \time \kieren 3 4.         | g4 a8 b4. a
  \time \kieren 2 { 8[ 8.] } | g4 a16 b a b8.

  \bar "|."
}