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