Mercurial > hg > amuse

(in-package "AMUSE-GSHARP")

(defun make-gsharp-composition (events buffer timepoint interval &key tempi key-signatures time-signatures)
  (let ((comp (make-instance 'gsharp-composition :buffer buffer :time timepoint :interval interval
                             :tempi tempi :key-signatures key-signatures :time-signatures time-signatures)))
    (sequence:adjust-sequence comp (length events) :initial-contents events)))

(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 index time)
  (typecase element
    (gsharp-buffer:cluster
     (mapcar (lambda (note)
               (make-instance 'gsharp-pitched-event
                              :note note
                              :slice-index index
                              :number (gsharp-play::midi-pitch note)
                              :time time
                              :interval (* 4 (compute-duration note))))
             (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element))))
    (gsharp-buffer:key-signature
     (list (make-gsharp-key-signature-period element time nil)))
    (gsharp-buffer::time-signature
     (list (make-gsharp-time-signature-period element time nil)))))

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

(defun events-from-slice (slice index durations)
  (let ((time 0))
    (mapcan (lambda (bar duration)
	      (prog1 (events-from-bar bar index time)
		(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))
         (key-signatures (get-initial-keysigs segment))
         (time-signatures)
         (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)))
         (duration (* 4 (reduce #'+ durations))))
    (multiple-value-setq (events key-signatures time-signatures)
      (filter-event-list-for-signatures events key-signatures duration))

    ;; FIXME: TEMPI here will break as soon as gsharp is made to have
    ;; a sane divisions value in play.lisp instead of 25
    (make-gsharp-composition events (gsharp::buffer segment) 0 duration
                             :tempi (list (make-standard-tempo-period (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment)))
                                                                      0 duration))
                             :key-signatures key-signatures
                             :time-signatures time-signatures)))

(defun filter-event-list-for-signatures (events key-signatures duration)
  "key-signatures here are initial `staff-level' signatures (what
  MusicXML calls attributes). MusicXML also has time sigs in the
  attributes, but GSharp converts them to normal elements."
  (let ((filtered-events) (time-signatures)
        (staves-data (mapcar #'(lambda (k)
                                 (list (gsharp::staff (gsh-source k)) k nil))
                             key-signatures)))
    (dolist (event events)
      (typecase event
        (gsharp-pitched-event (push event filtered-events))
        (gsharp-key-signature-period
         (if (assoc (gsharp::staff (gsh-source event)) staves-data)
             (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data)))
               (if (second data)
                   (setf (duration (second data)) (- (timepoint event) (timepoint (second data)))
                         (second data) event)
                   (setf (second data) event)))
             (acons (gsharp::staff (gsh-source event)) (list event nil) staves-data))
         (push event key-signatures))
        (gsharp-time-signature-period
         (if (assoc (gsharp::staff (gsh-source event)) staves-data)
             (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data)))
               (if (third data)
                   (setf (duration (third data)) (- (timepoint event) (timepoint (third data)))
                         (third data) event)
                   (setf (third data) event)))
             (acons (gsharp::staff (gsh-source event)) (list nil event) staves-data))
         (push event time-signatures))))
    (loop for item in staves-data
       when (second item)
       do (setf (duration (second item)) duration)
       when (third item)
       do (setf (duration (third item)) duration))
    (values (reverse filtered-events) (reverse key-signatures) (reverse time-signatures))))

(defun get-initial-keysigs (segment)
  (let ((staves (remove-duplicates
                 (loop for layer in (gsharp::layers segment)
                    nconc (gsharp::staves layer)))))
    (loop for staff in staves
       collect (make-gsharp-key-signature-period (gsharp::keysig staff) 0 nil))))

#|

(in-package :clim-user)

(define-command (com-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 (com-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-harmony: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)))


(in-package :gsharp-measure)

(define-stealth-mixin snote () note
  ((misspeltp :initform nil :accessor misspeltp)))

(in-package :gsharp-drawing)

;;; patch DRAW-NOTE
(defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos)
  (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note)))
    (cond
      ((gsharp-measure::misspeltp note)
       (with-output-as-presentation (pane note 'note)
         (score-pane:draw-notehead pane notehead x pos))
       (let ((ypos (score-pane:staff-step (- pos))))
         (draw-line* pane (- x 5) (+ ypos 3) (+ x 5) (+ ypos 3)
                     :line-thickness 3 :ink (make-rgb-color 0.8 0.1 0.1))))
      (t (score-pane:draw-notehead pane notehead x pos)))
    (when (final-accidental note)
      (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos))
    (draw-dots pane nb-dots x dot-xoffset dot-pos)))

(in-package :clim-user)

(defun ocp-list (composition)
  (flet ((sorter (x y)
           (or (amuse:time< x y)
               (and (amuse:time= x y)
                    (amuse:pitch< x y)))))
    (loop for e being each element of composition
          if (typep e 'amuse:pitched-event)
          collect (cons e (make-array 2 :initial-contents
                                      (list (slot-value e 'amuse::time)
                                            (- (slot-value e 'amuse::number) 21)))) into result
          finally (return (sort result #'sorter :key #'car)))))

(let ((accidental-conversions
       '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
         ("f" . :flat) ("ff" . :double-flat))))
  (defun annotate-misspellings (composition)
    (do* ((ocp-list (ocp-list composition))
          (note-sequence (ps13:ps13-new-imp (map 'list #'cdr ocp-list) 10 42 nil nil nil))
          (list ocp-list (cdr list))
          (spellings note-sequence (cdr spellings)))
         ((null list))
      (let* ((event (caar list))
              (note (amuse-gsharp:note event))
             (accidental (elt (second (car spellings)) 1))
             (converted (cdr (assoc accidental accidental-conversions :test #'string=))))
        (unless (eq (gsharp-buffer:accidentals note) converted)
          ;; this pun is not to be preserved once we get into real
          ;; code.
          (setf (gsharp-measure::misspeltp note) (second (car spellings))))))))

(define-command (com-spellcheck :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment)))
    (annotate-misspellings composition)
    #+nil
    (esa:display-message "~A" (first (ocp-list composition)))))

(let ((accidental-conversions
       '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
         ("f" . :flat) ("ff" . :double-flat))))
  (define-command (com-correct-misspelt-note :name t :command-table gsharp::global-gsharp-table)
      ((note 'gsharp::note))
    (let ((spelling (gsharp-measure::misspeltp note))
          (element (gsharp-buffer::cluster note))
          (staff (gsharp-buffer::staff note))
          (head (gsharp-buffer::head note))
          (dots (gsharp-buffer::dots note)))
      (let ((pitch (+ (mod (- (digit-char-p (char (elt spelling 0) 0) 17) 12) 7)
                      (* (parse-integer (elt spelling 2)) 7)))
            (accidentals (cdr (assoc (elt spelling 1) accidental-conversions :test #'string=))))
        (let ((new-note (gsharp-buffer::make-note pitch staff
                                                  :head head
                                                  :dots dots
                                                  :accidentals accidentals)))
          (gsharp-buffer::remove-note note)
          (gsharp-buffer::add-note element new-note))))))

(define-presentation-to-command-translator correct-misspelt-note-translator
    (gsharp::note com-correct-misspelt-note gsharp::global-gsharp-table
          :gesture :select
          :tester ((object) (gsharp-measure::misspeltp object)))
  (object)
  (list object))

|#
author	j.forth <j.forth@gold.ac.uk>
date	Thu, 24 Feb 2011 11:23:18 +0000
parents	22ac5ec1733c
children	bc893627f92d