```{-# LANGUAGE ExistentialQuantification #-}

module Sound.SC3.Lang.Pattern.Pattern
( P
, pfoldr, evalP
, pfix
, pcontinue
, pmap -- Prelude.fmap
, punfoldr -- Data.List.unfoldr
, pempty -- Data.Monoid.mempty
, pappend -- Data.Monoid.mappend
, ppure -- Control.Applicative.pure
, papply -- Control.Applicative.(<*>)
, prp
, pscan
, pinf
, pzipWith
, pcycle
, prepeat ) where

import Control.Applicative
import Data.Monoid
import System.Random

data P a = Empty
| Value a
| RP (StdGen -> (P a, StdGen))
| Append (P a) (P a)
| Fix StdGen (P a)
| forall x . Unfoldr (x -> Maybe (a, x)) x
| forall x . Continue (P x) (x -> P x -> P a)
| forall x . Apply (P (x -> a)) (P x)
| forall x y . Scan (x -> y -> (x, a)) (Maybe (x -> a)) x (P y)

data Result a = Result StdGen a (P a)
| Done StdGen

step :: StdGen -> P a -> Result a
step g Empty = Done g
step g (Value a) = Result g a pempty
step g (RP f) = let (p, g') = f g
in step g' p
step g (Append x y) = case step g x of
Done g' -> step g' y
Result g' a x' -> Result g' a (Append x' y)
step g (Fix fg p) = case step fg p of
Done _ -> Done g
Result fg' x p' -> Result g x (Fix fg' p')
step g (Continue p f) = case step g p of
Done g' -> Done g'
Result g' x p' -> step g' (f x p')
step g (Unfoldr f x) = let y = f x
in case y of
Nothing -> Done g
Just (a, x') -> Result g a (Unfoldr f x')
step g (Apply p q) = case step g p of
Done g' -> Done g'
Result g' f p' -> case step g' q of
Done g'' -> Done g''
Result g'' x q' -> Result g'' (f x) (Apply p' q')
step g (Scan f f' i p) = case step g p of
Done g' -> case f' of
Just h -> Result g' (h i) Empty
Nothing -> Done g'
Result g' a p' -> let (j, x) = f i a
in Result g' x (Scan f f' j p')

pfoldr' :: StdGen -> (a -> b -> b) -> b -> P a -> b
pfoldr' g f i p = case step g p of
Done _ -> i
Result g' a p' -> f a (pfoldr' g' f i p')

pfoldr :: Seed -> (a -> b -> b) -> b -> P a -> b
pfoldr = pfoldr' . mkStdGen

evalP :: Int -> P a -> [a]
evalP n = pfoldr n (:) []

instance (Show a) => Show (P a) where
show _ = show "a pattern"

instance (Eq a) => Eq (P a) where
_ == _ = False

-- | Apply `f' pointwise to elements of `p' and `q'.
pzipWith :: (a -> b -> c) -> P a -> P b -> P c
pzipWith f p = (<*>) (pure f <*> p)

instance (Num a) => Num (P a) where
(+) = pzipWith (+)
(-) = pzipWith (-)
(*) = pzipWith (*)
abs = fmap abs
signum = fmap signum
fromInteger = return . fromInteger
negate = fmap negate

instance (Fractional a) => Fractional (P a) where
(/) = pzipWith (/)
recip = fmap recip
fromRational = return . fromRational

pcycle :: P a -> P a
pcycle x = x `mappend` pcycle x

prepeat :: a -> P a
prepeat = pcycle . return

pmap :: (a -> b) -> P a -> P b
pmap = (<*>) . prepeat

instance Functor P where
fmap = pmap

(>>=) = pbind
return = preturn

instance Monoid (P a) where
mempty = pempty
mappend = pappend

ppure :: a -> P a
ppure = prepeat

instance Applicative P where
pure = ppure
(<*>) = papply

-- * Basic constructors

pempty :: P a
pempty = Empty

preturn :: a -> P a
preturn = Value

prp :: (StdGen -> (P a, StdGen)) -> P a
prp = RP

pinf :: P Int
pinf = return 83886028 -- 2 ^^ 23

pappend :: P a -> P a -> P a
pappend = Append

type Seed = Int

pfix :: Seed -> P a -> P a
pfix = Fix . mkStdGen

pcontinue :: P x -> (x -> P x -> P a) -> P a
pcontinue = Continue

pbind :: P x -> (x -> P a) -> P a
pbind p f = pcontinue p (\x q -> f x `mappend` pbind q f)

papply :: P (a -> b) -> P a -> P b
papply = Apply

pscan :: (x -> y -> (x, a)) -> Maybe (x -> a) -> x -> P y -> P a
pscan = Scan

punfoldr :: (x -> Maybe (a, x)) -> x -> P a
punfoldr = Unfoldr
```