-- | Common core functions.
module Sound.SC3.Common.Base where

import Control.Exception {- base -}
import Control.Monad {- base -}
import Data.Char {- base -}
import Data.Function {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import System.IO.Error {- base -}
import System.Environment {- base -}

-- * Function

-- | Unary function.
type Fn1 a b = a -> b

-- | Binary function.
type Fn2 a b c = a -> b -> c

-- | Ternary function.
type Fn3 a b c d = a -> b -> c -> d

-- | Quaternary function.
type Fn4 a b c d e = a -> b -> c -> d -> e

-- | Apply /f/ n times, ie. iterate f x !! n
--
-- > iter 3 (* 2) 1 == 8
-- > iterate (* 2) 1 !! 3 == 8
iter :: Int -> (a -> a) -> a -> a
iter :: Int -> (a -> a) -> a -> a
iter Int
n a -> a
f a
x = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then a
x else a -> a
f (Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
iter (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) a -> a
f a
x)

-- * Read

-- | Variant of 'reads' requiring exact match.
reads_exact :: Read a => String -> Maybe a
reads_exact :: String -> Maybe a
reads_exact String
s =
    case ReadS a
forall a. Read a => ReadS a
reads String
s of
      [(a
r,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
r
      [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

-- * STRING / CASE

-- | CI = Case insensitive, CS = case sensitive.
data Case_Rule = CI | CS deriving (Case_Rule -> Case_Rule -> Bool
(Case_Rule -> Case_Rule -> Bool)
-> (Case_Rule -> Case_Rule -> Bool) -> Eq Case_Rule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Case_Rule -> Case_Rule -> Bool
$c/= :: Case_Rule -> Case_Rule -> Bool
== :: Case_Rule -> Case_Rule -> Bool
$c== :: Case_Rule -> Case_Rule -> Bool
Eq)

-- | Predicates for 'Case_Rule'.
is_ci :: Case_Rule -> Bool
is_ci :: Case_Rule -> Bool
is_ci = Case_Rule -> Case_Rule -> Bool
forall a. Eq a => a -> a -> Bool
(==) Case_Rule
CI

-- | Predicates for 'Case_Rule'.
is_cs :: Case_Rule -> Bool
is_cs :: Case_Rule -> Bool
is_cs = Case_Rule -> Case_Rule -> Bool
forall a. Eq a => a -> a -> Bool
(==) Case_Rule
CS

-- | String equality with 'Case_Rule'.
--
-- > string_eq CI "lower" "LOWER" == True
string_eq :: Case_Rule -> String -> String -> Bool
string_eq :: Case_Rule -> String -> String -> Bool
string_eq Case_Rule
cr String
x String
y = if Case_Rule -> Bool
is_ci Case_Rule
cr then (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y else String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y

-- | 'rlookup_by' of 'string_eq'.
rlookup_str :: Case_Rule -> String -> [(a,String)] -> Maybe a
rlookup_str :: Case_Rule -> String -> [(a, String)] -> Maybe a
rlookup_str = (String -> String -> Bool) -> String -> [(a, String)] -> Maybe a
forall b a. (b -> b -> Bool) -> b -> [(a, b)] -> Maybe a
rlookup_by ((String -> String -> Bool) -> String -> [(a, String)] -> Maybe a)
-> (Case_Rule -> String -> String -> Bool)
-> Case_Rule
-> String
-> [(a, String)]
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Case_Rule -> String -> String -> Bool
string_eq

-- | 'Enum' parser with 'Case_Rule'.
--
-- > parse_enum CI "FALSE" == Just False
parse_enum :: (Show t,Enum t,Bounded t) => Case_Rule -> String -> Maybe t
parse_enum :: Case_Rule -> String -> Maybe t
parse_enum Case_Rule
cr String
nm =
    let u :: [t]
u = [t
forall a. Bounded a => a
minBound .. t
forall a. Bounded a => a
maxBound]
        t :: [(String, t)]
t = [String] -> [t] -> [(String, t)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((t -> String) -> [t] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map t -> String
forall a. Show a => a -> String
show [t]
u) [t]
u
    in (String -> String -> Bool) -> String -> [(String, t)] -> Maybe t
forall a t b. (a -> t -> Bool) -> a -> [(t, b)] -> Maybe b
lookup_by (Case_Rule -> String -> String -> Bool
string_eq Case_Rule
cr) String
nm [(String, t)]
t

-- * LIST

-- | Left to right composition of a list of functions.
--
-- > compose_l [(* 2),(+ 1)] 3 == 7
compose_l :: [t -> t] -> t -> t
compose_l :: [t -> t] -> t -> t
compose_l = (t -> [t -> t] -> t) -> [t -> t] -> t -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((t -> (t -> t) -> t) -> t -> [t -> t] -> t
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl t -> (t -> t) -> t
forall a b. a -> (a -> b) -> b
(&))

-- | Right to left composition of a list of functions.
--
-- > compose_r [(* 2),(+ 1)] 3 == 8
compose_r :: [t -> t] -> t -> t
compose_r :: [t -> t] -> t -> t
compose_r = (t -> [t -> t] -> t) -> [t -> t] -> t -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((t -> t) -> t -> t) -> t -> [t -> t] -> t
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t -> t) -> t -> t
forall a b. (a -> b) -> a -> b
($))

{- | SequenceableCollection.differentiate

> > [3,4,1,1].differentiate == [3,1,-3,0]

> d_dx [3,4,1,1] == [3,1,-3,0]
> d_dx [0,1,3,6] == [0,1,2,3]
-}
d_dx :: (Num a) => [a] -> [a]
d_dx :: [a] -> [a]
d_dx [a]
l = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [a]
l (a
0a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
l)

{- | Variant that does not prepend zero to input, ie. 'tail' of 'd_dx'.

> d_dx' [3,4,1,1] == [1,-3,0]
> d_dx' [0,1,3,6] == [1,2,3]
-}
d_dx' :: Num n => [n] -> [n]
d_dx' :: [n] -> [n]
d_dx' [n]
l = (n -> n -> n) -> [n] -> [n] -> [n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) ([n] -> [n]
forall a. [a] -> [a]
tail [n]
l) [n]
l

{- | SequenceableCollection.integrate

> > [3,4,1,1].integrate == [3,7,8,9]

> dx_d [3,4,1,1] == [3,7,8,9]
> dx_d (d_dx [0,1,3,6]) == [0,1,3,6]
> dx_d [0.5,0.5] == [0.5,1]
-}
dx_d :: Num n => [n] -> [n]
dx_d :: [n] -> [n]
dx_d = (n -> n -> n) -> [n] -> [n]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 n -> n -> n
forall a. Num a => a -> a -> a
(+)

{- | Variant pre-prending zero to output.

> dx_d' [3,4,1,1] == [0,3,7,8,9]
> dx_d' (d_dx' [0,1,3,6]) == [0,1,3,6]
> dx_d' [0.5,0.5] == [0,0.5,1]
-}
dx_d' :: Num n => [n] -> [n]
dx_d' :: [n] -> [n]
dx_d' = (n
0 n -> [n] -> [n]
forall a. a -> [a] -> [a]
:) ([n] -> [n]) -> ([n] -> [n]) -> [n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> [n]
forall n. Num n => [n] -> [n]
dx_d

-- | 'lookup' with equality function.
lookup_by :: (a -> t -> Bool) -> a -> [(t,b)] -> Maybe b
lookup_by :: (a -> t -> Bool) -> a -> [(t, b)] -> Maybe b
lookup_by a -> t -> Bool
f a
x = ((t, b) -> b) -> Maybe (t, b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, b) -> b
forall a b. (a, b) -> b
snd (Maybe (t, b) -> Maybe b)
-> ([(t, b)] -> Maybe (t, b)) -> [(t, b)] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, b) -> Bool) -> [(t, b)] -> Maybe (t, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> t -> Bool
f a
x (t -> Bool) -> ((t, b) -> t) -> (t, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t, b) -> t
forall a b. (a, b) -> a
fst)

-- | Erroring variant.
lookup_by_err :: (a -> t -> Bool) -> a -> [(t,b)] -> b
lookup_by_err :: (a -> t -> Bool) -> a -> [(t, b)] -> b
lookup_by_err a -> t -> Bool
f a
x = b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe (String -> b
forall a. HasCallStack => String -> a
error String
"lookup_by") (Maybe b -> b) -> ([(t, b)] -> Maybe b) -> [(t, b)] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t -> Bool) -> a -> [(t, b)] -> Maybe b
forall a t b. (a -> t -> Bool) -> a -> [(t, b)] -> Maybe b
lookup_by a -> t -> Bool
f a
x

