]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Semantics.hs
Volume modification.
[tmp/julm/arpeggigon.git] / src / RMCA / Semantics.hs
1 -- Basic Semantics V2 for a Reactive Music Cellular Automaton.
2 -- Inspired by the reacTogon.
3 -- Written by Henrik Nilsson, 2016-05-27
4 -- Based on an earlier version.
5 --
6 -- This gives the semantics of a single RMCA layer. The output is
7 -- a high-level representation of notes for each beat. This is to be
8 -- translated to low-level MIDI message by a subsequent translator
9 -- responsible for merging notes from different layers, ensuring that
10 -- a note off message corresponding to each note on message is always
11 -- emitted after the appropriate time, rendering any embellismnets
12 -- such as slides (while not generating too much MIDI data), etc.
13
14 -- ToDo:
15 -- * Add boolean flag to change direction to indicate start tile
16 -- DONE!
17 -- * Change main routine to generate start play heads from board
18 -- DONE!
19 -- * Add an optional restart facility: Maybe Int, restart every n
20 -- bars.
21 -- DONE!
22 -- * Interpret a negative repeat as repeat indefinitely.
23 -- DONE!
24 -- * Interpret a non-positve duration as mute: don't emit any note.
25 -- DONE!
26 -- * Eliminate Ignore as now almost the same as Absorb with duration 0?
27 -- The only difference is that Absorb mostly overrides the repeat count.
28 -- Absorb = Stop {duration 0, repeat 1}
29 -- And as absorb might be a common case, it might be useful to have
30 -- a distinct graphical representation?
31 -- DECIDED AGAINST FOR NOW
32
33 module RMCA.Semantics where
34
35 import Data.Array
36 import Data.List (intercalate, nub)
37 import Data.Maybe (catMaybes)
38 import RMCA.Auxiliary.Auxiliary
39
40
41 ------------------------------------------------------------------------------
42 -- Basic Type Synonyms
43 ------------------------------------------------------------------------------
44
45 -- Unipolar control value; [0, 1]
46 type UCtrl = Double
47
48 -- Bipolar control value; [-1, 1]
49 type BCtrl = Double
50
51 -- Unipolar control values are usually between 0 and 127.
52 toUCtrl :: Int -> UCtrl
53 toUCtrl x = fromIntegral x / 127
54
55 fromUCtrl :: UCtrl -> Int
56 fromUCtrl x = floor $ bound (0,1) x * 127
57
58 -- Bipolar control values are usually between -127 and 127.
59 toBCtrl :: Int -> BCtrl
60 toBCtrl = toUCtrl
61
62 fromBCtrl :: BCtrl -> Int
63 fromBCtrl = fromUCtrl
64
65 ------------------------------------------------------------------------------
66 -- Tempo
67 ------------------------------------------------------------------------------
68
69 type Tempo = Int
70
71 -- LTempo designates a layer tempo. Useful for not transforming twice
72 -- a tempo.
73 type LTempo = Tempo
74
75 ------------------------------------------------------------------------------
76 -- Time and Beats
77 ------------------------------------------------------------------------------
78
79 -- The assumption is that the automaton is clocked by a beat clock and
80 -- thus advances one step per beat. For an automaton working in real time,
81 -- the beat clock would be defined externally, synchronized with other
82 -- layers and possibly external MIDI, and account for tempo, any swing, etc.
83
84 -- Beats and Bars
85
86 -- A beat as such is nothing.
87 type Beat = ()
88
89 -- Beats per Bar: number of beats per bar in the time signature of a layer.
90 -- Non-negative.
91 type BeatsPerBar = Int
92
93 -- The beat number in the time signature of the layer. The first beat is 1.
94 type BeatNo = Int
95
96 nextBeatNo :: BeatsPerBar -> BeatNo -> BeatNo
97 nextBeatNo bpb bn = bn `mod` bpb + 1
98
99
100 {-
101 -- Not needed for individual layers (at present)
102
103 -- Time; [0,+inf)
104 type Time = Double
105 -}
106
107
108 ------------------------------------------------------------------------------
109 -- MIDI
110 ------------------------------------------------------------------------------
111
112 -- This semantics mainly works with a high-level represemntation of notes.
113 -- But it is convenient to express some of the high-level aspects directly
114 -- in the corresponding MIDI terms to facilitate the translation.
115
116 -- MIDI note number; [0,127]
117 type MIDINN = Int
118
119
120 -- Assume MIDI convetion: 60 = "Middle C" = C4
121 middleC :: Int
122 middleC = 60
123 middleCOct :: MIDINN
124 middleCOct = 4
125
126
127 -- MIDI velocity; [0,127]
128 type MIDIVel = Int
129
130
131 -- MIDI Program Change: Program Number; [0,127]
132 type MIDIPN = Int
133
134
135 -- MIDI Control Change: Control Number and Control Value; [0,127]
136 type MIDICN = Int
137 type MIDICV = Int
138
139 -- MIDICVRnd gives the option to pick a control value at random.
140 -- (Handled through subsequent translation to low-level MIDI events.)
141 data MIDICVRnd = MIDICV MIDICV | MIDICVRnd deriving (Eq, Show)
142
143 --
144 ------------------------------------------------------------------------------
145 -- Notes
146 ------------------------------------------------------------------------------
147
148 -- Pitch
149
150 -- We chose to represent pitch by MIDI note number
151 newtype Pitch = Pitch MIDINN deriving Eq
152
153 pitchToMNN :: Pitch -> MIDINN
154 pitchToMNN (Pitch nn) = nn
155
156 instance Show Pitch where
157 show (Pitch nn) = names !! note ++ show oct
158 where
159 nn' = nn - middleC
160 note = nn' `mod` 12
161 oct = nn' `div` 12 + middleCOct
162 names = ["C", "C#", "D", "D#", "E", "F",
163 "F#", "G", "G#", "A", "A#", "B"]
164
165 -- Relative pitch in semi tones. Used for e.g. transposition.
166 type RelPitch = Int
167
168
169 -- Articulation
170
171 -- Each layer has a setting that indicate how strongly the notes
172 -- should normally be played as a percentage of full strength.
173 -- (In the real application, this settig can be set to a fixed value
174 -- or set to be derived from teh last input note, "as played").
175 -- Individual notes can tehn be accented (played more strongly),
176 -- either unconditionally or as a function of the beat count.
177
178 type Strength = UCtrl
179
180 -- This could of course be generalised, e.g. a list of beat numbers to
181 -- accentuate. But this is simple and accounts for the most common patterns.
182 data Articulation = NoAccent
183 | Accent
184 | Accent1
185 | Accent13
186 | Accent14
187 | Accent24
188 deriving (Eq, Show, Enum)
189
190 accentStrength :: Strength
191 accentStrength = 1.2
192
193 -- Articulated strength
194 articStrength :: Strength -> BeatNo -> Articulation -> Strength
195 articStrength st bn art
196 | accentedBeat = st * accentStrength
197 | otherwise = st
198 where
199 accentedBeat =
200 case (bn, art) of
201 (_, NoAccent) -> False
202 (_, Accent) -> True
203 (1, Accent1) -> True
204 (1, Accent13) -> True
205 (3, Accent13) -> True
206 (1, Accent14) -> True
207 (4, Accent14) -> True
208 (1, Accent24) -> True
209 (4, Accent24) -> True
210 _ -> False
211
212
213 -- Duration
214
215 -- Duration in terms of a whole note at the *system* tempo. (Each layer
216 -- is clocked at a layer beat that is a fraction/multiple of the system
217 -- tempo). Note that notes are played a little shorter than their nominal
218 -- duration. This is taken care of by the translation into low-level
219 -- MIDI events. (One might consider adding indications of staccato or
220 -- tenuto.)
221 --
222 -- A non-positive duration is interpreted as mute: no note emitted.
223 type Duration = Rational
224
225
226 -- Ornamentation
227
228 -- Notes can be ornamented. Traditionnally, ornamenting refers to modifications
229 -- of the pitch, such as a trill or a grace note. Here we use the term in
230 -- a generalised sense.
231 -- * A MIDI program change (to be sent before the note).
232 -- * A MIDI Continuous Controler Change (to be sent before the note).
233 -- * A Slide
234 -- One might also consider adding trills, grace notes, MIDI after touch ...
235
236 data Ornaments = Ornaments {
237 ornPC :: Maybe MIDIPN,
238 ornCC :: [(MIDICN, MIDICVRnd)],
239 ornSlide :: SlideType
240 } deriving Show
241
242 data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show, Enum)
243
244 noOrn :: Ornaments
245 noOrn = Ornaments { ornPC = Nothing
246 , ornCC = []
247 , ornSlide = NoSlide
248 }
249
250 -- Notes
251
252 -- Attributes needed to generate a note.
253 -- * The pitch of a note is given by the position on the board
254 -- * The strength is given by the layer strength, beat no., and articulation
255 -- * Duratio and Ornamentatio are stored
256 data NoteAttr = NoteAttr {
257 naArt :: Articulation,
258 naDur :: Duration,
259 naOrn :: Ornaments
260 } deriving Show
261
262
263 -- High level note representation emitted form a layer
264 data Note = Note {
265 notePch :: Pitch,
266 noteStr :: Strength,
267 noteDur :: Duration,
268 noteOrn :: Ornaments
269 } deriving Show
270
271
272 ------------------------------------------------------------------------------
273 -- Board
274 ------------------------------------------------------------------------------
275
276 -- Numbering; row number inside tile, column number below:
277 -- _ _
278 -- _/2\_/2\_
279 -- / \_/1\_/1\
280 -- \_/1\_/1\_/
281 -- / \_/0\_/0\
282 -- \_/0\_/0\_/
283 -- \_/ \_/
284 -- -1 0 1 2
285
286
287 -- Angle measured in multiples of 60 degrees.
288 type Angle = Int
289
290 data Dir = N | NE | SE | S | SW | NW deriving (Enum, Bounded, Eq, Show)
291
292 predDir :: Dir -> Dir
293 predDir d | d == minBound = maxBound
294 | otherwise = pred d
295
296 nextDir :: Dir -> Dir
297 nextDir d | d == maxBound = minBound
298 | otherwise = succ d
299
300 turn :: Dir -> Angle -> Dir
301 turn d a = toEnum ((fromEnum d + a) `mod` 6)
302
303
304 type Pos = (Int, Int)
305
306 -- Position of neighbour in given direction
307 neighbor :: Dir -> Pos -> Pos
308 neighbor N (x,y) = (x, y + 1)
309 neighbor NE (x,y) = (x + 1, y + 1 - x `mod` 2)
310 neighbor SE (x,y) = (x + 1, y - x `mod` 2)
311 neighbor S (x,y) = (x, y - 1)
312 neighbor SW (x,y) = (x - 1, y - x `mod` 2)
313 neighbor NW (x,y) = (x - 1, y + 1 - x `mod` 2)
314
315
316 -- Position and transposition to pitch:
317 -- * Harmonic Table" layout: N = +7; NE = +4; SE = -3
318 -- * (0,0) assumed to be "Middle C"
319 posToPitch :: Pos -> RelPitch -> Pitch
320 posToPitch (x,y) tr =
321 Pitch (y * 7 + x `div` 2 - 3 * (x `mod` 2) + middleC + tr)
322
323
324 -- Actions
325 -- A ChDir counter is optionally a start counter if the Boolean flag is
326 -- set to true.
327 -- Any counter can be made silent by setting the note duration to a
328 -- non-positive number.
329
330 data Action = Inert -- No action, play heads move through.
331 | Absorb -- Remove play head silently.
332 | Stop NoteAttr -- Play note then remove play head.
333 | ChDir Bool NoteAttr Dir -- Play note then change direction.
334 | Split NoteAttr -- Play note then split head into five.
335 deriving (Show)
336
337
338 -- Cells
339 -- A cell stores an action and a repetition number.
340 -- 0: the cell is completely bypassed, as if it wasn't there.
341 -- 1: the action is carried out once (default)
342 -- n > 1: any note output of the action is repeated (n-1) times before the
343 -- action is carried out.
344 -- n < 0: any note output of the action is repeated indefinitely (oo).
345
346 type Cell = (Action, Int)
347
348
349 -- Make a cell with a default repeat count of 1.
350 mkCell :: Action -> Cell
351 mkCell a = mkCellRpt a 1
352
353
354 -- Make a cell with a non-default repeition number.
355 mkCellRpt :: Action -> Int -> Cell
356 mkCellRpt a n = (a, n)
357
358
359 -- Board extent: south-west corner and north-east corner.
360 -- This covers most of the MIDI range: A#-1 (10) to G7 (103).
361 swc, nec :: Pos
362 swc = (-9, -6)
363 nec = (9, 6)
364
365
366 -- Test if a position is on the board as defined by swc and nec.
367 -- The assumption is that odd columns contain one more cell, as per the
368 -- picture above. Of course, one could opt for a "zig-zag" layout
369 -- with each column having the same number of cells which would be slightly
370 -- simpler.
371 onBoard :: Pos -> Bool
372 onBoard (x,y) = xMin <= x && x <= xMax
373 && yMin <= y
374 && (if even x then
375 y < yMax
376 else
377 y <= yMax)
378 where
379 (xMin, yMin) = swc
380 (xMax, yMax) = case nec of
381 (x, y) | even x -> (x, y + 1)
382 | otherwise -> (x, y)
383
384
385 type Board = Array Pos Cell
386
387
388 -- Build a board from a list specifying the non-empty cells.
389 makeBoard :: [(Pos, Cell)] -> Board
390 makeBoard pcs =
391 array (swc,nec')
392 ([(p, if onBoard p then mkCell Inert else mkCell Absorb)
393 | p <- range (swc, nec')]
394 ++ [(p,c) | (p, c) <- pcs, onBoard p])
395 where
396 -- This is to ensure (neighbor NW nec) is included on the board,
397 -- regardless of whether the column of nec is even or odd.
398 -- Otherwise, due to the "jagged" upper edge, the top row would
399 -- be missing, but every other cell of that *is* on the board.
400 -- The "superfluous" cells are set to Absorb above.
401 nec' = neighbor N nec
402
403
404 -- Look up a cell
405 lookupCell :: Board -> Pos -> Cell
406 lookupCell b p = if onBoard p then b ! p else (Absorb, 1)
407
408
409 ------------------------------------------------------------------------------
410 -- Play Head
411 ------------------------------------------------------------------------------
412
413 -- A play head is characterised by:
414 -- * Current position
415 -- * Number of beats before moving
416 -- * Direction of travel
417 -- If an action involves playing a note, this is repeated once for
418 -- each beat the play head is staying, with the rest of the action
419 -- carried out at the last beat.
420
421 data PlayHead =
422 PlayHead {
423 phPos :: Pos,
424 phBTM :: Int,
425 phDir :: Dir
426 }
427 deriving (Eq, Show)
428
429
430 ------------------------------------------------------------------------------
431 -- Start Heads
432 ------------------------------------------------------------------------------
433
434 startHeads :: Board -> [PlayHead]
435 startHeads bd =
436 [ PlayHead {
437 phPos = p,
438 phBTM = n,
439 phDir = d
440 }
441 | (p, (ChDir True _ d, n)) <- assocs bd ]
442
443
444 ------------------------------------------------------------------------------
445 -- State transition
446 ------------------------------------------------------------------------------
447
448 -- Advance the state of a single play head.
449 --
450 -- The result is a list of heads to be actioned at the *next* beat
451 -- later) and possibly a note to be played at *this* beat.
452
453 advanceHead :: Board -> BeatNo -> RelPitch -> Strength -> PlayHead
454 -> ([PlayHead], Maybe Note)
455 advanceHead bd bn tr st ph = ahAux (moveHead bd ph)
456 where
457 ahAux ph@PlayHead {phPos = p, phBTM = btm, phDir = d} =
458 case fst (lookupCell bd p) of
459 Inert -> ([ph], Nothing)
460 Absorb -> ([], Nothing) -- No point waiting until BTM=0
461 Stop na -> (newPHs [], mkNote p bn tr st na)
462 ChDir _ na d' -> (newPHs [ph {phDir = d'}],
463 mkNote p bn tr st na)
464 Split na -> (newPHs [ PlayHead {
465 phPos = p,
466 phBTM = 0,
467 phDir = d'
468 }
469 | a <- [-2 .. 2],
470 let d' = turn d a
471 ],
472 mkNote p bn tr st na)
473 where
474 newPHs phs = if btm == 0 then phs else [ph]
475
476
477 -- Moves a play head if the BTM counter has reached 0, otherwise decrement BTM.
478 -- Any encountered cells where the repeat count is < 1 are skipped.
479 moveHead :: Board -> PlayHead -> PlayHead
480 moveHead bd (ph@PlayHead {phPos = p, phBTM = btm, phDir = d})
481 | btm == 0 = let
482 p' = neighbor d p
483 btm' = snd (lookupCell bd p')
484 in
485 moveHead bd (ph {phPos = p', phBTM = btm'})
486 | btm > 0 = ph {phBTM = btm - 1}
487 | otherwise = ph -- Repeat indefinitely
488
489 mkNote :: Pos -> BeatNo -> RelPitch -> Strength -> NoteAttr -> Maybe Note
490 mkNote p bn tr st na@NoteAttr {naDur = d}
491 | d <= 0 = Nothing -- Notes of non-positive length are silent.
492 | otherwise = Just
493 Note {
494 notePch = posToPitch p tr,
495 noteStr = articStrength st bn (naArt na),
496 noteDur = naDur na,
497 noteOrn = naOrn na
498 }
499
500
501 -- Advance a list of heads, collecting all resulting heads and notes.
502 -- Any duplicate play heads are eliminated (or their number may uselessly
503 -- grow very quickly), and a cap (50, arbitrary, but should be plenty,
504 -- expecially given the board size) on the number of simultaneous playheads
505 -- per layer is imposed.
506 advanceHeads :: Board -> BeatNo -> RelPitch -> Strength -> [PlayHead]
507 -> ([PlayHead], [Note])
508 advanceHeads bd bn tr st phs =
509 let
510 (phss, mns) = unzip (map (advanceHead bd bn tr st) phs)
511 in
512 (take 50 (nub (concat phss)), catMaybes mns)
513
514
515 -- Given a board with start counters, run a board indefinitely, optionally
516 -- restarting every ri bars.
517 --
518 -- Arguments:
519 -- (1) Board (bd)
520 -- (2) Beats Per Bar (bpb); > 0
521 -- (3) Optioal repeat Interval (mri); In bars.
522 -- (4) Transposition (tr)
523 -- (5) Strength (st)
524 --
525 -- Returns:
526 -- Stream of notes played at each beat.
527 --
528 -- In the real implementation:
529 -- * A layer beat clock would be derived from the system beat (as a
530 -- fraction/multiple, adding any swing) and each clock event be tagged
531 -- with the beat number.
532 -- * The board (bd) would not necessarily be a constant input. (One might
533 -- consider allowing editing a layer while the machine is running)
534 -- * The time signature, and thus the beats per par (bpb), along with
535 -- repeat interval (ri) would likely be static (only changeable while
536 -- automaton is stopped).
537 -- * The transposition (tr) would be dynamic, the sum of a per layer
538 -- transposition that can be set through the user interface and the
539 -- difference between the MIDI note number of the last external
540 -- note received for the layer and middle C (say).
541 -- * The strength (st) would be dynamic, configurable as either the strength
542 -- set through the user interface or the strength of the last external
543 -- note received for the layer (derived from its MIDI velocity).
544
545 runRMCA :: Board -> BeatsPerBar -> Maybe Int -> RelPitch -> Strength
546 -> [[Note]]
547 runRMCA bd bpb mri tr st
548 | bpb > 0 =
549 case mri of
550 Nothing -> nss
551 Just ri
552 | ri > 0 -> cycle (take (ri * bpb) nss)
553 | otherwise -> error "The repeat interval must be at \
554 \least 1 bar."
555 | otherwise = error "The number of beats per bar must be at least 1."
556 where
557 nss = runAux 1 (startHeads bd)
558
559 runAux bn phs = ns : runAux (nextBeatNo bpb bn) phs'
560 where
561 (phs', ns) = advanceHeads bd bn tr st phs
562
563
564 -- Print played notes in a time-stamped (bar, beat), easy-to-read format.
565
566 ppNotes :: BeatsPerBar -> [[Note]] -> IO ()
567 ppNotes bpb nss = ppnAux (zip [(br,bn) | br <- [1..], bn <- [1..bpb]] nss)
568 where ppnAux :: [((Int,BeatsPerBar),[Note])] -> IO ()
569 ppnAux [] = return ()
570 ppnAux ((_, []) : tnss) = ppnAux tnss
571 ppnAux ((t, ns) : tnss) = do
572 putStrLn (leftJustify 10 (show t) ++ ": "
573 ++ intercalate ", " (map show ns))
574 ppnAux tnss
575
576
577 leftJustify :: Int -> String -> String
578 leftJustify w s = replicate (w - length s) ' ' ++ s
579
580 {-
581 ------------------------------------------------------------------------------
582 -- Simple tests
583 ------------------------------------------------------------------------------
584
585 testBoard1 =
586 makeBoard [((0,0), mkCell (ChDir True na1 N)),
587 ((0,1), mkCell (ChDir False na1 SE)),
588 ((1,1), mkCell (Split na1)),
589 ((1,-1), mkCell (Split na1)),
590 ((-1,0), mkCell (ChDir False na2 NE))]
591
592 testBoard1a =
593 makeBoard [((0,0), mkCell (ChDir False na1 N)),
594 ((0,1), mkCell (ChDir False na1 SE)),
595 ((1,1), mkCell (Split na1)),
596 ((1,-1), mkCell (Split na1)),
597 ((-1,0), mkCell (ChDir False na2 NE))]
598
599 testBoard2 =
600 makeBoard [((0,0), mkCell (ChDir True na1 N)),
601 ((0,2), mkCellRpt (ChDir False na2 SE) 3),
602 ((2,1), mkCell (ChDir False na1 SW)),
603 ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
604 ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
605 ((0, -6), mkCell (ChDir True na1 N)),
606 ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]
607
608 testBoard3 =
609 makeBoard [((0,0), mkCell (ChDir True na1 N))]
610
611 na1 = NoteAttr {
612 naArt = Accent13,
613 naDur = 1 % 4,
614 naOrn = Ornaments Nothing [] NoSlide
615 }
616
617 na2 = NoteAttr {
618 naArt = NoAccent,
619 naDur = 1 % 16,
620 naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
621 }
622
623 na3 = NoteAttr {
624 naArt = Accent13,
625 naDur = 0,
626 naOrn = Ornaments Nothing [] NoSlide
627 }
628
629
630 bpb :: Int
631 bpb = 4
632
633 main = ppNotes bpb (take 50 (runRMCA testBoard3 bpb (Just 2) 0 0.8))
634 -}