module Fadno.Util where
import Control.Applicative
import Control.Monad (replicateM)
import Test.HUnit
import Data.List
import Data.Function (on)
import qualified Debug.Trace as T
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.State
import Control.Lens
diff :: Num a => [a] -> [a]
diff = zipTail (flip ())
zipTail :: (a -> a -> c) -> [a] -> [c]
zipTail f = zipWith f <*> tail
integ :: Int -> [Int] -> [Int]
integ = scanl (+)
trace :: String -> a -> a
trace s = T.trace ("<" ++ s ++ ">")
trace' :: Show a => String -> a -> a
trace' s a = trace1 s a a
trace1 :: Show b => String -> b -> a -> a
trace1 s a = trace (s ++ ":" ++ show a)
trace1' :: (Show a, Show b) => String -> b -> a -> a
trace1' s a b = trace (s ++ ":" ++ show a ++ "," ++ show b) b
popping :: (MonadState s m) => Int -> Lens' s [a] -> ([a] -> m b) -> m b
popping n l f = do
as <- use l
l .= drop n as
f (take n as)
popping' :: (MonadState s m) => Int -> Lens' s [a] -> ([a] -> m b) -> m (Maybe b)
popping' n l f = popping n l
(\as -> if null as then return Nothing else Just <$> f as)
popping1 :: (MonadState s m) => Lens' s [a] -> (a -> m b) -> m (Maybe b)
popping1 l f = popping' 1 l (f . head)
wrapSucc :: (Bounded a, Enum a, Eq a) => a -> a
wrapSucc s = if s == maxBound then minBound else succ s
wrapPred :: (Bounded a, Enum a, Eq a) => a -> a
wrapPred s = if s == minBound then maxBound else pred s
mutating :: MonadState s m => Lens' s a -> (a -> a) -> m (a,a)
mutating l f = do
a <- use l
a' <- l <.= f a
return (a,a')
maybe' :: Maybe a -> b -> (a -> b) -> b
maybe' m n j = maybe n j m
median :: Integral a => [a] -> Maybe a
median [] = Nothing
median ls = Just $ if odd len then sorted !! mid
else (sorted !! mid + sorted !! (mid 1)) `div` 2
where len = length ls
sorted = sort ls
mid = len `div` 2
normalize :: (Num a, Ord a) => [a] -> [a]
normalize l = map (flip () $ minimum l) l
pitchClassSet :: Int -> [Int] -> [Int]
pitchClassSet gamut line = let
modg = flip mod gamut
norm = normalize . sort . nub . map modg $ line
alts = nub $ map (\x -> normalize . sort $ map (modg . (x+)) norm) [0..(gamut1)]
vals = map (\x -> reverse $ map (flip () (head x)) x) alts
min = minimum vals
in fst . minimumBy (compare `on` snd) $ zip alts vals
lfsr :: Int -> Int -> Int -> [Bool]
lfsr len tap1 tap2 =
if len<tap1 || len<tap2 || tap1==tap2 || len<2 then
error ("lfsr: invalid arguments: " ++ show [len,tap1,tap2])
else
map snd . shift $ replicate len True where
shift r = v:next v where v = (r, r !! tap1 /= r !! tap2)
next (register,prev) = shift $ prev:register
rehMarks :: [String]
rehMarks = a ++ ((++) <$> a <*> a) where a = map (:[]) ['A'..'Z']
rotate :: Int -> [a] -> [a]
rotate i l = zipWith const (drop i $ cycle l) l
rotations :: [a] -> [[a]]
rotations l = flip rotate l <$> [1..(length l)]
allTuples :: Int -> [a] -> [[a]]
allTuples = replicateM
monotonic :: [Int] -> Bool
monotonic = (2 >) . length . nub . filter (EQ /=) . zipTail compare
interleave :: [[a]] -> [a]
interleave = concat . pivot
pivot :: [[a]] -> [[a]]
pivot chords = map iter [0..maxLength] where
maxLength = minimum (map length chords) 1
iter i = map (!! i) chords
filterOnKeys :: (Ord a) => [a] -> M.Map a b -> M.Map a b
filterOnKeys ks = M.filterWithKey (\k _ -> S.member k $ S.fromList ks)
pairBy :: (a -> b) -> [a] -> [(a,b)]
pairBy f = map (\a -> (a,f a))
delim :: String -> [String] -> String
delim _ [] = ""
delim _ [w] = w
delim d (w:ws) = w ++ d ++ delim d ws