MapFoldBinary.hs

{-# OPTIONS #-}

-- ------------------------------------------------------------

{- |
   Module     : Control.Sequential.MapFoldBinary
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental

   A map-fold function for interleaved map and fold.
   The elements of a list are processed like in a binary tree.

-}

-- ------------------------------------------------------------

module Control.Sequential.MapFoldBinary
    ( mapFoldBinary
    , mapFoldBinaryM
    )
where

-- ------------------------------------------------------------

-- | Pure version of binary map fold
--
-- @mapFoldBinary id (+) [1..8]@ adds the elements of a list in the following order:
-- @(((1+2)+(3+4))+((5+6)+(7+8)))@

mapFoldBinary                   :: (a -> b) -> (b -> b -> b) -> [a] -> b
mapFoldBinary m f xs0           = fst $ mapLeft (1::Int) $ map1 xs0
    where
    -- map1                     :: [a] -> (b, [a])
    map1 (x:xs)                 = (m x, xs)
    map1 []                     = error "mapFoldBinary with empty list"

    -- mapLeft                  :: Int -> (b, [a]) -> (b, [a])
    mapLeft n (r1, xs1)
        | null xs1              = (r1, [])
        | null xs2              = (r,  [])
        | otherwise             = mapLeft (n + 1) (r, xs2)
        where
        (r2, xs2)               = mapRight n xs1
        r                       = f r1 r2

    -- mapRight                 :: Int -> [a] -> (b, [a])
    mapRight 1 xs               = map1 xs
    mapRight n xs
        | null xs1              = (r1,      [] )
        | otherwise             = (f r1 r2, xs2)
        where
        (r1, xs1)               = mapRight (n - 1) xs
        (r2, xs2)               = mapRight (n - 1) xs1

-- ------------------------------------------------------------
{-
t1      :: [Int] -> String
t1      = mapFoldBinary show (\ x y -> "(" ++ x ++ "+" ++ y ++ ")")

r1      :: String
r1      = t1 [1..8]
-}
-- ------------------------------------------------------------

-- | Monadic version of a binary map fold
--
-- The elements of a list are mapped and folded in the same way as in the pure version.
-- The map and fold operations are interleaved. In the above example the expressions are evaluated
-- from left to right, folding is performed, as early as possible.


mapFoldBinaryM                  :: (Monad m) =>
                                   (a -> m b) -> (b -> b -> m b) -> [a] -> m b
mapFoldBinaryM m f xs0          = do
                                  r0 <- map1 xs0
                                  rn <- mapLeft (1::Int) r0
                                  return (fst rn)
    where
    -- map1                     :: [a] -> m (b, [a])
    map1 (x:xs)                 = do
                                  r1 <- m x
                                  return (r1, xs)
    map1 []                     = error "mapFoldBinary with empty list"

    -- mapLeft                  :: Int -> (b, [a]) -> m (b, [a])
    mapLeft n r@(r1, xs1)
        | null xs1              = return r
        | otherwise             = do
                                  (r2, xs2) <- mapRight n xs1
                                  res       <- f r1 r2
                                  ( if null xs2
                                    then return
                                    else mapLeft (n + 1) ) (res, xs2)

    -- mapRight                 :: Int -> [a] -> m (b, [a])
    mapRight 1 xs               = map1 xs
    mapRight n xs               = do
                                  r@(r1, xs1) <- mapRight (n - 1) xs
                                  if null xs1
                                     then return r
                                     else do
                                          (r2, xs2) <- mapRight (n - 1) xs1
                                          res       <- f r1 r2
                                          return (res, xs2)

-- ------------------------------------------------------------
{-
t1m     :: [Int] -> IO String
t1m     = mapFoldBinaryM
          ( \ x -> ( do
                     print x
                     return (show x)
                   )
          )
          ( \ x y -> ( do
                       putStrLn $ "(" ++ x ++ "+" ++ y ++ ")"
                       return   $ "(" ++ x ++ "+" ++ y ++ ")"
                     )
          )

r1m     :: IO String
r1m     = t1m [1..8]
-}
-- ------------------------------------------------------------