view tools/gsharp-output.lisp @ 330:2fbff655ba47 tip

Removed cpitch-adj and cents SQL columns

;; This file is for methods creating and using gsharp score buffers
;; for output. This would generally involve rendering to screen, file,
;; printer or browser.
;;
;; The interface doesn't obviously align perfectly with the gsharp
;; data structure, so some notes on the key elements are included
;; here:
;;
;; amuse:events have no direct analogue, with their attributes divided
;; between notes and clusters:
;;
;; * notes have a pitch with a number that is 1- the diatonic
;; component of mips pitch and an accidental that is one of a list of
;; keyword options, most relevant being :sharp :natural :flat
;; :double-sharp and :double-flat
;;
;; * clusters are the rhythmic and positional aspect of one or more
;; notes. Duration is stored in terms of notehead (:long :breve :whole
;; :half :filled) and, for :filled, lbeams and rbeams for the number
;; of beams in each direction, supplemented by a dots slot. To render
;; this to a number for standard time within amuse, there is a method,
;; gsharp:duration, for which a crotchet is 1/4
;;
;; Parts and staffs are viewed notationally, so we have largely
;; independant structures called layers (roughly = voices) and staves
;; (as they appear on the page). These have names and, at the moment,
;; are being identified by a string-getting method below. Within a
;; layer, clusters are to be found in bar objects and listed in the
;; bars slot.
;;
;; The musical entity into which these slot is a segment, and there
;; can be multiple segments in a buffer, though what this means and
;; how they relate is as yet a mystery to me.
;;
;;; IMPLEMENTATION
;; 
;; We're creating a buffer. Lots of this code is adapted from
;; gsharp/mxml/mxml.lisp, but wouldn't now be recognised
;;
;; * Clef is guessed at - we need amuse:get-applicable-clef (and
;; amuse:clef)
;;
;; [* Anacruses are ignored unless they have their own time-signatures!
;;  - not strictly true now. This depends on the implementation of current bar]
;;
;; The stages used are:
;;  1 - find layers and stave (was 1:1 with staves. Not anymore)
;;  2 - for each layer, get events and their timings (includes
;;  rounding/quantization)
;;  3 - Find all ties needed for graphical/courtesy reasons (includes
;;  removal of extraneous rests and other artefacts)
;;  4 - Generate gsharp clusters
;;  5 - Get gsharp pitch for events and add notes to clusters
;;  


(in-package "AMUSE-TOOLS")

(defparameter *rounding-factor* 1/4)

(defstruct gsharp-duration 
  "Structure for specifying duration-related parameters for g-sharp"
  notehead (beams 0) (dots 0) (tied-p nil))

;;;;;;;;;;;;;;;;;;;;;
;; Top-level methods

(defparameter *foo* nil)

