Utility.hs

module Synthesizer.Utility where

import qualified Algebra.Module    as Module
import qualified Algebra.RealField as RealField
import qualified Algebra.Field     as Field

import System.Random (Random, RandomGen, randomRs, )

import Prelude ()
import PreludeBase
import NumericPrelude


{-# INLINE viewListL #-}
viewListL :: [a] -> Maybe (a, [a])
viewListL [] = Nothing
viewListL (x:xs) = Just (x,xs)

-- for constant padding
{-# INLINE viewListR #-}
viewListR :: [a] -> Maybe ([a], a)
viewListR =
   foldr (\x -> Just . maybe ([],x) (mapFst (x:))) Nothing

{-|
Apply the function @f@ n times to the start value.

You can express that function using 

> nest n f x = (iterate f x) !! n
> nest n f = foldl (.) id (replicate n f)

but this is not as elegant as calling @nest@.
Simon Thompson calls it @iter@.
-}
{-# INLINE nest #-}
nest :: Int -> (a -> a) -> a -> a
nest 0 _ x = x
nest n f x = f (nest (n-1) f x)


-- see event-list package
-- | Control.Arrow.***
{-# INLINE mapPair #-}
mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)
mapPair ~(f,g) ~(x,y) = (f x, g y)

-- | Control.Arrow.first
{-# INLINE mapFst #-}
mapFst :: (a -> c) -> (a,b) -> (c,b)
mapFst f ~(x,y) = (f x, y)

-- | Control.Arrow.second
{-# INLINE mapSnd #-}
mapSnd :: (b -> d) -> (a,b) -> (a,d)
mapSnd g ~(x,y) = (x, g y)


{-# INLINE fst3 #-}
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a

{-# INLINE snd3 #-}
snd3 :: (a,b,c) -> b
snd3 (_,b,_) = b

{-# INLINE thd3 #-}
thd3 :: (a,b,c) -> c
thd3 (_,_,c) = c


{-# INLINE swap #-}
swap :: (a,b) -> (b,a)
swap (x,y) = (y,x)


{-|
If two values are equal, then return one of them,
otherwise raise an error.
-}
{-# INLINE common #-}
common :: (Eq a) => String -> a -> a -> a
common errorMsg x y =
   if x == y
     then x
     else error errorMsg


-- * arithmetic


{-# INLINE fwrap #-}
fwrap :: RealField.C a => (a,a) -> a -> a
fwrap (lo,hi) x = lo + fmod (x-lo) (hi-lo)

{-# INLINE fmod #-}
fmod :: RealField.C a => a -> a -> a
fmod x y = fraction (x/y) * y

{-# INLINE fmodAlt #-}
fmodAlt :: RealField.C a => a -> a -> a
fmodAlt x y = x - fromInteger (floor (x/y)) * y

propFMod :: RealField.C a => a -> a -> Bool
propFMod x y =
--   y /= 0 ==>
   fmod x y == fmodAlt x y

{-# INLINE affineComb #-}
affineComb :: (Module.C t y) => t -> (y,y) -> y
affineComb phase (x0,x1) = x0 + phase *> (x1-x0)

{-# INLINE balanceLevel #-}
balanceLevel :: (Field.C y) =>
   y -> [y] -> [y]
balanceLevel center xs =
   let d = center - sum xs / fromIntegral (length xs)
   in  map (d+) xs

{-# INLINE randomRsBalanced #-}
randomRsBalanced :: (RandomGen g, Random y, Field.C y) =>
   g -> Int -> y -> y -> [y]
randomRsBalanced g n center width =
   balanceLevel center (take n $ randomRs (zero,width) g)


{-# INLINE clip #-}
clip :: Ord a => a -> a -> a -> a
clip lower upper = max lower . min upper