MiscListUtils.hs

------------------------------------------------------------------------------

-- MiscListUtils.hs
-- created: Sun Mar 14 17:00:11 JST 2010

------------------------------------------------------------------------------

-- A set of functions for operating on lists of floats
-- The purpose is creating interesting lists for use in music.

module Sound.Conductive.MiscListUtils where

import System.Random
import Data.List
import Data.Array.ST
import Data.Time.Clock.POSIX
import Control.Monad
import Control.Monad.ST
import Data.STRef
import Sound.Conductive.MusicalTime

unconcat xs = map (\x -> [x]) xs

-- http://old.nabble.com/Request-for-code-review:-slice-1.0.0,-TestSupport-td20658828.html

getSeed = getPOSIXTime >>= \x -> return $ truncate $ x * 100000000

slice :: [a] -> [Int] -> [a]
xs `slice` indices = map (xs !!) indices

replaceAt :: Int -> [a] -> [a] -> [a]
replaceAt i ys xs = 
   let xz = splitAt i xs
   in (fst xz) ++ ys ++ (tail $ snd xz)

-- use this for double-time, creating triplets, fivelets even...

npletAt :: (Fractional a) => Int -> Int -> [a] -> [a]
npletAt n i xs =
   let x = xs!!i
       plet = replicate n $ x/(fromIntegral n)
   in replaceAt i plet xs

-- joins n number of values in list of xs beginning from sp

joinVals :: (Num a) => Int -> Int -> [a] -> [a]
joinVals sp n xs = let
   splitXs = splitAt sp xs
   newFront = fst splitXs
   oldRest = snd splitXs
   newRest = [sum $ take n $ oldRest] ++ (snd $ splitAt n oldRest)
   in newFront ++ newRest

stutter :: Int -> Int -> Int -> [a] -> [a]
stutter sp l n xs = let
   splitList = splitAt sp xs
   initial = fst splitList
   toBeStuttered = take l $ snd splitList
   remainder = snd $ splitAt l $ snd splitList
   stuttered = concat $ replicate n toBeStuttered
   in initial ++ stuttered ++ remainder

-- modified slightly from http://www.haskell.org/haskellwiki/99_questions/Solutions/24

diff_select :: Int -> Int -> IO [Int]
diff_select n to = diff_select' n [0..to]
 
diff_select' 0 _  = return []
diff_select' _ [] = error "too few elements to choose from"
diff_select' n xs = do r <- randomRIO (0,(length xs)-1)
                       let remaining = take r xs ++ drop (r+1) xs
                       rest <- diff_select' (n-1) remaining
                       return ((xs!!r) : rest)

randomSubset xs subsetSize = let
    len = length xs
    in do is <- diff_select subsetSize $ (len - 1)
          return $ map (xs!!) is

-- | Randomly shuffle a list without the IO Monad
--   /O(N)/
-- ??? -- where did I get this function from? I didn't write it...

shuffle' :: [a] -> StdGen -> ([a],StdGen)
shuffle' xs gen = runST (do
        g <- newSTRef gen
        let randomRST lohi = do
              (a,s') <- liftM (randomR lohi) (readSTRef g)
              writeSTRef g s'
              return a
        ar <- newArray n xs
        xs' <- forM [1..n] $ \i -> do
                j <- randomRST (i,n)
                vi <- readArray ar i
                vj <- readArray ar j
                writeArray ar j vi
                return vj
        gen' <- readSTRef g
        return (xs',gen'))
  where
    n = length xs
    newArray :: Int -> [a] -> ST s (STArray s Int a)
    newArray n xs =  newListArray (1,n) xs

shuffle :: [a] -> IO [a]
shuffle xs = getStdRandom (shuffle' xs) 

rotate :: [a] -> Int -> [a]
rotate xs n = drop nn xs ++ take nn xs
    where 
      nn = n `mod` length xs

lace :: [[a]] -> Int -> [a]
lace xss n = let
    listNLengths = zip (map length xss) (xss)
    selector t x = (snd x)!!(mod t $ fst x)
    aRun t = map (selector t) listNLengths
    o = ceiling $ (fromIntegral n)/(fromIntegral $ length xss)
    in take n $ concat $ map aRun [0..o]

randomList :: Int -> StdGen -> [Int]
randomList n = take n . unfoldr (Just . random)

-- normalizes to 1
normalize xs = map (\x -> x/m) xs where m = maximum xs

normalizeTo t xs = map (\x -> x * m) xs where m = t/(maximum xs)

-- linear interpolation of a point from
-- http://arcanesentiment.blogspot.jp/2009/08/function-of-day-lerp.html
-- retrieved June 2012

lerp (x1,y1) (x2,y2) x = y1 + (x - x1) * (y2 - y1) / (x2 - x1)

rList :: Int -> IO [Int]
rList x = do
    seed  <- newStdGen
    let rs = randomList x seed
    return $ map abs rs

-- http://osfameron.vox.com/library/post/random-pain-in-haskell.html
-- pick a = do r <- randomRIO (1, length a)
--             return $ a !! (r - 1)

pick :: [a] -> IO a
pick []     = undefined
pick [x]    = do return x
pick (x:xs) = pick' x xs (2 :: Int)

-- pick' :: (Num p, Random p) => t -> [t] -> p -> IO t
pick' curr []          _    = do return curr
pick' curr (next:rest) prob
  = do r <- getStdRandom (randomR (1,prob))
       let curr' = if r == 1 then next else curr
       pick' curr' rest (prob+1)

pickN :: (Num a, Enum a) => a -> [b] -> IO [b]
pickN n xs = mapM (\_ -> pick xs) [1..n]

coin :: IO Bool
coin = pick [True,False]

-- odds against 

odds :: Int -> Int -> IO Bool
odds n d = pick $ (replicate n False) ++ (replicate d True)

-- from tuples where fst says how many and snd says what, create the lists

replicator :: [(Int, b)] -> [b]
replicator xs = concat $ map (\x -> replicate (fst x) $ snd x ) xs

-- an alias for replicator

weightedList = replicator

------------------------------------------------------------------------------

-- takeToValue
-- give the maximum sum of a list
-- if the sum is greater than the given value, the list is cropped
-- the final sum is lowered so that the list sum equals the given value
-- if the list is short of the given value, another item is added so that the list sum equals the given value
--
-- This can be used to make a list of values sum to a specific number of beats.

takeToValue' :: (Ord a, Num a) => [a] -> a -> a -> [a] -> [a]
takeToValue' xs val curVal ys
    | xs == []  = if (val <= curVal)
                     then ys
                     else ys ++ [val-curVal]
    | otherwise =
          let c = head xs
              d = curVal + c
              adjustValue input comparison
                  | input >= comparison  = (False,input - comparison)
                  | input <  comparison  = (True,0)
              test = adjustValue d val
          in if (fst test)
              then takeToValue' (tail xs) val d $ ys ++ [c]
              else takeToValue' ([]) val d $ ys ++ [c - (snd test)]

takeToValue :: (Num a, Ord a) => a -> [a] -> [a]
takeToValue val xs = takeToValue' xs val 0 []

------------------------------------------------------------------------------