(defun write-gsharp-eps (composition pathname)
  ;; write a score eps from a composition. Most of this can be copied
  ;; straight (this is copied already from CSR's code)
  ;; Boilerplate stuff:
  (let* ((frame (clim:make-application-frame 'gsharp:gsharp))
         (clim:*application-frame* frame)
         (esa:*esa-instance* frame))
      (clim:adopt-frame (clim:find-frame-manager :server-path '(:null)) frame)
      (clim:execute-frame-command frame '(gsharp::com-new-buffer))
      ;; Now generate the buffer
      (make-objects-for-gsharp-buffer composition (car (esa:buffers frame)))
      ;; (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
      ;; Refresh and process
      (setf (gsharp::modified-p (car (esa:buffers frame))) t)
      (gsharp::recompute-measures (car (esa:buffers frame)))
      (setf *foo* (car (esa:buffers frame)))
      ;; Print
      (clim:execute-frame-command
       frame `(gsharp::com-print-buffer-to-file ,pathname))
      (car (esa:buffers frame))))

;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Big `walking through data structures' type functions

(defun make-objects-for-gsharp-buffer (composition buffer)
  "This replacement for fill-gsharp-buffer-with-constituent generates
  staves and layers itself and attaches them to a segment in the
  supplied buffer. Clefs are guessed rather than being read.  Each
  event is asked for its staff and layer using gsharp-staff-string
  gsharp-layer-string, and from this, the connections are
  made. gsharp-staff-string defaults to calling gsharp-layer-string,
  so in most cases there will be a single staff for each layer. Events
  are added, and then staves are sorted using staff<. A proper layout
  object would be another way of doing this."
  (let ((layer-names (make-hash-table :test #'equal))
	(layer-events (make-hash-table))
	(layer-staves (make-hash-table))
	(staff-names (make-hash-table :test #'equal))
	(staff-name)(staff)(layer-name)(layer)
	(segment))
    (sequence::dosequence (event composition)
      ;; can't do percussion parts yet:
      (when (pitchedp event)
	(setf layer-name (gsharp-layer-string event)
	      layer (gethash layer-name layer-names)
	      staff-name (gsharp-staff-string event)
	      staff (gethash staff-name staff-names))
	(if staff
	    ;; this looks a little cryptic, but we're keeping note of
	    ;; whether the mean pitch is above C for clef guessing.
	    (setf (third staff) (+ (third staff) 1)
		  (second staff) (+ (second staff) (min (floor (midi-pitch-number event) 60) 1)))
	    (setf staff (list (gsharp::make-fiveline-staff :name staff-name)
			      (min (floor (midi-pitch-number event) 60)
				   1)
			      1)
		  (gsharp::buffer (car staff)) buffer
		  (gethash staff-name staff-names) staff))
	(if layer
	    (progn
	      (unless (find (first staff) (gethash layer layer-staves))
		(push (first staff) (gethash layer layer-staves)))
	      (push event (gethash layer layer-events)))
	    (if segment
		(setf layer (gsharp::make-layer (list (first staff))
						:body (gsharp::make-slice :bars nil)
						:name layer-name
						:segment segment)
		      (gsharp::layers segment) (cons layer (gsharp::layers segment))
		      (gethash layer-name layer-names) layer
		      (gethash layer layer-staves) (list staff)
		      (gethash layer layer-events) (list event))
		(setf layer (gsharp::make-layer (list (first staff))
						:body (gsharp::make-slice :bars nil)
						:name layer-name)
		      segment (make-instance 'gsharp::segment
					     :buffer buffer
					     :layers (list layer))
		      (gsharp-buffer:segment layer) segment
		      (gethash layer-name layer-names) layer
		      (gethash layer layer-staves) (list (first staff))
		      (gethash layer layer-events) (list event))))))
    (maphash #'(lambda (key val)
		 (declare (ignore key))
		 (unless (>= (second val) (/ (third val) 2))
		   (setf *foo* (first val))
		   (setf (gsharp::clef (first val)) (gsharp::make-clef :bass))))
	     staff-names)
    (maphash #'(lambda (key events)
		 (add-music-to-layer key
				     (reverse events)
				     (gethash key layer-staves)
				     composition
				     (handler-bind ((insufficient-information
						     #'(lambda (c)
							 (declare (ignore c))
							 (invoke-restart 'guess))))
				       (get-applicable-key-signatures composition composition))))
	     layer-events)
    (setf (gsharp::segments buffer) (list segment)
	  (gsharp::staves buffer) nil)
    (let ((staves))
      (maphash #'(lambda (key val)
		   (declare (ignore key))
		   (push (car val) staves))
	     staff-names)
      (setf staves (sort staves #'stave<))
      (setf (gsharp::staves buffer) staves)
      buffer)))
(defgeneric stave< (staff1 staff2)
  (:method (s1 s2)
    (let* ((clefs '(:treble :bass))
	   (c1 (gsharp::clef s1))
	   (c2 (gsharp::clef s2))
	   (pos1 (position (gsharp::name c1) clefs))
	   (pos2 (position (gsharp::name c2) clefs)))
      (or (< pos1 pos2)
	  (and (= pos1 pos2)
	       (< (gsharp::lineno c1)
		  (gsharp::lineno c2)))
	  (and (= pos1 pos2)
	       (= (gsharp::lineno c1)
		  (gsharp::lineno c2))
	       (string< (gsharp::name s1)
			(gsharp::name s2)))))))

(defun bar-starts-2 (composition)
  (let ((starts))
    (do ((bar-period (current-bar (make-standard-moment 0) composition)
		     (current-bar (cut-off bar-period) composition)))
	((time>= (cut-off bar-period) (cut-off composition))
	 (reverse (cons (timepoint bar-period) starts)))
      (push (timepoint bar-period) starts))))
(defun beat-starts-2 (bar-starts composition)
  ;; FIXME: improve this
  (when (get-applicable-time-signatures composition composition)
    (handler-bind
	((insufficient-information
	  #'(lambda (c)
	      (declare (ignore c))
	      (invoke-restart 'use-whole-bar))))
      (let ((starts) (current))
	(do* ((bars bar-starts)
	      (beat-period (current-beat (make-standard-moment 0) composition)
			   (current-beat (cut-off beat-period) composition))
	      (beat-time (timepoint beat-period) (timepoint beat-period)))
	       ((time>= (cut-off beat-period) (cut-off composition))
		(progn
		  (when (and (cdr bars)
			     (>= beat-time (second bars)))
		    (push (reverse current) starts)
		    (setf current nil
			  bars (cdr bars)))
		  (push beat-time current)
		  (reverse (cons (reverse current) starts))))
	  (when (and (cdr bars)
		       (>= beat-time (second bars)))
	    (push (reverse current) starts)
	    (setf current nil
		  bars (cdr bars)))
	  (push beat-time current))))))
(defun add-music-to-layer (layer events staves composition key-sigs)
  "Creating all the musical objects for the gsharp staves in the
provided layer"
  (let* ((bar-moments (bar-starts-2 composition))
	 (beat-moments (or (beat-starts-2 bar-moments composition)
			   bar-moments))
	 (body (gsharp::body layer))
	 (bar-no 0)
	 (ons) (position) (clusters) (bar))
    ;; this is a cheat to guess timing rounding (quantisation) based
    ;; on onset times - only affects midi-like data where onsets are
    ;; already rounded, but durations are not (as in TC's fantasia
    ;; midi files....)
    (setf *rounding-factor* (max (guess-rounding-factor events)
                                 1/8))
    ;; First create a list of change-points for when events are
    ;; sounding, of the format (time event event event) (time event))
    (dolist (event events)
      (setf ons (add-on-off-pair event ons)))
    ;; These durations may span bars, which is an absolute ban for
    ;; most music (Mensurstrich aside), so insert bar starts if not
    ;; present. Note that, since the events themselves are recorded in
    ;; the list, the existence of ties shuold be detected.
    (when bar-moments
      (setf ons (add-bar-starts-if-not-present bar-moments ons)))
    ;; Finally, one problem here is that, in midi, there is often a
    ;; gap or overlap between consecutive notes or chords. Since
    ;; rounding happens, but there is no check for bar length here or
    ;; within g-sharp, this should verify that everything makes
    ;; sense. At the moment, it just removes short rests...
    (setf ons (check-ons ons bar-moments))
    ;; Now create the bars and the gsharp clusters
    (when key-sigs
      (dolist (staff staves)
	(setf (gsharp::keysig staff)
	      (make-gsharp-key-signature (car key-sigs) staff))))
    (do ((old-ons nil ons)
         (ons ons (cdr ons)))
        ((null (cdr ons)))
      (when (member (caar ons) bar-moments)
        ;; We're at the beginning of a bar.
        (when bar (check-beams bar))
        (setf bar (gsharp::make-melody-bar))
        (gsharp::add-bar bar body bar-no)
        (incf bar-no)
        (setf position 0))
      ;; A quick check for notes which span beats and don't start at
      ;; the beginning of their beats. IMO, this makes them more
      ;; likely to require a tie.
      (when (and (cdr ons)
		 (not (member (caar ons)
                              (car beat-moments)))
                 (find-if #'(lambda (x) (> x (caar ons)))
			  (car beat-moments))
                 (< (find-if #'(lambda (x) (> x (caar ons)))
			     (car beat-moments))
                    (car (second ons))))
        (setf (cdr ons)
              (cons (cons (find-if #'(lambda (x) (> x (caar ons)))
                                   (car beat-moments))
                          (cdar ons))
                    (cdr ons))))
      ;; Making clusters just from duration removes the ability to
      ;; divide notes into easy-to-read tied components based on the
      ;; time signature (for example, a note of a tactus beat + a
      ;; quaver in 6/8 will be rendered as a minim this way) - that's
      ;; why I've taken as much of the metrical logic out and put it
      ;; above if there are other straightforward rules, they should,
      ;; I think go there.
      (if (cdar ons)
          (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons))
								(car (car ons)))))
          (setf clusters (make-gsharp-rests-with-duration (- (car (second ons))
							     (car (car ons)))
							  layer)))
      (let ((now (caar ons)) (first-p t) (pitches))
        (do ((clusters clusters (cdr clusters)))
            ((null clusters))
          (when (member now (car beat-moments))
            (setf (gsharp::lbeams (car clusters)) 0))
          ;; This function adds cluster at a specific point in the
          ;; bar. It does a lot of other things that are probably a)
          ;; not necessary or b) should be within the duration logic
          ;; above. Would be good not to rely on it (which is not to
          ;; say that it isn't reliable)
          (gsharp::add-element (car clusters) bar position)
          ;; FIXME: Deleting notes that fall on the same note
          ;; name. Stupid thing to do.
          (setf pitches (remove-duplicates (mapcar #'(lambda (x)
                                                       (cons x (pitch-for-gsharp x composition)))
                                                   (cdar ons))
                                           :key #'second :test #'=))
          (dolist (pitch pitches)
            (with-simple-restart (ignore "Ignore note")
              (gsharp::add-note (car clusters)
                                (make-instance 'gsharp::note
                                               :pitch (second pitch)
                                               :accidentals (third pitch)
                                               :staff (staff-for-note (car pitch) staves)
                                               :tie-right (if (or (cdr clusters)
                                                                  (member (car pitch) (second ons)))
                                                              t
                                                              nil)
                                               :tie-left (if first-p
                                                             (member (car pitch) (first old-ons))
                                                             t)))))
          (incf now (* (gsharp::duration (car clusters)) 4))
          (setf first-p nil)
          (incf position)))
      (when (and (cdr bar-moments)
                 (= (car (second ons))
                    (second bar-moments)))
        (setf bar-moments (cdr bar-moments)
              beat-moments (cdr beat-moments))))))

(defun staff-for-note (event staves)
  (find-if #'(lambda (x) (string= (gsharp::name x) (gsharp-staff-string event)))
	   staves))

(defun check-beams (bar)
  (do* ((clusters (gsharp::elements bar) (cdr clusters))
        (left) (mid) (right))
       ((null (cddr clusters)))
    (setf left (first clusters)
          mid (second clusters)
          right (third clusters))
    (unless (or (typep mid 'gsharp::rest)
                (= (max (gsharp::rbeams mid)
                        (gsharp::lbeams mid))
                   0))
      (cond
        ((or (typep left 'gsharp::rest)
             (= (gsharp::rbeams left) 0))
         (setf (gsharp::lbeams mid) 0))
        ((or (typep right 'gsharp::rest)
             (= (gsharp::lbeams right) 0))
         (setf (gsharp::rbeams mid) 0))
        ((< (gsharp::rbeams left)
            (gsharp::lbeams right))
         (setf (gsharp::lbeams mid) (gsharp::rbeams left)))
        (t (setf (gsharp::rbeams mid) (gsharp::lbeams right)))))))

(defgeneric make-gsharp-key-signature (key-signature object))
(defmethod make-gsharp-key-signature ((key-signature standard-key-signature) (layer gsharp-buffer::layer))
  (let ((alterations (make-array 7 :initial-element :natural))
        (order-of-sharps #(3 0 4 1 5 2 6))
        (order-of-flats #(6 2 5 1 4 0 3)))
    (if (< (key-signature-sharps key-signature) 0)
        (dotimes (index (abs (key-signature-sharps key-signature)))
          (setf (elt alterations (elt order-of-flats index)) :flat))
        (dotimes (index (key-signature-sharps key-signature))
          (setf (elt alterations (elt order-of-sharps index)) :sharp)))
    (gsharp-buffer::make-key-signature (car (gsharp::staves layer))
                                       :alterations alterations)))
(defmethod make-gsharp-key-signature ((key-signature standard-key-signature)
				      (staff gsharp::staff))
  (let ((alterations (make-array 7 :initial-element :natural))
        (order-of-sharps #(3 0 4 1 5 2 6))
        (order-of-flats #(6 2 5 1 4 0 3)))
    (if (< (key-signature-sharps key-signature) 0)
        (dotimes (index (abs (key-signature-sharps key-signature)))
          (setf (elt alterations (elt order-of-flats index)) :flat))
        (dotimes (index (key-signature-sharps key-signature))
          (setf (elt alterations (elt order-of-sharps index)) :sharp)))
    (gsharp-buffer::make-key-signature staff
                                       :alterations alterations)))

;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Information conversion functions

;; Pitch

(defgeneric pitch-for-gsharp (pitch composition)
  (:documentation "Given a pitch object, return a list of gsharp's
  pitch number and accidental keyword"))
(defmethod pitch-for-gsharp ((pitch diatonic-pitch) composition)
  (declare (ignore composition))
  ;; Easy for diatonic pitch, although behaviour for extreme or
  ;; fractional alterations is unclear.
  (list (1+ (diatonic-pitch-mp pitch))
        (case (diatonic-pitch-accidental pitch)
            (1 :sharp)
            (-1 :flat)
            (2 :double-sharp)
            (-2 :double-flat)
            (0 :natural)
            (otherwise (error "gsharp can't handle this pitch")))))
(defmethod pitch-for-gsharp ((pitch chromatic-pitch) composition)
  ;; Just go for line-of-fifths proximity spelling, but based on
  ;; keysig if present. Could always try to spell it with ps13, but..
  (let* ((octave (octave pitch))
         (pitch-class (pitch-class pitch))
         (diatonic-pitch-number (aref #(0 0 1 2 2 3 3 4 4 5 6 6) pitch-class)))
    (list (+ (* 7 octave) diatonic-pitch-number)
          (aref #(:natural :sharp ;; C  C#
                  :natural        ;; D
                  :flat :natural  ;; Eb E
                  :natural :sharp ;; F  F#
                  :natural :sharp ;; G  G#
                  :natural        ;; A
                  :flat :natural) ;; Bb B
                pitch-class))))
(defmethod pitch-for-gsharp ((event standard-chromatic-pitched-event) composition)
  ;; Should probably go for line-of-fifths proximity spelling, 
  ;; if keysig present, but ps13ing for now.
  (let* ((octave (octave event))
         (event-pos (position event (ocp-list composition) :key #'car))
         (note-sequence (get-spelling-list composition))
         (spelling (elt note-sequence event-pos))
         (note-name (cdr (assoc (aref (second spelling) 0)
                                '(("C" . 0) ("D" . 1) ("E" . 2) ("F" . 3)
                                  ("G" . 4) ("A" . 5) ("B" . 6))
                                :test #'string=)))
         (accidental (cdr (assoc (aref (second spelling) 1)
                                 '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
                                   ("f" . :flat) ("ff" . :double-flat))
                                 :test #'string=))))
    (list (+ (* 7 octave) note-name) accidental)))
         
    
(defparameter *spelling-cache* (make-hash-table))
(defparameter *ocp-cache* (make-hash-table))

(defun get-spelling-list (composition)
  (unless (gethash composition *spelling-cache*)
    (setf (gethash composition *spelling-cache*) 
          (ps13:ps13-new-imp (map 'list #'cdr (get-ocp-list composition))
                             10 42 nil nil nil)))
  (gethash composition *spelling-cache*))

(defun get-ocp-list (composition)
  (unless (gethash composition *ocp-cache*)
    (setf (gethash composition *ocp-cache*) (ocp-list composition)))
  (gethash composition *ocp-cache*))

(defun ocp-list (composition)
  (flet ((sorter (x y)
           (or (amuse:time< x y)
               (and (amuse:time= x y)
                    (amuse:pitch< x y)))))
    (loop for e being each element of composition
          if (typep e 'amuse:pitched-event)
          collect (cons e (make-array 2 :initial-contents 
                                      (list (slot-value e 'amuse::time)
                                            (- (slot-value e 'amuse::number) 21)))) into result
          finally (return (sort result #'sorter :key #'car)))))

;; Time 

(defun make-gsharp-clusters-with-duration (duration)
  "Returns a list of cluster(s) whose total duration is equal to
  duration (which is given in crotchets)"
  (let ((new-durations (gsharp-durations-from-beats duration)))
    (loop for new-duration in new-durations
         collect (gsharp::make-cluster :notehead (gsharp-duration-notehead new-duration)
                                       :lbeams (gsharp-duration-beams new-duration)
                                       :rbeams (gsharp-duration-beams new-duration)
                                       :dots  (gsharp-duration-dots new-duration)))))

(defun make-gsharp-rests-with-duration (duration layer)
  "Returns a list of rest(s) whose total duration is equal to
  duration (which is given in crotchets)"
  (let ((new-durations (gsharp-durations-from-beats duration)))
    (loop for new-duration in new-durations
       collect(gsharp::make-rest (car (gsharp::staves layer))
                                 :notehead (gsharp-duration-notehead new-duration)
                                 :lbeams (gsharp-duration-beams new-duration)
                                 :rbeams (gsharp-duration-beams new-duration)
                                 :dots  (gsharp-duration-dots new-duration)))))

(defun gsharp-durations-from-beats (beats &optional (durations nil))
  ;; Takes a count of crotchets and returns a list of
  ;; <gsharp-duration>s that most simply defines the attached.  This
  ;; is a recursive function that finds the longest simple duration
  ;; that fits into beats and, if that leaves a remainder, runs again
  ;; on the remainder (until hemi-demi-semi-quavers are reached). It
  ;; avoids double dots and is ignorant of time-signature. It will be
  ;; replaced. Soon.
  ;;; FIXME: Handles quantisation fairly
  ;; stupidly. Could be made slightly smarter with simple rounding
  ;; (erring on the side of longer durations?)
  (assert (>= beats 0))
  (push (make-gsharp-duration) durations)
  ;; First find the longest simple duration that fits in beats
  ;; First with notes > 1 crotchet
  (loop for option in '((16 :long) (8 :breve) (4 :whole) (2 :half) (1 :filled))
     do (cond
          ((= beats (* (car option) 7/4))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option)
                 (gsharp-duration-dots (car durations))
                 2)
           (return-from gsharp-durations-from-beats (reverse durations)))
          ((= beats (* (car option) 3/2))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option)
                 (gsharp-duration-dots (car durations))
                 1)
           (return-from gsharp-durations-from-beats (reverse durations)))
          ((> beats (car option))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option))
           (return-from gsharp-durations-from-beats
             (gsharp-durations-from-beats (- beats (car option)) durations)))
          ((= beats (car option))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option))
           (return-from gsharp-durations-from-beats (reverse durations)))))
  (setf (gsharp-duration-notehead (car durations))
        :filled)
  ;; then with short notes (beams rather than noteheads)
  (do ((i 1 (1+ i)))
      ((= i 4) ;; means either tuplet, very short note or unquantised data
       (reverse durations))
    (cond
      ((= beats (* (/ 1 (expt 2 i)) 3/2))
       (setf (gsharp-duration-beams (car durations))
             i
             (gsharp-duration-dots (car durations))
             1)
       (return-from gsharp-durations-from-beats (reverse durations)))
      ((> beats (/ 1 (expt 2 i)))
       (setf (gsharp-duration-beams (car durations))
             i)
       (return-from gsharp-durations-from-beats
         (gsharp-durations-from-beats (- beats (/ 1 (expt 2 i))) durations)))
      ((= beats (/ 1 (expt 2 i)))
       (setf (gsharp-duration-beams (car durations))
             i)
       (return-from gsharp-durations-from-beats (reverse durations))))))

;;;;;;;;;;;;;;;;;;;;;
;; 
;; Other utility functions

(defgeneric gsharp-layer-string (event)
  (:method (e) (name-from-channel-and-patch e))
  (:method ((e amuse-gsharp::gsharp-object))
    (name-from-layer e))
  (:documentation "Return a string that uniquely identifies the layer
  to which event belongs"))

(defgeneric gsharp-staff-string (event)
  (:method (e) (gsharp-layer-string e))
  (:documentation "Return a string that uniquely identifies the staff
  to which event belongs"))

(defun name-from-layer (event)
  ;; Uses gsharp layer names. Numbers layers in cases of duplication
  (let* ((layers (gsharp::layers
                  (car
                   (gsharp::segments
                    (gsharp::buffer
                     (gsharp::staff
                      (amuse-gsharp::note event)))))))
         (layer (gsharp::layer
                 (gsharp::slice
                  (gsharp::bar
                   (gsharp::cluster
                    (amuse-gsharp::note event))))))
         (name (gsharp::name layer))
         (count))
    (dolist (cand-layer layers)
      (if (eq cand-layer layer)
          (if count
              (return-from name-from-layer (concatenate 'string
                                                        name
                                                        (princ-to-string count)))
              (return-from name-from-layer name))
          (when (string= name (gsharp::name cand-layer))
            (setf count (if count (+ count 1) 2)))))))

(defun name-from-channel-and-patch (event)
  "Generate layer-identifying string from the patch and channel that
would be used for midi export. For MIDI, this is guaranteed to
separate or over-separate. Tracks would possibly be better, but ?don't
exist in MIDI type 0?"
  (format nil "~D/~D"
          (get-patch-for-midi event)
          (get-channel-for-midi event)))

(defun bar-starts (time-signature-list &key (crotchet 1))
  (loop for time-signature in time-signature-list
     nconc (loop for i from (timepoint (onset time-signature))
                to (1- (timepoint (cut-off time-signature)))
                by (* (crotchets-in-a-bar time-signature) crotchet)
                collect i)))

(defun beat-starts (time-signature-list &key (crotchet 1))
  ;; provides a list of bars, each a list of beats. If no timesig,
  ;; guesses at 4/4
  ;; FIXME: This is stupid and should disappear if and when proper
  ;; beat methods are implemented.
  (if time-signature-list
      (loop for time-signature in time-signature-list
         nconc (loop for i from (timepoint (onset time-signature))
                  to (1- (timepoint (cut-off time-signature)))
                  by (* (crotchets-in-a-bar time-signature) crotchet)
                  collect (loop for j from 0
                             to (* (crotchets-in-a-bar time-signature)
                                   crotchet)
                             by (* (tactus-duration time-signature)
                                   crotchet)
                             collect (+ j i))))
      ;; FIXME: fudge
      (loop for i from 0 to 1000 by 4
         collect (loop for j from i to (+ i 3) 
                    collect j))))

;;;;;;;;;;;;;;;;;;
;;
;; Sequence and data structure functions


(defun add-bar-starts-if-not-present (bar-starts changes)
  "Takes a list of bar-start times and one of sounding notes at
times. If a bar has no change of sounding notes at its start, it would
not appear in the latter list, but since we will want notes tied over
barlines, we must add it and return the modified list"
  (let ((new-changes))
    (dolist (event changes (reverse new-changes))
      (do ()
          ((not (and bar-starts
                     (< (car bar-starts)
                        (car event)))))
        (setf new-changes
              (cons (if (cadr new-changes)
                        (cons (car bar-starts)
                              (cdar new-changes))
                        (list (car bar-starts)))
                    new-changes)
              bar-starts (cdr bar-starts)))
      (setf new-changes (cons event new-changes))
      (when (and bar-starts (= (car event) (car bar-starts)))
        (setf bar-starts (cdr bar-starts))))))

(defun add-on-off-pair (event data)
  "For walking through an ordered event sequence and building up a
list of changes to sounding pitches, this function takes an event and
adds the time for which it sounds to the structure."
  (let ((copied-data)
        (on (* (round
                (* (timepoint event)
                   (duration (crotchet event)))
                *rounding-factor*) *rounding-factor*))
        (off (* (round
                 (* (timepoint (cut-off event))
                    (duration (crotchet event)))
                 *rounding-factor*) *rounding-factor*)))
    (do ((data data (cdr data)))
        ((null data) (reverse (cons (list off)
                                    (cons (list on event)
                                          copied-data))))
      (cond
        ((<= on (caar data))
         (when (< on (caar data))
           (push (cons on (cons event (cdr (car copied-data))))
                 copied-data))
         (do ((data data (cdr data)))
             ((null data)
              (return-from add-on-off-pair
                (reverse (cons (cons off (cddr (car copied-data)))
                               copied-data))))
           (cond
             ((= (caar data) off)
              (return-from add-on-off-pair
                (nconc (reverse copied-data) data)))
             ((> (caar data) off)
              (push (cons off (cddr (car copied-data)))
                    copied-data)
              (return-from add-on-off-pair
                (nconc (reverse copied-data) data)))
             ((< (caar data) off)
              (push (cons (caar data) 
                          (cons event (cdr (car data))))
                    copied-data)))))
        (t
         (push (car data) copied-data))))))

(defun check-ons (ons bar-starts)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((time (caar ons)) (notes (cdar ons))(new-ons))
    (do ((ons (cdr ons) (cdr ons)))
        ((null ons) (reverse new-ons))
      (if (or (member (caar ons) bar-starts)
              (> (- (caar ons) time)
                 *rounding-factor*))
          (setf new-ons (cons (cons time notes) new-ons)
                time (caar ons)
                notes (cdar ons))
          (dolist (note (cdar ons))
            (unless (member note notes)
              (push note notes)))))))

#+nil

(defun check-ons (ons)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((new-ons) (skip))
    (do ((ons ons (cdr ons)))
        ((null (cdr ons))
         (if skip (reverse new-ons) (reverse (cons (car ons) new-ons))))
      (cond
	(skip (setf skip nil))
	((not (and (<= (- (car (second ons))
			  (car (first ons)))
		       *rounding-factor*)
		   (null (cdr (first ons)))))
	 (if (<= (- (car (second ons))
		    (car (first ons)))
		 *rounding-factor*)
	     (progn
	       (push (cons (caar ons) (remove-duplicates (nconc (cdr (first ons))
								(cdr (second ons)))))
		     new-ons)
	       (setf skip t))
	     (push (car ons) new-ons)))))))


(defun guess-rounding-factor (events)
  "Assuming that only durations need quantising, look at the lcd for
onsets"
  (let ((rounding-factor (/ 1 *rounding-factor*)))
    (when events
	(let ((crotchet (duration (crotchet (car events)))))
	  (do ((events events (cdr events)))
	      ((null (cdr events)))
	    (do ((divisor rounding-factor (* 2 divisor)))
		((<= (rem (* (timepoint (car events)) crotchet)
			  divisor)
		     (/ divisor 3))
		 (setf rounding-factor divisor))))))
    (/ 1 rounding-factor)))

(defun guess-rounding-factor-smart (events)
  "Assuming that only durations need quantising, look at the lcd for
onsets"
  (let ((times (map 'list #'(lambda (x)
                              (denominator (* (timepoint x)
                                              (duration (crotchet x)))))
                    events)))
    (/ 1 (apply #'lcm times))))