csr21@59: (in-package "AMUSE-GSHARP") csr21@59: d@197: (defun make-gsharp-composition (events buffer timepoint interval &key tempi key-signatures time-signatures) d@197: (let ((comp (make-instance 'gsharp-composition :buffer buffer :time timepoint :interval interval d@197: :tempi tempi :key-signatures key-signatures :time-signatures time-signatures))) d@197: (sequence:adjust-sequence comp (length events) :initial-contents events))) d@197: csr21@59: (defun last-bar-p (bar) csr21@59: ;; I know most of this file is cut-and-pasted, but this is a csr21@59: ;; particularly horrible example. csr21@59: (eq bar (car (last (gsharp-buffer:bars (gsharp-buffer:slice bar)))))) csr21@59: csr21@59: (defun find-next-note (note) csr21@59: (when (gsharp-buffer:tie-right note) csr21@59: (let ((bar (gsharp-buffer:bar (gsharp-buffer:cluster note))) csr21@59: (cluster (gsharp-buffer:cluster note)) csr21@59: (next-element nil)) csr21@59: (loop for (x y) on (gsharp-buffer:elements bar) csr21@59: until (null y) csr21@59: when (eq x cluster) do (setq next-element y)) csr21@59: (cond csr21@59: (next-element) csr21@59: ((last-bar-p bar) (return-from find-next-note nil)) csr21@59: (t (let ((next-bar (gsharp-buffer:barno (gsharp-buffer:slice bar) csr21@59: (1+ (gsharp-numbering::number bar))))) csr21@59: (if (gsharp-buffer:elements next-bar) csr21@59: (setq next-element (car (gsharp-buffer:elements next-bar))) csr21@59: (return-from find-next-note nil))))) csr21@59: ;; now NEXT-ELEMENT is the next element! csr21@59: (when (typep next-element 'gsharp-buffer:cluster) csr21@59: (loop for n in (gsharp-buffer:notes next-element) csr21@59: if (and (gsharp-buffer:tie-left n) csr21@59: (= (gsharp-buffer:pitch n) (gsharp-buffer:pitch note)) csr21@59: (eq (gsharp-buffer:staff n) (gsharp-buffer:staff note)) csr21@59: (eq (gsharp-buffer:accidentals n) (gsharp-buffer:accidentals note))) csr21@59: return n))))) csr21@59: csr21@59: (defun compute-duration (note) csr21@59: (loop for n = note then (find-next-note n) csr21@59: while n csr21@59: sum (gsharp-buffer:duration (gsharp-buffer:cluster n)))) csr21@59: c@61: (defun events-from-element (element index time) d@197: (typecase element d@197: (gsharp-buffer:cluster d@197: (mapcar (lambda (note) d@197: (make-instance 'gsharp-pitched-event d@197: :note note d@197: :slice-index index d@197: :number (gsharp-play::midi-pitch note) d@197: :time time d@197: :interval (* 4 (compute-duration note)))) d@197: (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element)))) d@197: (gsharp-buffer:key-signature d@197: (list (make-gsharp-key-signature-period element time nil))) d@197: (gsharp-buffer::time-signature d@197: (list (make-gsharp-time-signature-period element time nil))))) csr21@59: c@61: (defun events-from-bar (bar index time) csr21@59: (mapcan (lambda (element) c@61: (prog1 (events-from-element element index time) csr21@59: (incf time (* 4 (gsharp-buffer:duration element))))) csr21@59: (gsharp-buffer:elements bar))) csr21@59: c@61: (defun events-from-slice (slice index durations) csr21@59: (let ((time 0)) csr21@59: (mapcan (lambda (bar duration) c@61: (prog1 (events-from-bar bar index time) csr21@59: (incf time (* 4 duration)))) csr21@59: (gsharp-buffer:bars slice) durations))) csr21@59: csr21@59: (defun segment-composition (segment) csr21@59: (let* ((slices (mapcar #'gsharp-buffer:body (gsharp-buffer::layers segment))) d@197: (durations (gsharp-play::measure-durations slices)) csr21@59: (gsharp-play::*tuning* (gsharp-buffer:tuning segment)) d@197: (key-signatures (get-initial-keysigs segment)) d@197: (time-signatures) d@197: (events (loop for slice in slices d@197: for i from 0 d@197: for events = (events-from-slice slice i durations) d@197: then (merge 'list events (events-from-slice slice i durations) 'time<) d@197: finally (return events))) d@197: (duration (* 4 (reduce #'+ durations)))) d@197: (multiple-value-setq (events key-signatures time-signatures) d@197: (filter-event-list-for-signatures events key-signatures duration)) d@197: d@197: ;; FIXME: TEMPI here will break as soon as gsharp is made to have d@197: ;; a sane divisions value in play.lisp instead of 25 d@197: (make-gsharp-composition events (gsharp::buffer segment) 0 duration d@197: :tempi (list (make-standard-tempo-period (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment))) d@197: 0 duration)) d@197: :key-signatures key-signatures d@197: :time-signatures time-signatures))) d@197: d@197: (defun filter-event-list-for-signatures (events key-signatures duration) d@197: "key-signatures here are initial `staff-level' signatures (what d@197: MusicXML calls attributes). MusicXML also has time sigs in the d@197: attributes, but GSharp converts them to normal elements." d@197: (let ((filtered-events) (time-signatures) d@197: (staves-data (mapcar #'(lambda (k) d@197: (list (gsharp::staff (gsh-source k)) k nil)) d@197: key-signatures))) d@197: (dolist (event events) d@197: (typecase event d@197: (gsharp-pitched-event (push event filtered-events)) d@197: (gsharp-key-signature-period d@197: (if (assoc (gsharp::staff (gsh-source event)) staves-data) d@197: (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data))) d@197: (if (second data) d@197: (setf (duration (second data)) (- (timepoint event) (timepoint (second data))) d@197: (second data) event) d@197: (setf (second data) event))) d@197: (acons (gsharp::staff (gsh-source event)) (list event nil) staves-data)) d@197: (push event key-signatures)) d@197: (gsharp-time-signature-period d@197: (if (assoc (gsharp::staff (gsh-source event)) staves-data) d@197: (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data))) d@197: (if (third data) d@197: (setf (duration (third data)) (- (timepoint event) (timepoint (third data))) d@197: (third data) event) d@197: (setf (third data) event))) d@197: (acons (gsharp::staff (gsh-source event)) (list nil event) staves-data)) d@197: (push event time-signatures)))) d@197: (loop for item in staves-data d@197: when (second item) d@197: do (setf (duration (second item)) duration) d@197: when (third item) d@197: do (setf (duration (third item)) duration)) d@197: (values (reverse filtered-events) (reverse key-signatures) (reverse time-signatures)))) d@197: d@197: (defun get-initial-keysigs (segment) d@197: (let ((staves (remove-duplicates d@197: (loop for layer in (gsharp::layers segment) d@197: nconc (gsharp::staves layer))))) d@197: (loop for staff in staves d@197: collect (make-gsharp-key-signature-period (gsharp::keysig staff) 0 nil)))) csr21@59: csr21@59: #| csr21@59: csr21@59: (in-package :clim-user) csr21@59: c@60: (define-command (com-amuse-play :name t :command-table gsharp::global-gsharp-table) csr21@59: () csr21@59: (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor))) csr21@59: (composition (amuse-gsharp::segment-composition segment))) csr21@59: (amuse-utils::play composition))) csr21@59: c@60: (define-command (com-infer-key :name t :command-table gsharp::global-gsharp-table) csr21@59: () csr21@59: (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor))) csr21@59: (composition (amuse-gsharp::segment-composition segment)) c@94: (result (amuse-harmony:krumhansl-key-finder composition composition)) csr21@59: (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result))) csr21@59: (string (format nil "Key: ~A ~(~A~)" name (cadr result)))) c@91: (esa:display-message string))) csr21@59: csr21@59: c@60: (in-package :gsharp-measure) c@60: c@92: (define-stealth-mixin snote () note c@60: ((misspeltp :initform nil :accessor misspeltp))) c@60: c@60: (in-package :gsharp-drawing) c@60: c@60: ;;; patch DRAW-NOTE c@60: (defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos) c@60: (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note))) c@61: (cond c@61: ((gsharp-measure::misspeltp note) c@61: (with-output-as-presentation (pane note 'note) c@61: (score-pane:draw-notehead pane notehead x pos)) c@61: (let ((ypos (score-pane:staff-step (- pos)))) c@61: (draw-line* pane (- x 5) (+ ypos 3) (+ x 5) (+ ypos 3) c@61: :line-thickness 3 :ink (make-rgb-color 0.8 0.1 0.1)))) c@61: (t (score-pane:draw-notehead pane notehead x pos))) c@60: (when (final-accidental note) c@60: (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos)) c@60: (draw-dots pane nb-dots x dot-xoffset dot-pos))) c@60: c@60: (in-package :clim-user) c@60: c@60: (defun ocp-list (composition) c@60: (flet ((sorter (x y) c@60: (or (amuse:time< x y) c@60: (and (amuse:time= x y) c@60: (amuse:pitch< x y))))) c@60: (loop for e being each element of composition c@60: if (typep e 'amuse:pitched-event) c@60: collect (cons e (make-array 2 :initial-contents c@60: (list (slot-value e 'amuse::time) c@60: (- (slot-value e 'amuse::number) 21)))) into result c@60: finally (return (sort result #'sorter :key #'car))))) c@60: c@60: (let ((accidental-conversions c@60: '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural) c@60: ("f" . :flat) ("ff" . :double-flat)))) c@60: (defun annotate-misspellings (composition) c@60: (do* ((ocp-list (ocp-list composition)) c@93: (note-sequence (ps13:ps13-new-imp (map 'list #'cdr ocp-list) 10 42 nil nil nil)) c@60: (list ocp-list (cdr list)) c@60: (spellings note-sequence (cdr spellings))) c@60: ((null list)) c@60: (let* ((event (caar list)) csr21@62: (note (amuse-gsharp:note event)) c@61: (accidental (elt (second (car spellings)) 1)) c@61: (converted (cdr (assoc accidental accidental-conversions :test #'string=)))) c@61: (unless (eq (gsharp-buffer:accidentals note) converted) c@61: ;; this pun is not to be preserved once we get into real c@61: ;; code. c@61: (setf (gsharp-measure::misspeltp note) (second (car spellings)))))))) c@60: c@60: (define-command (com-spellcheck :name t :command-table gsharp::global-gsharp-table) c@60: () c@60: (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor))) c@60: (composition (amuse-gsharp::segment-composition segment))) c@60: (annotate-misspellings composition) c@60: #+nil c@60: (esa:display-message "~A" (first (ocp-list composition))))) c@61: c@61: (let ((accidental-conversions c@61: '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural) c@61: ("f" . :flat) ("ff" . :double-flat)))) c@61: (define-command (com-correct-misspelt-note :name t :command-table gsharp::global-gsharp-table) c@61: ((note 'gsharp::note)) c@61: (let ((spelling (gsharp-measure::misspeltp note)) c@61: (element (gsharp-buffer::cluster note)) c@61: (staff (gsharp-buffer::staff note)) c@61: (head (gsharp-buffer::head note)) c@61: (dots (gsharp-buffer::dots note))) c@61: (let ((pitch (+ (mod (- (digit-char-p (char (elt spelling 0) 0) 17) 12) 7) c@61: (* (parse-integer (elt spelling 2)) 7))) c@61: (accidentals (cdr (assoc (elt spelling 1) accidental-conversions :test #'string=)))) c@61: (let ((new-note (gsharp-buffer::make-note pitch staff c@61: :head head c@61: :dots dots c@61: :accidentals accidentals))) c@61: (gsharp-buffer::remove-note note) c@61: (gsharp-buffer::add-note element new-note)))))) c@61: c@61: (define-presentation-to-command-translator correct-misspelt-note-translator c@61: (gsharp::note com-correct-misspelt-note gsharp::global-gsharp-table c@61: :gesture :select c@61: :tester ((object) (gsharp-measure::misspeltp object))) c@61: (object) c@61: (list object)) c@60: csr21@59: |#