]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Semantics.hs
Add « update on event » function on RVs.
[tmp/julm/arpeggigon.git] / 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 (intersperse, nub)
37 import Data.Maybe (catMaybes)
38 import Data.Ratio
39 import RMCA.Auxiliary.Auxiliary
40
41
42 ------------------------------------------------------------------------------
43 -- Basic Type Synonyms
44 ------------------------------------------------------------------------------
45
46 -- Unipolar control value; [0, 1]
47 type UCtrl = Double
48
49 -- Bipolar control value; [-1, 1]
50 type BCtrl = Double
51
52 -- Unipolar control values are usually between 0 and 127.
53 toUCtrl :: Int -> UCtrl
54 toUCtrl x = fromIntegral x / 127
55
56 fromUCtrl :: UCtrl -> Int
57 fromUCtrl x = floor $ (bound (0,1) x) * 127
58
59 -- Bipolar control values are usually between -127 and 127.
60 toBCtrl :: Int -> BCtrl
61 toBCtrl = toUCtrl
62
63 fromBCtrl :: BCtrl -> Int
64 fromBCtrl = fromUCtrl
65
66 ------------------------------------------------------------------------------
67 -- Tempo
68 ------------------------------------------------------------------------------
69
70 type Tempo = Int
71
72 -- LTempo designates a layer tempo. Useful for not transforming twice
73 -- a tempo.
74 type LTempo = Tempo
75
76 ------------------------------------------------------------------------------
77 -- Time and Beats
78 ------------------------------------------------------------------------------
79
80 -- The assumption is that the automaton is clocked by a beat clock and
81 -- thus advances one step per beat. For an automaton working in real time,
82 -- the beat clock would be defined externally, synchronized with other
83 -- layers and possibly external MIDI, and account for tempo, any swing, etc.
84
85 -- Beats and Bars
86
87 -- A beat as such is nothing.
88 type Beat = ()
89
90 -- Beats per Bar: number of beats per bar in the time signature of a layer.
91 -- Non-negative.
92 type BeatsPerBar = Int
93
94 -- The beat number in the time signature of the layer. The first beat is 1.
95 type BeatNo = Int
96
97 nextBeatNo :: BeatsPerBar -> BeatNo -> BeatNo
98 nextBeatNo bpb bn = bn `mod` bpb + 1
99
100
101 {-
102 -- Not needed for individual layers (at present)
103
104 -- Time; [0,+inf)
105 type Time = Double
106 -}
107
108
109 ------------------------------------------------------------------------------
110 -- MIDI
111 ------------------------------------------------------------------------------
112
113 -- This semantics mainly works with a high-level represemntation of notes.
114 -- But it is convenient to express some of the high-level aspects directly
115 -- in the corresponding MIDI terms to facilitate the translation.
116
117 -- MIDI note number; [0,127]
118 type MIDINN = Int
119
120
121 -- Assume MIDI convetion: 60 = "Middle C" = C4
122 middleC = 60
123 middleCOct = 4
124
125
126 -- MIDI velocity; [0,127]
127 type MIDIVel = Int
128
129
130 -- MIDI Program Change: Program Number; [0,127]
131 type MIDIPN = Int
132
133
134 -- MIDI Control Change: Control Number and Control Value; [0,127]
135 type MIDICN = Int
136 type MIDICV = Int
137
138 -- MIDICVRnd gives the option to pick a control value at random.
139 -- (Handled through subsequent translation to low-level MIDI events.)
140 data MIDICVRnd = MIDICV MIDICV | MIDICVRnd deriving (Eq, Show)
141
142 -- TEMPORARY
143 data Controller = Lol
144 --
145 ------------------------------------------------------------------------------
146 -- Notes
147 ------------------------------------------------------------------------------
148
149 -- Pitch
150
151 -- We chose to represent pitch by MIDI note number
152 newtype Pitch = Pitch MIDINN deriving Eq
153
154 pitchToMNN :: Pitch -> MIDINN
155 pitchToMNN (Pitch nn) = nn
156
157 instance Show Pitch where
158 show (Pitch nn) = names !! note ++ show oct
159 where
160 nn' = nn - middleC
161 note = nn' `mod` 12
162 oct = nn' `div` 12 + middleCOct
163 names = ["C", "C#", "D", "D#", "E", "F",
164 "F#", "G", "G#", "A", "A#", "B"]
165
166 -- Relative pitch in semi tones. Used for e.g. transposition.
167 type RelPitch = Int
168
169
170 -- Articulation
171
172 -- Each layer has a setting that indicate how strongly the notes
173 -- should normally be played as a percentage of full strength.
174 -- (In the real application, this settig can be set to a fixed value
175 -- or set to be derived from teh last input note, "as played").
176 -- Individual notes can tehn be accented (played more strongly),
177 -- either unconditionally or as a function of the beat count.
178
179 type Strength = UCtrl
180
181 -- This could of course be generalised, e.g. a list of beat numbers to
182 -- accentuate. But this is simple and accounts for the most common patterns.
183 data Articulation = NoAccent
184 | Accent
185 | Accent1
186 | Accent13
187 | Accent14
188 | Accent24
189 deriving (Eq, Show)
190
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)
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, Eq, Show)
291
292
293 turn :: Dir -> Angle -> Dir
294 turn d a = toEnum ((fromEnum d + a) `mod` 6)
295
296
297 type Pos = (Int, Int)
298
299 -- Position of neighbour in given direction
300 neighbor :: Dir -> Pos -> Pos
301 neighbor N (x,y) = (x, y + 1)
302 neighbor NE (x,y) = (x + 1, y + 1 - x `mod` 2)
303 neighbor SE (x,y) = (x + 1, y - x `mod` 2)
304 neighbor S (x,y) = (x, y - 1)
305 neighbor SW (x,y) = (x - 1, y - x `mod` 2)
306 neighbor NW (x,y) = (x - 1, y + 1 - x `mod` 2)
307
308
309 -- Position and transposition to pitch:
310 -- * Harmonic Table" layout: N = +7; NE = +4; SE = -3
311 -- * (0,0) assumed to be "Middle C"
312 posToPitch :: Pos -> RelPitch -> Pitch
313 posToPitch (x,y) tr =
314 Pitch (y * 7 + x `div` 2 - 3 * (x `mod` 2) + middleC + tr)
315
316
317 -- Actions
318 -- A ChDir counter is optionally a start counter if the Boolean flag is
319 -- set to true.
320 -- Any counter can be made silent by setting the note duration to a
321 -- non-positive number.
322
323 data Action = Inert -- No action, play heads move through.
324 | Absorb -- Remove play head silently.
325 | Stop NoteAttr -- Play note then remove play head.
326 | ChDir Bool NoteAttr Dir -- Play note then change direction.
327 | Split NoteAttr -- Play note then split head into five.
328 deriving Show
329
330
331 -- Cells
332 -- A cell stores an action and a repetition number.
333 -- 0: the cell is completely bypassed, as if it wasn't there.
334 -- 1: the action is carried out once (default)
335 -- n > 1: any note output of the action is repeated (n-1) times before the
336 -- action is carried out.
337 -- n < 0: any note output of the action is repeated indefinitely (oo).
338
339 type Cell = (Action, Int)
340
341
342 -- Make a cell with a default repeat count of 1.
343 mkCell :: Action -> Cell
344 mkCell a = mkCellRpt a 1
345
346
347 -- Make a cell with a non-default repeition number.
348 mkCellRpt :: Action -> Int -> Cell
349 mkCellRpt a n = (a, n)
350
351
352 -- Board extent: south-west corner and north-east corner.
353 -- This covers most of the MIDI range: A#-1 (10) to G7 (103).
354 swc, nec :: Pos
355 swc = (-9, -6)
356 nec = (9, 6)
357
358
359 -- Test if a position is on the board as defined by swc and nec.
360 -- The assumption is that odd columns contain one more cell, as per the
361 -- picture above. Of course, one could opt for a "zig-zag" layout
362 -- with each column having the same number of cells which would be slightly
363 -- simpler.
364 onBoard :: Pos -> Bool
365 onBoard (x,y) = xMin <= x && x <= xMax
366 && yMin <= y
367 && (if even x then
368 y < yMax
369 else
370 y <= yMax)
371 where
372 (xMin, yMin) = swc
373 (xMax, yMax) = case nec of
374 (x, y) | even x -> (x, y + 1)
375 | otherwise -> (x, y)
376
377
378 type Board = Array Pos Cell
379
380
381 -- Build a board from a list specifying the non-empty cells.
382 makeBoard :: [(Pos, Cell)] -> Board
383 makeBoard pcs =
384 array (swc,nec')
385 ([(p, if onBoard p then mkCell Inert else mkCell Absorb)
386 | p <- range (swc, nec')]
387 ++ [(p,c) | (p, c) <- pcs, onBoard p])
388 where
389 -- This is to ensure (neighbor NW nec) is included on the board,
390 -- regardless of whether the column of nec is even or odd.
391 -- Otherwise, due to the "jagged" upper edge, the top row would
392 -- be missing, but every other cell of that *is* on the board.
393 -- The "superfluous" cells are set to Absorb above.
394 nec' = neighbor N nec
395
396
397 -- Look up a cell
398 lookupCell :: Board -> Pos -> Cell
399 lookupCell b p = if onBoard p then (b ! p) else (Absorb, 1)
400
401
402 ------------------------------------------------------------------------------
403 -- Play Head
404 ------------------------------------------------------------------------------
405
406 -- A play head is characterised by:
407 -- * Current position
408 -- * Number of beats before moving
409 -- * Direction of travel
410 -- If an action involves playing a note, this is repeated once for
411 -- each beat the play head is staying, with the rest of the action
412 -- carried out at the last beat.
413
414 data PlayHead =
415 PlayHead {
416 phPos :: Pos,
417 phBTM :: Int,
418 phDir :: Dir
419 }
420 deriving (Eq, Show)
421
422
423 ------------------------------------------------------------------------------
424 -- Start Heads
425 ------------------------------------------------------------------------------
426
427 startHeads :: Board -> [PlayHead]
428 startHeads bd =
429 [ PlayHead {
430 phPos = p,
431 phBTM = n,
432 phDir = d
433 }
434 | (p, (ChDir True _ d, n)) <- assocs bd ]
435
436
437 ------------------------------------------------------------------------------
438 -- State transition
439 ------------------------------------------------------------------------------
440
441 -- Advance the state of a single play head.
442 --
443 -- The result is a list of heads to be actioned at the *next* beat
444 -- later) and possibly a note to be played at *this* beat.
445
446 advanceHead :: Board -> BeatNo -> RelPitch -> Strength -> PlayHead
447 -> ([PlayHead], Maybe Note)
448 advanceHead bd bn tr st ph = ahAux (moveHead bd ph)
449 where
450 ahAux ph@PlayHead {phPos = p, phBTM = btm, phDir = d} =
451 case fst (lookupCell bd p) of
452 Inert -> ([ph], Nothing)
453 Absorb -> ([], Nothing) -- No point waiting until BTM=0
454 Stop na -> (newPHs [], mkNote p bn tr st na)
455 ChDir _ na d' -> (newPHs [ph {phDir = d'}],
456 mkNote p bn tr st na)
457 Split na -> (newPHs [ PlayHead {
458 phPos = p,
459 phBTM = 0,
460 phDir = d'
461 }
462 | a <- [-2 .. 2],
463 let d' = turn d a
464 ],
465 mkNote p bn tr st na)
466 where
467 newPHs phs = if btm == 0 then phs else [ph]
468
469
470 -- Moves a play head if the BTM counter has reached 0, otherwise decrement BTM.
471 -- Any encountered cells where the repeat count is < 1 are skipped.
472 moveHead :: Board -> PlayHead -> PlayHead
473 moveHead bd (ph@PlayHead {phPos = p, phBTM = btm, phDir = d})
474 | btm == 0 = let
475 p' = neighbor d p
476 btm' = snd (lookupCell bd p')
477 in
478 moveHead bd (ph {phPos = p', phBTM = btm'})
479 | btm > 0 = ph {phBTM = btm - 1}
480 | otherwise = ph -- Repeat indefinitely
481
482 mkNote :: Pos -> BeatNo -> RelPitch -> Strength -> NoteAttr -> Maybe Note
483 mkNote p bn tr st na@(NoteAttr {naDur = d})
484 | d <= 0 = Nothing -- Notes of non-positive length are silent.
485 | otherwise = Just $
486 Note {
487 notePch = posToPitch p tr,
488 noteStr = articStrength st bn (naArt na),
489 noteDur = naDur na,
490 noteOrn = naOrn na
491 }
492
493
494 -- Advance a list of heads, collecting all resulting heads and notes.
495 -- Any duplicate play heads are eliminated (or their number may uselessly
496 -- grow very quickly), and a cap (50, arbitrary, but should be plenty,
497 -- expecially given the board size) on the number of simultaneous playheads
498 -- per layer is imposed.
499 advanceHeads :: Board -> BeatNo -> RelPitch -> Strength -> [PlayHead]
500 -> ([PlayHead], [Note])
501 advanceHeads bd bn tr st phs =
502 let
503 (phss, mns) = unzip (map (advanceHead bd bn tr st) phs)
504 in
505 (take 50 (nub (concat phss)), catMaybes mns)
506
507
508 -- Given a board with start counters, run a board indefinitely, optionally
509 -- restarting every ri bars.
510 --
511 -- Arguments:
512 -- (1) Board (bd)
513 -- (2) Beats Per Bar (bpb); > 0
514 -- (3) Optioal repeat Interval (mri); In bars.
515 -- (4) Transposition (tr)
516 -- (5) Strength (st)
517 --
518 -- Returns:
519 -- Stream of notes played at each beat.
520 --
521 -- In the real implementation:
522 -- * A layer beat clock would be derived from the system beat (as a
523 -- fraction/multiple, adding any swing) and each clock event be tagged
524 -- with the beat number.
525 -- * The board (bd) would not necessarily be a constant input. (One might
526 -- consider allowing editing a layer while the machine is running)
527 -- * The time signature, and thus the beats per par (bpb), along with
528 -- repeat interval (ri) would likely be static (only changeable while
529 -- automaton is stopped).
530 -- * The transposition (tr) would be dynamic, the sum of a per layer
531 -- transposition that can be set through the user interface and the
532 -- difference between the MIDI note number of the last external
533 -- note received for the layer and middle C (say).
534 -- * The strength (st) would be dynamic, configurable as either the strength
535 -- set through the user interface or the strength of the last external
536 -- note received for the layer (derived from its MIDI velocity).
537
538 runRMCA :: Board -> BeatsPerBar -> Maybe Int -> RelPitch -> Strength
539 -> [[Note]]
540 runRMCA bd bpb mri tr st
541 | bpb > 0 =
542 case mri of
543 Nothing -> nss
544 Just ri
545 | ri > 0 -> cycle (take (ri * bpb) nss)
546 | otherwise -> error "The repeat interval must be at \
547 \least 1 bar."
548 | otherwise = error "The number of beats per bar must be at least 1."
549 where
550 nss = runAux 1 (startHeads bd)
551
552 runAux bn phs = ns : runAux (nextBeatNo bpb bn) phs'
553 where
554 (phs', ns) = advanceHeads bd bn tr st phs
555
556
557 -- Print played notes in a time-stamped (bar, beat), easy-to-read format.
558
559 ppNotes :: BeatsPerBar -> [[Note]] -> IO ()
560 ppNotes bpb nss = ppnAux (zip [(br,bn) | br <- [1..], bn <- [1..bpb]] nss)
561 where
562 ppnAux [] = return ()
563 ppnAux ((_, []) : tnss) = ppnAux tnss
564 ppnAux ((t, ns) : tnss) = do
565 putStrLn ((leftJustify 10 (show t)) ++ ": "
566 ++ concat (intersperse ", " (map show ns)))
567 ppnAux tnss
568
569
570 leftJustify :: Int -> String -> String
571 leftJustify w s = take (w - length s) (repeat ' ') ++ s
572
573 {-
574 ------------------------------------------------------------------------------
575 -- Simple tests
576 ------------------------------------------------------------------------------
577
578 testBoard1 =
579 makeBoard [((0,0), mkCell (ChDir True na1 N)),
580 ((0,1), mkCell (ChDir False na1 SE)),
581 ((1,1), mkCell (Split na1)),
582 ((1,-1), mkCell (Split na1)),
583 ((-1,0), mkCell (ChDir False na2 NE))]
584
585 testBoard1a =
586 makeBoard [((0,0), mkCell (ChDir False 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 testBoard2 =
593 makeBoard [((0,0), mkCell (ChDir True na1 N)),
594 ((0,2), mkCellRpt (ChDir False na2 SE) 3),
595 ((2,1), mkCell (ChDir False na1 SW)),
596 ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
597 ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
598 ((0, -6), mkCell (ChDir True na1 N)),
599 ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]
600
601 testBoard3 =
602 makeBoard [((0,0), mkCell (ChDir True na1 N))]
603
604 na1 = NoteAttr {
605 naArt = Accent13,
606 naDur = 1 % 4,
607 naOrn = Ornaments Nothing [] NoSlide
608 }
609
610 na2 = NoteAttr {
611 naArt = NoAccent,
612 naDur = 1 % 16,
613 naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
614 }
615
616 na3 = NoteAttr {
617 naArt = Accent13,
618 naDur = 0,
619 naOrn = Ornaments Nothing [] NoSlide
620 }
621
622
623 bpb :: Int
624 bpb = 4
625
626 main = ppNotes bpb (take 50 (runRMCA testBoard3 bpb (Just 2) 0 0.8))
627 -}