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
 262 -- High level note representation emitted form a layer
 263 data Note = Note {
 264     notePch :: Pitch,
 265     noteStr :: Strength,
 266     noteDur :: Duration,
 267     noteOrn :: Ornaments
 268 } deriving (Show,Eq)
 269
 270
 271 ------------------------------------------------------------------------------
 272 -- Board
 273 ------------------------------------------------------------------------------
 274
 275 -- Numbering; row number inside tile, column number below:
 276 --     _   _
 277 --   _/2\_/2\_
 278 --  / \_/1\_/1\
 279 --  \_/1\_/1\_/
 280 --  / \_/0\_/0\
 281 --  \_/0\_/0\_/
 282 --    \_/ \_/
 283 --    -1 0 1 2
 284
 285
 286 -- Angle measured in multiples of 60 degrees.
 287 type Angle = Int
 288
 289 data Dir = N | NE | SE | S | SW | NW deriving (Enum, Bounded, Eq, Show, Read)
 290
 291 predDir :: Dir -> Dir
 292 predDir d | d == minBound =  maxBound
 293           | otherwise = pred d
 294
 295 nextDir :: Dir -> Dir
 296 nextDir d | d ==  maxBound = minBound
 297           | otherwise = succ d
 298
 299 turn :: Dir -> Angle -> Dir
 300 turn d a = toEnum ((fromEnum d + a) `mod` 6)
 301
 302
 303 type Pos = (Int, Int)
 304
 305 -- Position of neighbour in given direction
 306 neighbor :: Dir -> Pos -> Pos
 307 neighbor N  (x,y) = (x,     y + 1)
 308 neighbor NE (x,y) = (x + 1, y + 1 - x `mod` 2)
 309 neighbor SE (x,y) = (x + 1, y - x `mod` 2)
 310 neighbor S  (x,y) = (x,     y - 1)
 311 neighbor SW (x,y) = (x - 1, y - x `mod` 2)
 312 neighbor NW (x,y) = (x - 1, y + 1 - x `mod` 2)
 313
 314
 315 -- Position and transposition to pitch:
 316 --   * Harmonic Table" layout: N = +7; NE = +4; SE = -3
 317 --   * (0,0) assumed to be "Middle C"
 318 posToPitch :: Pos -> RelPitch -> Pitch
 319 posToPitch (x,y) tr =
 320     Pitch (y * 7 + x `div` 2 - 3 * (x `mod` 2) + middleC + tr)
 321
 322
 323 -- Actions
 324 -- A ChDir counter is optionally a start counter if the Boolean flag is
 325 -- set to true.
 326 -- Any counter can be made silent by setting the note duration to a
 327 -- non-positive number.
 328
 329 data Action = Inert                   -- No action, play heads move through.
 330             | Absorb                  -- Remove play head silently.
 331             | Stop  NoteAttr          -- Play note then remove play head.
 332             | ChDir Bool NoteAttr Dir -- Play note then change direction.
 333             | Split NoteAttr          -- Play note then split head into five.
 334             deriving (Show,Read,Eq)
 335
 336
 337 -- Cells
 338 -- A cell stores an action and a repetition number.
 339 -- 0:     the cell is completely bypassed, as if it wasn't there.
 340 -- 1:     the action is carried out once (default)
 341 -- n > 1: any note output of the action is repeated (n-1) times before the
 342 --        action is carried out.
 343 -- n < 0: any note output of the action is repeated indefinitely (oo).
 344
 345 type Cell = (Action, Int)
 346
 347
 348 -- Make a cell with a default repeat count of 1.
 349 mkCell :: Action -> Cell
 350 mkCell a = mkCellRpt a 1
 351
 352
 353 -- Make a cell with a non-default repeition number.
 354 mkCellRpt :: Action -> Int -> Cell
 355 mkCellRpt a n = (a, n)
 356
 357
 358 -- Board extent: south-west corner and north-east corner.
 359 -- This covers most of the MIDI range: A#-1 (10) to G7 (103).
 360 swc, nec :: Pos
 361 swc = (-9, -6)
 362 nec = (9, 6)
 363
 364
 365 -- Test if a position is on the board as defined by swc and nec.
 366 -- The assumption is that odd columns contain one more cell, as per the
 367 -- picture above. Of course, one could opt for a "zig-zag" layout
 368 -- with each column having the same number of cells which would be slightly
 369 -- simpler.
 370 onBoard :: Pos -> Bool
 371 onBoard (x,y) =    xMin <= x && x <= xMax
 372                 && yMin <= y
 373                 && (if even x then
 374                         y < yMax
 375                     else
 376                         y <= yMax)
 377     where
 378         (xMin, yMin) = swc
 379         (xMax, yMax) = case nec of
 380                            (x, y) | even x    -> (x, y + 1)
 381                                   | otherwise -> (x, y)
 382
 383
 384 type Board = Array Pos Cell
 385
 386
 387 -- Build a board from a list specifying the non-empty cells.
 388 makeBoard :: [(Pos, Cell)] -> Board
 389 makeBoard pcs =
 390     array (swc,nec')
 391           ([(p, if onBoard p then mkCell Inert else mkCell Absorb)
 392            | p <- range (swc, nec')]
 393            ++ [(p,c) | (p, c) <- pcs, onBoard p])
 394     where
 395         -- This is to ensure (neighbor NW nec) is included on the board,
 396         -- regardless of whether the column of nec is even or odd.
 397         -- Otherwise, due to the "jagged" upper edge, the top row would
 398         -- be missing, but every other cell of that *is* on the board.
 399         -- The "superfluous" cells are set to Absorb above.
 400         nec' = neighbor N nec
 401
 402
 403 -- Look up a cell
 404 lookupCell :: Board -> Pos -> Cell
 405 lookupCell b p = if onBoard p then b ! p else (Absorb, 1)
 406
 407
 408 ------------------------------------------------------------------------------
 409 -- Play Head
 410 ------------------------------------------------------------------------------
 411
 412 -- A play head is characterised by:
 413 --   * Current position
 414 --   * Number of beats before moving
 415 --   * Direction of travel
 416 -- If an action involves playing a note, this is repeated once for
 417 -- each beat the play head is staying, with the rest of the action
 418 -- carried out at the last beat.
 419
 420 data PlayHead =
 421     PlayHead {
 422         phPos :: Pos,
 423         phBTM :: Int,
 424         phDir :: Dir
 425     }
 426     deriving (Eq, Show)
 427
 428
 429 ------------------------------------------------------------------------------
 430 -- Start Heads
 431 ------------------------------------------------------------------------------
 432
 433 startHeads :: Board -> [PlayHead]
 434 startHeads bd =
 435     [ PlayHead {
 436           phPos = p,
 437           phBTM = n,
 438           phDir = d
 439       }
 440     | (p, (ChDir True _ d, n)) <- assocs bd ]
 441
 442
 443 ------------------------------------------------------------------------------
 444 -- State transition
 445 ------------------------------------------------------------------------------
 446
 447 -- Advance the state of a single play head.
 448 --
 449 -- The result is a list of heads to be actioned at the *next* beat
 450 -- later) and possibly a note to be played at *this* beat.
 451
 452 advanceHead :: Board -> BeatNo -> RelPitch -> Strength -> PlayHead
 453             -> ([PlayHead], Maybe Note)
 454 advanceHead bd bn tr st ph = ahAux (moveHead bd ph)
 455     where
 456         ahAux ph@PlayHead {phPos = p, phBTM = btm, phDir = d} =
 457             case fst (lookupCell bd p) of
 458                 Inert         -> ([ph], Nothing)
 459                 Absorb        -> ([], Nothing)  -- No point waiting until BTM=0
 460                 Stop na       -> (newPHs [], mkNote p bn tr st na)
 461                 ChDir _ na d' -> (newPHs [ph {phDir = d'}],
 462                                   mkNote p bn tr st na)
 463                 Split na      -> (newPHs [ PlayHead {
 464                                                phPos   = p,
 465                                                phBTM   = 0,
 466                                                phDir   = d'
 467                                            }
 468                                          | a <- [-2 .. 2],
 469                                            let d' = turn d a
 470                                          ],
 471                                   mkNote p bn tr st na)
 472             where
 473                 newPHs phs = if btm == 0 then phs else [ph]
 474
 475
 476 -- Moves a play head if the BTM counter has reached 0, otherwise decrement BTM.
 477 -- Any encountered cells where the repeat count is < 1 are skipped.
 478 moveHead :: Board -> PlayHead -> PlayHead
 479 moveHead bd (ph@PlayHead {phPos = p, phBTM = btm, phDir = d})
 480     | btm == 0  = let
 481                       p'   = neighbor d p
 482                       btm' = snd (lookupCell bd p')
 483                   in
 484                       moveHead bd (ph {phPos = p', phBTM = btm'})
 485     | btm > 0   = ph {phBTM = btm - 1}
 486     | otherwise = ph        -- Repeat indefinitely
 487
 488 mkNote :: Pos -> BeatNo -> RelPitch -> Strength -> NoteAttr -> Maybe Note
 489 mkNote p bn tr st na@NoteAttr {naDur = d}
 490     | d <= 0    = Nothing    -- Notes of non-positive length are silent.
 491     | otherwise = Just
 492         Note {
 493             notePch = posToPitch p tr,
 494             noteStr = articStrength st bn (naArt na),
 495             noteDur = naDur na,
 496             noteOrn = naOrn na
 497         }
 498
 499
 500 -- Advance a list of heads, collecting all resulting heads and notes.
 501 -- Any duplicate play heads are eliminated (or their number may uselessly
 502 -- grow very quickly), and a cap (50, arbitrary, but should be plenty,
 503 -- expecially given the board size) on the number of simultaneous playheads
 504 -- per layer is imposed.
 505 advanceHeads :: Board -> BeatNo -> RelPitch -> Strength -> [PlayHead]
 506              -> ([PlayHead], [Note])
 507 advanceHeads bd bn tr st phs =
 508     let
 509        (phss, mns) = unzip (map (advanceHead bd bn tr st) phs)
 510     in
 511        (take 50 (nub (concat phss)), catMaybes mns)
 512
 513
 514 -- Given a board with start counters, run a board indefinitely, optionally
 515 -- restarting every ri bars.
 516 --
 517 -- Arguments:
 518 -- (1) Board (bd)
 519 -- (2) Beats Per Bar (bpb); > 0
 520 -- (3) Optioal repeat Interval (mri); In bars.
 521 -- (4) Transposition (tr)
 522 -- (5) Strength (st)
 523 --
 524 -- Returns:
 525 -- Stream of notes played at each beat.
 526 --
 527 -- In the real implementation:
 528 --   * A layer beat clock would be derived from the system beat (as a
 529 --     fraction/multiple, adding any swing) and each clock event be tagged
 530 --     with the beat number.
 531 --   * The board (bd) would not necessarily be a constant input. (One might
 532 --     consider allowing editing a layer while the machine is running)
 533 --   * The time signature, and thus the beats per par (bpb), along with
 534 --     repeat interval (ri) would likely be static (only changeable while
 535 --     automaton is stopped).
 536 --   * The transposition (tr) would be dynamic, the sum of a per layer
 537 --     transposition that can be set through the user interface and the
 538 --     difference between the MIDI note number of the last external
 539 --     note received for the layer and middle C (say).
 540 --   * The strength (st) would be dynamic, configurable as either the strength
 541 --     set through the user interface or the strength of the last external
 542 --     note received for the layer (derived from its MIDI velocity).
 543
 544 runRMCA :: Board -> BeatsPerBar -> Maybe Int -> RelPitch -> Strength
 545            -> [[Note]]
 546 runRMCA bd bpb mri tr st
 547     | bpb > 0 =
 548         case mri of
 549             Nothing -> nss
 550             Just ri
 551                 | ri > 0    -> cycle (take (ri * bpb) nss)
 552                 | otherwise -> error "The repeat interval must be at \
 553                                      \least 1 bar."
 554     | otherwise = error "The number of beats per bar must be at least 1."
 555     where
 556         nss = runAux 1 (startHeads bd)
 557
 558         runAux bn phs = ns : runAux (nextBeatNo bpb bn) phs'
 559             where
 560                 (phs', ns) = advanceHeads bd bn tr st phs
 561
 562
 563 -- Print played notes in a time-stamped (bar, beat), easy-to-read format.
 564
 565 ppNotes :: BeatsPerBar -> [[Note]] -> IO ()
 566 ppNotes bpb nss = ppnAux (zip [(br,bn) | br <- [1..], bn <- [1..bpb]] nss)
 567     where ppnAux :: [((Int,BeatsPerBar),[Note])] -> IO ()
 568           ppnAux [] = return ()
 569           ppnAux ((_, []) : tnss) = ppnAux tnss
 570           ppnAux ((t, ns) : tnss) = do
 571             putStrLn (leftJustify 10 (show t) ++ ": "
 572                       ++ intercalate ", " (map show ns))
 573             ppnAux tnss
 574
 575
 576 leftJustify :: Int -> String -> String
 577 leftJustify w s = replicate (w - length s) ' ' ++ s
 578
 579 {-
 580 ------------------------------------------------------------------------------
 581 -- Simple tests
 582 ------------------------------------------------------------------------------
 583
 584 testBoard1 =
 585     makeBoard [((0,0),  mkCell (ChDir True na1 N)),
 586                ((0,1),  mkCell (ChDir False na1 SE)),
 587                ((1,1),  mkCell (Split na1)),
 588                ((1,-1), mkCell (Split na1)),
 589                ((-1,0), mkCell (ChDir False na2 NE))]
 590
 591 testBoard1a =
 592     makeBoard [((0,0),  mkCell (ChDir False na1 N)),
 593                ((0,1),  mkCell (ChDir False na1 SE)),
 594                ((1,1),  mkCell (Split na1)),
 595                ((1,-1), mkCell (Split na1)),
 596                ((-1,0), mkCell (ChDir False na2 NE))]
 597
 598 testBoard2 =
 599     makeBoard [((0,0), mkCell (ChDir True na1 N)),
 600                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
 601                ((2,1), mkCell (ChDir False na1 SW)),
 602                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
 603                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
 604                ((0, -6), mkCell (ChDir True na1 N)),
 605                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]
 606
 607 testBoard3 =
 608     makeBoard [((0,0),  mkCell (ChDir True na1 N))]
 609
 610 na1 = NoteAttr {
 611           naArt = Accent13,
 612           naDur = 1 % 4,
 613           naOrn = Ornaments Nothing [] NoSlide
 614       }
 615
 616 na2 = NoteAttr {
 617           naArt = NoAccent,
 618           naDur = 1 % 16,
 619           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
 620       }
 621
 622 na3 = NoteAttr {
 623           naArt = Accent13,
 624           naDur = 0,
 625           naOrn = Ornaments Nothing [] NoSlide
 626       }
 627
 628
 629 bpb :: Int
 630 bpb = 4
 631
 632 main = ppNotes bpb (take 50 (runRMCA testBoard3 bpb (Just 2) 0 0.8))
 633 -}