{-# OPTIONS_GHC -threaded #-}
module DobutokO.Sound.Functional.Elements (
renormF
, renormFD
, sameOvertone
, sameOvertoneL
, sameFreqF
, sameFreqFI
, fAddFElem
, fRemoveFElem
, fChangeFElem
, gAdd01
, gAdd02
, gAdd03
, gAdd04
, gRem01
, gRem02
, gRem03
, fAddFElems
, fRemoveFElems
, fChangeFElems
, freqsOverlapOvers
, elemsOverlapOvers
, gAdds01
, gAdds02
) where
import Data.List (sort,sortBy)
import qualified Data.Vector as V
import DobutokO.Sound.Functional.Basics
renormF :: OvertonesO -> OvertonesO
renormF v
| V.null v = V.empty
| otherwise =
let v1 = V.fromList . sortBy (\(_,y1) (_,y2)-> compare (abs y2) (abs y1)) . V.toList $ v in
if (\(_,y) -> y == 0.0) . V.unsafeIndex v1 $ 0 then V.empty
else V.map (\(x,y) -> (x, y / (snd . V.unsafeIndex v1 $ 0))) v1
renormFD :: Float -> OvertonesO -> OvertonesO
renormFD ampl0 v
| V.null v = V.empty
| otherwise =
let v1 = V.fromList . sortBy (\(_,y1) (_,y2)-> compare (abs y2) (abs y1)) . V.toList $ v in
if (\(_,y) -> y == 0.0) . V.unsafeIndex v1 $ 0 then V.empty
else V.map (\(x,y) -> (x, ampl0 * y / (snd . V.unsafeIndex v1 $ 0))) v1
sameOvertone :: OvertonesO -> Bool
sameOvertone v
| V.null v = False
| otherwise = V.all (\(x,_) -> x == (fst . V.unsafeIndex v $ 0)) v
sameOvertoneL :: [(Float,Float)] -> Bool
sameOvertoneL xs@((x,_):_) = all (\(xn,_) -> xn == x) xs
sameOvertoneL _ = False
sameFreqF :: Float -> (Float,Float) -> (Float -> OvertonesO) -> ((Float,Float) -> OvertonesO -> OvertonesO) -> OvertonesO
sameFreqF freq (noteN0,amplN0) f g = g (noteN0,amplN0) (f freq)
sameFreqFI :: Float -> (Float,Float) -> (Float -> OvertonesO) -> ((Float,Float) -> OvertonesO -> OvertonesO) -> OvertonesO
sameFreqFI freq (noteN0,amplN0) f g = g (noteN0,amplN0) . V.filter (\(x,_) -> x == noteN0) $ f freq
fAddFElem :: (Float, Float) -> (Float -> OvertonesO) -> ((Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO) ->
(Float -> OvertonesO)
fAddFElem (noteN, amplN) f gAdd t = gAdd (noteN, amplN) t f
fRemoveFElem :: (Float, Float) -> (Float -> OvertonesO) -> ((Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO) ->
(Float -> OvertonesO)
fRemoveFElem (noteN, amplN) f gRem t = gRem (noteN, amplN) t f
fChangeFElem :: (Float, Float) -> Float -> (Float -> ((Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO)) -> (Float -> OvertonesO) ->
(Float -> OvertonesO)
fChangeFElem (noteN, amplN) freq h f t = (h freq) (noteN, amplN) t f
gAdd01 :: (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdd01 (note,ampl) freq f
| V.null . f $ freq = V.singleton (note,ampl)
| otherwise =
let v1 = renormF . f $ freq in
let v2 = V.findIndices (\(x,_) -> x == note) v1 in
if V.null v2 then V.cons (note,ampl) (f freq)
else renormF . V.imap (\i (t,w) -> if i `V.elem` v2 then (t,w + ampl / fromIntegral (V.length v2)) else (t,w)) $ v1
gAdd02 :: Float -> (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdd02 amplMax (note,ampl) freq = renormFD amplMax . gAdd01 (note,ampl) freq
gAdd03 :: (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdd03 (note,ampl) freq f
| V.null . f $ freq = V.singleton (note,ampl)
| otherwise =
let v1 = renormF . f $ freq in
let v2 = V.findIndices (\(x,_) -> x == note) v1 in
if V.null v2 then renormF . V.cons (note,ampl) $ f freq
else
let xs = sortBy (\(x1,_) (x2,_)-> compare (abs x2) (abs x1)) . V.toList $ v1
l = V.length v1
ys = if compare l 1 == GT then ((fst . head $ xs) + (fst . head . tail $ xs) / 2,ampl):xs
else [(note,((snd . V.unsafeIndex v1 $ 0) + ampl) / 2),(2 * note,(abs ((snd . V.unsafeIndex v1 $ 0) - ampl)) / 2)] in
renormF . V.fromList $ ys
gRem01 :: (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gRem01 (note,ampl) freq f
| V.null . f $ freq = V.empty
| otherwise =
let v1 = renormF . f $ freq in
let v2 = V.findIndices (\(x,y) -> x == note && y == ampl) v1 in
if V.null v2 then
if compare (V.length v1) 5 == GT then renormF . V.unsafeSlice 0 (V.length v1 - 1) $ v1
else v1
else renormF . V.imap (\i (t,w) -> if i `V.elem` v2 then (t,w - ampl / fromIntegral (V.length v2)) else (t,w)) $ v1
gRem02 :: Float -> (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gRem02 amplMax (note,ampl) freq = renormFD amplMax . gAdd01 (note,ampl) freq
fAddFElems :: OvertonesO -> (Float -> OvertonesO) -> (OvertonesO -> Float -> (Float -> OvertonesO) -> OvertonesO) ->
(Float -> OvertonesO)
fAddFElems v f gAdds t = gAdds v t f
fRemoveFElems :: OvertonesO -> (Float -> OvertonesO) -> (OvertonesO -> Float -> (Float -> OvertonesO) -> OvertonesO) ->
(Float -> OvertonesO)
fRemoveFElems v f gRems t = gRems v t f
fChangeFElems :: OvertonesO -> Float -> (Float -> (OvertonesO -> Float -> (Float -> OvertonesO) -> OvertonesO)) -> (Float -> OvertonesO) ->
(Float -> OvertonesO)
fChangeFElems v freq h f t = (h freq) v t f
freqsOverlapOvers :: OvertonesO -> OvertonesO -> Bool
freqsOverlapOvers v1 v2 =
let [v11,v21] = map (V.map fst) [v1,v2]
v22 = V.filter (<= V.maximum v11) v21 in
if V.null v22 then False
else
let v12 = V.filter (>= V.minimum v21) v11
[v13,v23] = map (V.uniq . V.fromList . sort . V.toList) [v12,v22]
[l1,l2] = map V.length [v13,v23] in compare (V.length . V.uniq . V.fromList . sort . V.toList . V.concat $ [v13,v23]) (l1 + l2) == LT
elemsOverlapOvers :: OvertonesO -> OvertonesO -> Bool
elemsOverlapOvers v1 v2 =
let v22 = V.filter (\(x,_) -> x <= fst (V.maximumBy (\(x1,_) (t,_) -> compare x1 t) v1)) v2 in
if V.null v22 then False
else
let v12 = V.filter (\(x,_) -> x >= fst (V.minimumBy (\(x1,_) (t,_) -> compare x1 t) v2)) v1
[v13,v23] = map (V.uniq . V.fromList . sort . V.toList) [v12,v22]
[l1,l2] = map V.length [v13,v23] in compare (V.length . V.uniq . V.fromList . sort . V.toList . V.concat $ [v13,v23]) (l1 + l2) == LT
gAdds01 :: OvertonesO -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdds01 v0 freq f
| V.null . f $ freq = v0
| freqsOverlapOvers v0 (f freq) =
let ys = sortBy (\(x1,_) (x2,_) -> compare x1 x2) . V.toList $ v0
h ys
| null ys = []
| otherwise = (takeWhile (not . (/= head ys)) ys):h (dropWhile (not . (/= head ys)) ys)
h1 = map (\zs -> (sum . map snd $ zs) / fromIntegral (length zs)) . h
h2 ys = map (fst . head) (h ys)
v2 = V.fromList . zip (h2 ys) $ (h1 ys)
us = sortBy (\(x1,_) (x2,_) -> compare x1 x2) . V.toList $ f freq
v3 = V.fromList . zip (h2 us) $ (h1 us) in renormF . V.concat $ [v2,v3]
| otherwise = renormF . V.concat $ [v0, f freq]
gAdds02 :: Float -> OvertonesO -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdds02 amplMax v0 freq = renormFD amplMax . gAdds01 v0 freq
gAdd04 :: (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gAdd04 (note,ampl) freq f
| V.null . f $ freq = V.singleton (note,ampl)
| otherwise =
let v1 = V.fromList . sortBy (\(x1,_) (x2,_) -> compare x1 x2) . V.toList . f $ freq
v2 = V.zipWith (\(x1,_) (x2,_) -> x2 - x1) v1 (V.unsafeSlice 1 (V.length v1 - 1) v1)
idxMax = V.maxIndex v2
newFreq = (fst (V.unsafeIndex v1 (idxMax + 1)) + fst (V.unsafeIndex v1 idxMax)) / 2 in (newFreq,ampl) `V.cons` v1
gRem03 :: (Float,Float) -> Float -> (Float -> OvertonesO) -> OvertonesO
gRem03 (note,halfwidth) freq f =
let v1 = V.filter (\(x,_) -> compare (abs (x - note)) halfwidth /= GT) . f $ freq in
if compare (V.length v1) 5 /= GT then renormF . V.generate 5 $ (\i -> (fromIntegral (i + 1) * note, halfwidth / fromIntegral (i + 3)))
else v1