]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Semantics.hs
Added a few calls to postGUIAsync.
[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 (intercalate, 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, 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
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 -}