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