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 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 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 reactogon 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]))