> {-# LANGUAGE OverloadedStrings #-}

> module Pattern where

> import Data.List
> import Data.Maybe
> import Control.Applicative
> import Data.Fixed

> type Period = Maybe Int
> type Behaviour a = Int -> [Maybe a]
> data Pattern a = Pattern {at :: Behaviour a, period :: Period}

> lcd :: Period -> Period -> Period
> lcd Nothing _ = Nothing
> lcd _ Nothing = Nothing
> lcd (Just n) (Just n') = Just $ lcm n n'

> justPeriod :: Pattern a -> Int
> justPeriod = fromJust . period

> instance (Show a) => Show (Pattern a) where
>    show (Pattern _ (Just 0)) = ""
>
>    show p@(Pattern f (Just l)) 
>        = show2D $ map (map show . at p) range
>     where range = [0 .. (l - 1)]
>
>    show p@(Pattern f Nothing) 
>        = show2D (map (map show . at p) range) ++ "\n..."
>     where range = [0 .. 15]

> show2D = intercalate "\n" . map (intercalate " ")

Thanks to Ryan Ingram for this elegant functor implementation.
http://ryani.livejournal.com/19471.html

> instance Functor Pattern where
>   fmap f (Pattern xs p) = Pattern (fmap (fmap (fmap f)) xs) p

> instance Applicative Pattern where 
>   pure x = Pattern (pure (pure (pure x))) (Just 1)
>   Pattern fs pf <*> Pattern xs px = Pattern (liftA2 (zipCycleA2 (<*>)) fs xs) (lcd pf px)

Halway between the applicative definition of a list and a ziplist.  If
lists aren't the same length, the smallest one is cycled to the same
length of the largest before zipping.

> zipCycleA2 f a b = zipWith id (f <$> takeCycle n a) (takeCycle n b)
>     where n = max (length a) (length b)

> takeCycle :: Int -> [a] -> [a]
> takeCycle n = take n . cycle

The null pattern is a zero period of undefinedness.

> nullPattern :: Pattern a
> nullPattern = Pattern {at = const undefined, period = Just 0}

Silence is one empty period.

> silence :: Pattern a
> silence = Pattern {at = const [Nothing], period = Just 1}

Turn a single thing into a pattern of things.

> atom :: a -> Pattern a
> atom = pure

> lToP :: [Maybe a] -> Pattern a
> lToP [] = silence
> lToP xs = Pattern (\n -> [xs !! (n `mod` len)]) (Just len)
>     where len = length xs

Add one pattern on the end of another.

> append :: Pattern a -> Pattern a -> Pattern a
> append a@(Pattern f Nothing) _ = a
> append a@(Pattern _ (Just l)) b@(Pattern _ Nothing) = Pattern newF Nothing
>     where newF n | n < l = at a n
>                  | otherwise = at b (n - l)
> append a@(Pattern f (Just l)) b@(Pattern f' (Just l')) = Pattern newF (Just newL)
>     where newL = l + l'
>           newF n | cycleP < l = f ((loopN * l) + cycleP)
>                  | otherwise = f' ((loopN * l') + (cycleP - l))
>                  where cycleP = n `mod` newL
>                        loopN = n `div` newL
    
> toInfinity (Pattern f _) = Pattern f Nothing

> isInf :: Pattern a -> Bool
> isInf (Pattern _ Nothing) = True
> isInf _ = False

Concatenate a list of patterns

> cat :: [Pattern a] -> Pattern a
> cat = foldr append nullPattern

> catMap :: (Pattern a -> Pattern a) -> [Pattern a] -> Pattern a
> catMap f = cat . map f

Find lowest common period (lcm but zeros are ignored)

> lcp :: [Pattern a] -> Period
> lcp [] = Just 0
> lcp ps = lcp' $ filter (/= Just 0) (map (\(Pattern _ l) -> l) ps)
>           where lcp' [] = Just 0
>                 lcp' ds = foldl lcd (Just 1) ds

Combine patterns, with where period is the lcm of all the periods.

> combine :: [Pattern a] -> Pattern a
> combine ps = Pattern (\n -> concatMap (\p -> at p n) ps) (lcp ps)

> combineMap :: (Pattern a -> Pattern a) -> [Pattern a] -> Pattern a
> combineMap f = combine . map f

-- As above but patterns are padded out to be the same length (the lcm,
-- so two patterns with periods of 2 and 3 will be padded out to have
-- period of 6).

> combinePad :: [Pattern a] -> Pattern a
> combinePad ps = combine $ map (pad newP) ps
>     where newP = lcp ps

> combinePadMap :: (Pattern a -> Pattern a) -> [Pattern a] -> Pattern a
> combinePadMap f = combinePad . map f

-- Zips two patterns together with the given function

-- > combineWith :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
-- > combineWith f a b = Pattern (\n -> zipWith f (at a n) (at b n)) (lcm (period a) (period b))

-- Pads pattern out to given duration.  Old period must be divisible
-- by new period.

> pad :: Period -> Pattern a -> Pattern a
> pad Nothing p = Pattern newF Nothing
>     where newF 0 = at p 0
>           newF _ = [Nothing]
> pad _ (Pattern _ Nothing) = error "can't pad an infinite pattern"
> pad newD@(Just newL) p@(Pattern f d@(Just l)) 
>     | newD == d = p
>     | newL `mod` l /= 0 = error "old period must be divisible by new"
>     | otherwise = Pattern newF newD
>     where pos = newL `div` l
>           newF n | n `mod` pos == 0 = f $ n `div` pos
>                  | otherwise = [Nothing]

> padUp :: Int -> Pattern a -> Pattern a
> padUp n p = pad (Just (n * justPeriod p)) p

