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@177: ;; d@185: ;; [* Anacruses are ignored unless they have their own time-signatures! d@185: ;; - not strictly true now. This depends on the implementation of current bar] d@177: ;; d@177: ;; The stages used are: d@185: ;; 1 - find layers and stave (was 1:1 with staves. Not anymore) d@177: ;; 2 - for each layer, get events and their timings (includes d@177: ;; rounding/quantization) d@177: ;; 3 - Find all ties needed for graphical/courtesy reasons (includes d@177: ;; removal of extraneous rests and other artefacts) d@177: ;; 4 - Generate gsharp clusters d@177: ;; 5 - Get gsharp pitch for events and add notes to clusters d@177: ;; d@177: 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@177: (defparameter *foo* nil) d@177: 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@185: (make-objects-for-gsharp-buffer composition (car (esa:buffers frame))) d@185: ;; (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@185: (setf *foo* (car (esa:buffers frame))) d@164: ;; Print d@164: (clim:execute-frame-command d@185: frame `(gsharp::com-print-buffer-to-file ,pathname)) d@185: (car (esa:buffers frame)))) d@164: d@164: ;;;;;;;;;;;;;;;;;;;;;;;; d@164: ;; d@164: ;; Big `walking through data structures' type functions d@164: d@185: (defun make-objects-for-gsharp-buffer (composition buffer) d@185: "This replacement for fill-gsharp-buffer-with-constituent generates d@185: staves and layers itself and attaches them to a segment in the d@185: supplied buffer. Clefs are guessed rather than being read. Each d@185: event is asked for its staff and layer using gsharp-staff-string d@185: gsharp-layer-string, and from this, the connections are d@185: made. gsharp-staff-string defaults to calling gsharp-layer-string, d@185: so in most cases there will be a single staff for each layer. Events d@185: are added, and then staves are sorted using staff<. A proper layout d@185: object would be another way of doing this." d@185: (let ((layer-names (make-hash-table :test #'equal)) d@185: (layer-events (make-hash-table)) d@185: (layer-staves (make-hash-table)) d@185: (staff-names (make-hash-table :test #'equal)) d@185: (staff-name)(staff)(layer-name)(layer) d@185: (segment)) d@185: (sequence::dosequence (event composition) d@185: ;; can't do percussion parts yet: d@185: (when (pitchedp event) d@185: (setf layer-name (gsharp-layer-string event) d@185: layer (gethash layer-name layer-names) d@185: staff-name (gsharp-staff-string event) d@185: staff (gethash staff-name staff-names)) d@185: (if staff d@185: ;; this looks a little cryptic, but we're keeping note of d@185: ;; whether the mean pitch is above C for clef guessing. d@185: (setf (third staff) (+ (third staff) 1) d@185: (second staff) (+ (second staff) (min (floor (midi-pitch-number event) 60) 1))) d@185: (setf staff (list (gsharp::make-fiveline-staff :name staff-name) d@185: (min (floor (midi-pitch-number event) 60) d@185: 1) d@185: 1) d@185: (gsharp::buffer (car staff)) buffer d@185: (gethash staff-name staff-names) staff)) d@185: (if layer d@185: (progn d@185: (unless (find (first staff) (gethash layer layer-staves)) d@185: (push (first staff) (gethash layer layer-staves))) d@185: (push event (gethash layer layer-events))) d@185: (if segment d@185: (setf layer (gsharp::make-layer (list (first staff)) d@185: :body (gsharp::make-slice :bars nil) d@185: :name layer-name d@185: :segment segment) d@185: (gsharp::layers segment) (cons layer (gsharp::layers segment)) d@185: (gethash layer-name layer-names) layer d@185: (gethash layer layer-staves) (list staff) d@185: (gethash layer layer-events) (list event)) d@185: (setf layer (gsharp::make-layer (list (first staff)) d@185: :body (gsharp::make-slice :bars nil) d@185: :name layer-name) d@185: segment (make-instance 'gsharp::segment d@185: :buffer buffer d@185: :layers (list layer)) d@185: (gsharp-buffer:segment layer) segment d@185: (gethash layer-name layer-names) layer d@185: (gethash layer layer-staves) (list (first staff)) d@185: (gethash layer layer-events) (list event)))))) d@185: (maphash #'(lambda (key val) d@185: (declare (ignore key)) d@185: (unless (>= (second val) (/ (third val) 2)) d@185: (setf *foo* (first val)) d@185: (setf (gsharp::clef (first val)) (gsharp::make-clef :bass)))) d@185: staff-names) d@185: (maphash #'(lambda (key events) d@185: (add-music-to-layer key d@185: (reverse events) d@185: (gethash key layer-staves) d@185: composition d@185: (handler-bind ((insufficient-information d@185: #'(lambda (c) d@185: (declare (ignore c)) d@185: (invoke-restart 'guess)))) d@185: (get-applicable-key-signatures composition composition)))) d@185: layer-events) d@185: (setf (gsharp::segments buffer) (list segment) d@185: (gsharp::staves buffer) nil) d@185: (let ((staves)) d@185: (maphash #'(lambda (key val) d@185: (declare (ignore key)) d@185: (push (car val) staves)) d@185: staff-names) d@185: (setf staves (sort staves #'stave<)) d@185: (setf (gsharp::staves buffer) staves) d@185: buffer))) d@185: (defgeneric stave< (staff1 staff2) d@185: (:method (s1 s2) d@185: (let* ((clefs '(:treble :bass)) d@185: (c1 (gsharp::clef s1)) d@185: (c2 (gsharp::clef s2)) d@185: (pos1 (position (gsharp::name c1) clefs)) d@185: (pos2 (position (gsharp::name c2) clefs))) d@185: (or (< pos1 pos2) d@185: (and (= pos1 pos2) d@185: (< (gsharp::lineno c1) d@185: (gsharp::lineno c2))) d@185: (and (= pos1 pos2) d@185: (= (gsharp::lineno c1) d@185: (gsharp::lineno c2)) d@185: (string< (gsharp::name s1) d@185: (gsharp::name s2))))))) d@164: d@185: (defun bar-starts-2 (composition) d@185: (let ((starts)) d@185: (do ((bar-period (current-bar (make-standard-moment 0) composition) d@185: (current-bar (cut-off bar-period) composition))) d@185: ((time>= (cut-off bar-period) (cut-off composition)) d@185: (reverse (cons (timepoint bar-period) starts))) d@185: (push (timepoint bar-period) starts)))) d@185: (defun beat-starts-2 (bar-starts composition) d@185: ;; FIXME: improve this d@185: (when (get-applicable-time-signatures composition composition) d@185: (handler-bind d@185: ((insufficient-information d@185: #'(lambda (c) d@185: (declare (ignore c)) d@185: (invoke-restart 'use-whole-bar)))) d@185: (let ((starts) (current)) d@185: (do* ((bars bar-starts) d@185: (beat-period (current-beat (make-standard-moment 0) composition) d@185: (current-beat (cut-off beat-period) composition)) d@185: (beat-time (timepoint beat-period) (timepoint beat-period))) d@185: ((time>= (cut-off beat-period) (cut-off composition)) d@185: (progn d@185: (when (and (cdr bars) d@185: (>= beat-time (second bars))) d@185: (push (reverse current) starts) d@185: (setf current nil d@185: bars (cdr bars))) d@185: (push beat-time current) d@185: (reverse (cons (reverse current) starts)))) d@185: (when (and (cdr bars) d@185: (>= beat-time (second bars))) d@185: (push (reverse current) starts) d@185: (setf current nil d@185: bars (cdr bars))) d@185: (push beat-time current)))))) d@185: (defun add-music-to-layer (layer events staves composition key-sigs) d@185: "Creating all the musical objects for the gsharp staves in the d@185: provided layer" d@185: (let* ((bar-moments (bar-starts-2 composition)) d@185: (beat-moments (or (beat-starts-2 bar-moments composition) d@185: bar-moments)) d@185: (body (gsharp::body layer)) d@185: (bar-no 0) d@185: (ons) (position) (clusters) (bar)) 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@185: (when bar-moments d@185: (setf ons (add-bar-starts-if-not-present bar-moments 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@185: (setf ons (check-ons ons bar-moments)) d@166: ;; Now create the bars and the gsharp clusters d@185: (when key-sigs d@185: (dolist (staff staves) d@185: (setf (gsharp::keysig staff) d@185: (make-gsharp-key-signature (car key-sigs) staff)))) d@166: (do ((old-ons nil ons) d@166: (ons ons (cdr ons))) d@166: ((null (cdr ons))) d@185: (when (member (caar ons) bar-moments) d@177: ;; We're at the beginning of a bar. d@177: (when bar (check-beams bar)) d@166: (setf bar (gsharp::make-melody-bar)) d@166: (gsharp::add-bar bar body bar-no) d@177: (incf bar-no) d@177: (setf position 0)) 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@177: (when (and (cdr ons) d@177: (not (member (caar ons) d@185: (car beat-moments))) d@166: (find-if #'(lambda (x) (> x (caar ons))) d@185: (car beat-moments)) d@166: (< (find-if #'(lambda (x) (> x (caar ons))) d@185: (car beat-moments)) d@166: (car (second ons)))) d@166: (setf (cdr ons) d@166: (cons (cons (find-if #'(lambda (x) (> x (caar ons))) d@185: (car beat-moments)) 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@177: (if (cdar ons) d@166: (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons)) d@177: (car (car ons))))) d@166: (setf clusters (make-gsharp-rests-with-duration (- (car (second ons)) d@177: (car (car ons))) d@177: layer))) d@177: (let ((now (caar ons)) (first-p t) (pitches)) d@166: (do ((clusters clusters (cdr clusters))) d@166: ((null clusters)) d@185: (when (member now (car beat-moments)) 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@177: (gsharp::add-element (car clusters) bar position) d@177: ;; FIXME: Deleting notes that fall on the same note d@177: ;; name. Stupid thing to do. d@177: (setf pitches (remove-duplicates (mapcar #'(lambda (x) d@177: (cons x (pitch-for-gsharp x composition))) d@177: (cdar ons)) d@177: :key #'second :test #'=)) d@177: (dolist (pitch pitches) d@168: (with-simple-restart (ignore "Ignore note") d@177: (gsharp::add-note (car clusters) d@177: (make-instance 'gsharp::note d@177: :pitch (second pitch) d@177: :accidentals (third pitch) d@185: :staff (staff-for-note (car pitch) staves) d@177: :tie-right (if (or (cdr clusters) d@177: (member (car pitch) (second ons))) d@177: t d@177: nil) d@177: :tie-left (if first-p d@177: (member (car pitch) (first old-ons)) d@177: t))))) d@166: (incf now (* (gsharp::duration (car clusters)) 4)) d@177: (setf first-p nil) d@177: (incf position))) d@185: (when (and (cdr bar-moments) d@166: (= (car (second ons)) d@185: (second bar-moments))) d@185: (setf bar-moments (cdr bar-moments) d@185: beat-moments (cdr beat-moments)))))) d@185: d@185: (defun staff-for-note (event staves) d@185: (find-if #'(lambda (x) (string= (gsharp::name x) (gsharp-staff-string event))) d@185: staves)) d@168: d@177: (defun check-beams (bar) d@177: (do* ((clusters (gsharp::elements bar) (cdr clusters)) d@177: (left) (mid) (right)) d@177: ((null (cddr clusters))) d@177: (setf left (first clusters) d@177: mid (second clusters) d@177: right (third clusters)) d@177: (unless (or (typep mid 'gsharp::rest) d@177: (= (max (gsharp::rbeams mid) d@177: (gsharp::lbeams mid)) d@177: 0)) d@177: (cond d@177: ((or (typep left 'gsharp::rest) d@177: (= (gsharp::rbeams left) 0)) d@177: (setf (gsharp::lbeams mid) 0)) d@177: ((or (typep right 'gsharp::rest) d@177: (= (gsharp::lbeams right) 0)) d@177: (setf (gsharp::rbeams mid) 0)) d@177: ((< (gsharp::rbeams left) d@177: (gsharp::lbeams right)) d@177: (setf (gsharp::lbeams mid) (gsharp::rbeams left))) d@177: (t (setf (gsharp::rbeams mid) (gsharp::lbeams right))))))) d@168: d@185: (defgeneric make-gsharp-key-signature (key-signature object)) d@185: (defmethod make-gsharp-key-signature ((key-signature standard-key-signature) (layer gsharp-buffer::layer)) d@183: (let ((alterations (make-array 7 :initial-element :natural)) d@168: (order-of-sharps #(3 0 4 1 5 2 6)) d@168: (order-of-flats #(6 2 5 1 4 0 3))) d@168: (if (< (key-signature-sharps key-signature) 0) d@168: (dotimes (index (abs (key-signature-sharps key-signature))) d@168: (setf (elt alterations (elt order-of-flats index)) :flat)) d@168: (dotimes (index (key-signature-sharps key-signature)) d@168: (setf (elt alterations (elt order-of-sharps index)) :sharp))) d@168: (gsharp-buffer::make-key-signature (car (gsharp::staves layer)) d@168: :alterations alterations))) d@185: (defmethod make-gsharp-key-signature ((key-signature standard-key-signature) d@185: (staff gsharp::staff)) d@185: (let ((alterations (make-array 7 :initial-element :natural)) d@185: (order-of-sharps #(3 0 4 1 5 2 6)) d@185: (order-of-flats #(6 2 5 1 4 0 3))) d@185: (if (< (key-signature-sharps key-signature) 0) d@185: (dotimes (index (abs (key-signature-sharps key-signature))) d@185: (setf (elt alterations (elt order-of-flats index)) :flat)) d@185: (dotimes (index (key-signature-sharps key-signature)) d@185: (setf (elt alterations (elt order-of-sharps index)) :sharp))) d@185: (gsharp-buffer::make-key-signature staff d@185: :alterations alterations))) d@164: d@164: ;;;;;;;;;;;;;;;;;;;;;;; d@164: ;; d@164: ;; Information conversion functions d@164: d@164: ;; Pitch d@164: d@168: (defgeneric pitch-for-gsharp (pitch composition) d@164: (:documentation "Given a pitch object, return a list of gsharp's d@164: pitch number and accidental keyword")) d@168: (defmethod pitch-for-gsharp ((pitch diatonic-pitch) composition) d@168: (declare (ignore composition)) 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@168: (defmethod pitch-for-gsharp ((pitch chromatic-pitch) composition) d@168: ;; Just go for line-of-fifths proximity spelling, but based on d@168: ;; keysig if present. Could always try to spell it with ps13, 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@168: (defmethod pitch-for-gsharp ((event standard-chromatic-pitched-event) composition) d@168: ;; Should probably go for line-of-fifths proximity spelling, d@168: ;; if keysig present, but ps13ing for now. d@168: (let* ((octave (octave event)) d@177: (event-pos (position event (ocp-list composition) :key #'car)) d@168: (note-sequence (get-spelling-list composition)) d@168: (spelling (elt note-sequence event-pos)) d@168: (note-name (cdr (assoc (aref (second spelling) 0) d@168: '(("C" . 0) ("D" . 1) ("E" . 2) ("F" . 3) d@168: ("G" . 4) ("A" . 5) ("B" . 6)) d@168: :test #'string=))) d@168: (accidental (cdr (assoc (aref (second spelling) 1) d@168: '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural) d@168: ("f" . :flat) ("ff" . :double-flat)) d@168: :test #'string=)))) d@168: (list (+ (* 7 octave) note-name) accidental))) d@168: d@168: d@168: (defparameter *spelling-cache* (make-hash-table)) d@168: (defparameter *ocp-cache* (make-hash-table)) d@168: d@168: (defun get-spelling-list (composition) d@168: (unless (gethash composition *spelling-cache*) d@168: (setf (gethash composition *spelling-cache*) d@168: (ps13:ps13-new-imp (map 'list #'cdr (get-ocp-list composition)) d@168: 10 42 nil nil nil))) d@168: (gethash composition *spelling-cache*)) d@168: d@168: (defun get-ocp-list (composition) d@168: (unless (gethash composition *ocp-cache*) d@168: (setf (gethash composition *ocp-cache*) (ocp-list composition))) d@168: (gethash composition *ocp-cache*)) d@168: d@168: (defun ocp-list (composition) d@168: (flet ((sorter (x y) d@168: (or (amuse:time< x y) d@168: (and (amuse:time= x y) d@168: (amuse:pitch< x y))))) d@168: (loop for e being each element of composition d@168: if (typep e 'amuse:pitched-event) d@168: collect (cons e (make-array 2 :initial-contents d@168: (list (slot-value e 'amuse::time) d@168: (- (slot-value e 'amuse::number) 21)))) into result d@168: finally (return (sort result #'sorter :key #'car))))) d@168: 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: ;; 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@168: (:method ((e amuse-gsharp::gsharp-object)) d@168: (name-from-layer e)) d@164: (:documentation "Return a string that uniquely identifies the layer d@164: to which event belongs")) d@164: d@185: (defgeneric gsharp-staff-string (event) d@185: (:method (e) (gsharp-layer-string e)) d@185: (:documentation "Return a string that uniquely identifies the staff d@185: to which event belongs")) d@185: d@168: (defun name-from-layer (event) d@177: ;; Uses gsharp layer names. Numbers layers in cases of duplication d@168: (let* ((layers (gsharp::layers d@168: (car d@168: (gsharp::segments d@168: (gsharp::buffer d@168: (gsharp::staff d@168: (amuse-gsharp::note event))))))) d@168: (layer (gsharp::layer d@168: (gsharp::slice d@168: (gsharp::bar d@168: (gsharp::cluster d@168: (amuse-gsharp::note event)))))) d@168: (name (gsharp::name layer)) d@168: (count)) d@168: (dolist (cand-layer layers) d@168: (if (eq cand-layer layer) d@168: (if count d@168: (return-from name-from-layer (concatenate 'string d@168: name d@168: (princ-to-string count))) d@168: (return-from name-from-layer name)) d@168: (when (string= name (gsharp::name cand-layer)) d@168: (setf count (if count (+ count 1) 2))))))) d@168: 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@177: ;; provides a list of bars, each a list of beats. If no timesig, d@177: ;; guesses at 4/4 d@177: ;; FIXME: This is stupid and should disappear if and when proper d@177: ;; beat methods are implemented. d@168: (if time-signature-list d@168: (loop for time-signature in time-signature-list d@168: nconc (loop for i from (timepoint (onset time-signature)) d@168: to (1- (timepoint (cut-off time-signature))) d@168: by (* (crotchets-in-a-bar time-signature) crotchet) d@168: 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@168: collect (+ j i)))) d@168: ;; FIXME: fudge d@168: (loop for i from 0 to 1000 by 4 d@168: collect (loop for j from i to (+ i 3) d@168: collect j)))) 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@177: (defun check-ons (ons bar-starts) d@177: "looks for small rests such as might be created by midi performance d@177: of tenuto lines" d@177: (let ((time (caar ons)) (notes (cdar ons))(new-ons)) d@177: (do ((ons (cdr ons) (cdr ons))) d@177: ((null ons) (reverse new-ons)) d@177: (if (or (member (caar ons) bar-starts) d@177: (> (- (caar ons) time) d@177: *rounding-factor*)) d@177: (setf new-ons (cons (cons time notes) new-ons) d@177: time (caar ons) d@177: notes (cdar ons)) d@177: (dolist (note (cdar ons)) d@177: (unless (member note notes) d@177: (push note notes))))))) d@177: d@177: #+nil d@177: 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@177: (let ((new-ons) (skip)) d@166: (do ((ons ons (cdr ons))) d@166: ((null (cdr ons)) d@177: (if skip (reverse new-ons) (reverse (cons (car ons) new-ons)))) d@177: (cond d@177: (skip (setf skip nil)) d@177: ((not (and (<= (- (car (second ons)) d@177: (car (first ons))) d@177: *rounding-factor*) d@177: (null (cdr (first ons))))) d@177: (if (<= (- (car (second ons)) d@177: (car (first ons))) d@177: *rounding-factor*) d@177: (progn d@177: (push (cons (caar ons) (remove-duplicates (nconc (cdr (first ons)) d@177: (cdr (second ons))))) d@177: new-ons) d@177: (setf skip t)) d@177: (push (car ons) new-ons))))))) d@177: 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@177: (let ((rounding-factor (/ 1 *rounding-factor*))) d@177: (when events d@177: (let ((crotchet (duration (crotchet (car events))))) d@177: (do ((events events (cdr events))) d@177: ((null (cdr events))) d@177: (do ((divisor rounding-factor (* 2 divisor))) d@177: ((<= (rem (* (timepoint (car events)) crotchet) d@177: divisor) d@177: (/ divisor 3)) d@177: (setf rounding-factor divisor)))))) d@177: (/ 1 rounding-factor))) d@177: d@177: (defun guess-rounding-factor-smart (events) d@177: "Assuming that only durations need quantising, look at the lcd for d@177: 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))))