view implementations/gsharp/gsharp-import.lisp @ 59:08468c3d5801

gsharp amuse implementation

darcs-hash:20070622062520-df18d-6c619e5668475044d209a1d987c24695ac065679.gz

(in-package "AMUSE-GSHARP")

(defun last-bar-p (bar)
  ;; I know most of this file is cut-and-pasted, but this is a
  ;; particularly horrible example.
  (eq bar (car (last (gsharp-buffer:bars (gsharp-buffer:slice bar))))))

(defun find-next-note (note)
  (when (gsharp-buffer:tie-right note)
    (let ((bar (gsharp-buffer:bar (gsharp-buffer:cluster note)))
	  (cluster (gsharp-buffer:cluster note))
	  (next-element nil))
      (loop for (x y) on (gsharp-buffer:elements bar)
	    until (null y)
	    when (eq x cluster) do (setq next-element y))
      (cond
	(next-element)
	((last-bar-p bar) (return-from find-next-note nil))
	(t (let ((next-bar (gsharp-buffer:barno (gsharp-buffer:slice bar)
						(1+ (gsharp-numbering::number bar)))))
	     (if (gsharp-buffer:elements next-bar)
		 (setq next-element (car (gsharp-buffer:elements next-bar)))
		 (return-from find-next-note nil)))))
      ;; now NEXT-ELEMENT is the next element!
      (when (typep next-element 'gsharp-buffer:cluster)
	(loop for n in (gsharp-buffer:notes next-element)
	      if (and (gsharp-buffer:tie-left n)
		      (= (gsharp-buffer:pitch n) (gsharp-buffer:pitch note))
		      (eq (gsharp-buffer:staff n) (gsharp-buffer:staff note))
		      (eq (gsharp-buffer:accidentals n) (gsharp-buffer:accidentals note)))
	      return n)))))
		      
(defun compute-duration (note)
  (loop for n = note then (find-next-note n)
	while n
	sum (gsharp-buffer:duration (gsharp-buffer:cluster n))))

(defun events-from-element (element time channel)
  (when (typep element 'gsharp-buffer:cluster)
    (mapcar (lambda (note)
	      (make-instance 'gsharp-pitched-event
			     :note note
			     :number (gsharp-play::midi-pitch note)
			     :time time
			     :interval (* 4 (compute-duration note))))
	    (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element)))))

(defun events-from-bar (bar time channel)
  (mapcan (lambda (element)
	    (prog1 (events-from-element element time channel)
	      (incf time (* 4 (gsharp-buffer:duration element)))))
	  (gsharp-buffer:elements bar)))

(defun events-from-slice (slice channel durations)
  (let ((time 0))
    (mapcan (lambda (bar duration)
	      (prog1 (events-from-bar bar time channel)
		(incf time (* 4 duration))))
	    (gsharp-buffer:bars slice) durations)))

(defun segment-composition (segment)
  (let* ((slices (mapcar #'gsharp-buffer:body (gsharp-buffer::layers segment)))
	 (durations (gsharp-play::measure-durations slices))
         (gsharp-play::*tuning* (gsharp-buffer:tuning segment))
	 (events (loop for slice in slices
		       for i from 0
		       for events = (events-from-slice slice i durations)
		       then (merge 'list events (events-from-slice slice i durations) 'time<)
		       finally (return events))))
    (let* ((duration (* 4 (reduce #'+ durations)))
	   (result (make-instance 'gsharp-composition 
				  :buffer (gsharp-buffer:buffer segment)
				  ;; FIXME: this will break as soon as
				  ;; gsharp is made to have a sane
				  ;; divisions value in play.lisp
				  ;; instead of 25
				  :tempi (list (make-tempo (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment))) 0 duration))
				  :time 0
				  :interval duration)))
      (sequence:adjust-sequence result (length events)
				:initial-contents events))))

#|

(in-package :clim-user)

(define-command (amuse-play :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment)))
    (amuse-utils::play composition)))
    
(define-command (infer-key :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment))
    	 (result (amuse-utils:krumhansl-key-finder composition composition))
	 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
	 (string (format nil "Key: ~A ~(~A~)" name (cadr result))))
    (esa:display-message string))
    

|#