MonadDependencyInjection.hs

import Control.Exception
import Control.Monad.Cont
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Control.Monad.Writer.Lazy

import System.IO 
import System.Process

class Monad t => MonadicFloatOps t where
    madd :: Float -> Float -> t Float
    madd = (return .) . (+)
    msqrt :: Float -> t Float
    mrecip :: Float -> t Float

f :: MonadicFloatOps t => Float -> t Float
f x = do
    x1 <- msqrt x
    x2 <- (madd 1 (-x)) >>= msqrt
    y1 <- mrecip x1
    y2 <- mrecip x2
    madd y1 y2

instance MonadicFloatOps Identity where
    madd = (return .) . (+)
    msqrt = return . sqrt
    mrecip = return . (1/)

instance MonadicFloatOps Maybe where
    madd = (return .) . (+)
    msqrt x
        | x >= 0 = Just (sqrt x)
        | otherwise = Nothing
    mrecip x
        | x == 0 = Nothing
        | otherwise = Just (1 / x)

data MyFloatError = ImaginarySqrtError | ZeroDivisionError deriving (Eq, Show)

instance MonadicFloatOps (Either MyFloatError) where
    madd = (return .) . (+)
    msqrt x
        | x >= 0 = Right (sqrt x)
        | otherwise = Left ImaginarySqrtError
    mrecip x
        | x == 0 = Left ZeroDivisionError
        | otherwise = Right (1 / x)

instance MonadicFloatOps [] where
    madd = (return .) . (+)
    msqrt x
        | x > 0 = [sqrt x, -sqrt x]
        | x == 0 = [0]
        | otherwise = []
    mrecip x
        | x == 0 = []
        | otherwise = [1 / x]

instance MonadicFloatOps IO where
    madd = (return .) . (+)
    msqrt x = do
        (_, Just hout, _, ph) <- createProcess (proc "./sqrt.o" [show x]) { std_out = CreatePipe }
        sqrtString <- hGetLine hout
        return (read sqrtString)
    mrecip x = return (1 / x)

instance MonadicFloatOps (Reader Bool) where
    madd = (return .) . (+)
    msqrt x = do
        pos <- ask
        let sx = sqrt x
        return $ if pos then sx else -sx
    mrecip x = return (1 / x)

instance Semigroup Int where
    (<>) = (+)

instance Monoid Int where
    mempty = 0

instance MonadicFloatOps (Writer Int) where
    madd x y = tell 1 >> return (x + y)
    msqrt x = tell 1 >> return (sqrt x)
    mrecip x = tell 1 >> return (1 / x)

data FloatOpsMemo = FloatOpsMemo {
    numOps :: Int,
    sqrtMemo :: [(Float, Float)]
} deriving (Eq, Show)

instance MonadicFloatOps (State FloatOpsMemo) where
    madd x y = modify (\s -> s { numOps = 1 + numOps s }) >> return (x + y)
    msqrt x = do
        memo <- fmap sqrtMemo get
        let lookupRes = lookup x memo
        case lookupRes of
            Nothing -> 
                modify (\s -> s { numOps = 1 + numOps s, sqrtMemo = (x,sqx):(sqrtMemo s) }) 
                >> return sqx
                where sqx = sqrt x
            (Just sqx) -> return sqx
    mrecip x = modify (\s -> s { numOps = 1 + numOps s }) >> return (1 / x)

fNaive = f :: Float -> Identity Float
fMaybe = f :: Float -> Maybe Float
fEither = f :: Float -> Either MyFloatError Float
fList = f :: Float -> [Float]
fIO = f :: Float -> IO Float
fReader = f :: Float -> Reader Bool Float
fWriter = f :: Float -> Writer Int Float
fMemo = f :: Float -> State FloatOpsMemo Float

analyzeRiemannSum :: MonadicFloatOps m => Float -> Float -> Int -> m Float
analyzeRiemannSum a b n = do
    let nf = fromIntegral n
    let step = (b - a)/nf
    let xs = [a + k*step | k <- [0..nf-1] ]
    ys <- sequence $ map f xs
    foldM madd 0 (map (step *) ys)