content: {-# 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]
  -}
  -- ------------------------------------------------------------
  