view implementations/gsharp/methods.lisp @ 226:64b795c2ff18

Fix bug in move-to-first-bar.

Ignore-this: 52a48e8771d159294e9ad51cbe04034d

darcs-hash:20090905200027-16a00-539b473b27ebd6b75282dac335cc8617403ed3ad.gz

committer: Jamie Forth <[e-mail]>

(in-package "AMUSE-GSHARP")

(defmethod time-signatures ((composition gsharp-composition))
  (%gsharp-time-signatures composition))
(defmethod key-signatures ((composition gsharp-composition))
  (%gsharp-key-signatures composition))

(defmethod get-composition ((id gsharp-gsh-identifier))
  "Makes a gsharp buffer from .gsh file and generates a composition
from its first segment. N.B. 1) This is not compatible with
multi-segment files 2) No application frame is created (=> data flow
is pretty much one way)"
  (let ((buffer (with-open-file (s (%gsharp-identifier-pathname id))
                  (gsharp::read-buffer-from-stream s))))
    (gsharp::recompute-measures buffer)
    (segment-composition (car (gsharp::segments buffer)))))

(defmethod get-composition ((id gsharp-mxml-identifier))
  "Makes a gsharp buffer from .mxml file and generates a composition
from its first segment. N.B. 1) This is not compatible with
multi-segment files 2) No application frame is created (=> data flow
is pretty much one way)"
  (let ((buffer (gsharp-mxml::parse-mxml 
                 (gsharp-mxml::musicxml-document
                  (%gsharp-identifier-pathname id)))))
    (gsharp::recompute-measures buffer)
    (segment-composition (car (gsharp::segments buffer)))))

;; These may want another file
(defun gsh-id (pathname)
  "Creates an identifier for gsh files, based on a pathname"
  (make-instance 'gsharp-gsh-identifier :path pathname))

(defun mxml-id (pathname)
  "Creates an identifier for MusicXML files, based on a pathname"
  (make-instance 'gsharp-mxml-identifier :path pathname))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; These versions may not be useful, but create and return a gsharp
;; application frame as well as a composition

(defgeneric get-composition-with-application-frame (identifier))
(defmethod get-composition-with-application-frame ((id gsharp-identifier))
  (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)
    (import-from-identifier frame id)
    (gsharp::recompute-measures (car (esa-buffer::buffers frame)))
    (values (segment-composition (car (gsharp::segments (car (esa-buffer::buffers frame)))))
            frame)))

(defgeneric import-from-identifier (frame id))
(defmethod import-from-identifier (frame (id gsharp-gsh-identifier))
  (clim:execute-frame-command frame '(gsharp::com-new-buffer))
  (gsharp::frame-find-file frame (%gsharp-identifier-pathname id)))
(defmethod import-from-identifier (frame (id gsharp-mxml-identifier))
  (clim:execute-frame-command frame `(gsharp::com-import-musicxml ,(%gsharp-identifier-pathname id))))

(defun make-gsharp-key-signature-period (keysig onset duration)
  (make-instance 'gsharp-key-signature-period :source keysig
                 :sharp-count (- (count :sharp 
                                        (gsharp::alterations keysig))
                                 (count :flat
                                        (gsharp::alterations keysig)))
                 :time onset :interval duration))

(defun make-gsharp-time-signature-period (timesig onset duration)
  (let ((component1 (car (gsharp-buffer::time-signature-components timesig))))
    (make-instance 'gsharp-time-signature-period :source timesig
                   :numerator (if (and (listp component1)
                                       (numberp (car component1)))
                                  (car component1)
                                  nil)
                   :denominator (if (and (listp component1)
                                         (numberp (cdr component1)))
                                    (cdr component1)
                                    nil)
                   :time onset :interval duration)))
                 

(defun import-key-signature (gsharp-keysig)
  ;; FIXME: This is WRONG - shouldn't be using standard key signature,
  ;; since important detail is lost (very rarely)
  #+nil
  (make-standard-key-signature-period (- (count :sharp (gsharp::alterations gsharp-keysig))
                                         (count :flat (gsharp::alterations gsharp-keysig)))
                                      ()))

(defmethod crotchet ((object gsharp-object))
  (make-standard-period 1))

;;;
;; Experimental

(defmethod amuse::current-bar ((moment standard-moment)
                               (composition gsharp-composition))
  ;; No, I don't know how (or if) these work. But it's a hard problem,
  ;; so I don't mind cheating.
  (let ((bar-lengths (gsharp-play::measure-durations
                      (mapcar #'gsharp-buffer:body
                              (gsharp-buffer::layers (car (gsharp::segments
                                                           (amuse-gsharp::buffer composition)))))))
        (moment-time (timepoint moment)) (now 0))
    (dolist (bar-duration bar-lengths)
      (when (> (+ now (* bar-duration 4)) moment-time)
        (return-from amuse::current-bar
          (make-standard-anchored-period now (* bar-duration 4))))
      (incf now (* bar-duration 4)))))

(defun really-applicable-p (event signature-period)
  (and (overlaps event signature-period)
       (eq (gsharp::staff (note event)) (gsharp::staff (gsh-source signature-period)))))

#+nil ;; There is no AMuSE equivalent to a clef.
(defmethod get-applicable-clefs (anchored-period (composition gsharp-composition))
  (let ((clefs))
    (sequence::dosequence (event composition (mapcar #'import-clef (reverse clefs)))
      (cond
        ((overlaps event anchored-period)
         (unless (member (gsharp::clef (gsharp::staff (note event))) clefs)
           (push (gsharp::clef (gsharp::staff (note event))) clefs)))
        ((not (before event anchored-period))
         (return-from get-applicable-clefs (mapcar #'import-clef (reverse clefs))))))))