248 | TOT is a collection of definitions that extend the algorithmic composition system Opusmodus. 249 |
250 | 251 |255 | TOT tutorial 256 |
257 |265 | Reference documentation with many usage examples 266 |
267 |Created: 2021-04-05 Mon 15:19
273 | 274 || 48 | Function summary | 49 ||
|---|---|
| 52 | 53 | export-melody-to-pwgl 54 | | 55 |56 | omn-mel &key (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-raw1.lisp") (harmonies '((60 64 67))) (harm-rhythm '(2)) (scales '((60 62 64 65 67 69 71))) (scale-rhythm '(2)) (meter '((4 4))) (bar-range nil) | 57 |
| 60 | 61 | import-transformed-melody-from-pwgl 62 | | 63 |64 | omn-mel &key (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-transformed1.lisp") (bar-range nil) | 65 |
| 68 | 69 | import-underlying-harmony-from-pwgl 70 | | 71 |72 | &key (velocity '(ppppp)) (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-transformed1.lisp") | 73 |
| 76 | 77 | pwgl-time-signatures 78 | | 79 |80 | ts-forms | 81 |
| 96 | export-melody-to-pwgl | 97 |98 | omn-mel &key (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-raw1.lisp") (harmonies '((60 64 67))) (harm-rhythm '(2)) (scales '((60 62 64 65 67 69 71))) (scale-rhythm '(2)) (meter '((4 4))) (bar-range nil) | 99 |100 | [Function] | 101 |
107 | Export a melody `omn-mel' alongside harmonic information for further processing by a PWGL patch. 108 | For documentation of further arguments see PWGL patch FitInHarmony. 109 |
110 |111 |
112 |117 | bar-range (default nil): if non-nil, must be pair (<start-bar-index> <end-bar-index>), that specifies a range of bars from `omn-mel' to export. `omn-mel' must be nested in that case. Indices are 0-based, and start-bar-index/end-bar-index specify the index of the first/last bar to include. 118 |
119 || 136 | import-transformed-melody-from-pwgl | 137 |138 | omn-mel &key (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-transformed1.lisp") (bar-range nil) | 139 |140 | [Function] | 141 |
147 | Complements export-melody-to-PWGL to import result from PWGL patch. `omn-mel' should be the same as given to export-melody-to-PWGL (its articulations and dynamics are merged into the result). 148 |
149 |150 |
151 |156 | bar-range: should be the same value as the `bar-range' of the corresponding call to `export-melody-to-PWGL'. 157 |
158 || 175 | import-underlying-harmony-from-pwgl | 176 |177 | &key (velocity '(ppppp)) (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/") (file "melody-transformed1.lisp") | 178 |179 | [Function] | 180 |
186 | Complements import-transformed-melody-from-PWGL to import harmonic result from PWGL patch. `harm-durations' is the 187 |
188 || 203 | pwgl-time-signatures | 204 |205 | ts-forms | 206 |207 | [Function] | 208 |
214 | Translates OMN format of time signatures into very similar but slighly simpler PWGL format. 215 |
216 |217 |
218 |221 | (PWGL-time-signatures '((3 4 2) (2 4 1))) 222 | => ((3 4) (3 4) (2 4))223 |
| 46 | Method summary | 47 ||
|---|---|
| 50 | 51 | ji-pc-ratio 52 | | 53 |54 | (x rational) | 55 |
| 60 | Function summary | 61 ||
|---|---|
| 64 | 65 | aux-def-tempered-score-instruments 66 | | 67 |68 | temperament score-parts | 69 |
| 72 | 73 | aux-def-tempered-score-let-decls 74 | | 75 |76 | score-parts | 77 |
| 80 | 81 | aux-def-tempered-score-mpe-parts-var-name 82 | | 83 |84 | instr | 85 |
| 88 | 89 | chord-sequences-to-parts 90 | | 91 |92 | sequence n | 93 |
| 98 | Macro summary | 99 ||
|---|---|
| 102 | 103 | def-tempered-score 104 | | 105 |106 | name global-args &rest instruments | 107 |
| 110 | 111 | deftemperament 112 | | 113 |114 | name vals generators &optional docstring | 115 |
| 130 | ji-pc-ratio | 131 |132 | (x rational) | 133 |134 | [Method] | 135 |
141 | Transforms the frequency ratio `x' into the interval [1, 2) to represent a corresponding pitch class expressed as a fraction. 142 |
143 || 158 | chord-sequences-to-parts | 159 |160 | sequence n | 161 |162 | [Function] | 163 |
169 | Return `n' monophonic sequences that distribute chords tones in `sequence' across the returned sequences. 170 |
171 || 186 | aux-def-tempered-score-mpe-parts-var-name | 187 |188 | instr | 189 |190 | [Function] | 191 |
197 | Return a variable name (symbol) for the quasi MPE parts for the given instr (symbol). 198 |
199 || 214 | aux-def-tempered-score-instruments | 215 |216 | temperament score-parts | 217 |218 | [Function] | 219 |
225 | [Called at compile time by macro] Generate the instruments body for def-score generated by def-tempered-score, where the instruments are split into multiple instruments on different MIDI channels for quasi MPE playback. 226 |
227 || 242 | aux-def-tempered-score-let-decls | 243 |244 | score-parts | 245 |246 | [Function] | 247 |
253 | [Called at compile time by macro] Generate the variable declarations around the def-score generated by def-tempered-score, which split the instrument parts into multiple parts for the different MIDI channels. The let is needed for efficiency (value reuse). 254 |
255 || 270 | deftemperament | 271 |272 | name vals generators &optional docstring | 273 |274 | [Macro] | 275 |
281 | Define a temperament with the given `vals' and `generators' bound to the `name'. This results in a method of the given name expecting a ratio and returning the temperament pitch in cents. The `vals' and `generators' can also later be accessed with `get-temperament-vals' and `get-temperament-generators'. 282 |
283 |284 | Note that `vals' and `generators' are evaluated (so they can be an expression resulting in the actual values), while the name is not. 285 |
286 |287 |
288 |291 |
292 || 307 | def-tempered-score | 308 |309 | name global-args &rest instruments | 310 |311 | [Macro] | 312 |
318 | The same as the Opusmodus builtin `def-score', but with the added arg `temperament'. 319 |
320 |321 |
322 |325 | TODO: Allow somehow for temperament to change over time (like arguments such as tempo etc.). 326 |
327 |330 | temperament (symbol): a temperament defined with deftemperament. 331 |
332 |335 | The other arguments are documented for the builtin `def-score'. 336 |
337 || 46 | Function summary | 47 ||
|---|---|
| 50 | 51 | corresponding-rest 52 | | 53 |54 | event | 55 |
| 58 | 59 | filter-notes-if 60 | | 61 |62 | test omn &key (remain t) (section nil) | 63 |
| 66 | 67 | insert-articulation 68 | | 69 |70 | flat-omn-list &rest articulations | 71 |
| 74 | 75 | remove-unless-parameters 76 | | 77 |78 | flat-omn-list parameter &key (remove-non-matching? nil) | 79 |
| 82 | 83 | separate-parts 84 | | 85 |86 | sequence articulation-sets | 87 |
| 90 | 91 | _push-event-and-rests 92 | | 93 |94 | event matching-position result-omns articulation-sets-length | 95 |
| 110 | filter-notes-if | 111 |112 | test omn &key (remain t) (section nil) | 113 |114 | [Function] | 115 |
121 | Extracts events in OMN for which a given test function returns true (or keeps only events for which the test function returns nils). All other notes are turned into rests. 122 |
123 |124 |
125 |130 | test: Boolean function expecting individual parameters of each note in `OMN' 131 |
132 |135 | OMN: An OMN sequence 136 |
137 |140 | remain: Boolean expressing whether only matching notes (T) or non-matching notes (nil) should be kept. 141 |
142 |145 | section: an integer or list of integers. Selected list or lists to process. The default is NIL. 146 |
147 |150 | See also Opusmodus builtin `filter-events'. 151 |
152 |153 |
154 |157 | Keep only notes above middle C and turn other notes into rests 158 |
159 |160 |
161 |162 | (filter-notes-if #'(lambda (dur pitch &rest other-args) 163 | (> (pitch-to-midi pitch) 60)) 164 | '(e c4 mp -e fermata e. d4 -h e. c4 e e4))165 |
166 | Do the opposite with 167 | :remain 168 | nil. 169 |
170 |171 |
172 |173 | (filter-notes-if #'(lambda (dur pitch &rest other-args) 174 | (> (pitch-to-midi pitch) 60)) 175 | '(e c4 mp -e fermata e. d4 -h e. c4 e e4) 176 | :remain nil)177 |
178 | This also works with nested lists and you can process only selected bars (other bars are kept unchanged). 179 |
180 |181 |
182 |183 | (filter-notes-if #'(lambda (dur pitch &rest other-args) 184 | (> (pitch-to-midi pitch) 60)) 185 | '((e c4 mp -e fermata e. d4 -s) (-q.. e. c4 e e4)) 186 | :section 1)187 |
188 | For musical application examples see also {https://opusmodus.com/forums/topic/867-opusmodus-1222292/}. 189 |
190 |191 |
192 |195 | This function could also be useful for Beethoven like motif condensation, where notes are first turned into rests with this function, and then their preceding notes are extended with length-legato, as demonstrated in the following example. 196 |
197 |198 |
199 |200 | (setf my-motif '((q. c4 e d4 q. e4 e f4) (h g4 -h))) 201 | (length-legato 202 | (filter-notes-if #'(lambda (dur pitch &rest other-args) 203 | (> (omn-encode dur) 1/4)) 204 | my-motif)) 205 | => ((h c4 e4) (w g4))206 |
207 |
208 |211 | https://opusmodus.com/forums/topic/910-merge-rests-with-preceeding-note/?tab=comments#comment-2713 212 |
213 |214 |
215 || 230 | corresponding-rest | 231 |232 | event | 233 |234 | [Function] | 235 |
241 | Turns a single OMN note into a rest of the same note value. Rests remain rests, and rest articulations are preserved. 242 |
243 |244 |
245 |248 | (corresponding-rest '(h c4))249 |
| 264 | _push-event-and-rests | 265 |266 | event matching-position result-omns articulation-sets-length | 267 |268 | [Function] | 269 |
| 287 | separate-parts | 288 |289 | sequence articulation-sets | 290 |291 | [Function] | 292 |
298 | The function `separate-parts' is useful for customising your sound playback with multiple sound libraries or for algorithmic orchestration. 299 | The function breaks an OMN sequence (a single part) into a list of multiple OMN sequences (multiple parts). It basically sorts notes from the OMN sequence into different parts, depending on the articulations of individual notes. All notes with certain articulations go in one resulting parts, and notes with other articulations in another part. In all other resulting parts, notes are substituted by rests, so that timing relations of notes in different parts are preserved. 300 | This function can be useful, when you have multiple sound libraries that support different articulations of the same instrument. You can then perform notes with certain articulations on one software instrument (on its own MIDI channel etc.), and notes with other articulations on another instrument. 301 | Alternatively, you can use the function for algorithmic orchestration, where you assign custom articulations (typically declared with add-text-attributes first) such as instrument labels with your custom algorithm, and then use this function in a second step to separate your instruments. 302 |
303 |304 | Remember that the result of this function is a list of multiple OMN sequences (multiple parts). You have to split it into its individual parts for use in OMN. 305 |
306 |307 | See also {https://opusmodus.com/forums/topic/849-towards-algorithmic-orchestration-and-customising-sound-playback-with-multiple-sound-libraries/} 308 |
309 |310 |
311 |316 | sequence: OMN sequence, can be nested 317 |
318 |321 | articulation-sets: list of list of articulations. All notes with articulations contained in the first articulation-set end up in the first resulting part, notes with articulations in the second set end up in the second part and so forth. 322 | 323 | The decision which part a note belongs to is always made based on the first articulation that matches an articulation-set. If a note contains no articulation, or an articulation contained in no set, then it is matched to the first articulation-set. If an articulation is contained in multiple articulation-sets, then the earlier match in articulation-sets is used. 324 |
325 |328 |
329 |332 |
333 |334 | (separate-parts '(h c4 pizz q arco) 335 | '((pizz) 336 | (arco))) 337 | => ((h c4 mf pizz -q) ; part 1 with pizz articulations 338 | (-h q c4 mf arco)) ; part 2 with arco339 |
340 |
341 |342 | (separate-parts '((h c4 pizz q arco) (h trem q h pizz) (h arco+stacc -q fermata)) 343 | '((pizz arco) 344 | (trem))) 345 | => (((h c4 mf pizz q arco) (-h q c4 mf h pizz) (h c4 mf arco+stacc -q fermata)) ; part 1: pizz and arco 346 | ((-h -q) (h c4 mf trem -q -h) (-h -q fermata))) ; part 2: trem347 |
348 | Full score example: 349 |
350 |351 |
352 |353 | (setf omn-expr '((h c4 pizz q arco) (h trem q h pizz) (h arco+stacc -q fermata))) 354 | (setf parts (separate-parts omn-expr 355 | '((pizz arco) 356 | (trem)))) 357 | (def-score two-violins 358 | (:title "Title" 359 | :composer "Composer" 360 | :copyright "Copyright © " 361 | :key-signature 'chromatic 362 | :time-signature '((1 1 1 1) 4) 363 | :tempo 100 364 | :layout (bracket-group 365 | (violin1-layout 'violin1) 366 | (violin2-layout 'violin2))) 367 | 368 | (violin1 369 | :omn (nth 0 parts) 370 | :channel 1 371 | :sound 'gm 372 | :program 'violin 373 | :volume 100 374 | :pan 54 375 | :controllers (91 '(48)) 376 | ) 377 | 378 | (violin2 379 | :omn (nth 1 parts) 380 | :channel 2 381 | :sound 'gm 382 | :program 'violin 383 | :volume 100 384 | :pan 74 385 | :controllers (91 '(60)) 386 | ) 387 | )388 |
| 403 | insert-articulation | 404 |405 | flat-omn-list &rest articulations | 406 |407 | [Function] | 408 |
414 | Merge in one or more lists of articulations to an OMN expression. 415 |
416 |417 |
418 |421 | added nil for the rest 422 |
423 |424 | (insert-articulation '(e c4 mp arco e. d4 -h e. p pizz e e4 arco) 425 | '(ponte tasto nil ponte tasto)) 426 | => (e c4 mp arco+ponte e. d4 mp tasto -h e. d4 p pizz+ponte e e4 p arco+tasto)427 |
428 | BUG: does not skip rests. Wait for omn-replace supports composite articulations to fix 429 |
430 || 445 | remove-unless-parameters | 446 |447 | flat-omn-list parameter &key (remove-non-matching? nil) | 448 |449 | [Function] | 450 |
456 | Checks every note whether it contains `parameter'. All notes containing the parameter are preserved, all other notes are turned into rests. If a note contains a combination of articulations, all of them are checked. 457 |
458 |459 |
460 |465 | flat-omn-list: flat OMN list 466 |
467 |470 | parameter: a length, pitch, OMN velocity or single articulation 471 |
472 |475 | remove-rests? (default nil): if true, all notes that do not match are removed instead of turned into rests. 476 |
477 |480 |
481 |484 | (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto) 485 | 'e.) 486 | => (-1/8 e. d4 mp tasto -1/2 e. c4 p pizz+ponte -1/8)487 |
488 |
489 |490 | (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto) 491 | 'arco) 492 | => (e c4 mp arco+ponte -3/16 -1/2 -3/16 e e4 p arco+tasto)493 |
494 | 495 |
496 |497 | (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto) 498 | 'arco 499 | :remove-non-matching? T) 500 | => (e c4 mp arco+ponte e e4 p arco+tasto)501 |
502 | 503 |
504 || 46 | Function summary | 47 ||
|---|---|
| 50 | 51 | fibonacci 52 | | 53 |54 | max-sum | 55 |
| 58 | 59 | fibonacci-transition 60 | | 61 |62 | num-items &optional (item1 0) (item2 1) | 63 |
| 66 | 67 | _fibonacci-start-at-2 68 | | 69 |70 | max-sum | 71 |
| 74 | 75 | _fibonacci-transition-aux1 76 | | 77 |78 | num-items &optional (item1 0) (item2 1) | 79 |
| 82 | 83 | _fibonacci-transition-aux2 84 | | 85 |86 | list item1 item2 | 87 |
| 102 | SLIPPERY-CHICKEN | 103 |104 | | 105 |106 | [Package] | 107 |
113 | This package contains selected definitions from the composition system Slippery Chicken by Michael Edwards. 114 |
115 || 130 | fibonacci | 131 |132 | max-sum | 133 |134 | [Function] | 135 |
141 | Return the fibonacci numbers in a list ending at 0 that add up to a maximum less than <max-sum>. Returns the fibonacci number < max-sum as a second value. 142 |
143 || 158 | _fibonacci-start-at-2 | 159 |160 | max-sum | 161 |162 | [Function] | 163 |
169 | Aux def 170 |
171 || 186 | _fibonacci-transition-aux2 | 187 |188 | list item1 item2 | 189 |190 | [Function] | 191 |
197 | Aux def 198 |
199 || 214 | _fibonacci-transition-aux1 | 215 |216 | num-items &optional (item1 0) (item2 1) | 217 |218 | [Function] | 219 |
225 | Aux def 226 |
227 || 242 | fibonacci-transition | 243 |244 | num-items &optional (item1 0) (item2 1) | 245 |246 | [Function] | 247 |
253 | Generates a list containing only instances of item1 and and item2, where initially item1 dominates, but then item1 gradually decreases and item2 increases, until item2 completely dominates. The transition follows Fibonacci numbers. 254 |
255 |256 |
257 |260 | (fibonacci-transition 35 0 1) 261 | => (0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1 0 1 0 1 1 0 1 0 1 1 0 1 1 1 1 1)262 |
263 | Function defined by Michael Edwards for his algorithmic composition system Slippery Chicken, see 264 |
265 |268 | Edwards, M. (2011) Algorithmic composition: computational thinking in music. Communications of the ACM. 54 (7), 58-67. 269 |
270 |273 | Edwards, M. (2012) An Introduction to Slippery Chicken, ICMC 2012. 274 |
275 |278 | Slippery Chicken also defines a variant of this function for more than two items. 279 |
280 || 48 | Function summary | 49 ||
|---|---|
| 52 | 53 | circle-repeat 54 | | 55 |56 | pattern n | 57 |
| 60 | 61 | insert-at-position 62 | | 63 |64 | position item list &key seed | 65 |
| 68 | 69 | keyword-to-om-symbol 70 | | 71 |72 | key | 73 |
| 76 | 77 | mapcar-nested 78 | | 79 |80 | fn &rest nested-lists | 81 |
| 84 | 85 | matrix-transpose* 86 | | 87 |88 | &rest lists | 89 |
| 104 | mapcar-nested | 105 |106 | fn &rest nested-lists | 107 |108 | [Function] | 109 |
115 | A simplified equivalent of mapcar, but expects nested lists (as common for OMN parameter lists). All lists in nested-lists must be nested equally. 116 |
117 |118 |
119 |122 | 123 |
124 |125 | (mapcar-nested #'(lambda (x) (* x 2)) '((1/4 1/8 1/8) (1/2))) 126 | => ((1/2 1/4 1/4) (1))127 |
128 | Using the built-in Opusmodus function `span' to ensure an equal nesting of value lists 129 |
130 |131 | (let* ((ls '((1/4 1/8 1/8) (1/2))) 132 | (factors (span ls '(2 3)))) 133 | (mapcar-nested #'* ls factors)) 134 | => ((1/2 3/8 1/4) (3/2))135 |
136 | 137 |
138 || 153 | matrix-transpose* | 154 |155 | &rest lists | 156 |157 | [Function] | 158 |
164 | Variant of matrix-transpose that is more allowing in terms of its input. The function performs a matrix transformation, but input lists can be of different length (shorter lists are then circled through) or even mere elements (internally turned into a list by repeating the element). 165 |
166 |167 |
168 |173 | lists: individual elements or lists 174 |
175 |180 | (matrix-transpose* '(0 1 2 3) 5) 181 | => ((0 5) (1 5) (2 5) (3 5)) 182 |
183 |184 | (matrix-transpose* '(0 1 2 3) '(a b) '_) 185 | => ((0 a _) (1 b _) (2 a _) (3 b _)) 186 |
187 |188 |
189 || 204 | circle-repeat | 205 |206 | pattern n | 207 |208 | [Function] | 209 |
215 | Circle through elements in pattern (a list) until n elements are collected. 216 |
217 |218 | NOTE: only supports flat list so far. 219 |
220 |221 |
222 |227 | pattern: a list or single value treated as a one-value list 228 |
229 |232 | n: an integer 233 |
234 |239 |
240 |241 | (circle-repeat '(bb4 g4) 10) 242 | => (bb4 g4 bb4 g4 bb4 g4 bb4 g4 bb4 g4)243 |
244 | The function span can do something very similar. 245 |
246 |247 |
248 |249 | (span (gen-repeat 10 'x) '(bb4 g4))250 |
251 | See also Opusmodus buildin gen-trim, which does the same, but is overall more flexible. 252 |
253 || 268 | insert-at-position | 269 |270 | position item list &key seed | 271 |272 | [Function] | 273 |
279 | Insert item(s) at given position into list. 280 |
281 |282 |
283 |288 | position: either symbol 's (start), 'e (end) or '? (random position), or integer specifying position. 289 |
290 |293 | item: value or list of values to be inserted. 294 |
295 |298 | list: flat list of values. 299 |
300 |305 | (insert-at-position 'e 'x '(a a a a)) 306 | (insert-at-position 's 'x '(a a a a)) 307 | (insert-at-position '? 'x '(a a a a)) 308 | (insert-at-position 'e '(x y) '(a a a a)) 309 | (insert-at-position '0 '(x y) '(a a a a))310 |
| 325 | keyword-to-om-symbol | 326 |327 | key | 328 |329 | [Function] | 330 |
336 | Translates the keyword `key' into a symbol of the Opusmodus package 337 |
338 | blocks from the Leuven theme */
2 | /*
3 | Sources:
4 | https://emacs.stackexchange.com/questions/7629/the-syntax-highlight-and-indentation-of-source-code-block-in-exported-html-file
5 | https://raw.githubusercontent.com/kaushalmodi/.emacs.d/master/misc/css/leuven_theme.css
6 | */
7 | pre {background-color:#FFFFFF;}
8 | pre span.org-builtin {color:#006FE0;font-weight:bold;}
9 | pre span.org-string {color:#008000;}
10 | pre span.org-doc {color:#008000;}
11 | pre span.org-keyword {color:#0000FF;}
12 | pre span.org-variable-name {color:#BA36A5;}
13 | pre span.org-function-name {color:#006699;}
14 | pre span.org-type {color:#6434A3;}
15 | pre span.org-preprocessor {color:#808080;font-weight:bold;}
16 | pre span.org-constant {color:#D0372D;}
17 | pre span.org-comment-delimiter {color:#8D8D84;}
18 | pre span.org-comment {color:#8D8D84;font-style:italic}
19 | pre span.org-outshine-level-1 {color:#8D8D84;font-style:italic}
20 | pre span.org-outshine-level-2 {color:#8D8D84;font-style:italic}
21 | pre span.org-outshine-level-3 {color:#8D8D84;font-style:italic}
22 | pre span.org-outshine-level-4 {color:#8D8D84;font-style:italic}
23 | pre span.org-outshine-level-5 {color:#8D8D84;font-style:italic}
24 | pre span.org-outshine-level-6 {color:#8D8D84;font-style:italic}
25 | pre span.org-outshine-level-7 {color:#8D8D84;font-style:italic}
26 | pre span.org-outshine-level-8 {color:#8D8D84;font-style:italic}
27 | pre span.org-outshine-level-9 {color:#8D8D84;font-style:italic}
28 | pre span.org-rainbow-delimiters-depth-1 {color:#707183;}
29 | pre span.org-rainbow-delimiters-depth-2 {color:#7388d6;}
30 | pre span.org-rainbow-delimiters-depth-3 {color:#909183;}
31 | pre span.org-rainbow-delimiters-depth-4 {color:#709870;}
32 | pre span.org-rainbow-delimiters-depth-5 {color:#907373;}
33 | pre span.org-rainbow-delimiters-depth-6 {color:#6276ba;}
34 | pre span.org-rainbow-delimiters-depth-7 {color:#858580;}
35 | pre span.org-rainbow-delimiters-depth-8 {color:#80a880;}
36 | pre span.org-rainbow-delimiters-depth-9 {color:#887070;}
37 | pre span.org-sh-quoted-exec {color:#FF1493;}
38 | pre span.org-diff-added {color:#008000;}
39 | pre span.org-diff-changed {color:#0000FF;}
40 | pre span.org-diff-header {color:#800000;}
41 | pre span.org-diff-hunk-header {color:#990099;}
42 | pre span.org-diff-none {color:#545454;}
43 | pre span.org-diff-removed {color:#A60000;}
44 |
--------------------------------------------------------------------------------
/docs/tutorial/tutorial.odt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tanders/tot/fa2472bcef816e7f36866dd04b1529acf67ea646/docs/tutorial/tutorial.odt
--------------------------------------------------------------------------------
/docs/tutorial/tutorial.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tanders/tot/fa2472bcef816e7f36866dd04b1529acf67ea646/docs/tutorial/tutorial.pdf
--------------------------------------------------------------------------------
/docs/tutorial/tutorial.tex:
--------------------------------------------------------------------------------
1 | % Created 2021-04-06 Tue 10:00
2 | % Intended LaTeX compiler: pdflatex
3 | \documentclass[11pt]{article}
4 | \usepackage[utf8]{inputenc}
5 | \usepackage[T1]{fontenc}
6 | \usepackage{graphicx}
7 | \usepackage{grffile}
8 | \usepackage{longtable}
9 | \usepackage{wrapfig}
10 | \usepackage{rotating}
11 | \usepackage[normalem]{ulem}
12 | \usepackage{amsmath}
13 | \usepackage{textcomp}
14 | \usepackage{amssymb}
15 | \usepackage{capt-of}
16 | \usepackage{hyperref}
17 | \usepackage{minted}
18 | \input{LatexHeader}
19 | \usepackage{harmony}
20 | \author{Torsten Anders}
21 | \date{\today}
22 | \title{TOT Tutorial}
23 | \hypersetup{
24 | pdfauthor={Torsten Anders},
25 | pdftitle={TOT Tutorial},
26 | pdfkeywords={},
27 | pdfsubject={},
28 | pdfcreator={Emacs 25.3.50.1 (Org mode 9.2.6)},
29 | pdflang={English}}
30 | \begin{document}
31 |
32 | \maketitle
33 | \setcounter{tocdepth}{4}
34 | \tableofcontents
35 |
36 |
37 | \section{Introduction}
38 | \label{sec:org880776f}
39 |
40 | This document presents in a tutorial fashion some functionality of the \href{https://github.com/tanders/tot}{TOT library} for
41 | \href{http://opusmodus.com/}{Opusmodus}. The TOT library is a loose collection of tools for algorithmic composition. This library
42 | implements some features, where a number of definitions work together. This tutorial focusses on
43 | documenting such features. Other functions are self-contained, and their \href{../reference/index.html}{reference documentation}
44 | is probably sufficient.
45 |
46 |
47 | \textbf{This document is unfinished\ldots{}}
48 |
49 |
50 | \section{Score processing}
51 | \label{sec:org046319c}
52 |
53 | \subsection{Score preview}
54 | \label{sec:org0d241bb}
55 |
56 |
57 | \subsection{Score transformations}
58 | \label{sec:orga598e42}
59 |
60 |
61 | \section{Microtonal and xenharmonic music with regular temperaments}
62 | \label{sec:orgd94fd22}
63 |
64 | \subsection{Introduction}
65 | \label{sec:org6df8c16}
66 |
67 | The TOT library greatly expands Opusmodus' builtin support for microtonal music. Opusmodus'
68 | builtin support for microtonal music only allows for quarter tones (24 tone equal division of
69 | the octave, 24-EDO) and eighth tones (48 tone equal division of the octave, 48-EDO). The
70 | microtonal model of the TOT library, by contrast, allows users to define arbitrary equal
71 | temperaments (both equal divisions of the octave and other intervals), just intonation (JI) for
72 | arbitrary prime limits, and arbitrary regular temperaments
73 | (\url{https://en.xen.wiki/w/Tour\_of\_Regular\_Temperaments}).
74 |
75 | The library provides this tuning universe in a way that is controllable by a single uniform
76 | notation embedded in \href{https://opusmodus.com/forums/tutorials/omn-the-language/}{OMN}. Still, the library tries to keep things relatively clear and simple by
77 | introducing mainly one actual new accidental symbol, and that symbol will then be combined with
78 | numbers (for prime limits) to express arbitrary JI pitches, which are then mapped to all the
79 | possible tunings. Technically, pitch deflections are expressed by OMN articulations, as a
80 | library cannot change the underlying OMN pitch format.
81 |
82 | For microtonal playback, the library implements what could be called a subset of \href{https://www.midi.org/midi-articles/midi-polyphonic-expression-mpe}{MIDI Polyphonic
83 | Expression (MPE)}, where chords are distributed automatically over multiple MIDI channels so that
84 | each tone is tuned independently by pitch bend messages. A considerable number of soft synth
85 | already support MPE directly (\href{https://roli.com/mpe}{some incomplete list is shown here, scroll down and select Soft
86 | Synths}), and every instrument plugin can be relatively easily made to support MPE by
87 | using multiple instances of that plugin in parallel (e.g., directly in a DAW or with a plugin
88 | host that itself is also a plugin, like \href{https://www.plogue.com/products/bidule.html}{Plogue Bidule}).
89 |
90 |
91 | The core idea of this xemharmonic support is that JI, arbitrary equal temperaments and very many
92 | other tunings (\url{https://en.xen.wiki/w/Tour\_of\_Regular\_Temperaments}) can all be expressed as
93 | regular temperaments. You can find an informal discussion of regular temperaments, its context
94 | and motivation -- how it extends/generalises many other tone systems -- at this link:
95 | \url{http://x31eq.com/paradigm.html}. Here is another introduction: \url{https://en.xen.wiki/w/Mike\%27s\_Lectures\_On\_Regular\_Temperament\_Theory}.
96 |
97 |
98 | \subsection{First steps}
99 | \label{sec:orgc1e7c9f}
100 |
101 | Importantly, regular temperaments can all be mapped to JI. Therefore, they can also all by
102 | notated by a pitch notation capable of notating JI for arbitrary prime limits. So, as a unifying
103 | pitch notation for all these temperaments I am using such a JI notation. Several recent JI staff
104 | notations \footnote{I found so far 5 of such JI notations. Examples of highly developed and more
105 | widely used notations are Sagittal (\url{http://sagittal.org}) and the Helmholtz-Ellis JI Pitch
106 | Notation (\url{https://marsbat.space/pdfs/notation.pdf}).} are based on the same fundamental idea: the
107 | traditional pitch nominals (A, B, C\ldots{}) and the traditional accidentals (sharp, double-sharp,
108 | flat\ldots{}) are denoting tones in a Pythagorean tuning (when the notation is read as a JI
109 | notation), i.e. the traditional nominals and accidentals notate all the pitches we can reach
110 | when stacking just fifths (plus their octaves). The core idea of these JI pitch notations is
111 | that they introduce a new accidental for the comma (\url{https://en.wikipedia.org/wiki/Comma\_(music)})
112 | of every prime limit (\url{https://en.wikipedia.org/wiki/Limit\_(music)}). These notations
113 | mainly differ in what kind of symbols they propose for these comma-accidentals.
114 |
115 | The JI notation of this library is based on the same principle idea. We notate Pythagorean
116 | nominals and accidentals using the standard OMN pitch notation. Here is a dominant seventh
117 | chord, which in a JI interpretation would be tuned in Pythagorean tuning.
118 |
119 | \begin{minted}[]{lisp}
120 | (setf pythagorean-seventh '(h c4e4g4bb4))
121 | \end{minted}
122 |
123 |
124 | We can play this chord in JI with the TOT macro \texttt{def-tempered-score}. This macro does almost
125 | exactly what the Opusmodus builtin \texttt{def-score} does, but it additionally receives a temperament as
126 | one of its arguments. Also, there are multiple MIDI channels specified per instrument, as
127 | simultaneous tones are played on different MIDI channels, so they can be tuned individually by
128 | pitch bend (the macro uses the \texttt{def-score} tuning argument in the background). Only chords with as
129 | many tones as we specify MIDI channels can be independently/correctly tuned.
130 |
131 | \begin{minted}[]{lisp}
132 | (def-tempered-score my-score-name
133 | (:temperament '31-limit-JI
134 | :time-signature '(4 4))
135 | (instr1
136 | :omn pythagorean-seventh
137 | :channel '(1 2 3 4)
138 | :sound 'gm))
139 | \end{minted}
140 |
141 |
142 | While \texttt{def-tempered-score} generates the score, it does not actually display it nor play it back
143 | (the built-in \texttt{def-score} behaves in the same way). We can always play back and notate the last
144 | score explicitly with the next code snippet. The notation also reveals how \texttt{def-tempered-score}
145 | works in the background: it splits the given score instrument (\texttt{instr1}) with the chord into as
146 | many staves as there are MIDI channels, so that these resulting monophonic staves can be
147 | independently tuned via MIDI pitchbend.
148 |
149 | \begin{minted}[]{lisp}
150 | (audition-last-score)
151 | (display-musicxml *last-score* :display :window)
152 | \end{minted}
153 |
154 | \begin{figure}[htbp]
155 | \centering
156 | \includegraphics[angle=90,width=5cm]{./graphics/test2.png}
157 | \caption{Some TMP test image}
158 | \end{figure}
159 |
160 |
161 | Instead of first defining a score with \texttt{def-tempered-score} and then explicitly triggering
162 | its notation or playback as shown, we can also use the TOT function \texttt{preview-score}, which then calls
163 | \texttt{def-tempered-score} in the background. We will commonly use a single temperament and a fixed set
164 | of instruments when working on a piece, so we might want to specify their settings only once and
165 | then use it for notating and playing back multiple snippets.
166 |
167 | We can set the tuning separately using the variable \texttt{*current-temperament*}.
168 |
169 | \begin{minted}[]{lisp}
170 | (setf *current-temperament* '31-limit-JI)
171 | \end{minted}
172 |
173 | We can specify all other score settings via the two variables \texttt{*default-preview-score-header*} and
174 | \texttt{*default-preview-score-instruments*}, where \texttt{*default-preview-score-header*} is a keyword list
175 | (plist) supporting all keyword arguments of \texttt{def-score}.
176 |
177 | \begin{minted}[]{lisp}
178 | (setf *default-preview-score-header*
179 | '(:title "Dummy title"
180 | :tempo 80))
181 | \end{minted}
182 |
183 | Any instrument-specific settings can be specified with the variable
184 | \texttt{*default-preview-score-instruments*} for each instrument we want to use. The instrument labels we
185 | use here are the same that we will later use in the score short-hand format given to
186 | \texttt{preview-score}. Note that multiple MIDI channels are specified here again, and also note the
187 | nested quote (\texttt{'}) signs.
188 |
189 | \begin{minted}[]{lisp}
190 | (setf *default-preview-score-instruments*
191 | '(:instr1 (:sound 'gm
192 | :channel '(1 2 3 4))))
193 | \end{minted}
194 |
195 | We can now instead of \texttt{def-tempered-score} use the shorter call \texttt{preview-score} with these
196 | settings. The function \texttt{preview-score} is designed for playing back polyphonic scores, so we need
197 | to specify the instrument labels as well.
198 |
199 | \begin{minted}[]{lisp}
200 | (preview-score (list :instr1 pythagorean-seventh))
201 | \end{minted}
202 |
203 |
204 | OK, how about instead of the Pythagorean third we want to use a just major third -- and also a
205 | harmonic seventh and the 11ths overtone? All pitches that go beyond Pythagorean tuning are
206 | notated using JI accidentals that express microtonal comma inflections.
207 |
208 | I suggest we use the letter \texttt{K} for marking any OMN attribute that serves as a Komma
209 | accidental,\footnote{Our letter \texttt{K} is similar to the Greek letter kappa, from where the word comma
210 | comes. (Besides, the letter \texttt{C} is already used in OMN for cent values). When extending OMN as
211 | users by microtonal accidentals, we are restricted to plain ASCII letters and numbers. Most of the
212 | ASCII special characters are already used for something else in OMN and are therefore unavailable
213 | for accidental symbols. Also, while the underlying CCL compiler does support unicode, unicode
214 | support in OMN attribute names is currently limited. I could use greek letters in the names of
215 | custon OMN attributes, but all unicode symbols I tried -- e.g., any mathematical symbols or arrows
216 | -- were not supported. Anyway, while such characters could currently not be used for the attribute
217 | name, they can be used for the string that is then shown for the attribute in the score.} and then
218 | to simply complement that letter with the digits of the prime of the comma in question. So, the
219 | OMN accidental for the \href{https://en.wikipedia.org/wiki/Syntonic\_comma}{5-limit comma (the syntonic comma)} is notated \texttt{5K}, the \href{https://en.wikipedia.org/wiki/Septimal\_comma }{7-limit comma} is
220 | notated \texttt{7K} and so forth. These accidentals raise the pitch by that comma. For a comma flat, put
221 | a minus in front of the accidental, e.g., \texttt{-5K}. So, here is how we can notate and play\footnote{Unfortunately, we cannot yet define new shortcuts for the standard Opusmodus editor. I am instead
222 | using Opusmodus mainly with Emacs, and I defined a shortcut for me for such microtonal snippets
223 | that calls the TOT function \texttt{prevew-score}, which in turn calls \texttt{def-tempered-score} with the OMN
224 | expression before the cursor.} the just harmonic seventh chord. \texttt{1K} is the natural sign, and
225 | multiple accidental attributes for a chord are assigned in ascending order of chord tones.
226 |
227 |
228 | \begin{minted}[]{lisp}
229 | (preview-score (list :instr1 '(h c4e4g4bb4 1K+-5K+1K+-7K)))
230 | \end{minted}
231 |
232 |
233 | JI leads to an infinite number of different pitches. Temperaments reduce that number. So, how about
234 | we want to play the above chord in, say, 22-tone equal temperament
235 | (\url{https://en.xen.wiki/w/22edo}). We only need to define that temperament. Each regular
236 | temperament (including all equal temperaments and also JI) is specified by only two settings: a small
237 | number of generator intervals, and a val for each generator. The vals together specify how each
238 | prime (up to the prime limit of the temperament) it is mapped to JI. These details are explained
239 | in the next section. For now, the following code simply shows the definition of 22-EDO, which is pretty brief.
240 |
241 | \begin{minted}[]{lisp}
242 | (deftemperament 7-limit-22-EDO
243 | ;; List of vals
244 | (list (list 22
245 | (+ 13 22)
246 | (+ 7 (* 2 22))
247 | (+ 18 (* 2 22))))
248 | ;; List of generators
249 | (list (/ 1200.0 22)))
250 |
251 | (setf *current-temperament* '7-limit-22-EDO)
252 | \end{minted}
253 |
254 | After we defined 22-EDO this way, we can play the above chord (and any other 7-limit OMN
255 | intervals) in this temperament.
256 |
257 |
258 | \begin{minted}[]{lisp}
259 | (preview-score (list :instr1 '(h c4e4g4bb4 1K+-5K+1K+-7K)))
260 | \end{minted}
261 |
262 |
263 |
264 | \subsection{Defining temperaments and scales}
265 | \label{sec:org1bb9c31}
266 |
267 | We can define arbitrary regular temperaments simply by specifying their vals and generators. This
268 | section briefly introduces these concept, so that you can define your own temperaments. We will
269 | first define the temperament for 12-tone equal temperament (12-EDO), because that is most widely
270 | used and best understood by most Western musicians.
271 |
272 | All pitches of a regular temperament are specified by a small number of \emph{generators}. For an
273 | equal temperament like 12-EDO, we only need a single generator. We can use the semitone of this
274 | temperament as its generator. All tones of the temperament 12-EDO can then be derived by
275 | stacking that interval multiple times. The semitone of 12-EDO and thus our generator is tuned to
276 | 100 \href{https://en.wikipedia.org/wiki/Cent\_(music)}{cents}.
277 |
278 | The \href{https://en.xen.wiki/w/Val}{\emph{vals}} of a temperament specify how the intervals of the prime frequency ratios 2, 3,
279 | 5\ldots{} up to the prime limit of our temperament are mapped to intervals in this temperament.
280 |
281 | \textbf{TODO}
282 |
283 |
284 | \begin{minted}[]{lisp}
285 | (deftemperament 11-limit-12-EDO
286 | (list (edo-val 12 '(0 7 4 10 6)))
287 | '(100.0)
288 | "12-EDO temperament with an 11-limit mapping.")
289 | \end{minted}
290 |
291 |
292 | \subsection{Obtaining information}
293 | \label{sec:org6a04364}
294 |
295 | \subsubsection{Information on intervals}
296 | \label{sec:org90cc0ff}
297 |
298 |
299 | \subsubsection{Information on scales}
300 | \label{sec:org6b6128e}
301 |
302 |
303 | \subsection{Defining harmony}
304 | \label{sec:orgfbd410f}
305 |
306 |
307 | \subsection{Constraining music to an underlying harmony}
308 | \label{sec:org2d4f13c}
309 |
310 |
311 |
312 | \subsection{Dynamic temperaments}
313 | \label{sec:orgd674fed}
314 |
315 | At a later stage, the library is also meant to support dynamic temperaments, so that the tuning
316 | can change during the course of a piece, but the implementation of dynamic temperaments is
317 | still unfinished.
318 |
319 |
320 |
321 | \section{Form}
322 | \label{sec:orgbd427d6}
323 |
324 | \texttt{fn-unfold}
325 |
326 |
327 |
328 | \section{Karnatic rhythms}
329 | \label{sec:orga2aa36e}
330 |
331 | \subsection{Creating a higher-level plan}
332 | \label{sec:orgc321911}
333 |
334 |
335 | \subsection{Filling in details}
336 | \label{sec:org660cd46}
337 | \end{document}
--------------------------------------------------------------------------------
/generate-documentation.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;;; Using cldoc (https://gitlab.common-lisp.net/cldoc/cldoc/)
4 | ;;; Just works. Minor doc string formatting supported.
5 | ;;; Perhaps only downside: internal and exported symbols are not distinguished. Workaround: mark auxiliary function names etc. with a leading underscore (e.g., _aux-function).
6 | ;;; BUG: Nested functions (e.g.g, global functions within flet) not documented. Could this be fixed with cldoc::define-descriptor-handler?
7 |
8 | (require :cldoc)
9 |
10 | (defparameter *doc-dir* (make-pathname :directory (append (pathname-directory *load-truename*) '("docs" "reference"))))
11 |
12 |
13 | (cldoc:extract-documentation 'cludg:html (format nil "~A" *doc-dir*)
14 | (asdf:find-system :tot)
15 | :table-of-contents-title
16 | "Torsten's Opusmodus Tools (TOT)")
17 |
--------------------------------------------------------------------------------
/sources/PWGL.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 | ;;;
8 | ;;; Interoperate with PWGL (e.g., the library Cluster Engine).
9 | ;;; Information between Opusmodus and PWGL is shared simply by textfiles, as PWGL cannot be "remote controlled".
10 | ;;; Note: Currently limited to monophoic music.
11 | ;;;
12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 |
14 | ;;; TODO: revise: expect OMN pitches for harmonies and scales and do conversion within this function.
15 | (defun export-melody-to-PWGL
16 | (omn-mel
17 | &key
18 | ;; directory and file name of exported file
19 | (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/")
20 | (file "melody-raw1.lisp")
21 | ; default: C major triad
22 | (harmonies '((60 64 67)))
23 | (harm-rhythm '(2))
24 | ; default: C major scale
25 | (scales '((60 62 64 65 67 69 71)))
26 | (scale-rhythm '(2))
27 | (meter '((4 4)))
28 | (bar-range nil)
29 | )
30 | "Export a melody `omn-mel' alongside harmonic information for further processing by a PWGL patch.
31 | For documentation of further arguments see PWGL patch FitInHarmony.
32 |
33 | * Arguments:
34 | - bar-range (default nil): if non-nil, must be pair ( ), that specifies a range of bars from `omn-mel' to export. `omn-mel' must be nested in that case. Indices are 0-based, and start-bar-index/end-bar-index specify the index of the first/last bar to include."
35 | (print "export-melody-to-PWGL test 1")
36 | (let* ((omn-mel-range (if bar-range
37 | (subseq omn-mel (first bar-range) (1+ (second bar-range)))
38 | omn-mel))
39 | (omn-mel-dur (when bar-range
40 | (total-duration omn-mel-range)))
41 | (harm-rhythm-range (if bar-range
42 | (length-adjust omn-mel-dur harm-rhythm)
43 | harm-rhythm))
44 | (scale-rhythm-range (if bar-range
45 | (length-adjust omn-mel-dur scale-rhythm)
46 | scale-rhythm)))
47 | (print "export-melody-to-PWGL test 2")
48 | (st:pprint-to-file (concatenate 'string dir file)
49 | (list
50 | ;;; TODO: change length symbols etc into fractions
51 | ;;; ? Necessary?
52 | (flatten (omn :length omn-mel-range))
53 | (pitch-to-midi (flatten (omn :pitch omn-mel-range)))
54 | harm-rhythm-range (circle-repeat harmonies (length harm-rhythm-range)) ; (pitch-to-midi harmonies)
55 | scale-rhythm-range (circle-repeat scales (length scale-rhythm-range)) ; (pitch-to-midi scales)
56 | meter))))
57 |
58 |
59 | ;; Solved by keeping the orig rhythm for now
60 | ; - extract meter from `omn-mel'
61 | ; - limit length of result to length of omn-mel
62 | (defun import-transformed-melody-from-PWGL
63 | (omn-mel
64 | &key
65 | ;; directory and file name of exported file
66 | (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/")
67 | (file "melody-transformed1.lisp")
68 | (bar-range nil))
69 | "Complements export-melody-to-PWGL to import result from PWGL patch. `omn-mel' should be the same as given to export-melody-to-PWGL (its articulations and dynamics are merged into the result).
70 |
71 | * Arguments:
72 | - bar-range: should be the same value as the `bar-range' of the corresponding call to `export-melody-to-PWGL'."
73 | (let* (; (note-no (length (single-events (flatten omn-mel))))
74 | (data (st:read-lisp-file (concatenate 'string dir file)))
75 | ;; first four element: sol-scale-durs sol-scale sol-harm-durs sol-harms
76 | ; (sol-durations (subseq (fifth data) 0 (1- note-no))) ; limit length of sol to length of input
77 | ; (sol-pitches (subseq (sixth data) 0 (1- note-no)))
78 | ; (sol-durations (fifth data)) ; limit length of sol to length of input
79 | (sol-pitches (sixth data))
80 | (sol-time-sigs (seventh data)))
81 | (format T "sol-pitches: ~A~%" (midi-to-pitch sol-pitches))
82 | (omn-to-time-signature ; split in bar sublists
83 | (omn-replace :pitch (midi-to-pitch sol-pitches)
84 | (flatten-omn (if bar-range
85 | (subseq omn-mel (first bar-range) (1+ (second bar-range)))
86 | omn-mel)))
87 | #|
88 | (make-omn
89 | :length (omn :length omn-mel)
90 | :pitch (midi-to-pitch sol-pitches)
91 | :velocity (omn :velocity omn-mel)
92 | :articulation (omn :articulation omn-mel)
93 | :leg (omn :leg omn-mel)
94 | )
95 | |#
96 | ;; add number of bars to each time signature
97 | (mapcar #'(lambda (time-sig) (append time-sig '(1)))
98 | sol-time-sigs))))
99 |
100 |
101 | (defun import-underlying-harmony-from-PWGL
102 | (&key
103 | ;; directory and file name of exported file
104 | (velocity '(ppppp))
105 | (dir "/Users/torsten/Compositions/0-Flute-solo/z-Opusmodus-PWGL-communication/")
106 | (file "melody-transformed1.lisp"))
107 | "Complements import-transformed-melody-from-PWGL to import harmonic result from PWGL patch. `harm-durations' is the "
108 | (let* ((data (st:read-lisp-file (concatenate 'string dir file)))
109 | ;; first four element: sol-scale-durs sol-scale sol-harm-durs sol-harms
110 | (harm-durations (third data))
111 | (harm-pitches (fourth data))
112 | (sol-time-sigs (seventh data)))
113 | (omn-to-time-signature ; split in bar sublists
114 | (make-omn
115 | :length harm-durations
116 | :pitch (mapcar #'chordize (midi-to-pitch harm-pitches))
117 | :velocity velocity)
118 | ;; add number of bars to each time signature
119 | (mapcar #'(lambda (time-sig) (append time-sig '(1)))
120 | sol-time-sigs))))
121 |
122 |
123 | (defun PWGL-time-signatures (ts-forms)
124 | "Translates OMN format of time signatures into very similar but slighly simpler PWGL format.
125 |
126 | * Examples:
127 | ;;; (PWGL-time-signatures '((3 4 2) (2 4 1)))
128 | ;;; => ((3 4) (3 4) (2 4))"
129 | (loop for ts in (isolate-time-signatures ts-forms)
130 | collect (subseq ts 0 2)))
131 |
132 |
133 | #|
134 |
135 | (setf mel (make-omn
136 | :length (gen-repeat 3 '((1/4 1/8 1/8 1/8 1/8)))
137 | :pitch (gen-repeat 3 '((c4 d4 f4 g4 a4)))
138 | :articulation '(stacc)))
139 |
140 |
141 | (export-melody-to-PWGL mel
142 | :meter '((3 4) (4 4) (3 4)))
143 |
144 | (setf transformed-mel (import-transformed-melody-from-PWGL mel))
145 |
146 | |#
147 |
148 |
149 |
150 |
--------------------------------------------------------------------------------
/sources/macros.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 |
7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 | ;;
9 | ;; Pitch-related utilities
10 | ;;
11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 |
13 | ;; Called by macro expansion, therefore defined here -- is this really necessary??
14 | (defmethod ji-pc-ratio ((x rational))
15 | "Transforms the frequency ratio `x' into the interval [1, 2) to represent a corresponding pitch class expressed as a fraction."
16 | (cond ((>= x 2) (let ((octaves (floor (log x 2))))
17 | (/ x (expt 2 octaves))))
18 | ((< x 2) (let ((octaves (abs (floor (log x 2)))))
19 | (* x (expt 2 octaves))))
20 | (T x)))
21 |
22 | #|
23 | (ji-pc-ratio 9/4)
24 | => 9/8
25 |
26 | (ji-pc-ratio 2/9)
27 | => 16/8
28 |
29 | (ji-pc-ratio 3/2)
30 | => 3/2
31 |
32 | (ji-pc-ratio 3)
33 | => 3/2
34 |
35 | (ji-pc-ratio 1.5)
36 | ; error
37 | |#
38 |
39 |
40 |
41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42 | ;;
43 | ;; deftemperament
44 | ;;
45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 |
47 | ;; BUG: Documentation unfinished
48 | ;; TODO: Consider getting custom syntax colouring for user-defined macros: deftemperament currently not highlighted...
49 | (defmacro deftemperament (name vals generators &optional docstring)
50 | "Define a temperament with the given `vals' and `generators' bound to the `name'. This results in a method of the given name expecting a ratio and returning the temperament pitch in cents. The `vals' and `generators' can also later be accessed with `get-temperament-vals' and `get-temperament-generators'.
51 |
52 | Note that `vals' and `generators' are evaluated (so they can be an expression resulting in the actual values), while the name is not.
53 |
54 | * Arguments:
55 |
56 |
57 | "
58 | ;; Optimisation: calculate vals and generators from potentially given expressions (at compile time)
59 | `(let ((my-vals ,vals)
60 | (my-generators ,generators)
61 | (function-docstring (concatenate 'string
62 | "Translate a JI interval (ratio) into the corresponding interval measured in cents of this temperament:
63 | "
64 | ,docstring
65 | "
66 |
67 | * Arguments:
68 | - ratio (rational): a JI interval for which we want to get a tempered interval")))
69 |
70 | (store-temperament ',name my-vals my-generators)
71 | (setf (documentation ',name 'setf) ,docstring)
72 | ;; BUG: Doc should only be added to method, not to a plain function, but so far I did not find out how to access the doc from methods. Seems to be special.
73 | ;; See also http://www.lispworks.com/documentation/HyperSpec/Body/f_docume.htm
74 | (setf (documentation ',name 'function) function-docstring)
75 | (defmethod ,name ((ratio rational))
76 | ;; TODO: Find out how to access method doc
77 | function-docstring
78 | (ratio-to-regular-temperament-cents ratio my-vals my-generators))))
79 |
80 |
81 | #|
82 | (deftemperament 11-limit-12-EDO
83 | (list (edo-val 12 '(0 7 4 10 6)))
84 | '(100.0)
85 | "12-EDO temperament with an 11-limit mapping.")
86 | |#
87 |
88 |
89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
90 | ;;
91 | ;; def-tempered-score
92 | ;;
93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 |
95 | (defun chord-sequences-to-parts (sequence n)
96 | "Return `n' monophonic sequences that distribute chords tones in `sequence' across the returned sequences."
97 | (mapcar (lambda (seq)
98 | ;; TODO: optimise: re-barring afterwards is inefficient
99 | (copy-time-signature sequence (flatten seq)))
100 | (ta-utils:mat-trans
101 | (loop
102 | for event in (single-events (om:flatten sequence))
103 | for pitches = (if (event-restp event)
104 | NIL
105 | (melodize (second event)))
106 | for joined-attributes = (fourth event)
107 | for all-attributes = (when joined-attributes
108 | (disjoin-attributes joined-attributes))
109 | for ji-accidentals = (remove-if-not #'is-JI-accidental all-attributes)
110 | for other-attributes = (remove-if #'is-JI-accidental all-attributes)
111 | collect (loop
112 | for i from 0 to (1- n)
113 | for len = (first event)
114 | for pitch = (nth i pitches)
115 | for ji-acc = (nth i ji-accidentals)
116 | for full-attr = (join-attributes (cons ji-acc other-attributes))
117 | collect (if pitch
118 | (list* len
119 | pitch
120 | (third event) ; dynamics
121 | ;; Empty attributes skipped (these are not handled well by copy-time-signature)
122 | (when (not (eql full-attr '-))
123 | (list full-attr)))
124 | (corresponding-rest (list len))
125 | ))))))
126 | #|
127 | (pprint
128 | (chord-sequences-to-parts '((h. c5) (h c4e4g4 stacc -q)) 3)
129 | )
130 |
131 |
132 | ;; (ta-utils:mat-trans
133 | ;; '(((Q C4 MF STACC) (Q E4 MF STACC) (Q G4 MF STACC))
134 | ;; ((Q C5 MF) (-1/4) (-1/4))))
135 |
136 | ;; (ta-utils:mat-trans '(((a 1) (a 2) (a 3)) ((b 1) (b 2) (b 3)) ((c 1) (c 2) (c 3))))
137 |
138 | |#
139 |
140 |
141 | (defun aux-def-tempered-score-mpe-parts-var-name (instr)
142 | "Return a variable name (symbol) for the quasi MPE parts for the given instr (symbol)."
143 | (intern (concatenate 'string (symbol-name instr) "-MPE-PARTS")))
144 | ; (aux-def-tempered-score-mpe-parts-var-name 'instr1)
145 |
146 | (defun aux-def-tempered-score-instruments (temperament score-parts)
147 | "[Called at compile time by macro] Generate the instruments body for def-score generated by def-tempered-score, where the instruments are split into multiple instruments on different MIDI channels for quasi MPE playback."
148 | (loop for part in score-parts
149 | for instr = (first part)
150 | for MPE-parts-var-name = (aux-def-tempered-score-mpe-parts-var-name instr)
151 | for instr-args = (rest part)
152 | ;; for parts = (chord-sequences-to-parts )
153 | ;; TODO: avoid eval
154 | ;; ? NOTE: channel param must be given explictly to def-tempered-score for this to work
155 | for chans = (eval (getf instr-args :channel
156 | ''(1)))
157 | append (loop
158 | for chan in (ta-utils:ensure-list chans)
159 | for i from 0
160 | collect ;; `(let ((part-omn (get-omn-part ,(getf instr-args :omn) ,i)))
161 | `(,instr
162 | :channel ,chan
163 | ;; TODO: Really inefficient code repetition -- chord-sequences-to-parts
164 | ;; called for every part again. Optimise with let in scope around
165 | ;; def-score
166 | ;; TODO: Vector instead of list element access
167 | :omn (nth ,i ,MPE-parts-var-name)
168 | ;; :omn (get-omn-part ,(getf instr-args :omn) ,i)
169 | :tuning (omn-to-tunings ,temperament
170 | ;; TODO: Really inefficient code repetition, but
171 | ;; perhaps unavoidable within the generated
172 | ;; def-score code for the part -- Or I wrap some
173 | ;; let expression for all parts around the whole
174 | ;; def-score...
175 | (nth ,i ,MPE-parts-var-name))
176 | ;; :omn part-omn
177 | ;; :tuning (omn-to-tunings ,temperament part-omn)
178 | ,@(ta-utils:remove-properties '(:omn :channel)
179 | instr-args)))))
180 | ;; )
181 | #|
182 | (aux-def-tempered-score-instruments '31-limit-12-EDO
183 | '((instr1
184 | :omn '((h c4eb4bb4 1K+-5K+-7K+stacc))
185 | ;; :channel '(1)
186 | :port "IAC Bus 1"
187 | :sound 'gm
188 | ;; :program pianoteq
189 | )))
190 | |#
191 |
192 | #|
193 | (defun aux-def-tempered-score (temperament score-parts)
194 | "[Called at compile time by macro]"
195 | (loop for part in score-parts
196 | for instr = (first part)
197 | for instr-args = (rest part)
198 | collect (list* instr
199 | :tuning `(omn-to-tunings ,temperament ,(getf instr-args :omn))
200 | instr-args)))
201 | |#
202 |
203 | ;; TODO: Avoid code repetition shared with aux-def-tempered-score-instruments, e.g., val of var chans: more aux functions...
204 | (defun aux-def-tempered-score-let-decls (score-parts)
205 | "[Called at compile time by macro] Generate the variable declarations around the def-score generated by def-tempered-score, which split the instrument parts into multiple parts for the different MIDI channels. The let is needed for efficiency (value reuse)."
206 | (loop for part in score-parts
207 | for instr = (first part)
208 | for MPE-parts-var-name = (aux-def-tempered-score-mpe-parts-var-name instr)
209 | for instr-args = (rest part)
210 | ;; TODO: avoid eval
211 | for chans = (eval (getf instr-args :channel
212 | ''(1)))
213 | ;; TODO: avoid eval
214 | ;; TODO: optimise: chord-sequences-to-parts should return vectors instead of lists
215 | for MPE-parts = (chord-sequences-to-parts (eval (getf instr-args :omn)) (length chans))
216 | collect `(,MPE-parts-var-name ',MPE-parts)))
217 |
218 | #|
219 | (aux-def-tempered-score-let-decls '((instr1
220 | :omn '((h c4eb4bb4 1K+-5K+-7K+stacc))
221 | :channel '(1 2 3)
222 | :port "IAC Bus 1"
223 | :sound 'gm
224 | ;; :program pianoteq
225 | )))
226 | |#
227 |
228 | (defmacro def-tempered-score (name global-args &rest instruments)
229 | "The same as the Opusmodus builtin `def-score', but with the added arg `temperament'.
230 |
231 | * Arguments:
232 | TODO: Allow somehow for temperament to change over time (like arguments such as tempo etc.).
233 | - temperament (symbol): a temperament defined with deftemperament.
234 |
235 | The other arguments are documented for the builtin `def-score'.
236 | "
237 | (destructuring-bind (&key title subtitle composer writer copyright
238 | time-signature (key-signature ''chromatic) (merge-rests T)
239 | (rewrite-lengths T) ignore-tempo ; ignore—velocity
240 | octave-shift (accidentals :natural) flexible-clef
241 | ignore-time-signature (tempo 60) file
242 | start end layout
243 | ;; added param
244 | (temperament `',*current-temperament*))
245 | global-args
246 | (assert time-signature (time-signature) "No time-signature given")
247 | `(let (,@(aux-def-tempered-score-let-decls instruments))
248 | (def-score ,name ,(list
249 | :title title :subtitle subtitle :composer composer :writer writer :copyright copyright
250 | :key-signature key-signature :time-signature time-signature :merge-rests merge-rests
251 | :rewrite-lengths rewrite-lengths
252 | ;; TODO: Report wrongly documented arg
253 | ;; :ignore—velocity ignore—velocity ; Incorrect keyword argument
254 | :ignore-tempo ignore-tempo
255 | :octave-shift octave-shift :accidentals accidentals :flexible-clef flexible-clef
256 | :ignore-time-signature ignore-time-signature :tempo tempo :file file
257 | :start start :end end :layout layout
258 | )
259 | ,@(aux-def-tempered-score-instruments temperament instruments)))))
260 |
261 | #|
262 |
263 |
264 | (def-tempered-score score-name
265 | (:temperament '31-limit-JI
266 | :time-signature '(4 4))
267 | (instr1 :omn '((w c4fs4 c4fs4 1K+-5K c4fs4 1K+-7K c4fs4 1K+-11K))
268 | :channel '(1 2 3)
269 | :port "IAC Bus 1"
270 | :sound 'gm
271 | ))
272 |
273 |
274 | (display-musicxml *last-score* :display :window)
275 |
276 |
277 | |#
278 |
279 |
280 | #|
281 | ;; NOTE: set for each instrument sufficient number of channels and suitable port
282 | (defparameter *default-preview-score-instruments*
283 | '(;; TODO: Ideally deduce number of necessary channels automatically -- and use splitting into multiple voices/channels only for playback, not for score notation
284 | :snippet (:program 'acoustic-grand-piano :sound 'gm :channel '(1 2 3 4 5 6 7 8) :port "IAC Bus 1")
285 | :vln (:program 'violin :sound 'gm :channel '(1 2 3 4) :port "IAC Bus 1")
286 | :vlc (:program 'cello :sound 'gm :channel '(5 6 7 8)) :port "IAC Bus 1")
287 | )
288 |
289 | (setf mat '(w c4 c4 -5K c4 -7K c4 -11K))
290 |
291 | (setf mat '(w c4fs4 c4fs4 1K+-5K c4fs4 1K+-7K c4fs4 1K+-11K))
292 |
293 | (setf mat '(w c4e4 c4e4 1K+-5K c4e4 1K+-7K c4e4 1K+-11K))
294 |
295 | (setf mat '((h c4eb4bb4 1K+-5K+-7K+stacc)
296 | (h c4eb4bb4 stacc)
297 | (h c4eb4bb4 1k+-5K+-7k+stacc)))
298 |
299 | (setf mat '((h c4eb4bb4 1K+-5K+-7K+stacc)
300 | (h c4eb4bb4)
301 | (h c4eb4bb4 1k+-5K+-7k+stacc)))
302 |
303 | (def-tempered-score score-name
304 | (; :temperament '31-limit-JI
305 | ; :temperament '23-limit-31-EDO
306 | :time-signature '(4 4))
307 | (instr1 :omn mat
308 | :channel '(1 2 3)
309 | :port "IAC Bus 1"
310 | :sound 'gm
311 | ;; :program pianoteq
312 | ))
313 |
314 | (display-musicxml *last-score* :display :window)
315 |
316 | (setf mat '((q c4 c4 -5K bb4) (q cs4 e4 e4 -5K)))
317 |
318 | ;; TODO: Collect correct chords from Erlich paper. Perhaps even encode chords by ratios, generate progression algorithmically and then translate them into OMN automatically...
319 | (setf symmetric-decatonic-scale-chords ;; Symmetric decatonic scale
320 | '((h C4E4G4BB4 1K+-5K+1K+-7K)
321 | ;; BUG: Unsupported accidental 5K*-7K
322 | (DB4F4Ab4CB5 5K+1K+5K+5K) ; CS4 -5K DB4 5K
323 | ;; NOTE: Fifth A missing
324 | (D4FS4C5 1K+-5K+-7K)
325 | ;; NOTE: Harm 7th missing
326 | (E4G4B4 -5K+1K+-5K) ; FB4 5K
327 | ;; NOTE: Harm 7th missing
328 | (F4AB4C5 1K+5K+1K)
329 | ;; BUG: Unsupported accidental 5K*-7K
330 | (GB4BB4DB5FB5 5K+1K+5K+5K) ; FS4 -5K GB4 5K
331 | (G4B4 1K+-5K)
332 | (GS4 -5K) ; AB4 5K
333 | (BB4)
334 | (B4 -5K) ; CB4 5K
335 | (c5)))
336 |
337 | (def-tempered-score score-name
338 | (
339 | ; :temperament '11-limit-12-EDO
340 | ; :temperament '31-limit-JI
341 | :temperament '11-limit-POTE-pajara
342 | :time-signature '(4 4))
343 | (instr1 :omn symmetric-decatonic-scale-chords
344 | :channel '(1 2 3 4)
345 | :sound 'gm
346 | :port "IAC Bus 1"
347 | ;; :program pianoteq
348 | ))
349 |
350 | ;; BUG: TODO: Ensure that channel is a list...
351 | (def-tempered-score 31-EDO-test
352 | (:temperament '11-limit-31-edo
353 | :tempo 50
354 | :time-signature '(4 4))
355 |
356 | (inst1 :omn '((h fs5) (h fs5 -11K) (h fs5) (w fs5 -11K))
357 | :channel 1
358 | :sound 'gm
359 | :program 0
360 | :port 0
361 | )
362 | (inst2 :omn '((h bb4) (h bb4 -7K) (h bb4) (w bb4 -7K))
363 | :channel 2
364 | :sound 'gm
365 | :program 0
366 | :port 0
367 | )
368 | ;; (inst2 :omn '((h eb4) (h eb4) (h eb4) (w eb4))
369 | ;; :channel 2
370 | ;; :sound 'gm
371 | ;; :program 0
372 | ;; :port 0
373 | ;; )
374 | (inst3 :omn '((h eb4) (h eb4 -7K) (h eb4) (w eb4 -7K))
375 | :channel 3
376 | :sound 'gm
377 | :program 0
378 | :port 0
379 | )
380 | (inst4 :omn '((h c4) (h c4) (h c4) (w c4))
381 | :channel 4
382 | :sound 'gm
383 | :program 0
384 | :port 0
385 | )
386 | )
387 |
388 | |#
389 |
390 |
--------------------------------------------------------------------------------
/sources/midi.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 | (defun write-midi-from-omn (omn-sequence filename)
7 | "Writes the given OMN sequence to a MIDI file with the specified filename."
8 | (compile-score
9 | (def-score test-score
10 | (:title "test score"
11 | :key-signature 'chromatic
12 | :time-signature '(4 4) ; TODO: from given OMN
13 | :tempo 72)
14 |
15 | (instrument
16 | :omn omn-sequence
17 | :channel 1
18 | :sound 'gm
19 | :program 'acoustic-grand-piano))
20 | :output :midi :file filename))
21 |
22 | #|
23 | (setf my-omn '((s a4 leg d5 leg fs4 leg d5 leg g4 leg d5)))
24 | (setf path "/Users/torsten/Desktop/test1.midi")
25 |
26 | (write-midi-from-omn my-omn path)
27 | |#
28 |
29 |
30 | (defun write-midi-from-score (score filename)
31 | "Writes score to a MIDI file with the specified filename."
32 | (compile-score score :output :midi :file filename))
33 |
34 | #|
35 | (def-score test-score
36 | (:title "test score"
37 | :key-signature 'chromatic
38 | :time-signature '(4 4)
39 | :tempo 72)
40 |
41 | (instrument
42 | :omn my-omn
43 | :channel 1
44 | :sound 'gm
45 | :program 'acoustic-grand-piano))
46 |
47 | (setf path "/Users/torsten/Desktop/test2.midi")
48 |
49 | (write-midi-from-score 'test-score path)
50 | |#
51 |
52 |
53 |
54 |
--------------------------------------------------------------------------------
/sources/minizinc.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; ! TODO Consider moving this file into a separate new project with a separate package.
4 |
5 | ;; Opusmodus package
6 | (in-package :om)
7 |
8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 | ;;;
10 | ;;; Definitions that depend on Minizinc
11 | ;;;
12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 |
14 | ;; BUG TMP: Use the full path to the MiniZinc executable
15 | (defparameter *minizinc-exec* "/Applications/MiniZincIDE.app/Contents/Resources/minizinc")
16 |
17 | ; ;; Use Minizinc executable in the PATH
18 | ; (defparameter *minizinc-exec* "minizinc")
19 |
20 | ;; TODO Get this working for a portable way to find the MiniZinc executable
21 | (defun load-path-from-profile ()
22 | (with-open-file (stream "~/.profile")
23 | (loop for line = (read-line stream nil)
24 | while line
25 | when (and (> (length line) 11)
26 | (string= "export PATH=" line :start2 0 :end2 11))
27 | do (let* ((path (subseq line 12))
28 | (current-path (uiop:getenv "PATH"))
29 | (new-path (if current-path
30 | (concatenate 'string path ":" current-path)
31 | path)))
32 | (setf (uiop:getenv "PATH") new-path)
33 | (return new-path)))))
34 |
35 | ; (load-path-from-profile)
36 |
37 | ; ;; Call the function and store the result
38 | ; (defparameter *updated-path* (load-path-from-profile))
39 |
40 |
41 | (defun check-minizinc-exec ()
42 | "Ensure that the MiniZinc executable is in the current PATH or report a warning if not."
43 | (multiple-value-bind (output error-output exit-code)
44 | (uiop:run-program `("which" ,*minizinc-exec*) :output :string :error-output :string :ignore-error-status t)
45 | (if (zerop exit-code)
46 | (setf *minizinc-exec* (string-trim '(#\Newline #\Return) output))
47 | (warn "MiniZinc executable not found in PATH. Please ensure it is installed and available. You can obtain it from here: https://www.minizinc.org"))))
48 |
49 |
50 | (defun call-minizinc (model-file data-file)
51 | "Run MiniZinc executable on given model and data files. Return the solution it prints as a string, or raise an error if it fails."
52 | (check-minizinc-exec)
53 | (uiop:run-program (format nil "~a ~a ~a" *minizinc-exec* model-file data-file)
54 | :output :string
55 | :error-output :string))
56 |
57 | ;; TODO Somehow generalise
58 | (defun minizinc-solve-int-list (model data solution-var-name)
59 | "Solve a Minizinc CSP over a list of integers and return result parsed as Lisp value.
60 |
61 | * Arguments:
62 | - model (str): The CSP definition in Minizinc syntax.
63 | - data (str): The CSP input data in Minizinc datafile syntax.
64 | - solution-var-name (str): The variable to solve in the model.
65 | "
66 | (uiop:with-temporary-file (:stream model-file :pathname model-path :type "mzn")
67 | (write-string model model-file)
68 | (finish-output model-file)
69 | (uiop:with-temporary-file (:stream data-file :pathname data-path :type "dzn")
70 | (write-string data data-file)
71 | (finish-output data-file)
72 | (let ((output (call-minizinc (namestring model-path) (namestring data-path))))
73 | (ppcre:register-groups-bind (solution)
74 | ((format nil "~a = \\[(\\d+(?:, \\d+)*)\\]" solution-var-name)
75 | output)
76 | (mapcar #'parse-integer (ppcre:split ", " solution)))))))
77 |
78 | ;; TODO
79 | ;; - ! Distances between ints in result xs should not be too uneven. Example: for (split-int-CSP 10 3) it should return (5 3 2) and not (5 4 1).
80 | ;; - ? Explicitly handle no solution: make sure Minizinc returns a certain value in that case. Seemingly uiop:run-program does return nil in that case?
81 | (defun split-int-CSP (n parts &key (order #'>))
82 | "Return a list of PARTS integers. All integers in the result are different, and their sum is N.
83 |
84 | This function uses Minizinc in the background.
85 |
86 | ? Return nil if there is no solution.
87 |
88 | * Arguments:
89 | - N (int): input integer to 'split'.
90 | - PARTS (int): number of integers to return.
91 | - ORDER (numerical comparison function): in which order to return the result.
92 |
93 | * Examples:
94 |
95 | ;;; (split-int-CSP 12 3)
96 | ;;; => (5 4 3)
97 |
98 | ;;; (split-int-CSP 9 3)
99 | ;;; => (4 3 2)
100 |
101 | ;;; (split-int-CSP 12 3 :order #'<)
102 | ;;; => (3 4 5)
103 |
104 | No solution
105 | ;;; (split-int-CSP 2 3)
106 | ;;; => nil
107 | "
108 | (let* ((model "
109 | include \"alldifferent.mzn\";
110 | int: n;
111 | int: parts;
112 | array[1..parts] of var 1..n: xs;
113 | constraint alldifferent(xs);
114 | constraint sum(xs) = n;
115 | solve ::int_search(xs, input_order, indomain_median) satisfy;")
116 | (data (format nil "n=~d; parts=~d;" n parts))
117 | (sol-val "xs")
118 | (result (minizinc-solve-int-list model data sol-val)))
119 | (sort result order)))
120 |
121 | #|
122 | (split-int-CSP 11 3)
123 | (split-int-CSP 10 3)
124 | (split-int-CSP 9 3)
125 | |#
126 |
127 |
--------------------------------------------------------------------------------
/sources/orchestration.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 |
7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 | ;;;
9 | ;;; Orchestration etc.
10 | ;;;
11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 |
13 |
14 | (defun filter-notes-if (test OMN &key (remain T) (section nil))
15 | "Extracts events in OMN for which a given test function returns true (or keeps only events for which the test function returns nils). All other notes are turned into rests.
16 |
17 | * Arguments:
18 | - test: Boolean function expecting individual parameters of each note in `OMN'
19 | - OMN: An OMN sequence
20 | - remain: Boolean expressing whether only matching notes (T) or non-matching notes (nil) should be kept.
21 | - section: an integer or list of integers. Selected list or lists to process. The default is NIL.
22 |
23 | See also Opusmodus builtin `filter-events'.
24 |
25 | * Examples:
26 |
27 | Keep only notes above middle C and turn other notes into rests
28 |
29 | ;;; (filter-notes-if #'(lambda (dur pitch &rest other-args)
30 | ;;; (> (pitch-to-midi pitch) 60))
31 | ;;; '(e c4 mp -e fermata e. d4 -h e. c4 e e4))
32 |
33 | Do the opposite with :remain nil.
34 |
35 | ;;; (filter-notes-if #'(lambda (dur pitch &rest other-args)
36 | ;;; (> (pitch-to-midi pitch) 60))
37 | ;;; '(e c4 mp -e fermata e. d4 -h e. c4 e e4)
38 | ;;; :remain nil)
39 |
40 | This also works with nested lists and you can process only selected bars (other bars are kept unchanged).
41 |
42 | ;;; (filter-notes-if #'(lambda (dur pitch &rest other-args)
43 | ;;; (> (pitch-to-midi pitch) 60))
44 | ;;; '((e c4 mp -e fermata e. d4 -s) (-q.. e. c4 e e4))
45 | ;;; :section 1)
46 |
47 | For musical application examples see also {https://opusmodus.com/forums/topic/867-opusmodus-1222292/}.
48 |
49 | * Notes:
50 |
51 | This function could also be useful for Beethoven like motif condensation, where notes are first turned into rests with this function, and then their preceding notes are extended with length-legato, as demonstrated in the following example.
52 |
53 | ;;; (setf my-motif '((q. c4 e d4 q. e4 e f4) (h g4 -h)))
54 | ;;; (length-legato
55 | ;;; (filter-notes-if #'(lambda (dur pitch &rest other-args)
56 | ;;; (> (omn-encode dur) 1/4))
57 | ;;; my-motif))
58 | ;;; => ((h c4 e4) (w g4))
59 |
60 | * See Also:
61 |
62 | https://opusmodus.com/forums/topic/910-merge-rests-with-preceeding-note/?tab=comments#comment-2713
63 |
64 | "
65 | (if section
66 | (maybe-section #'(lambda (seq) (filter-notes-if test seq :remain remain))
67 | OMN section)
68 | (copy-time-signature OMN
69 | (flatten
70 | (mapcar #'(lambda (params)
71 | (if (length-notep (first params))
72 | (if (if remain
73 | (apply test params)
74 | (not (apply test params)))
75 | params
76 | ;; turn non-matching note into rest
77 | ;;; TODO: preserve params relevant for rests (e.g., fermatas)
78 | (- (omn-encode (first params))))
79 | ;; leave rests unchanged
80 | params))
81 | (single-events (flatten OMN)))))))
82 |
83 |
84 |
85 | (defun corresponding-rest (event)
86 | "Turns a single OMN note into a rest of the same note value. Rests remain rests, and rest articulations are preserved.
87 |
88 | * Examples:
89 | ;;; (corresponding-rest '(h c4))"
90 | (let ((len (omn-encode (first event))))
91 | (cons
92 | ;; rests should remain rests
93 | (if (> len 0)
94 | (* len -1)
95 | len)
96 | (omn :rest-articulation event))))
97 |
98 |
99 | (defun _push-event-and-rests (event matching-position result-omns articulation-sets-length)
100 | (push event (nth matching-position result-omns))
101 | (loop for i in (remove matching-position (gen-integer 0 (1- articulation-sets-length)))
102 | do (push (corresponding-rest event) (nth i result-omns))))
103 |
104 |
105 | (defun separate-parts (sequence articulation-sets)
106 | "The function `separate-parts' is useful for customising your sound playback with multiple sound libraries or for algorithmic orchestration.
107 | The function breaks an OMN sequence (a single part) into a list of multiple OMN sequences (multiple parts). It basically sorts notes from the OMN sequence into different parts, depending on the articulations of individual notes. All notes with certain articulations go in one resulting parts, and notes with other articulations in another part. In all other resulting parts, notes are substituted by rests, so that timing relations of notes in different parts are preserved.
108 | This function can be useful, when you have multiple sound libraries that support different articulations of the same instrument. You can then perform notes with certain articulations on one software instrument (on its own MIDI channel etc.), and notes with other articulations on another instrument.
109 | Alternatively, you can use the function for algorithmic orchestration, where you assign custom articulations (typically declared with add-text-attributes first) such as instrument labels with your custom algorithm, and then use this function in a second step to separate your instruments.
110 |
111 | Remember that the result of this function is a list of multiple OMN sequences (multiple parts). You have to split it into its individual parts for use in OMN.
112 |
113 | See also {https://opusmodus.com/forums/topic/849-towards-algorithmic-orchestration-and-customising-sound-playback-with-multiple-sound-libraries/}
114 |
115 | * Arguments:
116 | - sequence: OMN sequence, can be nested
117 | - articulation-sets: list of list of articulations. All notes with articulations contained in the first articulation-set end up in the first resulting part, notes with articulations in the second set end up in the second part and so forth.
118 |
119 | The decision which part a note belongs to is always made based on the first articulation that matches an articulation-set. If a note contains no articulation, or an articulation contained in no set, then it is matched to the first articulation-set. If an articulation is contained in multiple articulation-sets, then the earlier match in articulation-sets is used.
120 |
121 |
122 | * Examples:
123 |
124 | ;;; (separate-parts '(h c4 pizz q arco)
125 | ;;; '((pizz)
126 | ;;; (arco)))
127 | ;;; => ((h c4 mf pizz -q) ; part 1 with pizz articulations
128 | ;;; (-h q c4 mf arco)) ; part 2 with arco
129 |
130 | ;;; (separate-parts '((h c4 pizz q arco) (h trem q h pizz) (h arco+stacc -q fermata))
131 | ;;; '((pizz arco)
132 | ;;; (trem)))
133 | ;;; => (((h c4 mf pizz q arco) (-h q c4 mf h pizz) (h c4 mf arco+stacc -q fermata)) ; part 1: pizz and arco
134 | ;;; ((-h -q) (h c4 mf trem -q -h) (-h -q fermata))) ; part 2: trem
135 |
136 |
137 | Full score example:
138 |
139 | ;;; (setf omn-expr '((h c4 pizz q arco) (h trem q h pizz) (h arco+stacc -q fermata)))
140 | ;;; (setf parts (separate-parts omn-expr
141 | ;;; '((pizz arco)
142 | ;;; (trem))))
143 | ;;; (def-score two-violins
144 | ;;; (:title \"Title\"
145 | ;;; :composer \"Composer\"
146 | ;;; :copyright \"Copyright © \"
147 | ;;; :key-signature 'chromatic
148 | ;;; :time-signature '((1 1 1 1) 4)
149 | ;;; :tempo 100
150 | ;;; :layout (bracket-group
151 | ;;; (violin1-layout 'violin1)
152 | ;;; (violin2-layout 'violin2)))
153 | ;;;
154 | ;;; (violin1
155 | ;;; :omn (nth 0 parts)
156 | ;;; :channel 1
157 | ;;; :sound 'gm
158 | ;;; :program 'violin
159 | ;;; :volume 100
160 | ;;; :pan 54
161 | ;;; :controllers (91 '(48))
162 | ;;; )
163 | ;;;
164 | ;;; (violin2
165 | ;;; :omn (nth 1 parts)
166 | ;;; :channel 2
167 | ;;; :sound 'gm
168 | ;;; :program 'violin
169 | ;;; :volume 100
170 | ;;; :pan 74
171 | ;;; :controllers (91 '(60))
172 | ;;; )
173 | ;;; )
174 | "
175 | (if (listp (first sequence))
176 | ;; sequence is nested
177 | (matrix-transpose
178 | (mapcar #'(lambda (seq) (separate-parts seq articulation-sets))
179 | sequence))
180 | ;; sequence is flat list
181 | (let* ((articulation-sets-length (length articulation-sets))
182 | (result-omns (make-list articulation-sets-length :initial-element nil)))
183 | (loop for event in (single-events sequence)
184 | do (let ((event-articulation (fourth event)))
185 | (if event-articulation
186 | (let ((matching-position
187 | (position-if #'(lambda (articulation-set)
188 | (some #'(lambda (art)
189 | (member art (disassemble-articulations event-articulation)))
190 | articulation-set))
191 | articulation-sets)))
192 | (if matching-position
193 | (_push-event-and-rests event matching-position result-omns articulation-sets-length)
194 | ;; if no match, then add event to first omn result
195 | (_push-event-and-rests event 0 result-omns articulation-sets-length)))
196 | ;; if no articulation, then add event to first omn result
197 | (_push-event-and-rests event 0 result-omns articulation-sets-length))))
198 | (mapcar #'(lambda (result) (flatten-omn (reverse result))) result-omns))))
199 |
200 | #|
201 | (separate-parts '(h c4 pizz q arco)
202 | '((pizz)
203 | (arco)))
204 | => ((h c4 mf pizz -q) ; part 1 with pizz articulations
205 | (-h q c4 mf arco)) ; part 2 with arco
206 |
207 | (separate-parts '((h c4 pizz q arco) (h trem q h pizz) (h arco+stacc -q fermata))
208 | '((pizz arco)
209 | (trem)))
210 | => (((h c4 mf pizz q arco) (-h q c4 mf h pizz) (h c4 mf arco+stacc -q fermata)) ; part 1: pizz and arco
211 | ((-h -q) (h c4 mf trem -q -h) (-h -q fermata))) ; part 2: trem
212 | |#
213 |
214 |
215 |
216 |
217 | (defun insert-articulation (flat-omn-list &rest articulations)
218 | "Merge in one or more lists of articulations to an OMN expression.
219 |
220 | * Examples:
221 | added nil for the rest
222 | ;;; (insert-articulation '(e c4 mp arco e. d4 -h e. p pizz e e4 arco)
223 | ;;; '(ponte tasto nil ponte tasto))
224 | ;;; => (e c4 mp arco+ponte e. d4 mp tasto -h e. d4 p pizz+ponte e e4 p arco+tasto)
225 |
226 | BUG: does not skip rests. Wait for omn-replace supports composite articulations to fix"
227 | (apply #'append
228 | (loop
229 | for event in (single-events flat-omn-list)
230 | for data in (matrix-transpose articulations)
231 | when (length-notep (first event))
232 | collect (let ((event-art (fourth event)))
233 | (append (subseq event 0 3)
234 | (list (merge-articulations (if event-art
235 | (cons event-art data)
236 | data)))))
237 | else collect event)))
238 |
239 | #| ;; automatic orchestration application
240 | (add-text-attributes
241 | '(trp "trp")
242 | '(fl "fl")
243 | '(clar "clar"))
244 |
245 | (insert-articulation '(e c4 mp stacc e. d4 -h e. c4 p ord e e4 stacc)
246 | '(trp fl trp trp fl clar)
247 | '(flt tr1 tr2 flt tr1 tr2))
248 | ; => '(e c4 mp stacc+trp+flt e. d4 mp fl+tr1 -h e. c4 p ord+trp+flt e e4 p stacc+fl+tr1)
249 | |#
250 |
251 |
252 |
253 |
254 | (defun remove-unless-parameters (flat-omn-list parameter &key (remove-non-matching? nil))
255 | "Checks every note whether it contains `parameter'. All notes containing the parameter are preserved, all other notes are turned into rests. If a note contains a combination of articulations, all of them are checked.
256 |
257 | * Arguments:
258 | - flat-omn-list: flat OMN list
259 | - parameter: a length, pitch, OMN velocity or single articulation
260 | - remove-rests? (default nil): if true, all notes that do not match are removed instead of turned into rests.
261 |
262 |
263 | * Examples:
264 | ;;; (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto)
265 | ;;; 'e.)
266 | ;;; => (-1/8 e. d4 mp tasto -1/2 e. c4 p pizz+ponte -1/8)
267 |
268 | ;;; (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto)
269 | ;;; 'arco)
270 | ;;; => (e c4 mp arco+ponte -3/16 -1/2 -3/16 e e4 p arco+tasto)
271 |
272 | ;;; (remove-unless-parameters '(e c4 mp arco+ponte e. d4 mp tasto -h e. c4 p pizz+ponte e e4 p arco+tasto)
273 | ;;; 'arco
274 | ;;; :remove-non-matching? T)
275 | ;;; => (e c4 mp arco+ponte e e4 p arco+tasto)
276 | "
277 | (remove :not-matching
278 | (apply #'append
279 | (loop for event in (single-events flat-omn-list)
280 | when (and (length-notep (first event))
281 | (member (omn-encode parameter)
282 | (append (list (omn-encode (first event)))
283 | (subseq event 1 3)
284 | (disassemble-articulations (fourth event)))))
285 | collect event
286 | else collect (if remove-non-matching?
287 | '(:not-matching)
288 | (corresponding-rest event))))))
289 |
290 | #| ;; continue automatic orchestration application
291 | (remove-unless-parameters '(e c4 mp stacc+trp+flt e. d4 mp fl+tr1 -h e. c4 p ord+trp+flt e e4 p stacc+fl+tr1)
292 | 'trp)
293 | ; => (e c4 mp stacc+trp+flt -3/16 -1/2 e. c4 p ord+trp+flt -1/8)
294 |
295 | (remove-unless-parameters '(e c4 mp stacc+trp+flt e. d4 mp fl+tr1 -h e. c4 p ord+trp+flt e e4 p stacc+fl+tr1)
296 | 'e.)
297 | |#
298 |
299 |
300 |
301 |
302 |
--------------------------------------------------------------------------------
/sources/package.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 | ;; (require :fenv)
7 | ; (asdf:load-system :fenv)
8 | ;; no idea why these unintern calls are necessary -- possibly because these functions are called in the actual source code of this project?
9 | ; (unintern 'v)
10 | ; (unintern 'y)
11 | ; (use-package :fenv)
12 |
13 | #|
14 | ; (ql:quickload :fn)
15 | (require :fn)
16 | (unintern 'fn*)
17 | (use-package :fn)
18 | |#
19 |
20 | ;; (require :ta-utilities)
21 |
22 | ;; (require :string-tools)
23 |
24 |
25 | #|
26 | ;;; NOTE: careful with shadowing-import
27 | (shadowing-import ; import all external symbols of :fenv
28 | (loop for s being the external-symbols of (find-package :fenv)
29 | collect s))
30 | |#
31 |
32 |
--------------------------------------------------------------------------------
/sources/slippery-chicken.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;;;
4 | ;;; This file contains definitions from the composition system Slippery Chicken by Michael Edwards
5 | ;;;
6 |
7 | (defpackage :slippery-chicken
8 | (:documentation "This package contains selected definitions from the composition system Slippery Chicken by Michael Edwards.")
9 | (:nicknames :sc)
10 | (:use :common-lisp)
11 | (:export fibonacci-transition))
12 |
13 | (in-package :sc)
14 |
15 | ;;;
16 | ;;; Implementation of Fibonacci Transition by Michael Edwards copied from
17 | ;;; http://www.moz.ac.at/sem/lehre/lib/mat/text/notes9.html
18 | ;;; This (or a variation therefore) is part of Slippery Chicken, hence the package name.
19 | ;;;
20 |
21 |
22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 | ;;;
24 | ;;; Aux defs
25 | ;;;
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 |
28 | (defun fibonacci (max-sum)
29 | "Return the fibonacci numbers in a list ending at 0 that add up to a maximum less than . Returns the fibonacci number < max-sum as a second value."
30 | (loop
31 | ;; our result will be in descending order
32 | with result = '(1 0)
33 | ;; the running total of sums
34 | with cumulative-sum = 1
35 | for x = 0
36 | for y = 0
37 | ;; the sum of our two most recent numbers.
38 | for sum = 0
39 | do
40 | (setf x (first result)
41 | y (second result)
42 | sum (+ x y))
43 | (incf cumulative-sum sum)
44 | (when (> cumulative-sum max-sum)
45 | ;; we're not using sum this time as we're over our limit.
46 | ;; return can be used in loops to exit immediately
47 | (return (values result (1+ (- cumulative-sum sum)))))
48 | (push sum result)))
49 |
50 |
51 | ;;; Same as fibonacci but eliminates the final 0 and 1s; can also reach max-sum
52 | ;;; rather than having to be < it.
53 | ;;; (fibonacci 20) -> (8 5 3 2 1 1 0) 20
54 | ;;; (_fibonacci-start-at-2 20) -> (8 5 3 2) 18
55 | (defun _fibonacci-start-at-2 (max-sum)
56 | "Aux def"
57 | (multiple-value-bind
58 | (series sum)
59 | (fibonacci (+ 2 max-sum)) ; + 2 so we can hit max-sum if need be
60 | ;; subseq returns a sequence out of our list
61 | (values (subseq series 0 (- (length series) 3))
62 | (- sum 2))))
63 |
64 |
65 | ;;; Once we have the numbers e.g. (8 5 3 2 1) we convert into indices e.g.
66 | ;;; (0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1 0 1 1)
67 | ;;; 8 5 3 2 1
68 | (defun _fibonacci-transition-aux2 (list item1 item2)
69 | "Aux def"
70 | (let ((result '()))
71 | (loop for num in list do
72 | ;; so each time we have 'num' items, all but one of which are item1
73 | (loop repeat (1- num) do
74 | (push item1 result))
75 | (push item2 result))
76 | ;; we've used push so we need to reverse the list before returning
77 | (nreverse result)))
78 |
79 |
80 | ;;; Say you want a transition between two repeating states over a period of x
81 | ;;; repetitions; this gives you a gradual break in of the second state using
82 | ;;; fibinacci relationships.
83 | ;;; is the start item, the item we want to transition towards
84 | ;;; e.g. (fibonacci-transition-aux1 21 0 1) ->
85 | ;;; (0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1 0 1 0 1 1)
86 | (defun _fibonacci-transition-aux1 (num-items &optional
87 | (item1 0)
88 | (item2 1))
89 | "Aux def"
90 | ;; local function: usually done with flet but you can't call flet functions
91 | ;; recursively...
92 | (labels ((ftar (num)
93 | ;; lisp functions can return more than one value (e.g. (floor
94 | ;; 3.24) usually you will only want the first value (as in the
95 | ;; case of floor) but we can get them all using
96 | ;; multiple-value-bind and friends.
97 | (multiple-value-bind
98 | (series sum)
99 | ;; returns a list of descending fib numbers and their sum--this
100 | ;; will be < num-items
101 | (_fibonacci-start-at-2 num)
102 | (let ((remainder (- num sum)))
103 | (if (> remainder 2)
104 | ;; recursive call: what we're looking for is a descending
105 | ;; list of fib numbers that total exactly,
106 | ;; hence we have to keep doing this until we've got
107 | ;; num-items
108 | (append series (ftar remainder))
109 | ;; we're done so just store the remainder and return
110 | (progn
111 | (when (> remainder 0)
112 | (push remainder series))
113 | series))))))
114 | ;; we might have something like (2 5 3 2 8 5 3 2) so make sure we sort them
115 | ;; in descending order. Note that our sort algorithm takes a function as
116 | ;; argument.
117 | (_fibonacci-transition-aux2
118 | (stable-sort (ftar num-items) #'>)
119 | item1 item2)))
120 |
121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122 | ;;;
123 | ;;; Top-level def
124 | ;;;
125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
126 |
127 |
128 | (defun fibonacci-transition (num-items &optional
129 | (item1 0)
130 | (item2 1))
131 | "Generates a list containing only instances of item1 and and item2, where initially item1 dominates, but then item1 gradually decreases and item2 increases, until item2 completely dominates. The transition follows Fibonacci numbers.
132 |
133 | * Examples:
134 | ;;; (fibonacci-transition 35 0 1)
135 | ;;; => (0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1 0 1 0 1 1 0 1 0 1 1 0 1 1 1 1 1)
136 |
137 | Function defined by Michael Edwards for his algorithmic composition system Slippery Chicken, see
138 | - Edwards, M. (2011) Algorithmic composition: computational thinking in music. Communications of the ACM. 54 (7), 58-67.
139 | - Edwards, M. (2012) An Introduction to Slippery Chicken, ICMC 2012.
140 |
141 | Slippery Chicken also defines a variant of this function for more than two items."
142 | ;; just some sanity checks
143 | (unless item1
144 | (setf item1 0))
145 | (unless item2
146 | (setf item2 1))
147 | ;; we use the aux1 function to first move towards more of item2, but then
148 | ;; again for less of item1. The point at which this shift occurs is at the
149 | ;; golden section (where else?).
150 | (let* ((left-num (round (* num-items .618)))
151 | (right-num (- num-items left-num))
152 | ;; get the two transitions.
153 | (left (_fibonacci-transition-aux1 left-num item1 item2))
154 | ;; this one will be reversed
155 | (right (_fibonacci-transition-aux1 right-num item2 item1)))
156 | ;; avoid two item1s at the crossover. we use equal as it can handle number
157 | ;; and symbol comparison
158 | (when (equal (first (last right))
159 | item1)
160 | ;; butlast returns it's argument minus the last element
161 | ;; e.g. (butlast '(1 2 3 4)) -> (1 2 3)
162 | (setf right (butlast right))
163 | (push item2 right))
164 | ;; append the two lists and return. we can use nreverse (which is more
165 | ;; efficient) rather than reverse as we won't need the original version of
166 | ;; result
167 | (append left (nreverse right))))
168 |
169 |
170 |
171 |
172 |
173 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 | ;;;
175 | ;;; Import defs into Opusmodus package
176 | ;;;
177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
178 |
179 | #| ;; Don't import any further packages into the already very busy OM package
180 | (in-package :om)
181 |
182 | ;; not sure why this is necessary
183 | (unintern 'fibonacci-transition)
184 |
185 | (use-package :sc :om)
186 | |#
187 |
188 |
189 | #|
190 | (sc:fibonacci-transition 35 0 1)
191 |
192 | (om::fibonacci-transition 35 0 1)
193 | |#
194 |
195 |
196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 | ;;; EOF
198 |
--------------------------------------------------------------------------------
/sources/texture.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 |
7 | ;; Implements the texture idea of Stephane Boussuge's 2nd Zoom into Opusmodus from 23 May 2020,
8 | ;; see https://opusmodus.com/forums/topic/1758-session-2-230520/?tab=comments#comment-6351
9 | (defun quasi-heterophony (materials bar-no instruments)
10 | "Return multiple voices (i.e. a polyphonic result) that form a polyphonic texture, where all voices are based on the same collection of input material. Their arrangement and variation is controlled by ..."
11 | ;; First implement orig texture, then by and by abstract that
12 | (let* (;; number of voices
13 | (n (length instruments))
14 | ;; TODO: Should tendency-vectors perhaps be input args?
15 | ;; NOTE: These are actually lists (not vectors) of floats
16 | (tendency-mask '(0.1 0.5 0.3 1 0.4 0.6 0.1))
17 | (tendency-vectors (loop repeat n
18 | collect (gen-tendency bar-no tendency-mask :variance 0.6)))
19 | ;; NOTE: Bars of input material do not need to share same length, and therefore resulting
20 | ;; voices can differ in length
21 | (voices-init (loop for vec in tendency-vectors
22 | collect (vector-map materials vec)))
23 | ;; The bar durations of all voices should use the same bar durations as the first voice
24 | (shared-span (get-span (first voices)))
25 | (voices-sp (cons (first voices-init) ;; no need for span correction for first voice
26 | (loop for voice in (rest voices-init)
27 | collect (length-span shared-span voice))))
28 | )
29 |
30 | ))
31 |
32 |
33 | #|
34 | ;;; Patterns definitions
35 | ;; Hand made:
36 | (setf patterns '(
37 | (q d4 p ord e4 < fs4 < h gs4 mf)
38 | (e gs5 mf pizz e5 d5 gs4 q d4)
39 | (q fs4 p snap e4 snap)
40 | (h b4 pp trem+ponte d5 trem+ponte)
41 | (h e5 pp trem+ponte gs4 trem+ponte)
42 | (6q a4 p leg b4 < leg c5 < leg d5 < leg e5 < leg fs5 < q gs5 f stacc)
43 | (3q gs4 f stacc a4 stacc e4 leg fs4 stacc gs4 stacc c5 stacc e4 leg fs4 stacc c5 stacc)
44 | (s gs5 p leg e5 d4 stacc a4 stacc q d4 stacc)
45 |
46 | ))
47 |
48 | ;; Algorithmically made
49 | (setf patterns2 (gen-eval
50 | 8
51 | '(make-omn
52 | :pitch (rnd-sample 8 '(d4 e4 fs4 gs4 a4 b4 c5 d5 e5 fs5))
53 | :length (setf len (euclidean-rhythm
54 | (setf lvl (rnd-round 8 16))
55 | 4 lvl 's :type 2))
56 | :velocity (rnd-pick '((pp)(p)(mp)(mf)(f)))
57 | :articulation (length-map '((e (stacc))((q (marc ord))))
58 | len :otherwise '(ord))
59 | )))
60 |
61 | ;;; Assemble the 2 list of patterns into 1 reservoir
62 | (setf reservoir (assemble-seq patterns patterns2))
63 |
64 | (setf bar-no 24)
65 | (quasi-heterophony reservoir bar-no)
66 | |#
67 |
--------------------------------------------------------------------------------
/sources/utils.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | ;; Opusmodus package
4 | (in-package :om)
5 |
6 |
7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 | ;;;
9 | ;;; General Utilities
10 | ;;;
11 | ;;; TODO: Consider moving this partly into my general TU utils package instead.
12 | ;;;
13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 |
15 | ;; CONSIDER: Move this into some utilities library?
16 | ;; https://exercism.io/tracks/common-lisp/exercises/prime-factors/solutions/8a1fc0fd648b44119c5d63c29ec22d26
17 | (defun prime-factors (n)
18 | "Return list of prime factors of given integer."
19 | (flet ((is-factor? (x n)
20 | (zerop (mod n x))))
21 | (when (> n 1)
22 | (loop for x from 2 to (isqrt n)
23 | when (is-factor? x n)
24 | return (nconc (prime-factors x) (prime-factors (/ n x)))
25 | finally (return (list n)) ))))
26 | #|
27 | (prime-factors 24)
28 | => (2 2 2 3)
29 | |#
30 |
31 |
32 | ;;; TODO: consider adding arguments :section and :exclude -- after nested-lists
33 | (defun mapcar-nested (fn &rest nested-lists)
34 | "A simplified equivalent of mapcar, but expects nested lists (as common for OMN parameter lists). All lists in nested-lists must be nested equally.
35 |
36 | * Examples:
37 |
38 | ;;; (mapcar-nested #'(lambda (x) (* x 2)) '((1/4 1/8 1/8) (1/2)))
39 | ;;; => ((1/2 1/4 1/4) (1))
40 |
41 | Using the built-in Opusmodus function `span' to ensure an equal nesting of value lists
42 | ;;; (let* ((ls '((1/4 1/8 1/8) (1/2)))
43 | ;;; (factors (span ls '(2 3))))
44 | ;;; (mapcar-nested #'* ls factors))
45 | ;;; => ((1/2 3/8 1/4) (3/2))
46 | "
47 | (apply #'mapcar #'(lambda (&rest lists) (apply #'mapcar fn lists))
48 | nested-lists))
49 |
50 | (defun matrix-transpose* (&rest lists)
51 | "Variant of matrix-transpose that is more allowing in terms of its input. The function performs a matrix transformation, but input lists can be of different length (shorter lists are then circled through) or even mere elements (internally turned into a list by repeating the element).
52 |
53 | * Arguments:
54 | - lists: individual elements or lists
55 |
56 | * Examples:
57 |
58 | (matrix-transpose* '(0 1 2 3) 5)
59 | => ((0 5) (1 5) (2 5) (3 5))
60 |
61 |
62 | (matrix-transpose* '(0 1 2 3) '(a b) '_)
63 | => ((0 a _) (1 b _) (2 a _) (3 b _))
64 |
65 | "
66 | (let* ((full-lists (mapcar #'tu:ensure-list lists))
67 | (l (apply #'max (mapcar #'length full-lists))))
68 | (matrix-transpose (mapcar #'(lambda (list)
69 | (circle-repeat list l))
70 | full-lists))))
71 |
72 |
73 | (defun circle-repeat (pattern n)
74 | "Circle through elements in pattern (a list) until n elements are collected.
75 |
76 | NOTE: only supports flat list so far.
77 |
78 | * Arguments:
79 | - pattern: a list or single value treated as a one-value list
80 | - n: an integer
81 |
82 | * Examples:
83 |
84 | ;;; (circle-repeat '(bb4 g4) 10)
85 | ;;; => (bb4 g4 bb4 g4 bb4 g4 bb4 g4 bb4 g4)
86 |
87 | The function span can do something very similar.
88 |
89 | ;;; (span (gen-repeat 10 'x) '(bb4 g4))
90 |
91 |
92 | See also Opusmodus buildin gen-trim, which does the same, but is overall more flexible.
93 | "
94 | ;; (assert pattern
95 | ;; (pattern) "circle-repeat: must be of at least length 1: ~A" pattern)
96 | (let* ((pattern-l (if pattern
97 | (tu:ensure-list pattern)
98 | ;; if pattern is nil then repeat nil
99 | (list nil)))
100 | (l (length pattern-l)))
101 | (loop
102 | for i from 0 to (- n 1)
103 | collect (nth (mod i l)
104 | pattern-l))))
105 |
106 | ; (circle-repeat '(bb4 g4 f4) 20)
107 | ; (circle-repeat nil 3)
108 |
109 |
110 |
111 | (defun insert-at-position (position item list &key seed)
112 | "Insert item(s) at given position into list.
113 |
114 | * Arguments:
115 | - position: either symbol 's (start), 'e (end) or '? (random position), or integer specifying position.
116 | - item: value or list of values to be inserted.
117 | - list: flat list of values.
118 |
119 | * Examples:
120 | ;;; (insert-at-position 'e 'x '(a a a a))
121 | ;;; (insert-at-position 's 'x '(a a a a))
122 | ;;; (insert-at-position '? 'x '(a a a a))
123 | ;;; (insert-at-position 'e '(x y) '(a a a a))
124 | ;;; (insert-at-position '0 '(x y) '(a a a a))
125 | "
126 | (rnd-seed seed)
127 | (let* ((pos1 (case position
128 | (s 0)
129 | (e (length list))
130 | (? (round (rnd1 :low 0 :high (length list) :seed (seed))))
131 | (otherwise (if (numberp position)
132 | position
133 | (error "~A is not a valid position" position)))))
134 | (pos (if (listp item)
135 | (gen-integer pos1 (+ pos1 (1- (length item))))
136 | pos1)))
137 | (position-insert pos item list)))
138 |
139 |
140 | (defun keyword-to-om-symbol (key)
141 | "Translates the keyword `key' into a symbol of the Opusmodus package"
142 | (intern (symbol-name key) :om))
143 |
144 |
145 |
146 | #|
147 | ;; function not necessary -- use undocumented rnd-pick arg :encode nil
148 | (defun rnd-pick2 (selections &key (prob 0.5) seed)
149 | "Randomly selects a value from `selections' (without transforming that value).
150 | Very similar to rnd-pick, but leaves selected value unchanged (e.g., unflattened).
151 |
152 | Args
153 | prob: a floating-point number. Probability value. The default is 0.5.
154 |
155 | Example
156 | (rnd-pick2 '(((h q) (h))
157 | ((h. q) (h))
158 | ((h. h) (h))))
159 | => ((h. q) (h))
160 | "
161 | (rnd-seed seed)
162 | (nth (rnd1 :low 0 :high (1- (length selections)) :prob prob :seed (seed))
163 | selections))
164 |
165 | (rnd-pick '(((h q) (h))
166 | ((h. q) (h))
167 | ((h. h) (h))) :encode nil)
168 | |#
169 |
170 |
171 |
--------------------------------------------------------------------------------
/tests/OMN-utils.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | #|
4 |
5 | ;; Run different random tests each time
6 | (let ((*random-state* (make-random-state T)))
7 | (run! 'OMN-utils))
8 |
9 | (progn
10 | (asdf:load-system :tot)
11 | (run! 'OMN-utils))
12 | |#
13 |
14 |
15 | (in-package :om)
16 | ;; (in-package :tot/tests)
17 |
18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 | ;;;
20 | ;;; FiveAM setup
21 | ;;;
22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 |
24 | (5am:def-suite OMN-utils :in tot)
25 | (5am:in-suite OMN-utils)
26 |
27 |
28 | ;; TODO: map-events
29 |
30 |
31 | ;; ? TODO: process-element
32 |
33 | ;; ? TODO: map-omn
34 |
35 | ;; !! TODO: copy-time-signature (called often)
36 |
37 |
38 | ;; TODO: map-section
39 |
40 |
41 | ;; !! TODO: edit-omn
42 |
43 |
44 | ;; ? TODO: process-omn2
45 |
46 |
47 | ;; ? TODO: map-position-in-bar
48 |
49 |
50 | ;; !! TODO: total-duration
51 |
52 |
53 | ;; TODO: flattened-length-adjust
54 |
55 |
56 |
57 | ;; !! TODO: count-notes
58 |
59 |
60 | ;; TODO: phrase-lengths
61 |
62 |
63 |
64 | ;; TODO: length-subtract
65 |
66 |
67 |
68 | ;; TODO: length-add
69 |
70 |
71 | ;; ? TODO: rnd-section
72 |
73 |
74 | ;; ? TODO: mk-seed
75 |
76 |
77 | ;; TODO: ensure-double-list
78 |
79 |
80 |
81 | ;; TODO: fn-unfold
82 |
83 |
84 | ;; TODO: swap-args
85 |
--------------------------------------------------------------------------------
/tests/articulations.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | (in-package :om)
4 | ;; (in-package :tot/tests)
5 |
6 | #|
7 |
8 | ;; Run different random tests each time
9 | (let ((*random-state* (make-random-state T)))
10 | (5am:run! 'articulations))
11 |
12 | (progn
13 | (asdf:load-system :tot/tests)
14 | (5am:run! 'articulations))
15 |
16 | |#
17 |
18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 | ;;;
20 | ;;; FiveAM setup
21 | ;;;
22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 |
24 | (5am:def-suite articulations :in tot)
25 | (5am:in-suite articulations)
26 |
27 |
28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 | ;;;
30 | ;;; Process articulations
31 | ;;;
32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 |
34 | (5am:test articulate-bars
35 | (5am:is (equal '((H D4 STACC+MARC Q TIE) (H. D4 MARC) (Q D4 TIE+MARC D4 D4 STACC) (-Q D4))
36 | (articulate-bars '((h d4 stacc q tie) (h. d4) (q d4 tie q q stacc) (-q q d4))
37 | :accent 'marc)))
38 | (5am:is (equal '((S C4 F P C4) (S C4 F P C4) (S C4 F P C4))
39 | (articulate-bars (gen-repeat 3 '((s s s)))
40 | :accent 'f :default 'p :parameter :velocity))))
41 |
--------------------------------------------------------------------------------
/tests/karnatic-rhythm.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | #|
4 |
5 | ;; Run different random tests each time
6 | (let ((*random-state* (make-random-state T)))
7 | (run! 'karnatic-rhythm))
8 |
9 | (progn
10 | (asdf:load-system :tot)
11 | (run! 'karnatic-rhythm))
12 |
13 | (progn
14 | (asdf:load-system :tot)
15 | (run! 'anga))
16 |
17 | |#
18 |
19 |
20 | (in-package :om)
21 | ;; (in-package :tot/tests)
22 |
23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 | ;;;
25 | ;;; FiveAM setup
26 | ;;;
27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 |
29 | (5am:def-suite karnatic-rhythm :in tot)
30 | (5am:in-suite karnatic-rhythm)
31 |
32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 | ;;;
34 | ;;; Karnatic rhythmical techniques
35 | ;;;
36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 |
38 |
39 | ;; Simplistic tests, less intended for thoroughly testing the definitions, more as regression tests
40 | ;; in case things change in Opusmodus. For many functions (incl. this one) there is no dependency
41 | ;; to Opusmodus, though. These tests are secondary, just in case.
42 | (5am:test anga
43 | (5am:is (equal '(1/4) (anga :a)))
44 | (5am:is (equal '(1/2) (anga :d)))
45 | (5am:is (equal '(5/4) (anga :l 5))))
46 |
47 | (5am:test tala
48 | (5am:is (equal '((1/2) (3/4))
49 | (tala '(:d :l))))
50 | (5am:is (equal '((1/2) (5/4))
51 | (tala '(:d :l) 5)))
52 | (5am:is (equal '((1/4) (5/8))
53 | (tala '(:d :l) 5 1/8))))
54 |
55 |
56 | (5am:test tala-time-signatures
57 | ;; The given duration 5/2 lasts exactly the length of two cycles of the given tala.
58 | (5am:is (equal '((2 4 1) (3 4 1) (2 4 1) (3 4 1))
59 | (tala-time-signatures '(10/4)
60 | (tala '(:d :l) 3))))
61 | ;; If a duration is given that does not exactly fit into a repetition of the tala cycle, then the last returned time signature is correspondingly shorter.
62 | (5am:is (equal '((2 4 1) (3 4 1) (2 4 1) (2 4 1))
63 | (tala-time-signatures '(9/4)
64 | (tala '(:d :l) 3)))))
65 |
66 | (5am:test complete-phrase-in-tala
67 | (5am:is (equal '((H C4 TIE) (W C4 TIE+TIE Q TIE) (H C4 TIE) (W C4 TIE Q))
68 | (complete-phrase-in-tala '((7/2 c4)) :tala (tala '(:d :l) 5))))
69 | (5am:is (equal '((H C4 TIE) (W C4 TIE Q) (H C4))
70 | (complete-phrase-in-tala '((7/4 c4)) :tala (tala '(:d :l) 5) :append-sam? T))))
71 |
72 |
73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
74 | ;;
75 | ;; gen-karnatic-cell: central function, therefore must params are tested here with randomised tests
76 | ;;
77 |
78 | (5am:test gen-karnatic-cell_overall-length
79 | (5am:for-all ((gati (5am:gen-one-element 3 4 5 7))
80 | (jathi (5am:gen-integer :min 3 :max 7))
81 | ;; TODO: add guard excluding large positions depending on jathi
82 | (position (5am:gen-integer :min 0 :max 44))
83 | (accented? (5am:gen-one-element T NIL)))
84 | (5am:is (= jathi (* 4 gati (apply #'+ (gen-karnatic-cell gati jathi position :accented? accented?))))
85 | "The found cell has the wrong overall length.")))
86 |
87 | ;; TODO: Consider: define a macro similar to for-all that allows for tests like this, where
88 | ;; there could be arbitrary and possibly nested conditions on generated arguments and the result
89 | ;; applied to decide whether to test, but still it is ensured that tests are run 5am:*num-trials*
90 | ;; times.
91 | (5am:test gen-karnatic-cell_min/max-number
92 | (let ((i 0))
93 | (loop while (< i 5am:*num-trials*)
94 | for gati = (funcall (5am:gen-one-element 3 4 5 7))
95 | for jathi = (funcall (5am:gen-integer :min 3 :max 7))
96 | ;; Lower max position setting
97 | for position = (funcall (5am:gen-integer :min 0 :max 5))
98 | for accented? = (funcall (5am:gen-one-element T NIL))
99 | for max-number = (funcall (5am:gen-integer :min 1 :max 10))
100 | for min-number = (funcall (5am:gen-integer :min 1 :max 10))
101 | do (when (<= min-number max-number)
102 | (let ((result (gen-karnatic-cell gati jathi position :accented? accented?
103 | :min-number min-number :max-number max-number)))
104 | (when result ;; ensure there is a result with these args
105 | (5am:is (<= min-number (length result))
106 | "Result too short with arg min-number for (gen-karnatic-cell ~A ~A ~A :accented? ~A :min-number ~A :max-number ~A)"
107 | gati jathi position accented? min-number max-number)
108 | (5am:is (>= max-number (length result))
109 | "Result too long with arg max-number for (gen-karnatic-cell ~A ~A ~A :accented? ~A :min-number ~A :max-number ~A)"
110 | gati jathi position accented? min-number max-number)
111 | (setf i (+ i 1))))))))
112 |
113 | (5am:test gen-karnatic-cell_first-length
114 | (let ((i 0))
115 | (loop while (< i 5am:*num-trials*)
116 | for gati = (funcall (5am:gen-one-element 3 4 5 7))
117 | for jathi = (funcall (5am:gen-integer :min 3 :max 7))
118 | ;; Lower max position setting
119 | for position = (funcall (5am:gen-integer :min 0 :max 5))
120 | for accented? = (funcall (5am:gen-one-element T NIL))
121 | for first-length = (funcall (5am::gen-ratio :numerator (5am:gen-one-element 1 2 3 4 5 6)
122 | :denominator (5am:gen-one-element 8 16)))
123 | do (let ((result (gen-karnatic-cell gati jathi position :accented? accented?
124 | :first-length first-length)))
125 | (when result ;; ensure there is a result with these args
126 | (5am:is (= first-length (first result)))
127 | (setf i (+ i 1)))))))
128 |
129 | (5am:test gen-karnatic-cell_include/exclude-length
130 | (let ((i 0))
131 | (loop while (< i 5am:*num-trials*)
132 | for gati = (funcall (5am:gen-one-element 3 4 5 7))
133 | for jathi = (funcall (5am:gen-integer :min 3 :max 7))
134 | ;; Lower max position setting
135 | for position = (funcall (5am:gen-integer :min 0 :max 5))
136 | for accented? = (funcall (5am:gen-one-element T NIL))
137 | for include-length = (funcall (5am::gen-ratio :numerator (5am:gen-one-element 1 2 3 4 5 6)
138 | :denominator (5am:gen-one-element 8 16)))
139 | for exclude-length = (funcall (5am::gen-ratio :numerator (5am:gen-one-element 1 2 3 4 5 6)
140 | :denominator (5am:gen-one-element 8 16)))
141 | do (when (/= include-length exclude-length)
142 | (let ((result (gen-karnatic-cell gati jathi position :accented? accented?
143 | :include-length include-length :exclude-length exclude-length)))
144 | (when result ;; ensure there is a result with these args
145 | (5am:is (member include-length result))
146 | (5am:is (not (member exclude-length result)))
147 | (setf i (+ i 1))))))))
148 |
149 |
--------------------------------------------------------------------------------
/tests/package.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
2 |
3 | (in-package :om)
4 |
5 | #|
6 | ;; Packages OM and FiveAM have name conflicts for external OM symbols GEN-INTEGER and RUN and internal symbols TEST, PASS and SKIP (the latter have no value nor function value)
7 | ;;
8 | ;; Import the defs of FiveAM.
9 | (shadowing-import '(5AM:GEN-INTEGER 5AM:RUN 5AM:TEST 5AM:PASS 5AM:SKIP) :OM)
10 | (use-package '(:FiveAM) :OM)
11 |
12 | ;; (describe 'om::test)
13 |
14 |
15 | ;; BUG: This is not working, because some tests depend on tot functions that call the Opusmodus function gen-integer.
16 | ;; Two possible solutions:
17 | ;; - Use OM package directly for TOT, and do not import FiveAM. Always define tests with 5am:test etc.
18 | ;; - Define a proper TOT package that imports OM and exports all its relevant symbols, incl. all the automatically created microtonal accidentals.
19 | ;; The first option for now is simpler, which is whatg I am currently doing...
20 | ;;
21 |
22 | |#
23 |
24 | #|
25 | ;; NOTE: The symbols of my library TOT are not exported, and therefore these symbols would not be used/imported by the tot/test package created here.
26 | ;; TMP solution: for now define tests in OM package.
27 | ;; TODO: define a custom package for both tot and tot/tests, and export all relevant symbols from tot, incl. all the automatically created microtonal accidentals.
28 | (defpackage #:tot/tests
29 | (:use #:cl
30 | #:FiveAM
31 | #:om)
32 | ;; Packages OM and FiveAM have name conflicts for symbols GEN-INTEGER and RUN. Import the defs of FiveAM.
33 | (:shadowing-import-from #:FiveAM #:GEN-INTEGER #:RUN)
34 | #|
35 | (:export #:run!
36 | #:all-tests
37 | )
38 | |#
39 | )
40 | |#
41 |
42 |
43 |
44 |
45 | #|
46 | (defpackage #:tot/tests
47 | (:use #:cl
48 | #:om
49 | #:rove))
50 | |#
51 |
52 |
--------------------------------------------------------------------------------
/tests/rhythm.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | #|
4 |
5 | ;; Run different random tests each time
6 | (let ((*random-state* (make-random-state T)))
7 | (run! 'rhythm))
8 |
9 | (progn
10 | (asdf:load-system :tot)
11 | (run! 'rhythm))
12 | |#
13 |
14 |
15 | (in-package :om)
16 | ;; (in-package :tot/tests)
17 |
18 |
19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20 | ;;;
21 | ;;; FiveAM setup
22 | ;;;
23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 |
25 | (5am:def-suite rhythm :in tot)
26 | (5am:in-suite rhythm)
27 |
28 |
29 |
30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 | ;;;
32 | ;;; Rhythm generation
33 | ;;;
34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 |
36 |
37 |
38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 | ;;;
40 | ;;; Rhythm transformation
41 | ;;;
42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
43 |
44 |
45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 | ;;;
47 | ;;; Rhythm utilities
48 | ;;;
49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
50 |
51 |
52 |
53 |
--------------------------------------------------------------------------------
/tests/setup-tests.lisp:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | (in-package :5am)
4 | ;; (in-package :om)
5 | ;; (in-package :tot/tests)
6 |
7 |
8 | #|
9 | ;; ASDF interface for running all tests
10 | (asdf:test-system :tot)
11 |
12 | ;; Run different random tests each time
13 | (let ((*random-state* (make-random-state T)))
14 | (5am:run! 'tot))
15 |
16 | (progn
17 | (asdf:load-system :tot/tests)
18 | (5am:run! 'om::tot))
19 | |#
20 |
21 |
22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 | ;;;
24 | ;;; FiveAM setup
25 | ;;;
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 |
28 | (declaim (optimize (speed 0) (space 0) (debug 3)))
29 |
30 | ;; Interactive debugging
31 | (setf *on-error* :DEBUG)
32 | ;; (setf *on-error* :BACKTRACE)
33 | ;; (setf *on-error* NIL)
34 | (setf *on-failure* :debug)
35 |
36 | ;; NOTE: reduce number of trials for speeding up during test developments
37 | ;; (setf *num-trials* 10)
38 | (setf *num-trials* 100)
39 | ;; (setf *num-trials* 1000)
40 |
41 | ;; When non-NIL tests are run as soon as they are defined.
42 | ;; (setf *run-test-when-defined* T)
43 | (setf *run-test-when-defined* NIL)
44 |
45 | ;; T if we should print the expression failing, NIL otherwise.
46 | (setf *verbose-failures* T)
47 |
48 |
49 | ;; Copied from cluster-engine-test-utils.lisp
50 | (defun gen-selection (&key (length (gen-integer :min 0 :max 10))
51 | elements)
52 | "Return a generator that picks LENGTH values (int or generator) from ELEMENTS (list of ints or generator) without repeating them. Must be called less often than length of ELEMENTS."
53 | (lambda ()
54 | (let ((length* (if (functionp length)
55 | (funcall length)
56 | length))
57 | (elements-copy (if (functionp elements)
58 | (copy-list (funcall elements))
59 | (copy-list elements))))
60 | (assert (<= length* (length elements-copy))
61 | (length elements)
62 | "Cannot pick ~A different elements from ~A." length* elements)
63 | (loop for i from length* downto 1
64 | for pos = (random (length elements-copy))
65 | collect (tu:pop-nth elements-copy pos)))))
66 | #|
67 | (setf my-gen (gen-selection :length (gen-integer :min 1 :max 3) :elements '((-1/2) (-1/4) (-1/8) (1/8) (1/4) (1/2))))
68 | (funcall my-gen)
69 | |#
70 |
71 | ;; Copied from cluster-engine-test-utils.lisp
72 | (defun gen-ratio (&key
73 | ;; (numerator (gen-integer :min -7 :max 7))
74 | ;; no grace-notes for now
75 | (numerator (gen-one-element -5 -4 -3 -2 -1 1 2 3 4 5 6))
76 | (denominator (gen-one-element 1 2 4 8 16)))
77 | "Return a generator that produces a ratio. NUMERATOR and DENOMINATOR are both integer generators with default values suitable for standard Cluster Engine rhythmic values."
78 | (lambda ()
79 | (/ (funcall numerator) (funcall denominator))))
80 |
81 |
82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83 |
84 | (in-package :om)
85 |
86 | (5am:def-suite tot
87 | :description "Top-level test suite")
88 |
89 |
90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
91 |
92 | #|
93 | (in-package :5am)
94 |
95 | ;; BUG: Always returns the same value
96 | (funcall (gen-one-element -5 -4 -3 -2 -1 1 2 3 4 5 6))
97 | (funcall (gen-one-element 1 2 4 8 16))
98 |
99 | (setf my-gen (gen-ratio))
100 | (funcall my-gen)
101 |
102 | ;; Generate a rhythmic motif
103 | (setf my-gen (gen-list :length (gen-integer :min 1 :max 5) :elements (gen-ratio)))
104 | (funcall my-gen)
105 |
106 | ;; Generate a rhythmic domain
107 | (setf my-gen (gen-list :length (gen-integer :min 1 :max 5)
108 | :elements (gen-list :length (gen-integer :min 1 :max 5) :elements (gen-ratio))))
109 | (funcall my-gen)
110 | |#
111 |
112 |
113 | #|
114 | (loop repeat 100
115 | collect (funcall (gen-ratio)))
116 |
117 |
118 | (setf *random-state* (make-random-state T))
119 | (loop repeat 10
120 | collect (random 1000))
121 |
122 | (let ((*random-state* (make-random-state T)))
123 | (loop repeat 10
124 | collect (random 1000)))
125 |
126 | (loop repeat 10
127 | collect (random 1000 (make-random-state)))
128 |
129 | (loop repeat 10
130 | collect (random 1000 (make-random-state T)))
131 |
132 |
133 | (funcall (gen-integer))
134 | (funcall (gen-one-element 1 2 3 4 5))
135 |
136 | ;; BUG: Always the same value
137 | (setf min 1 max 1000)
138 | (+ min (random (1+ (- max min))))
139 | |#
140 |
141 |
142 |
143 | #|
144 | (in-package :5am)
145 |
146 | (test dummy
147 | (for-all ((xs (gen-list)))
148 | (let ((result (reverse xs)))
149 | (when result
150 | (is (equal xs (reverse result)))))))
151 |
152 | (test dummy
153 | (for-all ((xs (gen-list)))
154 | (for-all ((result (lambda () (reverse xs))
155 | ;; xs is not empty
156 | xs))
157 | (is (equal xs (reverse result))))))
158 |
159 |
160 | ;; Error: Slot TEST-EXPR is unbound in #
161 | (test dummy
162 | (for-all ((xs (gen-list)))
163 | (when xs
164 | (is (< 0 (length xs))))))
165 |
166 | ;; Slot TEST-EXPR is unbound in #
167 | (test dummy
168 | (for-all ((l (gen-integer :min 0 :max 10)))
169 | (for-all ((xs (gen-list :length (lambda () l))
170 | xs))
171 | (is (equal l (length xs))))))
172 |
173 |
174 | ;; Cases above made working by replacing for-all with a loop
175 | (test dummy
176 | (loop repeat 100
177 | for xs = (funcall (gen-list))
178 | do (when xs
179 | (is (< 0 (length xs))))))
180 |
181 | (test dummy
182 | (loop repeat 100
183 | for l = (funcall (gen-integer :min 0 :max 10))
184 | for xs = (funcall (gen-list :length (lambda () l)))
185 | do (when xs
186 | (is (< 0 (length xs))))))
187 |
188 | ;; Working test with dependency between generator values
189 | (test dummy
190 | (for-all ((l (gen-integer :min 0 :max 10)))
191 | (for-all ((xs (gen-list :length (lambda () l))))
192 | (is (equal l (length xs))))))
193 |
194 |
195 | ;; Working
196 | (test dummy
197 | (for-all ((xs (gen-list)))
198 | (let ((result (reverse xs)))
199 | (is (equal xs (reverse result))))))
200 |
201 | (let ((*random-state* (make-random-state T)))
202 | (run!' dummy))
203 | |#
204 |
205 |
--------------------------------------------------------------------------------
/tot.asd:
--------------------------------------------------------------------------------
1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 |
3 | (in-package :asdf-user)
4 |
5 | #-opusmodus
6 | (error "This library depends on the commercial composition system Opusmodus, http://opusmodus.com.")
7 |
8 | (asdf:defsystem tot
9 | :description "Torsten's Opusmodus Tools (TOT) is a collection of definitions that extend the algorithmic composition system Opusmodus (http://opusmodus.com/). Note that these tools have been developed for personal use for specific projects, and therefore their generality (or even applicabiliy) for other projects might be limited. Nevertheless, at least I tried to document their purpose and limitations."
10 | :author "Torsten Anders "
11 | :licence "GNU General Public License, Version 3"
12 | :source-control "https://github.com/tanders/tot"
13 | :version "0.3"
14 | :components ((:module "sources"
15 | :serial t
16 | :components (; (:file "package")
17 | (:file "macros")
18 | ;; (:file "slippery-chicken") ;; independent
19 | (:file "utils")
20 | (:file "minizinc")
21 | (:file "OMN-utils")
22 | (:file "midi")
23 | (:file "score")
24 | (:file "rhythm")
25 | (:file "karnatic-rhythm")
26 | (:file "pitch")
27 | (:file "tuning")
28 | (:file "velocity")
29 | (:file "articulations")
30 | (:file "PWGL")
31 | (:file "constraints")
32 | (:file "form")
33 | (:file "orchestration")
34 | ;; (:file "sources/export")
35 | )))
36 | ;; :if-feature :opusmodus
37 | ;;; !! NOTE: This code additionally depends on the commercial system Opusmodus
38 | :depends-on (;; https://common-lisp.net/project/alexandria/
39 | ;; Alexandria should already be loaded with Opusmodus
40 | "alexandria"
41 | ;; https://common-lisp.net/project/cl-utilities/
42 | "cl-utilities"
43 | ;; Libraries by Torsten Anders, see https://github.com/tanders?tab=repositories
44 | "string-tools"
45 | "ta-utilities"
46 | "fenv"
47 | "cluster-rules")
48 | :in-order-to ((test-op (test-op #:tot/tests))))
49 |
50 | (defsystem #:tot/tests
51 | :depends-on (:FiveAM :tot)
52 | :components ((:module "tests"
53 | :serial t
54 | :components ((:file "package")
55 | (:file "setup-tests")
56 | (:file "karnatic-rhythm")
57 | (:file "articulations")
58 | (:file "OMN-utils")
59 | )))
60 | :perform (test-op (o s)
61 | ;; Find and run top-level test suite
62 | (uiop:symbol-call :fiveam '#:run!
63 | (uiop:find-symbol* '#:tot :om)
64 | ;; (uiop:find-symbol* '#:tot :tot/tests)
65 | )))
66 |
67 | ;;
68 | ;; Opusmodus setup (this cannot be set in ~/Opusmodus/Extensions for some reason.
69 | ;;
70 |
71 | ;; For details see https://opusmodus.com/forums/topic/1391-disabling-do-verbose/
72 | (defparameter om::*do-verbose* nil
73 | "Enable or disable traces printed by do-verbose.")
74 |
75 |
76 |
--------------------------------------------------------------------------------