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