2009-12-21

List processors, request/response map

Once I tried to implement TigerHash in Haskell. Pure implementation was very slow no matter how did I tried to optimize it and I switched to foreign implementation in C. As most of hash function it need to store intermediate state between calls to update to process long streams. So interface in haskell consist of init/reset/update/finalize. But implementing only tigerHash function means that it will create and destroy context at each call. To avoid that I thought that I can make tigerHashList which will hold context while processing the list. That was pretty easy to use that tigerHashList when you have to just mapM_ print (tigerHashList $ map getContents files) or something like that. But when you will need to calculate something complicated which the way to use that function isn't so straight. For example:
out = tigerHashList (inp out)
inp ~(nextHash:ys) = nextFile : walk nextHash files ys
And there you have two choices: to make tigerHashMonad or to wrap that tigerHashList. As I did used "list processors" several times before:
newtype LPMonad a b c = LPMonad { unLPMonad :: [b] -> ([a] -> [a], c, [b]) }

runLPMonad :: LPMonad a b c -> ([a] -> [b]) -> c
runLPMonad m f = r where
    (inp, r, _) = unLPMonad m out
    out = f (inp [])

request :: a -> LPMonad a b b
request x = LPMonad (\ ~(y:ys) -> ((x:), y, ys) )

instance Monad (LPMonad a b) where
    return z = LPMonad (\ ys -> (id, z, ys))
    m >>= f = LPMonad next where
        next ys = (inp . inp', r', ys'') where
            (inp, r, ys') = unLPMonad m ys
            (inp', r', ys'') = unLPMonad (f r) ys'

data Action = Withdraw Int
            | Deposit Int
            | Receipt
            | Balance Int


account :: Int -> [Action] -> [Int]
account balance (Withdraw amount : xs) = balance' : account balance' xs where balance' = balance - amount
account balance (Deposit amount : xs) = balance' : account balance' xs where balance' = balance + amount
account balance (Receipt : xs) = balance : account balance xs
account balance (Balance amount : xs) = (amount - balance) : account balance xs


test1 = do
    request $ Deposit 200
    request $ Withdraw 50
    x <- request Receipt
    request $ Withdraw 50
    y <- request $ Balance 100
    return (x,y)

{-
tth = tree . splitBlocks 1024 where
    tree xs = runLPMonad (getHash 0 (length xs)) tigerHashList where
        getHash n 1 = request (xs !! n)
        getHash n m = do
            let l = m `div` 2
            a <- getHash n l
            b <- getHash (n+l) (m-l)
            request . runPut $ do
                putWord8 1
                put a
                put b
-}

main = do
    print (runLPMonad test1 (account 1))
P.S. simplified example from Curry's (MCC) Ports library.