|
csr21@59
|
1 (in-package "AMUSE-GSHARP")
|
|
csr21@59
|
2
|
|
d@197
|
3 (defun make-gsharp-composition (events buffer timepoint interval &key tempi key-signatures time-signatures)
|
|
d@197
|
4 (let ((comp (make-instance 'gsharp-composition :buffer buffer :time timepoint :interval interval
|
|
d@197
|
5 :tempi tempi :key-signatures key-signatures :time-signatures time-signatures)))
|
|
d@197
|
6 (sequence:adjust-sequence comp (length events) :initial-contents events)))
|
|
d@197
|
7
|
|
csr21@59
|
8 (defun last-bar-p (bar)
|
|
csr21@59
|
9 ;; I know most of this file is cut-and-pasted, but this is a
|
|
csr21@59
|
10 ;; particularly horrible example.
|
|
csr21@59
|
11 (eq bar (car (last (gsharp-buffer:bars (gsharp-buffer:slice bar))))))
|
|
csr21@59
|
12
|
|
csr21@59
|
13 (defun find-next-note (note)
|
|
csr21@59
|
14 (when (gsharp-buffer:tie-right note)
|
|
csr21@59
|
15 (let ((bar (gsharp-buffer:bar (gsharp-buffer:cluster note)))
|
|
csr21@59
|
16 (cluster (gsharp-buffer:cluster note))
|
|
csr21@59
|
17 (next-element nil))
|
|
csr21@59
|
18 (loop for (x y) on (gsharp-buffer:elements bar)
|
|
csr21@59
|
19 until (null y)
|
|
csr21@59
|
20 when (eq x cluster) do (setq next-element y))
|
|
csr21@59
|
21 (cond
|
|
csr21@59
|
22 (next-element)
|
|
csr21@59
|
23 ((last-bar-p bar) (return-from find-next-note nil))
|
|
csr21@59
|
24 (t (let ((next-bar (gsharp-buffer:barno (gsharp-buffer:slice bar)
|
|
csr21@59
|
25 (1+ (gsharp-numbering::number bar)))))
|
|
csr21@59
|
26 (if (gsharp-buffer:elements next-bar)
|
|
csr21@59
|
27 (setq next-element (car (gsharp-buffer:elements next-bar)))
|
|
csr21@59
|
28 (return-from find-next-note nil)))))
|
|
csr21@59
|
29 ;; now NEXT-ELEMENT is the next element!
|
|
csr21@59
|
30 (when (typep next-element 'gsharp-buffer:cluster)
|
|
csr21@59
|
31 (loop for n in (gsharp-buffer:notes next-element)
|
|
csr21@59
|
32 if (and (gsharp-buffer:tie-left n)
|
|
csr21@59
|
33 (= (gsharp-buffer:pitch n) (gsharp-buffer:pitch note))
|
|
csr21@59
|
34 (eq (gsharp-buffer:staff n) (gsharp-buffer:staff note))
|
|
csr21@59
|
35 (eq (gsharp-buffer:accidentals n) (gsharp-buffer:accidentals note)))
|
|
csr21@59
|
36 return n)))))
|
|
csr21@59
|
37
|
|
csr21@59
|
38 (defun compute-duration (note)
|
|
csr21@59
|
39 (loop for n = note then (find-next-note n)
|
|
csr21@59
|
40 while n
|
|
csr21@59
|
41 sum (gsharp-buffer:duration (gsharp-buffer:cluster n))))
|
|
csr21@59
|
42
|
|
c@61
|
43 (defun events-from-element (element index time)
|
|
d@197
|
44 (typecase element
|
|
d@197
|
45 (gsharp-buffer:cluster
|
|
d@197
|
46 (mapcar (lambda (note)
|
|
d@197
|
47 (make-instance 'gsharp-pitched-event
|
|
d@197
|
48 :note note
|
|
d@197
|
49 :slice-index index
|
|
d@197
|
50 :number (gsharp-play::midi-pitch note)
|
|
d@197
|
51 :time time
|
|
d@197
|
52 :interval (* 4 (compute-duration note))))
|
|
d@197
|
53 (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element))))
|
|
d@197
|
54 (gsharp-buffer:key-signature
|
|
d@197
|
55 (list (make-gsharp-key-signature-period element time nil)))
|
|
d@197
|
56 (gsharp-buffer::time-signature
|
|
d@197
|
57 (list (make-gsharp-time-signature-period element time nil)))))
|
|
csr21@59
|
58
|
|
c@61
|
59 (defun events-from-bar (bar index time)
|
|
csr21@59
|
60 (mapcan (lambda (element)
|
|
c@61
|
61 (prog1 (events-from-element element index time)
|
|
csr21@59
|
62 (incf time (* 4 (gsharp-buffer:duration element)))))
|
|
csr21@59
|
63 (gsharp-buffer:elements bar)))
|
|
csr21@59
|
64
|
|
c@61
|
65 (defun events-from-slice (slice index durations)
|
|
csr21@59
|
66 (let ((time 0))
|
|
csr21@59
|
67 (mapcan (lambda (bar duration)
|
|
c@61
|
68 (prog1 (events-from-bar bar index time)
|
|
csr21@59
|
69 (incf time (* 4 duration))))
|
|
csr21@59
|
70 (gsharp-buffer:bars slice) durations)))
|
|
csr21@59
|
71
|
|
csr21@59
|
72 (defun segment-composition (segment)
|
|
csr21@59
|
73 (let* ((slices (mapcar #'gsharp-buffer:body (gsharp-buffer::layers segment)))
|
|
d@197
|
74 (durations (gsharp-play::measure-durations slices))
|
|
csr21@59
|
75 (gsharp-play::*tuning* (gsharp-buffer:tuning segment))
|
|
d@197
|
76 (key-signatures (get-initial-keysigs segment))
|
|
d@197
|
77 (time-signatures)
|
|
d@197
|
78 (events (loop for slice in slices
|
|
d@197
|
79 for i from 0
|
|
d@197
|
80 for events = (events-from-slice slice i durations)
|
|
d@197
|
81 then (merge 'list events (events-from-slice slice i durations) 'time<)
|
|
d@197
|
82 finally (return events)))
|
|
d@197
|
83 (duration (* 4 (reduce #'+ durations))))
|
|
d@197
|
84 (multiple-value-setq (events key-signatures time-signatures)
|
|
d@197
|
85 (filter-event-list-for-signatures events key-signatures duration))
|
|
d@197
|
86
|
|
d@197
|
87 ;; FIXME: TEMPI here will break as soon as gsharp is made to have
|
|
d@197
|
88 ;; a sane divisions value in play.lisp instead of 25
|
|
d@197
|
89 (make-gsharp-composition events (gsharp::buffer segment) 0 duration
|
|
d@197
|
90 :tempi (list (make-standard-tempo-period (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment)))
|
|
d@197
|
91 0 duration))
|
|
d@197
|
92 :key-signatures key-signatures
|
|
d@197
|
93 :time-signatures time-signatures)))
|
|
d@197
|
94
|
|
d@197
|
95 (defun filter-event-list-for-signatures (events key-signatures duration)
|
|
d@197
|
96 "key-signatures here are initial `staff-level' signatures (what
|
|
d@197
|
97 MusicXML calls attributes). MusicXML also has time sigs in the
|
|
d@197
|
98 attributes, but GSharp converts them to normal elements."
|
|
d@197
|
99 (let ((filtered-events) (time-signatures)
|
|
d@197
|
100 (staves-data (mapcar #'(lambda (k)
|
|
d@197
|
101 (list (gsharp::staff (gsh-source k)) k nil))
|
|
d@197
|
102 key-signatures)))
|
|
d@197
|
103 (dolist (event events)
|
|
d@197
|
104 (typecase event
|
|
d@197
|
105 (gsharp-pitched-event (push event filtered-events))
|
|
d@197
|
106 (gsharp-key-signature-period
|
|
d@197
|
107 (if (assoc (gsharp::staff (gsh-source event)) staves-data)
|
|
d@197
|
108 (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data)))
|
|
d@197
|
109 (if (second data)
|
|
d@197
|
110 (setf (duration (second data)) (- (timepoint event) (timepoint (second data)))
|
|
d@197
|
111 (second data) event)
|
|
d@197
|
112 (setf (second data) event)))
|
|
d@197
|
113 (acons (gsharp::staff (gsh-source event)) (list event nil) staves-data))
|
|
d@197
|
114 (push event key-signatures))
|
|
d@197
|
115 (gsharp-time-signature-period
|
|
d@197
|
116 (if (assoc (gsharp::staff (gsh-source event)) staves-data)
|
|
d@197
|
117 (let ((data (assoc (gsharp::staff (gsh-source event)) staves-data)))
|
|
d@197
|
118 (if (third data)
|
|
d@197
|
119 (setf (duration (third data)) (- (timepoint event) (timepoint (third data)))
|
|
d@197
|
120 (third data) event)
|
|
d@197
|
121 (setf (third data) event)))
|
|
d@197
|
122 (acons (gsharp::staff (gsh-source event)) (list nil event) staves-data))
|
|
d@197
|
123 (push event time-signatures))))
|
|
d@197
|
124 (loop for item in staves-data
|
|
d@197
|
125 when (second item)
|
|
d@197
|
126 do (setf (duration (second item)) duration)
|
|
d@197
|
127 when (third item)
|
|
d@197
|
128 do (setf (duration (third item)) duration))
|
|
d@197
|
129 (values (reverse filtered-events) (reverse key-signatures) (reverse time-signatures))))
|
|
d@197
|
130
|
|
d@197
|
131 (defun get-initial-keysigs (segment)
|
|
d@197
|
132 (let ((staves (remove-duplicates
|
|
d@197
|
133 (loop for layer in (gsharp::layers segment)
|
|
d@197
|
134 nconc (gsharp::staves layer)))))
|
|
d@197
|
135 (loop for staff in staves
|
|
d@197
|
136 collect (make-gsharp-key-signature-period (gsharp::keysig staff) 0 nil))))
|
|
csr21@59
|
137
|
|
csr21@59
|
138 #|
|
|
csr21@59
|
139
|
|
csr21@59
|
140 (in-package :clim-user)
|
|
csr21@59
|
141
|
|
c@60
|
142 (define-command (com-amuse-play :name t :command-table gsharp::global-gsharp-table)
|
|
csr21@59
|
143 ()
|
|
csr21@59
|
144 (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
|
|
csr21@59
|
145 (composition (amuse-gsharp::segment-composition segment)))
|
|
csr21@59
|
146 (amuse-utils::play composition)))
|
|
csr21@59
|
147
|
|
c@60
|
148 (define-command (com-infer-key :name t :command-table gsharp::global-gsharp-table)
|
|
csr21@59
|
149 ()
|
|
csr21@59
|
150 (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
|
|
csr21@59
|
151 (composition (amuse-gsharp::segment-composition segment))
|
|
c@94
|
152 (result (amuse-harmony:krumhansl-key-finder composition composition))
|
|
csr21@59
|
153 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
|
|
csr21@59
|
154 (string (format nil "Key: ~A ~(~A~)" name (cadr result))))
|
|
c@91
|
155 (esa:display-message string)))
|
|
csr21@59
|
156
|
|
csr21@59
|
157
|
|
c@60
|
158 (in-package :gsharp-measure)
|
|
c@60
|
159
|
|
c@92
|
160 (define-stealth-mixin snote () note
|
|
c@60
|
161 ((misspeltp :initform nil :accessor misspeltp)))
|
|
c@60
|
162
|
|
c@60
|
163 (in-package :gsharp-drawing)
|
|
c@60
|
164
|
|
c@60
|
165 ;;; patch DRAW-NOTE
|
|
c@60
|
166 (defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos)
|
|
c@60
|
167 (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note)))
|
|
c@61
|
168 (cond
|
|
c@61
|
169 ((gsharp-measure::misspeltp note)
|
|
c@61
|
170 (with-output-as-presentation (pane note 'note)
|
|
c@61
|
171 (score-pane:draw-notehead pane notehead x pos))
|
|
c@61
|
172 (let ((ypos (score-pane:staff-step (- pos))))
|
|
c@61
|
173 (draw-line* pane (- x 5) (+ ypos 3) (+ x 5) (+ ypos 3)
|
|
c@61
|
174 :line-thickness 3 :ink (make-rgb-color 0.8 0.1 0.1))))
|
|
c@61
|
175 (t (score-pane:draw-notehead pane notehead x pos)))
|
|
c@60
|
176 (when (final-accidental note)
|
|
c@60
|
177 (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos))
|
|
c@60
|
178 (draw-dots pane nb-dots x dot-xoffset dot-pos)))
|
|
c@60
|
179
|
|
c@60
|
180 (in-package :clim-user)
|
|
c@60
|
181
|
|
c@60
|
182 (defun ocp-list (composition)
|
|
c@60
|
183 (flet ((sorter (x y)
|
|
c@60
|
184 (or (amuse:time< x y)
|
|
c@60
|
185 (and (amuse:time= x y)
|
|
c@60
|
186 (amuse:pitch< x y)))))
|
|
c@60
|
187 (loop for e being each element of composition
|
|
c@60
|
188 if (typep e 'amuse:pitched-event)
|
|
c@60
|
189 collect (cons e (make-array 2 :initial-contents
|
|
c@60
|
190 (list (slot-value e 'amuse::time)
|
|
c@60
|
191 (- (slot-value e 'amuse::number) 21)))) into result
|
|
c@60
|
192 finally (return (sort result #'sorter :key #'car)))))
|
|
c@60
|
193
|
|
c@60
|
194 (let ((accidental-conversions
|
|
c@60
|
195 '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
|
|
c@60
|
196 ("f" . :flat) ("ff" . :double-flat))))
|
|
c@60
|
197 (defun annotate-misspellings (composition)
|
|
c@60
|
198 (do* ((ocp-list (ocp-list composition))
|
|
c@93
|
199 (note-sequence (ps13:ps13-new-imp (map 'list #'cdr ocp-list) 10 42 nil nil nil))
|
|
c@60
|
200 (list ocp-list (cdr list))
|
|
c@60
|
201 (spellings note-sequence (cdr spellings)))
|
|
c@60
|
202 ((null list))
|
|
c@60
|
203 (let* ((event (caar list))
|
|
csr21@62
|
204 (note (amuse-gsharp:note event))
|
|
c@61
|
205 (accidental (elt (second (car spellings)) 1))
|
|
c@61
|
206 (converted (cdr (assoc accidental accidental-conversions :test #'string=))))
|
|
c@61
|
207 (unless (eq (gsharp-buffer:accidentals note) converted)
|
|
c@61
|
208 ;; this pun is not to be preserved once we get into real
|
|
c@61
|
209 ;; code.
|
|
c@61
|
210 (setf (gsharp-measure::misspeltp note) (second (car spellings))))))))
|
|
c@60
|
211
|
|
c@60
|
212 (define-command (com-spellcheck :name t :command-table gsharp::global-gsharp-table)
|
|
c@60
|
213 ()
|
|
c@60
|
214 (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
|
|
c@60
|
215 (composition (amuse-gsharp::segment-composition segment)))
|
|
c@60
|
216 (annotate-misspellings composition)
|
|
c@60
|
217 #+nil
|
|
c@60
|
218 (esa:display-message "~A" (first (ocp-list composition)))))
|
|
c@61
|
219
|
|
c@61
|
220 (let ((accidental-conversions
|
|
c@61
|
221 '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
|
|
c@61
|
222 ("f" . :flat) ("ff" . :double-flat))))
|
|
c@61
|
223 (define-command (com-correct-misspelt-note :name t :command-table gsharp::global-gsharp-table)
|
|
c@61
|
224 ((note 'gsharp::note))
|
|
c@61
|
225 (let ((spelling (gsharp-measure::misspeltp note))
|
|
c@61
|
226 (element (gsharp-buffer::cluster note))
|
|
c@61
|
227 (staff (gsharp-buffer::staff note))
|
|
c@61
|
228 (head (gsharp-buffer::head note))
|
|
c@61
|
229 (dots (gsharp-buffer::dots note)))
|
|
c@61
|
230 (let ((pitch (+ (mod (- (digit-char-p (char (elt spelling 0) 0) 17) 12) 7)
|
|
c@61
|
231 (* (parse-integer (elt spelling 2)) 7)))
|
|
c@61
|
232 (accidentals (cdr (assoc (elt spelling 1) accidental-conversions :test #'string=))))
|
|
c@61
|
233 (let ((new-note (gsharp-buffer::make-note pitch staff
|
|
c@61
|
234 :head head
|
|
c@61
|
235 :dots dots
|
|
c@61
|
236 :accidentals accidentals)))
|
|
c@61
|
237 (gsharp-buffer::remove-note note)
|
|
c@61
|
238 (gsharp-buffer::add-note element new-note))))))
|
|
c@61
|
239
|
|
c@61
|
240 (define-presentation-to-command-translator correct-misspelt-note-translator
|
|
c@61
|
241 (gsharp::note com-correct-misspelt-note gsharp::global-gsharp-table
|
|
c@61
|
242 :gesture :select
|
|
c@61
|
243 :tester ((object) (gsharp-measure::misspeltp object)))
|
|
c@61
|
244 (object)
|
|
c@61
|
245 (list object))
|
|
c@60
|
246
|
|
csr21@59
|
247 |# |
