gistfile1.hs

{-# LANGUAGE ExistentialQuantification, TypeOperators #-}
module Fold where
 
import Control.Applicative
import Control.Functor.Contra
 
import Data.Array.Vector
import qualified Data.Foldable as Foldable
 
data Fold b c = forall a. Fold (a -> b -> a) a (a -> c)
 
instance Functor (Fold a) where
  fmap = after
  
instance Applicative (Fold a) where
  pure f = foldF undefined undefined (const f) -- The do-nothing fold! :P
  f <*> g = (\(h :*: x) -> h x) <$> both f g
 
-- Just to be exotic
newtype ContraFold a b = ContraFold { runContraFold :: Fold b a }
 
instance ContraFunctor (ContraFold a) where
  contramap g (ContraFold f) = ContraFold $ g `before` f
 
-- Fucking haskell typeclass hierarchy, I hate you
instance Show (Fold a b) where
  show = undefined
 
-- Fucking haskell typeclass hierarchy, I hate you  
instance Eq (Fold a b) where
  (==) = undefined
 
instance Num b => Num (Fold a b) where
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  (*) = liftA2 (*)
  negate = fmap negate
  abs = fmap abs
  signum = fmap signum
  fromInteger = undefined
 
instance Fractional b => Fractional (Fold a b) where
  (/) = liftA2 (/)
  recip = fmap recip
  fromRational = undefined
 
instance Floating b => Floating (Fold a b) where
  pi = pure pi
  exp = fmap exp
  log = fmap log
  sqrt = fmap sqrt
  sin = fmap sin
  cos = fmap cos
  tan = fmap tan
  asin = fmap asin
  acos = fmap acos
  atan = fmap atan
  sinh = fmap sinh
  cosh = fmap cosh
  tanh = fmap tanh
  asinh = fmap asinh
  acosh = fmap acosh
  atanh = fmap atanh
  (**) = liftA2 (**)
  logBase = liftA2 logBase
 
 
{-# INLINE foldF #-}
foldF :: (a -> b -> a) -> a -> (a -> c) -> Fold b c
foldF f x c = Fold f x c
 
{-# INLINE fold1F #-}
fold1F :: (b -> b -> b) -> (b -> b1) -> Fold b (MaybeS b1)
fold1F f c = Fold (\m x -> pure $ maybeS x (`f` x) m) NothingS (fmap c)
 
{-# INLINE both #-}
both :: Fold b c -> Fold b c' -> Fold b (c :*: c')
both (Fold f x c) (Fold g y c') = Fold (\(a :*: b) e -> (f a e :*: g b e)) 
                                         (x :*: y) 
                                       (\(a :*: b)   -> (c a   :*: c' b))
 
{-# INLINE after #-}
after :: (c -> c') -> Fold b c -> Fold b c'
after g (Fold f x c) = Fold f x (g . c)
 
{-# INLINE before #-}
before :: (b' -> b) -> Fold b c -> Fold b' c
before g (Fold f x c) = Fold ((. g) . f) x c
 
{-# INLINE bothWith #-}
bothWith :: (c -> c' -> c'') -> Fold b c -> Fold b c' -> Fold b c''
bothWith c f1 f2 = uncurryS c <$> both f1 f2
 
 
{-# INLINE applyFold #-}
{-# SPECIALIZE applyFold :: Fold b c -> [b] -> c #-}
applyFold :: (Foldable.Foldable f) => Fold b c -> f b -> c
applyFold (Fold f x a) = a . Foldable.foldl' f x
 
{-# INLINE applyFoldU #-}
applyFoldU :: (UA b) => Fold b c -> UArr b -> c
applyFoldU (Fold f x a) = a . foldlU f x
 
------------------------------------------------------------------------------
 
{-# INLINE lengthF #-}
lengthF :: Fold a Int
lengthF = foldF (const . (+1)) 0 id
 
{-# INLINE genericLengthF #-}
{-# SPECIALIZE genericLengthF :: Fold a Double #-}
genericLengthF :: (Num b) => Fold a b
genericLengthF = foldF (const . (+1)) 0 id
 
{-# INLINE sumF #-}
sumF :: (Num a) => Fold a a
sumF = foldF (+) 0 id
 
{-# INLINE productF #-}
productF :: (Num a) => Fold a a
productF = foldF (*) 1 id
 
{-# INLINE maximumF #-}
maximumF :: (Ord a) => Fold a (MaybeS a)
maximumF = fold1F max id
 
{-# INLINE minimumF #-}
minimumF :: (Ord a) => Fold a (MaybeS a)
minimumF = fold1F min id
 
------------------------------------------------------------------------------
 
{-# INLINE meanF #-}
{-# SPECIALIZE meanF :: Fold Double Double #-}
meanF :: (Num a, Fractional a) => Fold a a
meanF = sumF / genericLengthF
 
{-# INLINE harmonicF #-}
harmonicF :: (Num a, Fractional a) => Fold a a
harmonicF = genericLengthF / (recip `before` sumF)
 
{-# INLINE geometricF #-}
geometricF :: (Num a, RealFloat a) => Fold a a
geometricF = productF ** (recip genericLengthF)
 
{-# INLINE rangeF #-}
rangeF :: (Num a, Ord a) => Fold a (MaybeS a)
rangeF = liftA2 (-) <$> maximumF <*> minimumF 
 
-- Not a very good name
{-# INLINE linregF #-}
linregF :: (Num a, Floating a) => Fold (a :*: a) (a :*: a :*: a)
linregF = (\x y z -> x :*: y :*: z) <$> alpha <*> beta <*> r
  where sX  = fstS `before` sumF
        sY  = sndS `before` sumF
        n   = genericLengthF
        sXX = ((^2) . fstS) `before` sumF
        sXY = (uncurryS (*)) `before` sumF
        sYY = ((^2) . sndS) `before` sumF
        alpha = sY - beta * sX
        beta = (n * sXY - sX * sY) / (n * sXX - sX * sX)
        r = (n * sXY - sX * sY) / (sqrt (n * sXX - sX^2) * (n * sYY - sY^2))
 
 
-- The following functions do not short circuit!
 
{-# INLINE andF #-}
andF :: Fold Bool Bool
andF = foldF (&&) True id
 
{-# INLINE orF #-}
orF :: Fold Bool Bool
orF = foldF (||) False id
 
{-# INLINE allF #-}
allF :: (a -> Bool) -> Fold a Bool
allF f = f `before` andF
 
{-# INLINE anyF #-}
anyF :: (a -> Bool) -> Fold a Bool
anyF f = f `before` orF