{-# Language FlexibleInstances #-}

-- | Unique identifier types and classes.
--   Used by non-deterministic (noise) and non-sharable (demand) unit generators.
module Sound.SC3.Common.UId where

import Data.Functor.Identity {- base -}
import Data.List {- base -}
import qualified Data.Unique as Unique {- base -}

import qualified Control.Monad.Trans.Reader as Reader {- transformers -}
import qualified Control.Monad.Trans.State as State {- transformers -}
import qualified Data.Digest.Murmur32 as Murmur32 {- hashable -}

import qualified Sound.SC3.Common.Base as Base {- hsc3 -}

-- * Id & UId

-- | Identifiers are integers.
type Id = Int

-- | A class indicating a monad (and functor and applicative) that will
-- generate a sequence of unique integer identifiers.
class (Functor m,Applicative m,Monad m) => UId m where
   generateUId :: m Int

-- | Requires FlexibleInstances.
instance UId (State.StateT Int Identity) where
    generateUId :: StateT Int Identity Int
generateUId = StateT Int Identity Int
forall (m :: * -> *) s. Monad m => StateT s m s
State.get StateT Int Identity Int
-> (Int -> StateT Int Identity Int) -> StateT Int Identity Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n -> Int -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) StateT Int Identity ()
-> StateT Int Identity Int -> StateT Int Identity Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT Int Identity Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

instance UId IO where
    generateUId :: IO Int
generateUId = (Unique -> Int) -> IO Unique -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Int
Unique.hashUnique IO Unique
Unique.newUnique

instance UId m => UId (Reader.ReaderT t m) where
   generateUId :: ReaderT t m Int
generateUId = (t -> m Int) -> ReaderT t m Int
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
Reader.ReaderT (m Int -> t -> m Int
forall a b. a -> b -> a
const m Int
forall (m :: * -> *). UId m => m Int
generateUId)

-- * UId_ST

-- | 'State.State' UId.
type UId_ST = State.State Int

-- | Alias for 'runIdentity'.
uid_id_eval :: Identity t -> t
uid_id_eval :: Identity t -> t
uid_id_eval = Identity t -> t
forall a. Identity a -> a
runIdentity

-- | 'State.evalState' with initial state of zero.
--
-- > uid_st_eval (replicateM 3 generateUId) == [0,1,2]
uid_st_eval :: UId_ST t -> t
uid_st_eval :: UId_ST t -> t
uid_st_eval UId_ST t
x = UId_ST t -> Int -> t
forall s a. State s a -> s -> a
State.evalState UId_ST t
x Int
0

-- | Thread state through sequence of 'State.runState'.
uid_st_seq :: [UId_ST t] -> ([t],Int)
uid_st_seq :: [UId_ST t] -> ([t], Int)
uid_st_seq =
    let swap :: (b, a) -> (a, b)
swap (b
p,a
q) = (a
q,b
p)
        step_f :: a -> State a b -> (a, b)
step_f a
n State a b
x = (b, a) -> (a, b)
forall b a. (b, a) -> (a, b)
swap (State a b -> a -> (b, a)
forall s a. State s a -> s -> (a, s)
State.runState State a b
x a
n)
    in (Int, [t]) -> ([t], Int)
forall b a. (b, a) -> (a, b)
swap ((Int, [t]) -> ([t], Int))
-> ([UId_ST t] -> (Int, [t])) -> [UId_ST t] -> ([t], Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> UId_ST t -> (Int, t)) -> Int -> [UId_ST t] -> (Int, [t])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Int -> UId_ST t -> (Int, t)
forall a b. a -> State a b -> (a, b)
step_f Int
0

-- | 'fst' of 'uid_st_seq'.
--
-- > uid_st_seq_ (replicate 3 generateUId) == [0,1,2]
uid_st_seq_ :: [UId_ST t] -> [t]
uid_st_seq_ :: [UId_ST t] -> [t]
uid_st_seq_ = ([t], Int) -> [t]
forall a b. (a, b) -> a
fst (([t], Int) -> [t])
-> ([UId_ST t] -> ([t], Int)) -> [UId_ST t] -> [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UId_ST t] -> ([t], Int)
forall t. [UId_ST t] -> ([t], Int)
uid_st_seq

-- * Lift

-- | Unary UId lift.
liftUId1 :: UId m => (Int -> Base.Fn1 a b) -> Base.Fn1 a (m b)
liftUId1 :: (Int -> Fn1 a b) -> Fn1 a (m b)
liftUId1 Int -> Fn1 a b
f a
a = do
  Int
n <- m Int
forall (m :: * -> *). UId m => m Int
generateUId
  b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Fn1 a b
f Int
n a
a)

-- | Binary UId lift.
liftUId2 :: UId m => (Int -> Base.Fn2 a b c) -> Base.Fn2 a b (m c)
liftUId2 :: (Int -> Fn2 a b c) -> Fn2 a b (m c)
liftUId2 Int -> Fn2 a b c
f a
a b
b = do
  Int
n <- m Int
forall (m :: * -> *). UId m => m Int
generateUId
  c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Fn2 a b c
f Int
n a
a b
b)

-- | Ternary UId lift.
liftUId3 :: UId m => (Int -> Base.Fn3 a b c d) -> Base.Fn3 a b c (m d)
liftUId3 :: (Int -> Fn3 a b c d) -> Fn3 a b c (m d)
liftUId3 Int -> Fn3 a b c d
f a
a b
b c
c = do
  Int
n <- m Int
forall (m :: * -> *). UId m => m Int
generateUId
  d -> m d
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Fn3 a b c d
f Int
n a
a b
b c
c)

-- | Quaternary UId lift.
liftUId4 :: UId m => (Int -> Base.Fn4 a b c d e) -> Base.Fn4 a b c d (m e)
liftUId4 :: (Int -> Fn4 a b c d e) -> Fn4 a b c d (m e)
liftUId4 Int -> Fn4 a b c d e
f a
a b
b c
c d
d = do
  Int
n <- m Int
forall (m :: * -> *). UId m => m Int
generateUId
  e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Fn4 a b c d e
f Int
n a
a b
b c
c d
d)

-- * ID

-- | Typeclass to constrain UGen identifiers.
--
-- > map resolveID [0::Int,1] == [3151710696,1500603050]
-- > map resolveID ['α','β'] == [1439603815,4131151318]
-- > map resolveID [('α','β'),('β','α')] == [3538183581,3750624898]
-- > map resolveID [('α',('α','β')),('β',('α','β'))] == [0020082907,2688286317]
-- > map resolveID [('α','α','β'),('β','α','β')] == [0020082907,2688286317]
class Murmur32.Hashable32 a => ID a where
    resolveID :: a -> Id
    resolveID = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> (a -> Word32) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash32 -> Word32
Murmur32.asWord32 (Hash32 -> Word32) -> (a -> Hash32) -> a -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Hash32
forall a. Hashable32 a => a -> Hash32
Murmur32.hash32

instance ID Char where
instance ID Int where
instance (ID p,ID q) => ID (p,q) where
instance (ID p,ID q,ID r) => ID (p,q,r) where

-- | /n/ identifiers from /x/.
--
-- > id_seq 10 'α' == [1439603815 .. 1439603824]
id_seq :: ID a => Int -> a -> [Id]
id_seq :: Int -> a -> [Int]
id_seq Int
n a
x = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n [a -> Int
forall a. ID a => a -> Int
resolveID a
x ..]