-- | Reverse 'lookup' with equality function.
rlookup_by :: (b -> b -> Bool) -> b -> [(a,b)] -> Maybe a
rlookup_by :: (b -> b -> Bool) -> b -> [(a, b)] -> Maybe a
rlookup_by b -> b -> Bool
f b
x = ((a, b) -> a) -> Maybe (a, b) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst (Maybe (a, b) -> Maybe a)
-> ([(a, b)] -> Maybe (a, b)) -> [(a, b)] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (b -> b -> Bool
f b
x (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd)

-- | (prev,cur,next) triples.
--
-- > pcn_triples [1..3] == [(Nothing,1,Just 2),(Just 1,2,Just 3),(Just 2,3,Nothing)]
pcn_triples :: [a] -> [(Maybe a,a,Maybe a)]
pcn_triples :: [a] -> [(Maybe a, a, Maybe a)]
pcn_triples =
    let f :: Maybe a -> [a] -> [(Maybe a, a, Maybe a)]
f Maybe a
e [a]
l = case [a]
l of
                  a
e1 : a
e2 : [a]
l' -> (Maybe a
e,a
e1,a -> Maybe a
forall a. a -> Maybe a
Just a
e2) (Maybe a, a, Maybe a)
-> [(Maybe a, a, Maybe a)] -> [(Maybe a, a, Maybe a)]
forall a. a -> [a] -> [a]
: Maybe a -> [a] -> [(Maybe a, a, Maybe a)]
f (a -> Maybe a
forall a. a -> Maybe a
Just a
e1) (a
e2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
l')
                  [a
e'] -> [(Maybe a
e,a
e',Maybe a
forall a. Maybe a
Nothing)]
                  [] -> [(Maybe a, a, Maybe a)]
