;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Longuet-Higgins & Lee 1984 Syncopation Measure 
;;; as described in Longuet-Higgins & Lee (1984) Music Perception, pp 424-441.
;;;
;;; In Common Lisp 
;;; (c) 2001/2010, Henkjan Honing (honing@uva.nl; https://www.mcg.uva.nl/)
;;;
;;;
;;; N.B. Contains LHL's theoretical metric salience. Still has to be extended 
;;; with empirical metric salience as found by, e.g., Palmer & Krumhansl (1990) 
;;; or Ladinig & Honing (in press); See https://tinyurl.com/3vyzahz


;;; Examples from Figure 9 in Longuet-Higgins & Lee (1984):

;(syncopation-lhl84 '(1 3) '(2 2))        -> (2),      lhl84: 1
;(syncopation-lhl84 '(2 1 3 2) '(2 2 2))  -> (0 3 0) , lhl84: 2
;(syncopation-lhl84 '(3 1) '(2 2))        -> (0) ,     lhl84: no sync
;(syncopation-lhl84 '(2 1) '(3))          -> (0) ,     lhl84: no sync
;(syncopation-lhl84 '(1 2) '(3))          -> (1) ,     lhl84: 0

;;; toplevel function

(defun syncopation-LHL84 (rhythm meter)
 "Return syncopation strengths, or NIL if meter cannot accomodate rhythm.~
  0=no syncopation, other values=LHL84 strengths + 1"
 (when (can-meter-accomodate-rhythm? meter rhythm)
   (calculate-syncopations (iois-to-onsets (scale-rhythm rhythm meter)) meter)))

;;; calculate syncopations

(defun calculate-syncopations (onsets meter)
 "Return list of syncopation strengths"
 (loop with rhythm   = (onsets-to-grid onsets)
       with salience = (metric-salience meter)
       for position from 0 below (length salience)
       when (and (note? (elt rhythm position))             ; note,
                 (not (note? (elt rhythm (1+ position))))) ; followed by rest
       collect (syncopation (elt salience position)        ; metric-salience note
                            (metric-salience-rest position rhythm salience))))

;;; calculating metric salience

(defun metric-salience (meter)
 "Return list of metric weights; 0 highest level, -n lowest"
 (loop with grid-length = (apply #'* meter)
       with salience = (make-list grid-length :initial-element nil)
       initially (setf (elt salience 0) 0)
       for division in meter
       as level = -1 then (1- level)
       as interval = (/ grid-length division) then (/ interval division)
       do (loop for pos from 0 below grid-length by interval
                do (unless (elt salience pos) (setf (elt salience pos) level)))
       finally (return salience)))

;(metric-salience '(3 2 2)) -> (0 -3 -2 -3 -1 -3 -2 -3 -1 -3 -2 -3)
;(metric-salience '(2 2))   -> (0 -2 -1 -2)

;;; utilities

(defun syncopation (note-weight rest-weight) 
 (cond ((> note-weight rest-weight)
        0)
       ((= note-weight rest-weight)
        1)
       (t (1+ (- rest-weight note-weight)))))

(defun note? (value) (= value 1))

(defun scale-rhythm (rhythm meter)
 "Return rhythm scaled such that it fits length of metric grid"
 (let* ((sum (apply #'+ rhythm))
        (grid (apply #'* meter))
        (factor (/ grid sum)))
   (if (= factor 1)
     rhythm
     (mapcar #'(lambda (x) (* x factor)) rhythm))))

;(scale-rhythm '(2 3 1) '(2 2 3)) -> (4 6 2)

(defun metric-salience-rest (position rhythm salience)
 "Return highest metric-salience in note-to-note interval"
 (loop for pos from (1+ position) below (next-note-position rhythm position)
       maximize (elt salience pos)))

;(metric-salience-rest 1 '(1 1 0 0 0 1) '(0 -2 -1 -2 -1 -2)) -> -1

(defun next-note-position (rhythm position)
 (loop for pos from (1+ position) below (length rhythm)
       when (note? (elt rhythm pos))
       do (return pos)))

;(next-note-position '(1 1 0 0 1) 1) -> 4

(defun iois-to-onsets (iois &optional (onset 0))
 (if iois
   (cons onset (iois-to-onsets (rest iois) (+ onset (first iois))))
   (list onset)))

;(iois-to-onsets '(1 3 2)) -> (0 1 4 6)

(defun onsets-to-grid (onsets)
 (loop with rhythm = (make-list (1+ (first (last onsets))) :initial-element 0)
       for onset in onsets
       do (setf (elt rhythm onset) 1)
       finally (return rhythm)))

;(onsets-to-grid '(0 1 4 6)) -> (1 1 0 0 1 0 1)

(defun can-meter-accomodate-rhythm? (meter rhythm)
 (let ((sum (apply #'+ rhythm))
       (grid (apply #'* meter)))
   (zerop (mod grid sum))))

;(can-meter-accomodate-rhythm? '(1 3 2) '(2 3)) -> t
;(can-meter-accomodate-rhythm? '(1 3 2) '(2 2)) -> nil

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;