annotate tools/gsharp-output.lisp @ 204:10d47e78a53d

Added support for most significant midi messages (some remain missing,
but these do not occur in a 1000-file test sample)

;; 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

(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)))
      ;; Print
      (clim:execute-frame-command
       frame `(gsharp::com-print-buffer-to-file ,pathname))
      (car (esa:buffers frame))))

(defun gsharp-change-size-but-keep-bounding-box (left-margin right-edge buffer)
  (declare (ignorable buffer))
  (setf gsharp-buffer::*default-left-margin* left-margin
        (gsharp-buffer::left-margin buffer) left-margin
        gsharp-buffer::*default-right-edge* right-edge
        (gsharp-buffer::right-edge buffer) right-edge
        gsharp::*scale* (/ (+ left-margin right-edge) 900)
        gsharp::*top-margin* (/ 80 gsharp::*scale*)))

(defun prepare-gsharp-for-single-system-stuff (buffer)
  (gsharp-change-size-but-keep-bounding-box 5 1100 buffer)
  (setf gsharp-measure::*staves-per-page* (length (gsharp::staves buffer))))

(defun write-gsharp-ps-single-system (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)))
      (prepare-gsharp-for-single-system-stuff (car (esa:buffers frame)))
      (gsharp::recompute-measures (car (esa:buffers frame)))
      ;; Print
      (clim:execute-frame-command
       frame `(gsharp::com-print-buffer-to-file ,pathname))
      (car (esa:buffers frame))))

(defun gsharp-preview (composition)
  ;; see above for origin of this code
  (let* ((frame (clim:make-application-frame 'gsharp::gsharp-minimal))
         (clim:*application-frame* frame)
         (esa:*esa-instance* frame))
    (clim:adopt-frame (clim:find-frame-manager :server-path '(:clx)) 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)
    ;; make views, cursors, input states, etc.
    (let ((view (make-instance 'gsharp::orchestra-view
                               :buffer (car (esa:buffers frame))
                               :cursor (gsharp::make-initial-cursor 
					(car (esa:buffers frame))))))
      (push view (gsharp::views gsharp::*application-frame*))
      (setf (gsharp::view (car (gsharp::windows gsharp::*application-frame*))) view
            (gsharp::input-state gsharp::*application-frame*) (gsharp::make-input-state)))
    ;; Refresh and process
    (setf (gsharp::modified-p (car (esa:buffers frame))) t)
    (gsharp::recompute-measures (car (esa:buffers frame)))
    (gsharp::update-page-numbers frame)
    #+nil
    (clim:redisplay-frame-panes frame)
    (clim:run-frame-top-level frame)))

(defparameter *composition-event-maps* (make-hash-table :test 'eq))

;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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."
  (multiple-value-bind (layer-events layer-staves)
      (%gather-objects-for-gsharp-output composition buffer)
    ;; Add events/notes/clusters
    (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)
    buffer))

(defun %gather-objects-for-gsharp-output (composition buffer)
  (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) (staves)
        (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))
	(unless staff
	  (setf staff (list (%new-gsharp-staff-for-amuse staff-name buffer)
			    0 0)
		(gethash staff-name staff-names) staff))
	;; 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)))
	;; Check if layer has happened before, if not make it
	(unless layer
	  (setf layer (%create-and-record-layer layer-name (first staff)
					       segment buffer layer-names
					       layer-staves layer-events)
		segment (gsharp::segment layer)))
	;; Associate new event with layer
	(setf layer-events 
	      (%add-event-to-layer-hash event (first staff)
				       layer layer-events layer-staves))))
    ;; Guess clefs for staves: bass if most pitches are below middle
    ;; C, otherwise treble. (yes, I know this is stupid)
    (maphash #'(lambda (key val)
                 (declare (ignore key))
                 (unless (>= (second val) (/ (third val) 2))
                   (setf (gsharp::clef (first val)) (gsharp::make-clef :bass))))
             staff-names)
    ;; gather and sort staves
    (maphash #'(lambda (key val)
		 (declare (ignore key))
		 (push (car val) staves))
	     staff-names)
    (setf staves (sort staves #'stave<)
	  (gsharp::staves buffer) staves)
    (values layer-events layer-staves)))

(defun %new-gsharp-staff-for-amuse (staff-name buffer)
  (let ((staff (gsharp::make-fiveline-staff :name staff-name)))
    (setf (gsharp::buffer staff) buffer)
    staff))

(defun %add-event-to-layer-hash (event staff layer layer-events layer-staves)
;;  (unless (find staff (gethash layer layer-staves))
  (unless (member staff (gethash layer layer-staves))
    (push staff (gethash layer layer-staves)))
  (push event (gethash layer layer-events))
  layer-events)

(defun %create-and-record-layer (name staff segment buffer
				 layer-names layer-staves layer-events)
  ;; create fresh layer called name and add to all necessary objects
  (let ((layer (gsharp::make-layer (list staff)
				   :body (gsharp::make-slice :bars nil)
				   :name name
				   :segment segment)))
    (if segment
	(setf (gsharp::layers segment) 
	      (cons layer (gsharp::layers segment)))
	(setf segment (make-instance 'gsharp::segment
				     :buffer buffer
				     :layers (list layer))
	      (gsharp::segment layer) segment
	      (gsharp::segments buffer) (list segment)))
    (setf (gethash name layer-names) layer
	  (gethash layer layer-staves) nil
	  (gethash layer layer-events) nil)
    layer))

(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))))))

(defgeneric add-music-to-layer (layer events staves composition key-sigs)
  (:documentation "Creating all the musical objects for the gsharp staves in the
provided layer"))
;; change this into some sort of quantize-please mixin? or switch? or something
(defmethod add-music-to-layer (layer events staves (composition amuse-midi::unquantized-composition) key-sigs)
  (let* ((bar-moments (bar-starts-2 composition))
	 (beat-moments (or (beat-starts-2 bar-moments composition)
			   (mapcar #'list 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-smart 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-2 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 (car 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.
      ;; NB now incorporating JF fix (not via version control)
      (if (second ons)
	  (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)))
	  (if (cdar ons)
	      (setf clusters (make-gsharp-clusters-with-duration (duration (cadar ons))))
	      (setf clusters (make-gsharp-rests-with-duration (- (timepoint 
								  (cut-off composition))
								 (caar 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 (or first-p
                                                                 (member (car pitch) (first old-ons)))
                                                             t
                                                             nil)))))
          (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))))))

(defclass amuse-gsharp-note (gsharp::note)
  ((composition :initarg :composition
		:accessor composition)
   (event :initarg :event
	  :accessor event)
   (groups :initarg :groups
	  :accessor groups)))

(defun make-amuse-gsharp-note (event staves composition 
			       &key tie-right tie-left groups)
  (destructuring-bind (pitch accidental)
      (pitch-for-gsharp event composition)
    (let ((note (make-instance 'amuse-gsharp-note 
			       :pitch pitch
			       :accidentals accidental
			       :staff (staff-for-note event staves)
			       :tie-right tie-right
			       :tie-left tie-left
			       :composition composition
			       :event event
			       :groups groups))
	  (event-map (get-event-map composition)))
      (setf (gethash event event-map) note)
      note)))

(defun get-event-map (composition)
  (unless (gethash composition *composition-event-maps*)
    (setf (gethash composition *composition-event-maps*)
	  (make-hash-table :test 'eq)))
  (gethash composition *composition-event-maps*))

(defun get-gsharp-note (event composition)
  (gethash event (get-event-map composition)))

(defmethod add-music-to-layer (layer events staves composition key-sigs)
  ;; no beaming yet
  (let* ((scale (duration (crotchet composition)))
	 (times (loop for event in events
		   collect (timepoint event)
		   collect (timepoint (cut-off event))))
	 (event-array)
	 (bar-no 0) (slice (gsharp::body layer)) (bar)
	 (position 0) (bar-starts) (clusters))
    (do* ((bar-period (current-bar (make-moment 0) composition)
		      (current-bar (cut-off bar-period) composition))
	  (bar-start (when bar-period (timepoint bar-period))
		     (when bar-period (timepoint bar-period))))
	 ((time>= (cut-off bar-period) (cut-off composition))
	  (setf bar-starts (reverse bar-starts)))
      (push bar-start times)
      (push bar-start bar-starts))
    (setf times (sort (remove-duplicates times) #'<)
	  event-array (make-array (list-length times) :initial-element nil))
    ;; Create an array of which rhythmic clusters each event belongs
    ;; to (notational clusters come later)
    (loop for time in times
       for i from 0
       do (loop for event in events
	     while (<= (timepoint event) time)
	     when (> (timepoint (cut-off event)) time)
	     do (push event (aref event-array i))))
    (when (and key-sigs (= (timepoint (first key-sigs)) 0))
      (mapcar #'(lambda (x) (set-staff-key-signature (first key-sigs) x))
	      staves)
      (setf key-sigs (cdr key-sigs)))
    (do ((times times (cdr times))
	 (i 0 (1+ i)))
	((not times))
      (when (and bar-starts (<= (first bar-starts) 
				(first times)))
	(setf bar (gsharp::make-melody-bar))
	(gsharp::add-bar bar slice bar-no)
	(incf bar-no)
	(setf position 0)
	(setf bar-starts (cdr bar-starts)))
      (if (aref event-array i)
	  (setf clusters (make-gsharp-clusters-with-exact-duration
			  (/ (- (or (second times)
				    (timepoint (cut-off composition)))
				(first times))
			     scale)))
	  (setf clusters (make-gsharp-rests-with-exact-duration
			  (/ (- (or (second times)
				    (timepoint (cut-off composition)))
				(first times))
			     scale)
			  layer)))
      ;; FIXME: This has possible problem cases for key-sig changes
      ;; mid-note and for multi-staff signatures. Fix this when the
      ;; AMUSE representation is a bit richer.
      (when (and key-sigs (<= (timepoint (first key-sigs))
			      (first times)))
	(gsharp::add-element (make-gsharp-key-signature (car key-sigs)
							(gsharp::staff bar))
		     bar position)
	(incf position)
	(setf key-sigs (cdr key-sigs)))
      (do* ((clusters clusters (cdr clusters))
	    (cluster (car clusters) (car clusters))
	    (firstp t nil))
	   ((not clusters))
	(gsharp::add-element cluster bar position)
	(incf position)
	;; There will be trouble with same pitch in same layer,
	;; but that's a gsharp bug, not an amuse one
	(dolist (event (aref event-array i))
	  (gsharp::add-note
	   cluster
	   (make-amuse-gsharp-note event staves composition 
				   :tie-right (or (cdr clusters)
						  (and (< (1+ i) (length event-array))
						       (member event (aref event-array (1+ i)))))
				   :tie-left (or (not firstp)
						 (and (> i 0)
						      (member event (aref event-array (1- i))))))))))))

(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)))))))