forall a. HasCallStack => a
undefined
    in Maybe a -> [a] -> [(Maybe a, a, Maybe a)]
forall a. Maybe a -> [a] -> [(Maybe a, a, Maybe a)]
f Maybe a
forall a. Maybe a
Nothing

-- | Separate first list element.
--
-- > sep_first "astring" == Just ('a',"string")
sep_first :: [t] -> Maybe (t,[t])
sep_first :: [t] -> Maybe (t, [t])
sep_first [t]
l =
    case [t]
l of
      t
e:[t]
l' -> (t, [t]) -> Maybe (t, [t])
forall a. a -> Maybe a
Just (t
e,[t]
l')
      [t]
_ -> Maybe (t, [t])
forall a. Maybe a
Nothing

-- | Separate last list element.
--
-- > sep_last "stringb" == Just ("string",'b')
sep_last :: [t] -> Maybe ([t], t)
sep_last :: [t] -> Maybe ([t], t)
sep_last =
    let f :: (b, [a]) -> ([a], b)
f (b
e,[a]
l) = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
l,b
e)
    in ((t, [t]) -> ([t], t)) -> Maybe (t, [t]) -> Maybe ([t], t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, [t]) -> ([t], t)
forall b a. (b, [a]) -> ([a], b)
f (Maybe (t, [t]) -> Maybe ([t], t))
-> ([t] -> Maybe (t, [t])) -> [t] -> Maybe ([t], t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Maybe (t, [t])
forall t. [t] -> Maybe (t, [t])
sep_first ([t] -> Maybe (t, [t])) -> ([t] -> [t]) -> [t] -> Maybe (t, [t])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> [t]
forall a. [a] -> [a]
reverse

-- | Are lists of equal length?
--
-- > equal_length_p ["t1","t2"] == True
-- > equal_length_p ["t","t1","t2"] == False
equal_length_p :: [[a]] -> Bool
equal_length_p :: [[a]] -> Bool
equal_length_p = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> ([[a]] -> Int) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> ([[a]] -> [Int]) -> [[a]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> ([[a]] -> [Int]) -> [[a]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

-- | Histogram
histogram :: Ord a => [a] -> [(a,Int)]
histogram :: [a] -> [(a, Int)]
histogram [a]
x =
    let g :: [[a]]
g = [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
x)
    in [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
forall a. [a] -> a
head [[a]]
g) (([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
g)

-- * TUPLES

-- | Zip two 4-tuples.
p4_zip :: (a,b,c,d) -> (e,f,g,h) -> ((a,e),(b,f),(c,g),(d,h))
p4_zip :: (a, b, c, d) -> (e, f, g, h) -> ((a, e), (b, f), (c, g), (d, h))
p4_zip (a
a,b
b,c
c,d
d) (e
e,f
f,g
g,h
h) = ((a
a,e
e),(b
b,f
f),(c
c,g
g),(d
d,h
h))

-- | Two-tuple.
type T2 a = (a,a)

-- | Three-tuple.
type T3 a = (a,a,a)

-- | Four-tuple.
type T4 a = (a,a,a,a)

-- | t -> (t,t)
dup2 :: t -> T2 t
dup2 :: t -> T2 t
dup2 t
t = (t
t,t
t)

-- | t -> (t,t,t)
dup3 :: t -> T3 t
dup3 :: t -> T3 t
dup3 t
t = (t
t,t
t,t
t)

-- | t -> (t,t,t,t)
dup4 :: t -> T4 t
dup4 :: t -> T4 t
dup4 t
t = (t
t,t
t,t
t,t
t)

-- | 'concatMap' of /f/ at /x/ and /g/ at /y/.
mk_duples :: (a -> c) -> (b -> c) -> [(a, b)] -> [c]
mk_duples :: (a -> c) -> (b -> c) -> [(a, b)] -> [c]
mk_duples a -> c
a b -> c
b = ((a, b) -> [c]) -> [(a, b)] -> [c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
x,b
y) -> [a -> c
a a
x, b -> c
b b
y])

-- | Length prefixed list variant of 'mk_duples'.
mk_duples_l :: (Int -> c) -> (a -> c) -> (b -> c) -> [(a,[b])] -> [c]
mk_duples_l :: (Int -> c) -> (a -> c) -> (b -> c) -> [(a, [b])] -> [c]
mk_duples_l Int -> c
i a -> c
a b -> c
b = ((a, [b]) -> [c]) -> [(a, [b])] -> [c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
x,[b]
y) -> a -> c
a a
x c -> [c] -> [c]
forall a. a -> [a] -> [a]
: Int -> c
i ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
y) c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (b -> c) -> [b] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map b -> c
b [b]
y)

-- | 'concatMap' of /f/ at /x/ and /g/ at /y/ and /h/ at /z/.
mk_triples :: (a -> d) -> (b -> d) -> (c -> d) -> [(a, b, c)] -> [d]
mk_triples :: (a -> d) -> (b -> d) -> (c -> d) -> [(a, b, c)] -> [d]
mk_triples a -> d
a b -> d
b c -> d
c = ((a, b, c) -> [d]) -> [(a, b, c)] -> [d]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
x,b
y,c
z) -> [a -> d
a a
x, b -> d
b b
y, c -> d
c c
z])

