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 RCMA 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 Main 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))