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