Mercurial > hg > amuse

--- a/implementations/gsharp/gsharp-import.lisp	Tue Jan 01 12:39:30 2008 +0000
+++ b/implementations/gsharp/gsharp-import.lisp	Tue Jan 01 12:42:12 2008 +0000
@@ -40,7 +40,7 @@
     (mapcar (lambda (note)
 	      (make-instance 'gsharp-pitched-event
 			     :note note
-                             :slice-index index
+                 :slice-index index
 			     :number (gsharp-play::midi-pitch note)
 			     :time time
 			     :interval (* 4 (compute-duration note))))
--- a/tools/gsharp-output.lisp	Tue Jan 01 12:39:30 2008 +0000
+++ b/tools/gsharp-output.lisp	Tue Jan 01 12:42:12 2008 +0000
@@ -42,6 +42,8 @@

 (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))
@@ -80,6 +82,7 @@
   ;; FIXME: Throughout this, I assume that
   ;; get-applicable-time-signatures isn't '()
   (let ((time-signatures (get-applicable-time-signatures composition composition))
+        (key-signatures (get-applicable-key-signatures composition composition))
         (layers))
     (multiple-value-bind (layer-events layer-scores)
         ;; Get hash-tables of events by layer and counts of events
@@ -100,7 +103,9 @@
                                                :name name)
                            layers)
                      ;; Add the notes and bars
-                     (add-bars-and-events (car layers) (reverse events) time-signatures)))
+                     (add-bars-and-events-to-layer (car layers) (reverse events)
+                                                   time-signatures
+                                                   :key-signatures key-signatures)))
                layer-events)
       ;; Attach layers to a segment and place segment into buffer
       (let* ((segment (make-instance 'gsharp::segment :layers layers :buffer buffer)))
@@ -131,87 +136,125 @@
                    (if (< (midi-pitch-number event) 60)
                        1 0))))))))

