Commit f633d863 authored by Guerric Chupin's avatar Guerric Chupin

RCMA -> RMCA

parent c20c4700
......@@ -30,7 +30,7 @@
-- a distinct graphical representation?
-- DECIDED AGAINST FOR NOW
module RMCA.Semantics where
module Main where
import Data.Array
import Data.List (intersperse, nub)
......@@ -443,11 +443,11 @@ moveHead bd (ph@PlayHead {phPos = p, phBTM = btm, phDir = d})
in
moveHead bd (ph {phPos = p', phBTM = btm'})
| btm > 0 = ph {phBTM = btm - 1}
| otherwise = ph -- Repeat indefinitely
| otherwise = ph -- Repeat indefinitely
mkNote :: Pos -> BeatNo -> RelPitch -> Strength -> NoteAttr -> Maybe Note
mkNote p bn tr st na@(NoteAttr {naDur = d})
| d <= 0 = Nothing -- Notes of non-positive length are silent.
| d <= 0 = Nothing -- Notes of non-positive length are silent.
| otherwise = Just $
Note {
notePch = posToPitch p tr,
......@@ -513,7 +513,7 @@ runRMCA bd bpb mri tr st
\least 1 bar."
| otherwise = error "The number of beats per bar must be at least 1."
where
nss = runAux 1 (startHeads bd)
nss = runAux 1 []--(startHeads bd)
runAux bn phs = ns : runAux (nextBeatNo bpb bn) phs'
where
......
{-# LANGUAGE Arrows #-}
module RCMA.Auxiliary.Auxiliary where
module RMCA.Auxiliary.Auxiliary where
import Data.Maybe
import FRP.Yampa
......
module RCMA.Auxiliary.Concurrent where
module RMCA.Auxiliary.Concurrent where
import Control.Concurrent
import Control.Concurrent.MVar
......
-- Contains function to currify/uncurrify functions with more than
-- two arguments. It might be useful to use Template Haskell there.
module RCMA.Auxiliary.Curry where
module RMCA.Auxiliary.Curry where
curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
curry3 f a b c = f (a,b,c)
......
{-# LANGUAGE ScopedTypeVariables #-}
module RCMA.Auxiliary.RV where
module RMCA.Auxiliary.RV where
import Data.CBMVar
import Data.ReactiveValue
......
module RCMA.Global.Clock where
module RMCA.Global.Clock where
import Control.Concurrent
import Control.Monad
import Data.CBMVar
import Data.ReactiveValue
import FRP.Yampa
import RCMA.Auxiliary.Auxiliary
import RCMA.Semantics
import RMCA.Auxiliary.Auxiliary
import RMCA.Semantics
tempo :: Tempo -> SF () Tempo
tempo = constant
......
{-# LANGUAGE Arrows, FlexibleContexts #-}
module RCMA.Layer.Board ( boardSF
module RMCA.Layer.Board ( boardSF
, (^:>)
) where
......@@ -10,46 +10,48 @@ import Data.ReactiveValue
import Data.Tuple
import FRP.Yampa
import Hails.Yampa
import RCMA.Auxiliary.Curry
import RCMA.Layer.Layer
import RCMA.Semantics
import RCMA.Global.Clock
import RMCA.Auxiliary.Curry
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Global.Clock
import Control.Monad
import Debug.Trace
-- The state of the board is described by the list of the playheads
-- and the different actions onto the board.
-- It can then be modified discretly when a beat is received or
-- continuously when the user acts on it.
boardAction :: SF (Board, Layer, [PlayHead], Event BeatNo)
(Event ([PlayHead], [Note]))
boardAction = proc (board, Layer { relPitch = rp
, strength = s
, beatsPerBar = bpb
}, pl, ebn) ->
ahSF <<^ arr propEvent -< (board, ebn, rp, s, pl)
where
ahSF :: SF (Event (Board, BeatNo, RelPitch, Strength, [PlayHead]))
(Event ([PlayHead], [Note]))
ahSF = arr $ fmap (uncurry5 $ advanceHeads)
propEvent (a,b,c,d,e) = if let a = b in traceShow a $ isEvent b
then Event (a,fromEvent b,c,d,e)
else NoEvent
boardSF :: SF (Event BeatNo) (Event ([PlayHead], [Note]))
boardSF' :: [PlayHead]
-> SF (Board, Layer, Tempo) (Event ([PlayHead], [Note]))
boardSF' ph = proc (board, l, t) -> do
boardAction :: [PlayHead]
-> SF ((Board, Layer), Event BeatNo) (Event ([PlayHead], [Note]))
boardAction ph = proc ((board, Layer { relPitch = rp
, strength = s
, beatsPerBar = bpb
}), ebno) -> do
e <- arr $ fmap (uncurry5 $ advanceHeads) -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
returnA -< traceShow e e
{-
boardSF :: SF (Board, Layer, Tempo) (Event [Note])
boardSF = proc (board, l, t) -> do
ebno <- layerMetronome -< (t, l)
boardAction -< (board, l, ph, ebno)
iph <- startHeads -< board
boardSF' iph -< (board, l, ebno)
where boardSF' :: [PlayHead] -> SF (Board, Layer, Event BeatNo) (Event [Note])
boardSF' ph = switch (swap ^<< splitE ^<< boardAction ph)
boardSF'
-}
boardSF :: SF (Board, Layer, Tempo) (Event [Note])
boardSF = boardSF'' []
where boardSF'' :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
boardSF'' ph = switch (splitE ^<< fmap swap ^<< boardSF' ph)
boardSF''
boardSF = proc (board, l@Layer { relPitch = rp
, strength = s
}, t) -> do
ebno <- layerMetronome -< (t,l)
--iph <- arr startHeads -< board
boardSF' [] -< ((board, l), ebno)
where
boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
boardSF' ph = switch (boardAction ph >>> arr splitE >>> arr swap)
(\nph -> second notYet >>> boardSF' nph)
{-
boardSetup :: Board
-> ReactiveFieldReadWrite IO Tempo
......
{-# LANGUAGE Arrows #-}
module RCMA.Layer.Layer where
module RMCA.Layer.Layer where
import Data.CBMVar
import Data.ReactiveValue
import FRP.Yampa
import RCMA.Global.Clock
import RCMA.Semantics
import RMCA.Global.Clock
import RMCA.Semantics
import Debug.Trace
......@@ -29,7 +29,7 @@ layerMetronome' b = proc (t, l@Layer { beatsPerBar = bpb }) -> do
layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
layerMetronome = layerMetronome'' 0
where layerMetronome'' no = switch (layerMetronome' no >>^ dup)
where layerMetronome'' no = dSwitch (layerMetronome' no >>^ dup)
layerMetronome''
layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
......
module RCMA.Layer.PlayHead where
module RMCA.Layer.PlayHead where
import RCMA.Semantics
import RMCA.Semantics
import FRP.Yampa
playHead :: SF () ()
......@@ -6,16 +6,16 @@ import Control.Concurrent
import Data.ReactiveValue
import FRP.Yampa
import Hails.Yampa
import RCMA.Auxiliary.Concurrent
import RCMA.Auxiliary.RV
import RCMA.Auxiliary.RV
import RCMA.Global.Clock
import RCMA.Layer.Board
import RCMA.Layer.Layer
import RCMA.Semantics
import RCMA.Translator.Jack
import RCMA.Translator.Message
import RCMA.Translator.Translator
import RMCA.Auxiliary.Concurrent
import RMCA.Auxiliary.RV
import RMCA.Auxiliary.RV
import RMCA.Global.Clock
import RMCA.Layer.Board
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Jack
import RMCA.Translator.Message
import RMCA.Translator.Translator
import Control.Monad
import Data.Ratio
......
......@@ -3,7 +3,7 @@
-- Written by Henrik Nilsson, 2016-05-27
-- Based on an earlier version.
--
-- This gives the semantics of a single RCMA layer. The output is
-- This gives the semantics of a single RMCA layer. The output is
-- a high-level representation of notes for each beat. This is to be
-- translated to low-level MIDI message by a subsequent translator
-- responsible for merging notes from different layers, ensuring that
......@@ -30,7 +30,7 @@
-- a distinct graphical representation?
-- DECIDED AGAINST FOR NOW
module RCMA.Semantics where
module RMCA.Semantics where
import Data.Array
import Data.List (intersperse, nub)
......
module RCMA.Translator.Controller where
module RMCA.Translator.Controller where
import RCMA.Semantics
import RCMA.Translator.Message
import RMCA.Semantics
import RMCA.Translator.Message
messageToController :: Message -> Controller
messageToController _ = Lol
......
-- Contains function for scheduling and filtering events given the
-- correct informations.
module RCMA.Translator.Filter where
module RMCA.Translator.Filter where
import Data.Bifunctor as BF
import Data.Function (on)
import Data.List (group, groupBy, sortBy)
import Data.Ord
import FRP.Yampa
import RCMA.Semantics
import RCMA.Translator.Message
import RMCA.Semantics
import RMCA.Translator.Message
import Sound.JACK (NFrames (NFrames))
-- Takes a list of time stamped "things", a sample rate and a buffer
......
-- Contains all the information and functions necessary to run a Jack
-- port and exchange information through reactive values and Yampa.
module RCMA.Translator.Jack ( jackSetup
module RMCA.Translator.Jack ( jackSetup
) where
import Control.Applicative ((<**>))
......@@ -12,19 +12,19 @@ import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import Hails.Yampa
import RCMA.Semantics
import RCMA.Translator.Filter
import RCMA.Translator.Message
import RCMA.Translator.RV
import RCMA.Translator.Translator
import RMCA.Semantics
import RMCA.Translator.Filter
import RMCA.Translator.Message
import RMCA.Translator.RV
import RMCA.Translator.Translator
import qualified Sound.JACK as Jack
import qualified Sound.JACK.Exception as JExc
import qualified Sound.JACK.MIDI as JMIDI
import Debug.Trace
rcmaName :: String
rcmaName = "RCMA"
rmcaName :: String
rmcaName = "RMCA"
inPortName :: String
inPortName = "input"
......@@ -38,13 +38,13 @@ jackSetup :: ReactiveFieldRead IO (LTempo, Int, [Note])
-> IO ()
jackSetup boardInRV = Jack.handleExceptions $ do
toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
Jack.withClientDefault rcmaName $ \client ->
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
Jack.withPort client inPortName $ \input ->
Jack.withProcess client (jackCallBack client input output
toProcessRV boardInRV) $
Jack.withActivation client $ Trans.lift $ do
putStrLn $ "Started " ++ rcmaName ++ " JACK client."
putStrLn $ "Started " ++ rmcaName ++ " JACK client."
Jack.waitForBreak
{-
......@@ -56,7 +56,7 @@ jackRun :: (JExc.ThrowsErrno e) =>
-> Sync.ExceptionalT e IO ()
jackRun client callback =
Jack.withProcess client callback $ do
Trans.lift $ putStrLn $ "Startedbbb " ++ rcmaName
Trans.lift $ putStrLn $ "Startedbbb " ++ rmcaName
Trans.lift $ Jack.waitForBreak
-}
defaultTempo :: Tempo
......
module RCMA.Translator.Message where
module RMCA.Translator.Message where
import RCMA.Semantics
import RMCA.Semantics
import qualified Sound.JACK as Jack
import qualified Sound.MIDI.Message as Message
import qualified Sound.MIDI.Message.Channel as Channel
......
{-# LANGUAGE Arrows #-}
module RCMA.Translator.Note where
module RMCA.Translator.Note where
import Data.Ratio
import FRP.Yampa
import RCMA.Global.Clock
import RCMA.Layer.Layer
import RCMA.Semantics
import RCMA.Translator.Message
import RMCA.Global.Clock
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Message
messageToNote :: Message -> Note
messageToNote (NoteOn _ p s) = Note { notePch = p
......
{-# LANGUAGE ScopedTypeVariables #-}
module RCMA.Translator.RV where
module RMCA.Translator.RV where
import Control.Monad
import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
......@@ -12,7 +12,7 @@ import qualified Data.List as L
import Data.Ord (comparing)
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import RCMA.Translator.Message
import RMCA.Translator.Message
import qualified Sound.JACK as Jack
import Sound.JACK.Exception
( All
......
......@@ -5,7 +5,7 @@
-- events and other events. The latter will be transmitted as is
-- through the whole systems.
module RCMA.Translator.SortMessage where
module RMCA.Translator.SortMessage where
import qualified Data.Bifunctor as BF
import Data.Function (on)
......@@ -13,10 +13,10 @@ import Data.List (groupBy)
import Data.Maybe
import Data.Ratio
import FRP.Yampa
import RCMA.Semantics
import RCMA.Translator.Controller
import RCMA.Translator.Message
import RCMA.Translator.Note
import RMCA.Semantics
import RMCA.Translator.Controller
import RMCA.Translator.Message
import RMCA.Translator.Note
sortRawMessages :: [(Frames, RawMessage)]
-> ([(Frames,Message)], [(Frames,RawMessage)])
......
{-# LANGUAGE Arrows #-}
module RCMA.Translator.Translator ( readMessages
module RMCA.Translator.Translator ( readMessages
, gatherMessages
) where
import qualified Data.Bifunctor as BF
import FRP.Yampa
import RCMA.Auxiliary.Curry
import RCMA.Layer.Layer
import RCMA.Semantics
import RCMA.Translator.Controller
import RCMA.Translator.Message
import RCMA.Translator.Note
import RCMA.Translator.SortMessage
import RMCA.Auxiliary.Curry
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Controller
import RMCA.Translator.Message
import RMCA.Translator.Note
import RMCA.Translator.SortMessage
-- Uses function defined in SortMessage. This is a pure function and
-- it might not need to be a signal function.
......
......@@ -40,8 +40,8 @@ outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
})] | t <- [0,2..]]
-}
rcmaName :: String
rcmaName = "RCMA"
rmcaName :: String
rmcaName = "RMCA"
inPortName :: String
inPortName = "input"
......@@ -56,7 +56,7 @@ main = do
inState <- newMVar M.empty
outState <- newMVar M.empty
Jack.handleExceptions $
Jack.withClientDefault rcmaName $ \client ->
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
Jack.withPort client inPortName $ \input -> do
clientState <- Trans.lift $ newEmptyMVar
......@@ -64,8 +64,8 @@ main = do
(jackLoop client clientState inState outState input output) $
Jack.withActivation client $ do
frpid <- Trans.lift $ forkIO $ mainReact inState outState clientState
Jack.connect client (rcmaName ++ ":" ++ outPortName) fsPortName
Trans.lift $ putStrLn $ "Started " ++ rcmaName
Jack.connect client (rmcaName ++ ":" ++ outPortName) fsPortName
Trans.lift $ putStrLn $ "Started " ++ rmcaName
Trans.lift $ Jack.waitForBreak
jackLoop :: Jack.Client
......
import RCMA.Global.Clock
import RCMA.Auxiliary.Auxiliary
import RCMA.Semantics
import RMCA.Global.Clock
import RMCA.Auxiliary.Auxiliary
import RMCA.Semantics
import FRP.Yampa
main :: IO ()
......
import RCMA.Auxiliary.Auxiliary
import RMCA.Auxiliary.Auxiliary
import FRP.Yampa
main :: IO ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment