module Harmonic.Interface.Tidal.Form
(
FormNode(..)
, FormTime(..)
, Transition(..)
, Kinetics(..)
, IK
, at
, at'
, rh
, rh'
, iK
, lK
, formK
, ki
, slate
, kinPick
, withForm
) where
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import Sound.Tidal.Context
data FormTime = Secs Double | Bars Double
deriving (Int -> FormTime -> ShowS
[FormTime] -> ShowS
FormTime -> String
(Int -> FormTime -> ShowS)
-> (FormTime -> String) -> ([FormTime] -> ShowS) -> Show FormTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormTime -> ShowS
showsPrec :: Int -> FormTime -> ShowS
$cshow :: FormTime -> String
show :: FormTime -> String
$cshowList :: [FormTime] -> ShowS
showList :: [FormTime] -> ShowS
Show, FormTime -> FormTime -> Bool
(FormTime -> FormTime -> Bool)
-> (FormTime -> FormTime -> Bool) -> Eq FormTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormTime -> FormTime -> Bool
== :: FormTime -> FormTime -> Bool
$c/= :: FormTime -> FormTime -> Bool
/= :: FormTime -> FormTime -> Bool
Eq)
data Transition = Smooth | Snap
deriving (Int -> Transition -> ShowS
[Transition] -> ShowS
Transition -> String
(Int -> Transition -> ShowS)
-> (Transition -> String)
-> ([Transition] -> ShowS)
-> Show Transition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Transition -> ShowS
showsPrec :: Int -> Transition -> ShowS
$cshow :: Transition -> String
show :: Transition -> String
$cshowList :: [Transition] -> ShowS
showList :: [Transition] -> ShowS
Show, Transition -> Transition -> Bool
(Transition -> Transition -> Bool)
-> (Transition -> Transition -> Bool) -> Eq Transition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Transition -> Transition -> Bool
== :: Transition -> Transition -> Bool
$c/= :: Transition -> Transition -> Bool
/= :: Transition -> Transition -> Bool
Eq)
data FormNode = FormNode
{ FormNode -> FormTime
fnTime :: FormTime
, FormNode -> Double
fnKinetics :: Double
, FormNode -> Double
fnDynamic :: Double
, FormNode -> ProgressionContext
fnProg :: PC.ProgressionContext
, FormNode -> Transition
fnTrans :: Transition
} deriving (Int -> FormNode -> ShowS
[FormNode] -> ShowS
FormNode -> String
(Int -> FormNode -> ShowS)
-> (FormNode -> String) -> ([FormNode] -> ShowS) -> Show FormNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormNode -> ShowS
showsPrec :: Int -> FormNode -> ShowS
$cshow :: FormNode -> String
show :: FormNode -> String
$cshowList :: [FormNode] -> ShowS
showList :: [FormNode] -> ShowS
Show, FormNode -> FormNode -> Bool
(FormNode -> FormNode -> Bool)
-> (FormNode -> FormNode -> Bool) -> Eq FormNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormNode -> FormNode -> Bool
== :: FormNode -> FormNode -> Bool
$c/= :: FormNode -> FormNode -> Bool
/= :: FormNode -> FormNode -> Bool
Eq)
data Kinetics = Kinetics
{ Kinetics -> Pattern Double
kSignal :: Pattern Double
, Kinetics -> Pattern Double
kDynamic :: Pattern Double
, Kinetics -> Pattern ProgressionContext
kProg :: Pattern PC.ProgressionContext
, Kinetics -> Double
kLoopSecs :: Double
, Kinetics -> Double
kCps :: Double
}
type IK = (Kinetics, Pattern Int)
at, at', rh, rh' :: Double -> Double -> Double -> PC.ProgressionContext -> FormNode
at :: Double -> Double -> Double -> ProgressionContext -> FormNode
at Double
t Double
k Double
d ProgressionContext
pc = FormTime
-> Double -> Double -> ProgressionContext -> Transition -> FormNode
FormNode (Double -> FormTime
Secs Double
t) Double
k Double
d ProgressionContext
pc Transition
Smooth
at' :: Double -> Double -> Double -> ProgressionContext -> FormNode
at' Double
t Double
k Double
d ProgressionContext
pc = FormTime
-> Double -> Double -> ProgressionContext -> Transition -> FormNode
FormNode (Double -> FormTime
Secs Double
t) Double
k Double
d ProgressionContext
pc Transition
Snap
rh :: Double -> Double -> Double -> ProgressionContext -> FormNode
rh Double
b Double
k Double
d ProgressionContext
pc = FormTime
-> Double -> Double -> ProgressionContext -> Transition -> FormNode
FormNode (Double -> FormTime
Bars Double
b) Double
k Double
d ProgressionContext
pc Transition
Smooth
rh' :: Double -> Double -> Double -> ProgressionContext -> FormNode
rh' Double
b Double
k Double
d ProgressionContext
pc = FormTime
-> Double -> Double -> ProgressionContext -> Transition -> FormNode
FormNode (Double -> FormTime
Bars Double
b) Double
k Double
d ProgressionContext
pc Transition
Snap
iK :: Double -> [FormNode] -> Pattern Int -> IK
iK :: Double -> [FormNode] -> Pattern Int -> IK
iK Double
bpm [FormNode]
nodes Pattern Int
chordPat = (Double -> [FormNode] -> Kinetics
formK Double
bpm [FormNode]
nodes, Pattern Int
chordPat)
lK :: Pattern Double
-> Pattern Double
-> PC.ProgressionContext
-> Pattern Int
-> IK
lK :: Pattern Double
-> Pattern Double -> ProgressionContext -> Pattern Int -> IK
lK Pattern Double
sig Pattern Double
dyn ProgressionContext
pc Pattern Int
chordPat = (Pattern Double
-> Pattern Double
-> Pattern ProgressionContext
-> Double
-> Double
-> Kinetics
Kinetics Pattern Double
sig Pattern Double
dyn (ProgressionContext -> Pattern ProgressionContext
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressionContext
pc) Double
0 Double
0, Pattern Int
chordPat)
beatsPerBar :: Double
beatsPerBar :: Double
beatsPerBar = Double
4
nodeCycles :: Double -> FormNode -> Double
nodeCycles :: Double -> FormNode -> Double
nodeCycles Double
cps FormNode
n = case FormNode -> FormTime
fnTime FormNode
n of
Secs Double
s -> Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cps
Bars Double
b -> Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
beatsPerBar
nodeSecs :: Double -> FormNode -> Double
nodeSecs :: Double -> FormNode -> Double
nodeSecs Double
cps FormNode
n = case FormNode -> FormTime
fnTime FormNode
n of
Secs Double
s -> Double
s
Bars Double
b -> Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
beatsPerBar Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
cps
formK :: Double -> [FormNode] -> Kinetics
formK :: Double -> [FormNode] -> Kinetics
formK Double
bpm [FormNode]
nodes = Kinetics
{ kSignal :: Pattern Double
kSignal = Double -> [FormNode] -> (FormNode -> Double) -> Pattern Double
formSignal Double
cps [FormNode]
nodes FormNode -> Double
fnKinetics
, kDynamic :: Pattern Double
kDynamic = Double -> [FormNode] -> (FormNode -> Double) -> Pattern Double
formSignal Double
cps [FormNode]
nodes FormNode -> Double
fnDynamic
, kProg :: Pattern ProgressionContext
kProg = Double
-> [FormNode]
-> (FormNode -> ProgressionContext)
-> Pattern ProgressionContext
forall a. Double -> [FormNode] -> (FormNode -> a) -> Pattern a
formStep Double
cps [FormNode]
nodes FormNode -> ProgressionContext
fnProg
, kLoopSecs :: Double
kLoopSecs = case [FormNode]
nodes of
(FormNode
_:FormNode
_:[FormNode]
_) -> Double -> FormNode -> Double
nodeSecs Double
cps ([FormNode] -> FormNode
forall a. HasCallStack => [a] -> a
last [FormNode]
nodes)
[FormNode]
_ -> Double
0
, kCps :: Double
kCps = Double
cps
}
where cps :: Double
cps = Double
bpm Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60
formSignal :: Double -> [FormNode] -> (FormNode -> Double) -> Pattern Double
formSignal :: Double -> [FormNode] -> (FormNode -> Double) -> Pattern Double
formSignal Double
_ [FormNode
node] FormNode -> Double
accessor = Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ FormNode -> Double
accessor FormNode
node)
formSignal Double
cps [FormNode]
nodes FormNode -> Double
accessor =
let totalCycles :: Time
totalCycles = Double -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> FormNode -> Double
nodeCycles Double
cps ([FormNode] -> FormNode
forall a. HasCallStack => [a] -> a
last [FormNode]
nodes)) :: Time
pairs :: [(FormNode, FormNode)]
pairs = [FormNode] -> [FormNode] -> [(FormNode, FormNode)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FormNode]
nodes ([FormNode] -> [FormNode]
forall a. HasCallStack => [a] -> [a]
tail [FormNode]
nodes)
segments :: [(Time, Pattern Double)]
segments = [ ( Double -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> FormNode -> Double
nodeCycles Double
cps FormNode
n2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> FormNode -> Double
nodeCycles Double
cps FormNode
n1)
, case FormNode -> Transition
fnTrans FormNode
n1 of
Transition
Snap -> Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ FormNode -> Double
accessor FormNode
n1)
Transition
Smooth -> Pattern Time -> Pattern Double -> Pattern Double
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
16 (Pattern Double -> Pattern Double)
-> Pattern Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Pattern Double
-> Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a
range (Double -> Pattern Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ FormNode -> Double
accessor FormNode
n1)
(Double -> Pattern Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ FormNode -> Double
accessor FormNode
n2) Pattern Double
forall a. (Fractional a, Real a) => Pattern a
saw
)
| (FormNode
n1, FormNode
n2) <- [(FormNode, FormNode)]
pairs
]
in Pattern Time -> Pattern Double -> Pattern Double
forall a. Pattern Time -> Pattern a -> Pattern a
slow (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Time
totalCycles) (Pattern Double -> Pattern Double)
-> Pattern Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ [(Time, Pattern Double)] -> Pattern Double
forall a. [(Time, Pattern a)] -> Pattern a
timecat [(Time, Pattern Double)]
segments
formStep :: Double -> [FormNode] -> (FormNode -> a) -> Pattern a
formStep :: forall a. Double -> [FormNode] -> (FormNode -> a) -> Pattern a
formStep Double
_ [FormNode
node] FormNode -> a
accessor = a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormNode -> a
accessor FormNode
node)
formStep Double
cps [FormNode]
nodes FormNode -> a
accessor =
let totalCycles :: Time
totalCycles = Double -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> FormNode -> Double
nodeCycles Double
cps ([FormNode] -> FormNode
forall a. HasCallStack => [a] -> a
last [FormNode]
nodes)) :: Time
pairs :: [(FormNode, FormNode)]
pairs = [FormNode] -> [FormNode] -> [(FormNode, FormNode)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FormNode]
nodes ([FormNode] -> [FormNode]
forall a. HasCallStack => [a] -> [a]
tail [FormNode]
nodes)
segments :: [(Time, Pattern a)]
segments = [ ( Double -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> FormNode -> Double
nodeCycles Double
cps FormNode
n2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> FormNode -> Double
nodeCycles Double
cps FormNode
n1)
, a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormNode -> a
accessor FormNode
n1)
)
| (FormNode
n1, FormNode
n2) <- [(FormNode, FormNode)]
pairs
]
in Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
slow (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Time
totalCycles) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [(Time, Pattern a)] -> Pattern a
forall a. [(Time, Pattern a)] -> Pattern a
timecat [(Time, Pattern a)]
segments
ki :: (Double, Double) -> IK -> Pattern a -> Pattern a
ki :: forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double
lo, Double
hi) (Kinetics
kin, Pattern Int
_) = Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask ((Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Double
x -> Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi) (Kinetics -> Pattern Double
kSignal Kinetics
kin))
slate :: (Double, Double) -> IK -> [Pattern a] -> Pattern a
slate :: forall a. (Double, Double) -> IK -> [Pattern a] -> Pattern a
slate (Double, Double)
range IK
k [Pattern a]
pats = (Double, Double) -> IK -> Pattern a -> Pattern a
forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double, Double)
range IK
k (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack [Pattern a]
pats
kinPick :: IK -> [Pattern a] -> Pattern a
kinPick :: forall a. IK -> [Pattern a] -> Pattern a
kinPick IK
_ [] = Pattern a
forall a. Pattern a
silence
kinPick (Kinetics
kin, Pattern Int
_) [Pattern a]
pats =
let n :: Int
n = [Pattern a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
pats
step :: Double
step = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
window :: p -> Pattern a -> Pattern a
window p
i Pattern a
p =
let lo :: Double
lo = p -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
step
hi :: Double
hi = p -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (p
i p -> p -> p
forall a. Num a => a -> a -> a
+ p
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
step
inWin :: Double -> Bool
inWin Double
x | p
i p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
0 = Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi
| Bool
otherwise = Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi
in Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask ((Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Bool
inWin (Kinetics -> Pattern Double
kSignal Kinetics
kin)) Pattern a
p
in [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack ((Integer -> Pattern a -> Pattern a)
-> [Integer] -> [Pattern a] -> [Pattern a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Pattern a -> Pattern a
forall {p} {a}. Integral p => p -> Pattern a -> Pattern a
window [Integer
0..] [Pattern a]
pats)
withForm :: IK -> (PC.ProgressionContext -> Pattern ValueMap) -> Pattern ValueMap
withForm :: IK -> (ProgressionContext -> Pattern ValueMap) -> Pattern ValueMap
withForm (Kinetics
kin, Pattern Int
_) ProgressionContext -> Pattern ValueMap
f = Pattern (Pattern ValueMap) -> Pattern ValueMap
forall b. Pattern (Pattern b) -> Pattern b
innerJoin (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (ProgressionContext -> Pattern ValueMap)
-> Pattern ProgressionContext -> Pattern (Pattern ValueMap)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProgressionContext -> Pattern ValueMap
f (Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin)