d@164: ;; This file is for methods creating and using gsharp score buffers
d@164: ;; for output. This would generally involve rendering to screen, file,
d@164: ;; printer or browser.
d@164: ;;
d@164: ;; The interface doesn't obviously align perfectly with the gsharp
d@164: ;; data structure, so some notes on the key elements are included
d@164: ;; here:
d@164: ;;
d@164: ;; amuse:events have no direct analogue, with their attributes divided
d@164: ;; between notes and clusters:
d@164: ;;
d@164: ;; * notes have a pitch with a number that is 1- the diatonic
d@164: ;; component of mips pitch and an accidental that is one of a list of
d@164: ;; keyword options, most relevant being :sharp :natural :flat
d@164: ;; :double-sharp and :double-flat
d@164: ;;
d@164: ;; * clusters are the rhythmic and positional aspect of one or more
d@164: ;; notes. Duration is stored in terms of notehead (:long :breve :whole
d@164: ;; :half :filled) and, for :filled, lbeams and rbeams for the number
d@164: ;; of beams in each direction, supplemented by a dots slot. To render
d@164: ;; this to a number for standard time within amuse, there is a method,
d@164: ;; gsharp:duration, for which a crotchet is 1/4
d@164: ;;
d@164: ;; Parts and staffs are viewed notationally, so we have largely
d@164: ;; independant structures called layers (roughly = voices) and staves
d@164: ;; (as they appear on the page). These have names and, at the moment,
d@164: ;; are being identified by a string-getting method below. Within a
d@164: ;; layer, clusters are to be found in bar objects and listed in the
d@164: ;; bars slot.
d@164: ;;
d@164: ;; The musical entity into which these slot is a segment, and there
d@164: ;; can be multiple segments in a buffer, though what this means and
d@164: ;; how they relate is as yet a mystery to me.
d@164: ;;
d@164: ;;; IMPLEMENTATION
d@164: ;; 
d@164: ;; We're creating a buffer. Lots of this code is adapted from
d@164: ;; gsharp/mxml/mxml.lisp, but wouldn't now be recognised
d@164: ;;
d@164: ;; * Clef is guessed at - we need amuse:get-applicable-clef (and
d@164: ;; amuse:clef)
d@164: 
d@164: (in-package "AMUSE-TOOLS")
d@164: 
d@166: (defparameter *rounding-factor* 1/4)
d@166: 
d@164: (defstruct gsharp-duration 
d@164:   "Structure for specifying duration-related parameters for g-sharp"
d@164:   notehead (beams 0) (dots 0) (tied-p nil))
d@164: 
d@164: ;;;;;;;;;;;;;;;;;;;;;
d@164: ;; Top-level methods
d@164: 
d@164: (defun write-gsharp-eps (composition pathname)
d@164:   ;; write a score eps from a composition. Most of this can be copied
d@164:   ;; straight (this is copied already from CSR's code)
d@164:   ;; Boilerplate stuff:
d@164:   (let* ((frame (clim:make-application-frame 'gsharp:gsharp))
d@164:          (clim:*application-frame* frame)
d@164:          (esa:*esa-instance* frame))
d@164:       (clim:adopt-frame (clim:find-frame-manager :server-path '(:null)) frame)
d@164:       (clim:execute-frame-command frame '(gsharp::com-new-buffer))
d@164:       ;; Now generate the buffer
d@164:       (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
d@164:       ;; Refresh and process
d@164:       (setf (gsharp::modified-p (car (esa:buffers frame))) t)
d@164:       (gsharp::recompute-measures (car (esa:buffers frame)))
d@164:       ;; Print
d@164:       (clim:execute-frame-command
d@164:        frame `(gsharp::com-print-buffer-to-file ,pathname))))
d@164: 
d@164: ;;;;;;;;;;;;;;;;;;;;;;;;
d@164: ;;
d@164: ;; Big `walking through data structures' type functions
d@164: 
d@164: (defgeneric fill-gsharp-buffer-with-constituent (buffer constituent)
d@164:   (:documentation "Takes an empty gsharp buffer and a constituent and
d@164:   fills the buffer based on the contents of constituent. Buffer is
d@164:   returned, but this is not necessary, since it is modified in
d@164:   place."))
d@164: (defmethod fill-gsharp-buffer-with-constituent (buffer (composition composition))
d@164:   ;; FIXME: Throughout this, I assume that
d@164:   ;; get-applicable-time-signatures isn't '()
d@164:   (let ((time-signatures (get-applicable-time-signatures composition composition))
d@166:         (key-signatures (get-applicable-key-signatures composition composition))
d@164:         (layers))
d@164:     (multiple-value-bind (layer-events layer-scores)
d@164:         ;; Get hash-tables of events by layer and counts of events
d@164:         ;; below middle C for guessing clef.
d@164:         (identify-gsharp-layers composition)
d@164:       ;; For each layer make clef, and one staff per layer
d@164:       ;; FIXME: this is cheating
d@164:       (maphash #'(lambda (name events)
d@164:                    (let* ((clef (if (> (gethash name layer-scores)
d@164:                                        (/ (length events) 2))
d@164:                                     (gsharp::make-clef :bass)
d@164:                                     (gsharp::make-clef :treble)))
d@164:                           (staff (gsharp::make-fiveline-staff :name name
d@164:                                                               :clef clef)))
d@164:                      ;; Make the layers
d@164:                      (push (gsharp::make-layer (list staff)
d@164:                                                :body (gsharp::make-slice :bars nil)
d@164:                                                :name name)
d@164:                            layers)
d@164:                      ;; Add the notes and bars
d@166:                      (add-bars-and-events-to-layer (car layers) (reverse events)
d@166:                                                    time-signatures
d@166:                                                    :key-signatures key-signatures)))
d@164:                layer-events)
d@164:       ;; Attach layers to a segment and place segment into buffer
d@164:       (let* ((segment (make-instance 'gsharp::segment :layers layers :buffer buffer)))
d@164:         (setf (gsharp::segments buffer) (list segment)
d@164:               (gsharp::staves buffer) (mapcar #'(lambda (x) (car (gsharp::staves x)))
d@164:                                               layers))
d@164:         buffer))))
d@164: 
d@164: (defgeneric identify-gsharp-layers (constituent)
d@164:   (:documentation "Takes a composition, returns two hash tables, one
d@164:   of events grouped by layer name and the other of counts of notes
d@164:   below middle C by layer (for choosing clef). N.B. On two counts this
d@164:   is a dodgy way of tying clef, staff and layer. Separate later."))
d@164: 
d@164: (defmethod identify-gsharp-layers ((composition composition))
d@164:   (let ((layer-events (make-hash-table :test #'equal))
d@164:         (layer-scores (make-hash-table :test #'equal)))
d@164:     (sequence:dosequence (event composition (values layer-events layer-scores))
d@164:       (when (pitchedp event)
d@164:         (cond
d@164:           ((gethash (gsharp-layer-string event) layer-events)
d@164:            (push event (gethash (gsharp-layer-string event) layer-events))
d@164:            (when (< (midi-pitch-number event) 60)
d@164:              (incf (gethash (gsharp-layer-string event) layer-scores))))
d@164:           (t (setf (gethash (gsharp-layer-string event) layer-events)
d@164:                    (list event)
d@164:                    (gethash (gsharp-layer-string event) layer-scores)
d@164:                    (if (< (midi-pitch-number event) 60)
d@164:                        1 0))))))))
d@164: 
d@166: (defun add-bars-and-events-to-layer (layer events time-signatures &key (key-signatures nil))
d@164:   "Given list of events to be attached to a layer, along with
d@164:   applicable time signatures, clumsily waddle through them all and
d@164:   slap an approximation to the events into place. Improve this."
d@164:   (let* ((crotchet-beats (duration (crotchet (car events)))) ;; (or make into semibreves?)
d@166:          (beat-starts (beat-starts time-signatures 
d@166:                                    :crotchet crotchet-beats))
d@166:          (bar-starts (mapcar #'car beat-starts))
d@166:          (ons)
d@166:          (clusters) (bar) (bar-no 0)
d@164:          (body (gsharp::body layer)))
d@166:     ;; this is a cheat to guess timing rounding (quantisation) based
d@166:     ;; on onset times - only affects midi-like data where onsets are
d@166:     ;; already rounded, but durations are not (as in TC's fantasia
d@166:     ;; midi files....)
d@166:     (setf *rounding-factor* (max (guess-rounding-factor events)
d@166:                                  1/8))
d@166:     ;; First create a list of change-points for when events are
d@166:     ;; sounding, of the format (time event event event) (time event))
d@166:     (dolist (event events)
d@166:       (setf ons (add-on-off-pair event ons)))
d@166:     ;; These durations may span bars, which is an absolute ban for
d@166:     ;; most music (Mensurstrich aside), so insert bar starts if not
d@166:     ;; present. Note that, since the events themselves are recorded in
d@166:     ;; the list, the existence of ties shuold be detected.
d@166:     (when bar-starts
d@166:       (setf ons (add-bar-starts-if-not-present bar-starts ons)))
d@166:     ;; Finally, one problem here is that, in midi, there is often a
d@166:     ;; gap or overlap between consecutive notes or chords. Since
d@166:     ;; rounding happens, but there is no check for bar length here or
d@166:     ;; within g-sharp, this should verify that everything makes
d@166:     ;; sense. At the moment, it just removes short rests...
d@166:     (setf ons (check-ons ons))
d@166:     ;; Now create the bars and the gsharp clusters
d@166:     (do ((old-ons nil ons)
d@166:          (ons ons (cdr ons)))
d@166:         ((null (cdr ons)))
d@166:       (when (member (caar ons) bar-starts)
d@166:         (setf bar (gsharp::make-melody-bar))
d@166:         (gsharp::add-bar bar body bar-no)
d@166:         (incf bar-no))
d@166:       ;; A quick check for notes which span beats and don't start at
d@166:       ;; the beginning of their beats. IMO, this makes them more
d@166:       ;; likely to require a tie.
d@166:       (when (and (not (member (caar ons)
d@166:                               (car beat-starts)))
d@166:                  (find-if #'(lambda (x) (> x (caar ons)))
d@166:                                  (car beat-starts))
d@166:                  (< (find-if #'(lambda (x) (> x (caar ons)))
d@166:                                  (car beat-starts))
d@166:                     (car (second ons))))
d@166:         (setf (cdr ons)
d@166:               (cons (cons (find-if #'(lambda (x) (> x (caar ons)))
d@166:                                    (car beat-starts))
d@166:                           (cdar ons))
d@166:                     (cdr ons))))
d@166:       ;; Making clusters just from duration removes the ability to
d@166:       ;; divide notes into easy-to-read tied components based on the
d@166:       ;; time signature (for example, a note of a tactus beat + a
d@166:       ;; quaver in 6/8 will be rendered as a minim this way) - that's
d@166:       ;; why I've taken as much of the metrical logic out and put it
d@166:       ;; above if there are other straightforward rules, they should,
d@166:       ;; I think go there.
d@166:       (if (cdr (car ons))
d@166:           (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons))
d@166:                                                               (car (car ons)))))
d@166:           (setf clusters (make-gsharp-rests-with-duration (- (car (second ons))
d@166:                                                            (car (car ons)))
d@166:                                                         layer)))
d@166:       (let ((now (caar ons)) (first-p t))
d@166:         (do ((clusters clusters (cdr clusters)))
d@166:             ((null clusters))
d@166:           (when (member now (car beat-starts))
d@166:             (setf (gsharp::lbeams (car clusters)) 0))
d@164:           ;; This function adds cluster at a specific point in the
d@164:           ;; bar. It does a lot of other things that are probably a)
d@164:           ;; not necessary or b) should be within the duration logic
d@164:           ;; above. Would be good not to rely on it (which is not to
d@164:           ;; say that it isn't reliable)
d@166:           (gsharp-mxml::add-element-at-duration (car clusters)
d@166:                                                 bar
d@166:                                                 (/ (- now (car bar-starts))
d@166:                                                    4))
d@166:           (dolist (note (cdr (car ons)))
d@166:             (when note
d@166:               (let ((pitch (pitch-for-gsharp note)))
d@166:                 (gsharp::add-note (car clusters)
d@166:                                   (make-instance 'gsharp::note
d@164:                                                  :pitch (first pitch)
d@164:                                                  :accidentals (second pitch)
d@166:                                                  :staff (car (gsharp::staves layer))
d@166:                                                  :tie-right (if (cdr clusters)
d@166:                                                                 t
d@166:                                                                 (member note (second ons)))
d@166:                                                  :tie-left (if first-p
d@166:                                                                (member note (first old-ons))
d@166:                                                                t))))))
d@166:           (incf now (* (gsharp::duration (car clusters)) 4))
d@166:           (setf first-p nil)))
d@166:       (when (and (cdr bar-starts)
d@166:                  (= (car (second ons))
d@166:                     (second bar-starts)))
d@166:         (setf bar-starts (cdr bar-starts)
d@166:               beat-starts (cdr beat-starts))))
d@166:     (dolist (key-signature key-signatures)
d@166:       ;; code half-inched from mxml.lisp (maybe there's a useful
d@166:       ;; function to be abstracted here?), but I don't really
d@166:       ;; understand how key changes work...?
d@166:       (let ((alterations (make-array 7))
d@166:             (order-of-sharps #(3 0 4 1 5 2 6))
d@166:             (order-of-flats #(6 2 5 1 4 0 3)))
d@166:         (if (< (key-signature-sharps key-signature) 0)
d@166:             (dotimes (index (abs (key-signature-sharps key-signature)))
d@166:               (setf (elt alterations (elt order-of-flats index)) :flat))
d@166:             (dotimes (index (key-signature-sharps key-signature))
d@166:               (setf (elt alterations (elt order-of-sharps index)) :sharp)))
d@166:         (setf (gsharp::keysig (car (gsharp::staves layer)))
d@166:               (gsharp-buffer::make-key-signature (car (gsharp::staves layer))
d@166:                                                  :alteration alterations))))))
d@164: 
d@164: ;;;;;;;;;;;;;;;;;;;;;;;
d@164: ;;
d@164: ;; Information conversion functions
d@164: 
d@164: ;; Pitch
d@164: 
d@164: (defgeneric pitch-for-gsharp (pitch)
d@164:   (:documentation "Given a pitch object, return a list of gsharp's
d@164:   pitch number and accidental keyword"))
d@164: (defmethod pitch-for-gsharp ((pitch diatonic-pitch))
d@164:   ;; Easy for diatonic pitch, although behaviour for extreme or
d@164:   ;; fractional alterations is unclear.
d@164:   (list (1+ (diatonic-pitch-mp pitch))
d@164:         (case (diatonic-pitch-accidental pitch)
d@164:             (1 :sharp)
d@164:             (-1 :flat)
d@164:             (2 :double-sharp)
d@164:             (-2 :double-flat)
d@164:             (0 :natural)
d@164:             (otherwise (error "gsharp can't handle this pitch")))))
d@164: (defmethod pitch-for-gsharp ((pitch chromatic-pitch))
d@164:   ;; Just go for line-of-fifths proximity spelling. Could always try
d@164:   ;; to spell it, but...
d@164:   (let* ((octave (octave pitch))
d@164:          (pitch-class (pitch-class pitch))
d@164:          (diatonic-pitch-number (aref #(0 0 1 2 2 3 3 4 4 5 6 6) pitch-class)))
d@164:     (list (+ (* 7 octave) diatonic-pitch-number)
d@164:           (aref #(:natural :sharp ;; C  C#
d@164:                   :natural        ;; D
d@164:                   :flat :natural  ;; Eb E
d@164:                   :natural :sharp ;; F  F#
d@164:                   :natural :sharp ;; G  G#
d@164:                   :natural        ;; A
d@164:                   :flat :natural) ;; Bb B
d@164:                 pitch-class))))
d@164: 
d@164: ;; Time 
d@164: 
d@166: (defun make-gsharp-clusters-with-duration (duration)
d@166:   "Returns a list of cluster(s) whose total duration is equal to
d@166:   duration (which is given in crotchets)"
d@166:   (let ((new-durations (gsharp-durations-from-beats duration)))
d@166:     (loop for new-duration in new-durations
d@166:          collect (gsharp::make-cluster :notehead (gsharp-duration-notehead new-duration)
d@166:                                        :lbeams (gsharp-duration-beams new-duration)
d@166:                                        :rbeams (gsharp-duration-beams new-duration)
d@166:                                        :dots  (gsharp-duration-dots new-duration)))))
d@166: 
d@166: (defun make-gsharp-rests-with-duration (duration layer)
d@166:   "Returns a list of rest(s) whose total duration is equal to
d@166:   duration (which is given in crotchets)"
d@166:   (let ((new-durations (gsharp-durations-from-beats duration)))
d@166:     (loop for new-duration in new-durations
d@166:        collect(gsharp::make-rest (car (gsharp::staves layer))
d@166:                                  :notehead (gsharp-duration-notehead new-duration)
d@166:                                  :lbeams (gsharp-duration-beams new-duration)
d@166:                                  :rbeams (gsharp-duration-beams new-duration)
d@166:                                  :dots  (gsharp-duration-dots new-duration)))))
d@164: 
d@164: (defun gsharp-durations-from-beats (beats &optional (durations nil))
d@164:   ;; Takes a count of crotchets and returns a list of
d@164:   ;; <gsharp-duration>s that most simply defines the attached.  This
d@164:   ;; is a recursive function that finds the longest simple duration
d@164:   ;; that fits into beats and, if that leaves a remainder, runs again
d@164:   ;; on the remainder (until hemi-demi-semi-quavers are reached). It
d@164:   ;; avoids double dots and is ignorant of time-signature. It will be
d@164:   ;; replaced. Soon.
d@164:   ;;; FIXME: Handles quantisation fairly
d@164:   ;; stupidly. Could be made slightly smarter with simple rounding
d@164:   ;; (erring on the side of longer durations?)
d@164:   (assert (>= beats 0))
d@164:   (push (make-gsharp-duration) durations)
d@164:   ;; First find the longest simple duration that fits in beats
d@164:   ;; First with notes > 1 crotchet
d@164:   (loop for option in '((16 :long) (8 :breve) (4 :whole) (2 :half) (1 :filled))
d@164:      do (cond
d@166:           ((= beats (* (car option) 7/4))
d@166:            (setf (gsharp-duration-notehead (car durations))
d@166:                  (cadr option)
d@166:                  (gsharp-duration-dots (car durations))
d@166:                  2)
d@166:            (return-from gsharp-durations-from-beats (reverse durations)))
d@164:           ((= beats (* (car option) 3/2))
d@164:            (setf (gsharp-duration-notehead (car durations))
d@164:                  (cadr option)
d@164:                  (gsharp-duration-dots (car durations))
d@164:                  1)
d@164:            (return-from gsharp-durations-from-beats (reverse durations)))
d@164:           ((> beats (car option))
d@164:            (setf (gsharp-duration-notehead (car durations))
d@164:                  (cadr option))
d@164:            (return-from gsharp-durations-from-beats
d@164:              (gsharp-durations-from-beats (- beats (car option)) durations)))
d@164:           ((= beats (car option))
d@164:            (setf (gsharp-duration-notehead (car durations))
d@164:                  (cadr option))
d@164:            (return-from gsharp-durations-from-beats (reverse durations)))))
d@164:   (setf (gsharp-duration-notehead (car durations))
d@164:         :filled)
d@164:   ;; then with short notes (beams rather than noteheads)
d@164:   (do ((i 1 (1+ i)))
d@164:       ((= i 4) ;; means either tuplet, very short note or unquantised data
d@164:        (reverse durations))
d@164:     (cond
d@164:       ((= beats (* (/ 1 (expt 2 i)) 3/2))
d@164:        (setf (gsharp-duration-beams (car durations))
d@164:              i
d@164:              (gsharp-duration-dots (car durations))
d@164:              1)
d@164:        (return-from gsharp-durations-from-beats (reverse durations)))
d@164:       ((> beats (/ 1 (expt 2 i)))
d@164:        (setf (gsharp-duration-beams (car durations))
d@164:              i)
d@164:        (return-from gsharp-durations-from-beats
d@164:          (gsharp-durations-from-beats (- beats (/ 1 (expt 2 i))) durations)))
d@164:       ((= beats (/ 1 (expt 2 i)))
d@164:        (setf (gsharp-duration-beams (car durations))
d@164:              i)
d@164:        (return-from gsharp-durations-from-beats (reverse durations))))))
d@164: 
d@164: ;;;;;;;;;;;;;;;;;;;;;
d@164: ;; 
d@164: ;; Other utility functions
d@164: 
d@164: (defgeneric gsharp-layer-string (event)
d@164:   (:method (e) (name-from-channel-and-patch e))
d@164:   (:documentation "Return a string that uniquely identifies the layer
d@164:   to which event belongs"))
d@164: 
d@164: (defun name-from-channel-and-patch (event)
d@164:   "Generate layer-identifying string from the patch and channel that
d@164: would be used for midi export. For MIDI, this is guaranteed to
d@164: separate or over-separate. Tracks would possibly be better, but ?don't
d@164: exist in MIDI type 0?"
d@164:   (format nil "~D/~D"
d@164:           (get-patch-for-midi event)
d@164:           (get-channel-for-midi event)))
d@164: 
d@164: (defun bar-starts (time-signature-list &key (crotchet 1))
d@164:   (loop for time-signature in time-signature-list
d@164:      nconc (loop for i from (timepoint (onset time-signature))
d@164:                 to (1- (timepoint (cut-off time-signature)))
d@164:                 by (* (crotchets-in-a-bar time-signature) crotchet)
d@164:                 collect i)))
d@166: 
d@166: (defun beat-starts (time-signature-list &key (crotchet 1))
d@166:   (loop for time-signature in time-signature-list
d@166:      nconc (loop for i from (timepoint (onset time-signature))
d@166:                 to (1- (timepoint (cut-off time-signature)))
d@166:                 by (* (crotchets-in-a-bar time-signature) crotchet)
d@166:                 collect (loop for j from 0
d@166:                              to (* (crotchets-in-a-bar time-signature)
d@166:                                    crotchet)
d@166:                              by (* (tactus-duration time-signature)
d@166:                                    crotchet)
d@166:                              collect (+ j i)))))
d@166: 
d@166: ;;;;;;;;;;;;;;;;;;
d@166: ;;
d@166: ;; Sequence and data structure functions
d@166: 
d@166: 
d@166: (defun add-bar-starts-if-not-present (bar-starts changes)
d@166:   "Takes a list of bar-start times and one of sounding notes at
d@166: times. If a bar has no change of sounding notes at its start, it would
d@166: not appear in the latter list, but since we will want notes tied over
d@166: barlines, we must add it and return the modified list"
d@166:   (let ((new-changes))
d@166:     (dolist (event changes (reverse new-changes))
d@166:       (do ()
d@166:           ((not (and bar-starts
d@166:                      (< (car bar-starts)
d@166:                         (car event)))))
d@166:         (setf new-changes
d@166:               (cons (if (cadr new-changes)
d@166:                         (cons (car bar-starts)
d@166:                               (cdar new-changes))
d@166:                         (list (car bar-starts)))
d@166:                     new-changes)
d@166:               bar-starts (cdr bar-starts)))
d@166:       (setf new-changes (cons event new-changes))
d@166:       (when (and bar-starts (= (car event) (car bar-starts)))
d@166:         (setf bar-starts (cdr bar-starts))))))
d@166: 
d@166: (defun add-on-off-pair (event data)
d@166:   "For walking through an ordered event sequence and building up a
d@166: list of changes to sounding pitches, this function takes an event and
d@166: adds the time for which it sounds to the structure."
d@166:   (let ((copied-data)
d@166:         (on (* (round
d@166:                 (* (timepoint event)
d@166:                    (duration (crotchet event)))
d@166:                 *rounding-factor*) *rounding-factor*))
d@166:         (off (* (round
d@166:                  (* (timepoint (cut-off event))
d@166:                     (duration (crotchet event)))
d@166:                  *rounding-factor*) *rounding-factor*)))
d@166:     (do ((data data (cdr data)))
d@166:         ((null data) (reverse (cons (list off)
d@166:                                     (cons (list on event)
d@166:                                           copied-data))))
d@166:       (cond
d@166:         ((<= on (caar data))
d@166:          (when (< on (caar data))
d@166:            (push (cons on (cons event (cdr (car copied-data))))
d@166:                  copied-data))
d@166:          (do ((data data (cdr data)))
d@166:              ((null data)
d@166:               (return-from add-on-off-pair
d@166:                 (reverse (cons (cons off (cddr (car copied-data)))
d@166:                                copied-data))))
d@166:            (cond
d@166:              ((= (caar data) off)
d@166:               (return-from add-on-off-pair
d@166:                 (nconc (reverse copied-data) data)))
d@166:              ((> (caar data) off)
d@166:               (push (cons off (cddr (car copied-data)))
d@166:                     copied-data)
d@166:               (return-from add-on-off-pair
d@166:                 (nconc (reverse copied-data) data)))
d@166:              ((< (caar data) off)
d@166:               (push (cons (caar data) 
d@166:                           (cons event (cdr (car data))))
d@166:                     copied-data)))))
d@166:         (t
d@166:          (push (car data) copied-data))))))
d@166: 
d@166: (defun check-ons (ons)
d@166:   "looks for small rests such as might be created by midi performance
d@166: of tenuto lines"
d@166:   (let ((new-ons))
d@166:     (do ((ons ons (cdr ons)))
d@166:         ((null (cdr ons))
d@166:          (reverse (cons (car ons) new-ons)))
d@166:       (unless (and (<= (- (car (second ons))
d@166:                           (car (first ons)))
d@166:                        *rounding-factor*)
d@166:                    (null (cdr (first ons))))
d@166:         (push (car ons) new-ons)))))
d@166: 
d@166: (defun guess-rounding-factor (events)
d@166:   "Assuming that only durations need quantising, look at the lcd for
d@166: onsets"
d@166:   (let ((times (map 'list #'(lambda (x)
d@166:                               (denominator (* (timepoint x)
d@166:                                               (duration (crotchet x)))))
d@166:                     events)))
d@166:     (/ 1 (apply #'lcm times))))