-- Inline operators for above.

> (>+<) a b = combine [a, b]
> (<+>) a b = combinePad [a, b]

-- Make a pattern representing a sine wave with a given period.

> sine :: Int -> Pattern Double
> sine l = Pattern f (Just l)
>     where f n = [Just $ sin $ fromIntegral n * (pi / fromIntegral l * 2)]

> sine1 :: Int -> Pattern Double
> sine1 l = ((/ 2.0) . (+ 1.0)) <$> sine l

 square :: Int -> Pattern Int
 square l = Pattern f (Just l)
     where f n | (n `mod` l) > (l `div` 2) = 1
               | otherwise = -1
 square1 :: Int -> Pattern Int
 square1 l = ((`div` 2) . (+ 1)) <$> square l

-- Multiply a pattern's period by n.

> (~*) :: Pattern a -> Int -> Pattern a
> (~*) p n = Pattern (at p) (fmap (* n) (period p))

-- Apply a function to a pattern every nth period.

> every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
> every 0 _ p = p
> every n f p = (p ~* (n - 1)) `append` f p

-- Shift (rotate) a pattern n steps to the left.

> rotL :: Int -> Pattern a -> Pattern a
> rotL n p = Pattern (\t -> at p (t + n)) (period p)

-- Shift (rotate) a pattern n steps to the right.

> rotR :: Int -> Pattern a -> Pattern a
> rotR =  rotL . negate

> (<~) = rotL
> (~>) = rotR

-- Reverse a pattern.

> rev :: Pattern a -> Pattern a
> rev p | isNothing (period p) = error "Can't reverse infinity"
> rev p |otherwise = Pattern (\n -> at p $ fromJust d - n - 1) d
>       where d = period p

> (<<~) = rev

-- Make a pattern into a palindrome by playing forward then back.

> palindrome :: Pattern a -> Pattern a
> palindrome p@(Pattern _ Nothing) = p
> palindrome p@(Pattern _ (Just 1)) = p
> palindrome p@(Pattern _ (Just l)) = cat [p `loopAt` (l - 1),
>                                          (<<~) p `loopAt` (l - 1)
>                                         ]

> patternToList :: Pattern a -> [[a]]
> patternToList p = map (catMaybes . at p) (range p)

> range p | period p == Nothing = [0 ..]
>         | otherwise = [0 .. justPeriod p - 1]

> maxPolyphony = foldr (max . length) 0 . patternToList

> loopAt :: Pattern a -> Int -> Pattern a
> loopAt p l = Pattern (\n -> at p $ n `mod` l) (Just l)

> modify :: ((Int -> [Maybe a]) -> (Int -> [Maybe b])) -> Pattern a -> Pattern b
> modify f p = Pattern (f (at p)) (period p)

Replaces empty beats with the previous beat in the pattern plus 1

Needs redoing with nothings

 incNulls :: Pattern Int -> Pattern Int
 incNulls p = Pattern (f 0) (period p)
     where f i n | and [isLooped p i, isSam p i] = [Just 0]
                 | null (at p n) = [(head (f (i+1) (n-1))) + 1]
                 | otherwise = [head $ at p n]

 breakbeat :: Pattern a -> Pattern Int -> Pattern a
 breakbeat p breakPattern = Pattern f (lcd (period p) (period breakPattern))
     where f n = at p (head $ at (incNulls breakPattern) n)

> periodPos :: Pattern a -> Int -> Int
> periodPos p n | isInf p = n
>               | otherwise = n `mod` justPeriod p

> isSam :: Pattern a -> Int -> Bool
> isSam p n = periodPos p n == 0

> isLooped :: Pattern a -> Int -> Bool
> isLooped p n | isInf p = False
>              | otherwise = n > justPeriod p

> onsets :: Pattern a -> Pattern a
> onsets p = modify f p
>     where f l n =  if and [not $ null $ l n, null $ l (n-1)] 
>                    then l n 
>                    else []

> tween :: Double -> Double -> Int -> Pattern Double
> tween from to steps = Pattern f (Just steps)
>     where f n = [Just (from + fromIntegral (n `mod` steps) * (diff / fromIntegral steps))]
>           diff = to - from

> soundSet :: String -> Int -> Pattern String
> soundSet s p = Pattern (\n -> [Just  $ s ++ "/" ++ show (n `mod` p)]) (Just p)

> enumerate :: Eq a => Pattern a -> Pattern Int
> enumerate p = (\x -> fromJust $ elemIndex x l) <$> p 
>     where l = nub $ concat $ patternToList p


> headP :: Pattern a -> [Maybe a]
> headP p = at p 0

> tailP :: Pattern a -> Pattern a
> tailP p | isInf p = error "tailP of infinite pattern"
>         | l <= 0 = error "tailP of pattern with zero period"
>         | l == 1 = nullPattern
>         | otherwise = Pattern (at p . offset) (fmap (subtract 1) (period p))
>         where offset n = 1 + n + (n `div` (l- 1))
>               l = fromJust $ period p

> extrapolate :: Int -> Pattern Int -> Pattern Int
> extrapolate by p | isInf p = p
>                  | otherwise = Pattern newF newP
>     where newF n = map (fmap (+ ((by * (n `div` justPeriod p)) `mod` 12))) (at p n)
>           newP = (* ((lcm 12 by) `div` by)) `fmap` period p 

> extrapolateF :: Double -> Pattern Double -> Pattern Double
> extrapolateF by p | isInf p = p
>                   | otherwise = Pattern newF (period p)
>      where newF n = map (fmap (+ ((by * fromIntegral (n `div` justPeriod p)) `mod'` 12))) (at p n)