(defun set-staff-key-signature (key-sig staff)
  (setf (gsharp::keysig staff)
	(make-gsharp-key-signature key-sig staff)))

(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-exact-duration (duration)
  ;; at least for now
  (make-gsharp-clusters-with-duration duration))
(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-exact-duration (duration layer)
  ;; at least for now
  (make-gsharp-rests-with-duration duration layer))
(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) (rounding (/ *rounding-factor* 2))
	 (on (* (timepoint event)
		(duration (crotchet event)))
	 #+nil (* (round
                (* (timepoint event)
                   (duration (crotchet event)))
                rounding) rounding))
	 (off (* (round
		  (* (timepoint (cut-off event))
		     (duration (crotchet event)))
		  rounding) rounding)))
    (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)))))))

(defun check-ons-2 (ons bar-starts)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((best-time) (found-bar) (new-ons))
    (do* ((ons ons (cdr ons))
	  (on1 (first ons) (first ons))
	  (on2 (second ons) (second ons))
	  (query nil nil))
	 ((null on2) (reverse new-ons))
      (unless found-bar
	(cond
	  ((member (first on1) bar-starts)
	   (setf found-bar t
		 best-time (first on1)))
	  ((or (not best-time)
	       (better-timep (first on1) best-time)) ;; this ought to know about tactus
	   (setf best-time (first on1)))))
      (when (>= (- (first on2) (first on1))
		*rounding-factor*)
	(push (cons best-time (cdr on1)) new-ons)
	(setf best-time nil
	      found-bar nil)))))
       
(defun better-timep (t1 t2)
  (< (or (granularity t1 4)
	 (granularity (/ (round t1 1/16) 16) 4))
     (or (granularity t2 4)
	 (granularity (/ (round t2 1/16) 16) 4))))

(defun granularity (n &optional (max 16))
  (loop for i from 1 to max
     when (= (rem n (expt 2 (- i))) 0)
       do (return-from granularity i)))

#+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))))