;;;; auto-beam.scm -- Auto-beam-engraver settings
;;;;
;;;; source file of the GNU LilyPond music typesetter
;;;;
;;;; (c) 2000--2009 Jan Nieuwenhuizen <janneke@gnu.org>

;;; specify generic beam end times

;;; format:
;;;
;;;   function shortest-duration-in-beam time-signature
;;;
;;; where
;;;
;;;     function = begin or end
;;;     shortest-duration-in-beam = numerator denominator; e.g.: 1 16
;;;     time-signature = numerator denominator, e.g.: 4 4
;;;
;;; unspecified or wildcard entries for duration or time-signature
;;; are given by * *

;;; maybe do:  '(end shortest-1 16 time-3 4) ?

(define-public default-auto-beam-settings
  `(
    ;; in 2 2 time:
    ;;   use beatLength for all except 32nd notes
    ;;   end beams with 32nd notes each 1 4 beat

    ((end 1 32 2 2) . ,(ly:make-moment 1 4))
    ((end 1 32 2 2) . ,(ly:make-moment 2 4))
    ((end 1 32 2 2) . ,(ly:make-moment 3 4))

    ;; in 2 4, 2 8 and 2 16 time:
    ;;   use beatLength

    ;; in 3 2 time:
    ;;   use beatLength for all except 32nd notes
    ;;   end beams with 32nd notes each 1 4 beat

    ((end 1 32 3 2) . ,(ly:make-moment 1 4))
    ((end 1 32 3 2) . ,(ly:make-moment 2 4))
    ((end 1 32 3 2) . ,(ly:make-moment 3 4))
    ((end 1 32 3 2) . ,(ly:make-moment 4 4))
    ((end 1 32 3 2) . ,(ly:make-moment 5 4))

    ;; in 3 4, 3 8 and 3 16 time:
    ;;   use beatLength

    ;; in 4 2 time:
    ;;   use beatLength for all except 16th and 32nd notes
    ;;   end beams with 16th notes each 1 4 beat
    ;;   end beams with 32nd notes each 1 8 beat

    ((end 1 16 4 2) . ,(ly:make-moment 1 4))
    ((end 1 16 4 2) . ,(ly:make-moment 2 4))
    ((end 1 16 4 2) . ,(ly:make-moment 3 4))
    ((end 1 16 4 2) . ,(ly:make-moment 4 4))
    ((end 1 16 4 2) . ,(ly:make-moment 5 4))
    ((end 1 16 4 2) . ,(ly:make-moment 6 4))
    ((end 1 16 4 2) . ,(ly:make-moment 7 4))

    ((end 1 32 4 2) . ,(ly:make-moment 1 8))
    ((end 1 32 4 2) . ,(ly:make-moment 2 8))
    ((end 1 32 4 2) . ,(ly:make-moment 3 8))
    ((end 1 32 4 2) . ,(ly:make-moment 4 8))
    ((end 1 32 4 2) . ,(ly:make-moment 5 8))
    ((end 1 32 4 2) . ,(ly:make-moment 6 8))
    ((end 1 32 4 2) . ,(ly:make-moment 7 8))
    ((end 1 32 4 2) . ,(ly:make-moment 8 8))
    ((end 1 32 4 2) . ,(ly:make-moment 9 8))
    ((end 1 32 4 2) . ,(ly:make-moment 10 8))
    ((end 1 32 4 2) . ,(ly:make-moment 11 8))
    ((end 1 32 4 2) . ,(ly:make-moment 12 8))
    ((end 1 32 4 2) . ,(ly:make-moment 13 8))
    ((end 1 32 4 2) . ,(ly:make-moment 14 8))
    ((end 1 32 4 2) . ,(ly:make-moment 15 8))

    ;; in 4 4 (common) time:
    ;;  use beatLength for all except 32nd notes:
    ;;  end beams with 32nd notes each 1 8 beat

    ((end 1 32 4 4) . ,(ly:make-moment 1 8))
    ((end 1 32 4 4) . ,(ly:make-moment 2 8))
    ((end 1 32 4 4) . ,(ly:make-moment 3 8))
    ((end 1 32 4 4) . ,(ly:make-moment 4 8))
    ((end 1 32 4 4) . ,(ly:make-moment 5 8))
    ((end 1 32 4 4) . ,(ly:make-moment 6 8))
    ((end 1 32 4 4) . ,(ly:make-moment 7 8))

    ;; in 4 8 and 4 16 time:
    ;;   use beatLength

    ;; in 6 4 time:
    ;;   use beatGrouping for all except 16th, 32nd notes
    ;;   end beams with 16th or 32nd notes each 1 4 beat


    ((end 1 16 6 4) . ,(ly:make-moment 1 4))
    ((end 1 16 6 4) . ,(ly:make-moment 2 4))
    ((end 1 16 6 4) . ,(ly:make-moment 3 4))
    ((end 1 16 6 4) . ,(ly:make-moment 4 4))
    ((end 1 16 6 4) . ,(ly:make-moment 5 4))

    ((end 1 32 6 4) . ,(ly:make-moment 1 4))
    ((end 1 32 6 4) . ,(ly:make-moment 2 4))
    ((end 1 32 6 4) . ,(ly:make-moment 3 4))
    ((end 1 32 6 4) . ,(ly:make-moment 4 4))
    ((end 1 32 6 4) . ,(ly:make-moment 5 4))

    ;; in 6 8 time:
    ;;   use beatGrouping for all except 32nd notes
    ;;   end beams with 32nd notes each 1 8 beat

    ((end 1 32 6 8) . ,(ly:make-moment 1 8))
    ((end 1 32 6 8) . ,(ly:make-moment 2 8))
    ((end 1 32 6 8) . ,(ly:make-moment 3 8))
    ((end 1 32 6 8) . ,(ly:make-moment 4 8))
    ((end 1 32 6 8) . ,(ly:make-moment 5 8))

    ;; in 6 16 time:
    ;;   use beatGrouping

    ;; in 9 4 time:
    ;;   use beatGrouping for all except 16th, 32nd notes
    ;;   end beams with 16th or 32nd notes each 1 4 beat

    ((end 1 16 9 4) . ,(ly:make-moment 1 4))
    ((end 1 16 9 4) . ,(ly:make-moment 2 4))
    ((end 1 16 9 4) . ,(ly:make-moment 3 4))
    ((end 1 16 9 4) . ,(ly:make-moment 4 4))
    ((end 1 16 9 4) . ,(ly:make-moment 5 4))
    ((end 1 16 9 4) . ,(ly:make-moment 6 4))
    ((end 1 16 9 4) . ,(ly:make-moment 7 4))
    ((end 1 16 9 4) . ,(ly:make-moment 8 4))

    ((end 1 32 9 4) . ,(ly:make-moment 1 4))
    ((end 1 32 9 4) . ,(ly:make-moment 2 4))
    ((end 1 32 9 4) . ,(ly:make-moment 3 4))
    ((end 1 32 9 4) . ,(ly:make-moment 4 4))
    ((end 1 32 9 4) . ,(ly:make-moment 5 4))
    ((end 1 32 9 4) . ,(ly:make-moment 6 4))
    ((end 1 32 9 4) . ,(ly:make-moment 7 4))
    ((end 1 32 9 4) . ,(ly:make-moment 8 4))

    ;; in 9 8 time:
    ;;   use beatGrouping for all except 32nd notes
    ;;   end beams with 32nd notes each 1 8 beat

    ((end 1 32 9 8) . ,(ly:make-moment 1 8))
    ((end 1 32 9 8) . ,(ly:make-moment 2 8))
    ((end 1 32 9 8) . ,(ly:make-moment 3 8))
    ((end 1 32 9 8) . ,(ly:make-moment 4 8))
    ((end 1 32 9 8) . ,(ly:make-moment 5 8))
    ((end 1 32 9 8) . ,(ly:make-moment 6 8))
    ((end 1 32 9 8) . ,(ly:make-moment 7 8))
    ((end 1 32 9 8) . ,(ly:make-moment 8 8))

    ;; in 9 16 time
    ;;   use beatGrouping

    ;; in 12 4 time:
    ;;   use beatGrouping for all except 16th, 32nd notes
    ;;   end beams with 16th or 32nd notes each 1 4 beat

    ((end 1 16 12 4) . ,(ly:make-moment 1 4))
    ((end 1 16 12 4) . ,(ly:make-moment 2 4))
    ((end 1 16 12 4) . ,(ly:make-moment 3 4))
    ((end 1 16 12 4) . ,(ly:make-moment 4 4))
    ((end 1 16 12 4) . ,(ly:make-moment 5 4))
    ((end 1 16 12 4) . ,(ly:make-moment 6 4))
    ((end 1 16 12 4) . ,(ly:make-moment 7 4))
    ((end 1 16 12 4) . ,(ly:make-moment 8 4))
    ((end 1 16 12 4) . ,(ly:make-moment 9 4))
    ((end 1 16 12 4) . ,(ly:make-moment 10 4))
    ((end 1 16 12 4) . ,(ly:make-moment 11 4))

    ((end 1 32 12 4) . ,(ly:make-moment 1 4))
    ((end 1 32 12 4) . ,(ly:make-moment 2 4))
    ((end 1 32 12 4) . ,(ly:make-moment 3 4))
    ((end 1 32 12 4) . ,(ly:make-moment 4 4))
    ((end 1 32 12 4) . ,(ly:make-moment 5 4))
    ((end 1 32 12 4) . ,(ly:make-moment 6 4))
    ((end 1 32 12 4) . ,(ly:make-moment 7 4))
    ((end 1 32 12 4) . ,(ly:make-moment 8 4))
    ((end 1 32 12 4) . ,(ly:make-moment 9 4))
    ((end 1 32 12 4) . ,(ly:make-moment 10 4))
    ((end 1 32 12 4) . ,(ly:make-moment 11 4))

    ;; in 12 8 time:
    ;;   use beatGrouping for all except 32nd notes
    ;;   end beams with 32nd notes each 1 8 beat

    ((end 1 32 12 8) . ,(ly:make-moment 1 8))
    ((end 1 32 12 8) . ,(ly:make-moment 2 8))
    ((end 1 32 12 8) . ,(ly:make-moment 3 8))
    ((end 1 32 12 8) . ,(ly:make-moment 4 8))
    ((end 1 32 12 8) . ,(ly:make-moment 5 8))
    ((end 1 32 12 8) . ,(ly:make-moment 6 8))
    ((end 1 32 12 8) . ,(ly:make-moment 7 8))
    ((end 1 32 12 8) . ,(ly:make-moment 8 8))
    ((end 1 32 12 8) . ,(ly:make-moment 9 8))
    ((end 1 32 12 8) . ,(ly:make-moment 10 8))
    ((end 1 32 12 8) . ,(ly:make-moment 11 8))

    ;; in 12 16 time:
    ;;   use beatGrouping

    ))

(define (override-property-setting context property setting value)
  "Like the C++ code that executes \\override, but without type
checking. "
  (ly:context-set-property!
   context property
   (cons (cons setting value) (ly:context-property context property))))

(define (revert-property-setting context property setting)
  "Like the C++ code that executes \revert, but without type
checking. "

  (define (revert-member alist entry new)
    "Return ALIST, with ENTRY removed.  ALIST is not modified, instead
a fresh copy of the list-head is made."
    (cond
     ((null? alist) new)
     ((equal? (car alist) entry) (revert-member (cdr alist) entry new))
     (else (revert-member (cdr alist) entry (cons (car alist) new)))))

  (ly:context-set-property!
   context property
   (revert-member (ly:context-property context property) setting '())))

(define-public (override-auto-beam-setting setting num den . rest)
  (ly:export
   (context-spec-music
    (make-apply-context (lambda (c)
        (override-property-setting
         c 'autoBeamSettings
         setting (ly:make-moment num den))))
    (if (and (pair? rest) (symbol? (car rest)))
        (car rest)
        'Voice))))

(define-public (score-override-auto-beam-setting setting num den)
  (override-auto-beam-setting setting num den 'Score))

(define-public (revert-auto-beam-setting setting num den . rest)
  (ly:export
   (context-spec-music
    (make-apply-context
      (lambda (c)
        (revert-property-setting
         c 'autoBeamSettings
         (cons setting (ly:make-moment num den)))))
    (if (and (pair? rest) (symbol? (car rest)))
        (car rest)
        'Voice))))

;;  Determine end moment for auto beaming (or begin moment, but mostly
;;  0== anywhere).  In order of decreasing priority:
;;
;;  1. end <type>   *     *
;;  2. end   *      *     *
;;  3. end <type> <num> <den>
;;  4. end   *    <num> <den>
;;  5. if 1-4 not specified, begin anywhere, end at time determined by
;;          beatGrouping and beatLength:
;;     if beatGrouping and beatLength are consistent with measureLength,
;;        use beatGrouping to determine end of beams.
;;     if beatGrouping and beatLength are inconsistent with measureLength,
;;        use beatLength to determine end of beams.
;;
;;  Rationale:
;;
;;  [user override]
;;  1. override for specific duration type
;;  2. generic override
;;
;;  [to be defined in config file]
;;  3. exceptions for specific time signature, for specific duration type
;;  4. exceptions for specific time signature
;;  5. easy catch-all rule for non-specified measure types


(define-public (default-auto-beam-check context dir test)
  (define (get name default)
    (let ((value (ly:context-property context name)))
      (if (not (null? value)) value default)))

  (define (ending-moments group-list start-beat beat-length)
    (if (null? group-list)
        '()
        (let ((new-start (+ start-beat (car group-list))))
          (cons (ly:moment-mul (ly:make-moment new-start 1) beat-length)
                (ending-moments (cdr group-list) new-start beat-length)))))

  (define (make-end-settings time ending-list moment-den)
    (if (null? ending-list)
        '()
        (cons (cons (append '(end * *) time)
                    (ly:make-moment (car ending-list) moment-den))
              (make-end-settings time (cdr ending-list) moment-den))))
  
  ;; Don't start auto beams on grace notes
  (if (and (!= (ly:moment-grace-numerator (ly:context-now context)) 0)
           (= dir START))
      #f
      (let* ((beat-length (get 'beatLength (ly:make-moment 1 4)))
             (measure-length (get 'measureLength (ly:make-moment 1 1)))
             (measure-pos (get 'measurePosition ZERO-MOMENT))
             (beat-grouping (get 'beatGrouping '()))
             (settings (get 'autoBeamSettings '()))
             (function (list (if (= dir START) 'begin 'end)))
             ;; Calculate implied time signature based on measureLength
             ;; and beatLength for default value in get
             (num-mom (ly:moment-div measure-length beat-length))
             (num (inexact->exact
                    (round (/ (ly:moment-main-numerator num-mom)
                              (ly:moment-main-denominator num-mom)))))
             (den (ly:moment-main-denominator beat-length))
             (time-signature-fraction 
               (get 'timeSignatureFraction (cons num den)))
             (time (list (car time-signature-fraction)
                         (cdr time-signature-fraction)))
             (type (list (ly:moment-main-numerator test)
                         (ly:moment-main-denominator test)))
             (pos (if (>= (ly:moment-main-numerator measure-pos) 0)
                      measure-pos
                      (ly:moment-add measure-length measure-pos)))
             (grouping-moments (ending-moments beat-grouping 0 beat-length))
             ;; Calculate implied measure length from beatGrouping
             ;; and beatLength
             (grouping-length (if (null? grouping-moments)
                                  ZERO-MOMENT
                                  (list-ref grouping-moments 
                                            (1- (length grouping-moments)))))
             (lst (list
                    ;; Hmm, should junk user-override feature,
                    ;; or split this in user-override and config section?
                    (append function type '(* *))
                    (append function '(* * * *))
                    (append function type time)
                    (append function '(* *) time)))
             (predefined-setting (first-assoc lst settings)))
         (if (or
                ;; always begin or end beams at beginning/ending of measure
                (= (ly:moment-main-numerator pos) 0)
                (first-member (map (lambda (x) (cons x pos)) lst) settings))
             #t
             (if (= dir START)
                 ;; if no entry matches our function + time or type,
                 ;; start anywhere
                 (not predefined-setting)
                 ;; if entry matches our function + time or type, check moment
                 (if predefined-setting
                    (equal? measure-pos (cdr predefined-setting))
                    ;; if measure-length matches grouping-length, use
                    ;; grouping moments, else use beat-length
                    (if (equal? measure-length grouping-length)
                        (member measure-pos grouping-moments)
                        (= (ly:moment-main-denominator
                           (ly:moment-div pos beat-length)) 1))))))))