-- | [x,y] -> (x,y)
t2_from_list :: [t] -> T2 t
t2_from_list :: [t] -> T2 t
t2_from_list [t]
l = case [t]
l of {[t
p,t
q] -> (t
p,t
q);[t]
_ -> String -> T2 t
forall a. HasCallStack => String -> a
error String
"t2_from_list"}

-- | [x,y,z] -> (x,y,z)
t3_from_list :: [t] -> (t,t,t)
t3_from_list :: [t] -> (t, t, t)
t3_from_list [t]
l = case [t]
l of {[t
p,t
q,t
r] -> (t
p,t
q,t
r);[t]
_ -> String -> (t, t, t)
forall a. HasCallStack => String -> a
error String
"t3_from_list"}

-- * System

-- | Guarded variant of 'getEnv' with default value.
get_env_default :: String -> String -> IO String
get_env_default :: String -> String -> IO String
get_env_default String
e String
k = do
  Either () String
r <- (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO String
getEnv String
e)
  case Either () String
r of
    Right String
v -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
v
    Either () String
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
k

-- | 'lookupEnv' with default value.
--
-- > lookup_env_default "PATH" "/usr/bin"
lookup_env_default :: String -> String -> IO String
lookup_env_default :: String -> String -> IO String
lookup_env_default String
e String
k = (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
k) (String -> IO (Maybe String)
lookupEnv String
e)