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