ema.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-unused-do-bind -fno-warn-unused-imports -fno-warn-orphans #-}

module Main where

import Control.Applicative
import Data.List (foldl')
import Data.Monoid
import Data.Strict.Tuple
import Prelude hiding (sum, length)

data Fold a b = forall w.  (Monoid w) => Fold
    { tally   :: a -> w
    , compute :: w -> b
    }

fold :: Fold a b -> [a] -> b
fold (Fold t c) xs =
    c (foldl' mappend mempty (map t xs))

instance (Monoid a, Monoid b) => Monoid (Pair a b) where
    mempty = mempty :!: mempty
    mappend (aL :!: aR) (bL :!: bR) =
        mappend aL bL :!: mappend aR bR

instance Functor (Fold a) where
    fmap f (Fold t k) = Fold t (f . k)

instance Applicative (Fold a) where
    pure a    = Fold (const ()) (const a)
    (Fold tL cL) <*> (Fold tR cR) =
        let t x = (tL x :!: tR x)
            c (wL :!: wR) = cL wL (cR wR)
        in  Fold t c

genericLength :: (Num b) => Fold a b
genericLength =
    Fold (\_ -> Sum (1::Int)) (fromIntegral . getSum)

sum :: (Num a) => Fold a a
sum = Fold Sum getSum

sumSq :: (Num a) => Fold a a
sumSq = Fold (\x -> Sum (x ^ 2)) getSum

average :: (Fractional a) => Fold a a
average = (/) <$> sum <*> genericLength

product :: (Num a) => Fold a a
product = Fold Product getProduct

std :: (Floating a) => Fold a a
std =  (\ss s len -> sqrt (ss / len - (s / len)^2))
    <$> sumSq
    <*> sum
    <*> genericLength

-- Ema
data Ema = Ema { total :: {-# UNPACK #-} !Double
               , num :: {-# UNPACK #-} !Double }
            deriving Show

alpha = 0.1

instance Monoid Ema where
    mempty = Ema 0 0
    mappend (Ema t1 n1) (Ema t2 n2) =
        Ema ((1-alpha)**n2 * t1 + t2) ((1-alpha)**n2 * n1 + n2)

singletonEma :: Double -> Ema
singletonEma x = Ema x 1

computeEma :: Ema -> Double
computeEma (Ema t n) = t / n

ema :: Fold Double Double
ema = Fold singletonEma computeEma

demo = fold ema [1..10]

-- EmaSq

singletonSq :: Double -> Ema
singletonSq x = Ema (x^2) 1

emaSq :: Fold Double Double
emaSq = Fold singletonSq computeEma

demoSq = fold emaSq [1..10]

estd :: Fold Double Double
estd =  (\s ss -> sqrt (ss - s^2))
    <$> ema
    <*> emaSq

main = putStrLn "There is no executable"