-(defun add-bars-and-events (layer events time-signatures)
+(defun add-bars-and-events-to-layer (layer events time-signatures &key (key-signatures nil))
   "Given list of events to be attached to a layer, along with
   applicable time signatures, clumsily waddle through them all and
   slap an approximation to the events into place. Improve this."
   (let* ((crotchet-beats (duration (crotchet (car events)))) ;; (or make into semibreves?)
-         (bar-starts (bar-starts time-signatures :crotchet crotchet-beats))
-         (cluster) (bar (gsharp::make-melody-bar)) (cluster-time) (bar-no 0)
+         (beat-starts (beat-starts time-signatures
+                                   :crotchet crotchet-beats))
+         (bar-starts (mapcar #'car beat-starts))
+         (ons)
+         (clusters) (bar) (bar-no 0)
          (body (gsharp::body layer)))
-    (gsharp::add-bar bar body bar-no)
-    (do* ((events events (cdr events))
-          (event (car events) (car events)))
-         ((null events) layer)
-      (when (and (cdr bar-starts)
-                 (>= (timepoint event) (second bar-starts)))
-        ;; new bar - and add 0 or more empty bars
-        (dotimes (i (- (or (position-if #'(lambda (x) (> x (timepoint event)))
-                                         bar-starts)
-                            2)
-                       2))
-          ;; This only runs if one or more whole-bar rests is needed
-          ;; in a layer.
-          (incf bar-no)
-          (setf bar (gsharp::make-melody-bar))
-          (gsharp::add-bar bar body bar-no)
-          (let* ((new-duration (quick-gs-duration (if (cdr bar-starts)
-                                                      (- (second bar-starts)
-                                                         (first bar-starts))
-                                                      4)))
-                 (rest (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))))
-            (gsharp-mxml::add-element-at-duration rest bar 0))
-          (setf bar-starts (cdr bar-starts)))
-        ;; Move on to new bar
-        (setf bar (gsharp::make-melody-bar)
-              bar-starts (cdr bar-starts))
-        (incf bar-no)
-        (gsharp::add-bar bar body bar-no))
-      (when (or (not cluster-time)
-                (not (time= cluster-time (onset event))))
-        ;; Not part of a pre-existant chord (this will have more
-        ;; complicated logic when I add ties). Create a new cluster.
-        (let* ((beat-duration (/ (duration event) crotchet-beats))
-               ;; This hideous thing gives a duration that doesn't
-               ;; overlap with the next note or barline. Unneccessary
-               ;; when I fix ties and start supplying bar info to
-               ;; duration function.
-               (new-duration (quick-gs-duration (min beat-duration
-                                                    (if (or (not (cdr events))
-                                                            (time= (second events)
-                                                                   event))
-                                                        beat-duration
-                                                        (/ (- (timepoint (second events))
-                                                              (timepoint event))
-                                                           crotchet-beats))
-                                                    (if (cdr bar-starts)
-                                                        (- (second bar-starts)
-                                                           (/ (timepoint event)
-                                                              crotchet-beats))
-                                                        beat-duration)))))
-          (setf cluster (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)))
+    ;; 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-starts
+      (setf ons (add-bar-starts-if-not-present bar-starts 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))
+    ;; Now create the bars and the gsharp clusters
+    (do ((old-ons nil ons)
+         (ons ons (cdr ons)))
+        ((null (cdr ons)))
+      (when (member (caar ons) bar-starts)
+        (setf bar (gsharp::make-melody-bar))
+        (gsharp::add-bar bar body bar-no)
+        (incf bar-no))
+      ;; 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 (not (member (caar ons)
+                              (car beat-starts)))
+                 (find-if #'(lambda (x) (> x (caar ons)))
+                                 (car beat-starts))
+                 (< (find-if #'(lambda (x) (> x (caar ons)))
+                                 (car beat-starts))
+                    (car (second ons))))
+        (setf (cdr ons)
+              (cons (cons (find-if #'(lambda (x) (> x (caar ons)))
+                                   (car beat-starts))
+                          (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 (cdr (car 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))
+        (do ((clusters clusters (cdr clusters)))
+            ((null clusters))
+          (when (member now (car beat-starts))
+            (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-mxml::add-element-at-duration cluster bar (/ (- (/ (timepoint event)
-                                                                     crotchet-beats)
-                                                                  (car bar-starts))
-                                                               4))
-          (setf cluster-time (onset event))))
-      (let ((pitch (pitch-for-gsharp event)))
-        (gsharp::add-note cluster (make-instance 'gsharp::note
+          (gsharp-mxml::add-element-at-duration (car clusters)
+                                                bar
+                                                (/ (- now (car bar-starts))
+                                                   4))
+          (dolist (note (cdr (car ons)))
+            (when note
+              (let ((pitch (pitch-for-gsharp note)))
+                (gsharp::add-note (car clusters)
+                                  (make-instance 'gsharp::note
                                                  :pitch (first pitch)
                                                  :accidentals (second pitch)
-                                                 :staff (car (gsharp::staves layer))))))))
+                                                 :staff (car (gsharp::staves layer))
+                                                 :tie-right (if (cdr clusters)
+                                                                t
+                                                                (member note (second ons)))
+                                                 :tie-left (if first-p
+                                                               (member note (first old-ons))
+                                                               t))))))
+          (incf now (* (gsharp::duration (car clusters)) 4))
+          (setf first-p nil)))
+      (when (and (cdr bar-starts)
+                 (= (car (second ons))
+                    (second bar-starts)))
+        (setf bar-starts (cdr bar-starts)
+              beat-starts (cdr beat-starts))))
+    (dolist (key-signature key-signatures)
+      ;; code half-inched from mxml.lisp (maybe there's a useful
+      ;; function to be abstracted here?), but I don't really
+      ;; understand how key changes work...?
+      (let ((alterations (make-array 7))
+            (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)))
+        (setf (gsharp::keysig (car (gsharp::staves layer)))
+              (gsharp-buffer::make-key-signature (car (gsharp::staves layer))
+                                                 :alteration alterations))))))

 ;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -251,10 +294,26 @@

 ;; Time

-(defun quick-gs-duration (crotchets)
-  ;; gsharp-durations-from-beats returns a list of durations. Take the
-  ;; first (= largest).
-  (car (gsharp-durations-from-beats crotchets)))
+(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
@@ -273,6 +332,12 @@
   ;; 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)
@@ -335,3 +400,107 @@
                 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))
+  (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)))))
+
+;;;;;;;;;;;;;;;;;;
+;;
+;; 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)
+  "looks for small rests such as might be created by midi performance
+of tenuto lines"
+  (let ((new-ons))
+    (do ((ons ons (cdr ons)))
+        ((null (cdr ons))
+         (reverse (cons (car ons) new-ons)))
+      (unless (and (<= (- (car (second ons))
+                          (car (first ons)))
+                       *rounding-factor*)
+                   (null (cdr (first ons))))
+        (push (car ons) new-ons)))))
+
+(defun guess-rounding-factor (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))))
\ No newline at end of file