Mixed.hs

{- |
Copyright   :  (c) Henning Thielemann 2007

Maintainer  :  haskell@henning-thielemann.de
Stability   :  stable
Portability :  Haskell 98

Functions that combine both data types,
'Data.AlternatingList.List.Disparate.T' and
'Data.AlternatingList.List.Uniform.T'
-}
module Data.AlternatingList.List.Mixed (
    consFirst, consSecond, (./), (/.),
    snocFirst, snocSecond,
    viewL, viewFirstL, viewSecondL,
    viewR, viewFirstR, viewSecondR,
    switchL, switchFirstL, switchSecondL,
    switchR, switchFirstR, switchSecondR,
    mapFirstL,  mapFirstHead,  mapFirstTail,
    mapSecondL, mapSecondHead, mapSecondTail,
    mapFirstR,  mapFirstLast,  mapFirstInit,
    mapSecondR, mapSecondLast, mapSecondInit,
    appendUniformUniform, appendDisparateUniform, appendUniformDisparate,
    concatUniform, concatDisparate,
    splitAtDisparateUniform, splitAtUniformDisparate, splitAtUniformUniform,
    takeDisparate, takeUniform, dropDisparate, dropUniform,
    {- spanFirst, spanSecond, spanDisparate, -}

   ) where


import qualified Data.AlternatingList.List.Disparate as Disp
import qualified Data.AlternatingList.List.Uniform as Uniform

import Data.AlternatingList.List.Uniform (mapSecondHead)

import qualified Control.Monad as Monad

import Data.EventList.Utility (mapPair, mapFst, mapSnd)

import Prelude hiding
   (null, foldr, map, concat, sequence, sequence_, mapM, mapM_)


infixr 5 ./, /.

(/.) :: a -> Uniform.T a b -> Disp.T a b
(/.) = consFirst

(./) :: b -> Disp.T a b -> Uniform.T a b
(./) = consSecond


consFirst :: a -> Uniform.T a b -> Disp.T a b
consFirst a ~(Uniform.Cons b xs) = Disp.cons a b xs

consSecond :: b -> Disp.T a b -> Uniform.T a b
consSecond = Uniform.Cons


snocFirst :: Uniform.T a b -> a -> Disp.T b a
snocFirst xs = appendUniformUniform xs . Uniform.singleton
-- snocFirst xs a = Uniform.foldr consSecond consFirst (Uniform.singleton a) xs

snocSecond :: Disp.T b a -> b -> Uniform.T a b
snocSecond xs = appendDisparateUniform xs . Uniform.singleton
-- snocSecond xs b = Disp.foldr consSecond consFirst (Uniform.singleton b) xs


viewL :: Uniform.T a b -> (b, Maybe (a, Uniform.T a b))
viewL = mapSnd viewFirstL . viewSecondL

viewFirstL :: Disp.T a b -> Maybe (a, Uniform.T a b)
viewFirstL =
   Monad.liftM (\((a,b), xs) -> (a, consSecond b xs)) . Disp.viewL

viewSecondL :: Uniform.T a b -> (b, Disp.T a b)
viewSecondL (Uniform.Cons b xs) = (b,xs)


viewR :: Uniform.T a b -> (Maybe (Uniform.T a b, a), b)
viewR (Uniform.Cons b0 xs0) =
   Disp.switchR
      (Nothing, b0)
      (\ xs a b -> (Just (consSecond b0 xs, a), b))
      xs0

viewFirstR :: Disp.T b a -> Maybe (Uniform.T a b, a)
viewFirstR =
   Monad.liftM (\ (xs, ~(a,b)) -> (snocSecond xs a, b)) .
   Disp.viewR

{-
TODO:
Must be more lazy in case of
@viewSecondR (2 /. 'a' ./ 3 /. 'b' ./ 4 /. undefined)@.
It must also return the @'b'@ but it does not.
-}
viewSecondR :: Uniform.T a b -> (Disp.T b a, b)
viewSecondR (Uniform.Cons b0 xs0) =
   Disp.switchR
      (Disp.empty, b0)
      (\ xs a b -> (consFirst b0 (snocSecond xs a), b))
      xs0


{-# INLINE switchL #-}
switchL :: (b -> c) -> (b -> a -> Uniform.T a b -> c) -> Uniform.T a b -> c
switchL f g =
   switchSecondL (\x -> switchFirstL (f x) (g x))

{-# INLINE switchFirstL #-}
switchFirstL :: c -> (a -> Uniform.T a b -> c) -> Disp.T a b -> c
switchFirstL f g =
   Disp.switchL f (\ a b xs -> g a (consSecond b xs))

{-# INLINE switchSecondL #-}
switchSecondL :: (b -> Disp.T a b -> c) -> Uniform.T a b -> c
switchSecondL f (Uniform.Cons b xs) = f b xs


{-# INLINE switchR #-}
switchR :: (b -> c) -> (Uniform.T a b -> a -> b -> c) -> Uniform.T a b -> c
switchR f g =
   switchSecondR (\xs b -> switchFirstR (f b) (\ys a -> g ys a b) xs)

{-# INLINE switchFirstR #-}
switchFirstR :: c -> (Uniform.T a b -> a -> c) -> Disp.T b a -> c
switchFirstR f g =
   maybe f (uncurry g) . viewFirstR

{-# INLINE switchSecondR #-}
switchSecondR :: (Disp.T b a -> b -> c) -> Uniform.T a b -> c
switchSecondR f = uncurry f . viewSecondR


-- could also be in ListDisparate
mapFirstL ::
   (a -> a, Uniform.T a b0 -> Uniform.T a b1) ->
   Disp.T a b0 -> Disp.T a b1
mapFirstL f =
   maybe Disp.empty (uncurry consFirst . mapPair f) . viewFirstL

mapFirstHead ::
   (a -> a) ->
   Disp.T a b -> Disp.T a b
mapFirstHead f = mapFirstL (f,id)

mapFirstTail ::
   (Uniform.T a b0 -> Uniform.T a b1) ->
   Disp.T a b0 -> Disp.T a b1
mapFirstTail f = mapFirstL (id,f)


mapSecondL ::
   (b -> b, Disp.T a0 b -> Disp.T a1 b) ->
   Uniform.T a0 b -> Uniform.T a1 b
mapSecondL f = uncurry consSecond . mapPair f . viewSecondL

{-
mapSecondHead ::
   (b -> b) ->
   Uniform.T a b -> Uniform.T a b
mapSecondHead f = mapSecondL (f,id)
-}

mapSecondTail ::
   (Disp.T a0 b -> Disp.T a1 b) ->
   Uniform.T a0 b -> Uniform.T a1 b
mapSecondTail f = mapSecondL (id,f)


mapFirstR ::
   (Uniform.T a b0 -> Uniform.T a b1, a -> a) ->
   Disp.T b0 a -> Disp.T b1 a
mapFirstR f =
   maybe Disp.empty (uncurry snocFirst . mapPair f) . viewFirstR

-- could also be in ListDisparate
mapFirstLast ::
   (a -> a) ->
   Disp.T b a -> Disp.T b a
mapFirstLast f = mapFirstR (id,f)

mapFirstInit ::
   (Uniform.T a b0 -> Uniform.T a b1) ->
   Disp.T b0 a -> Disp.T b1 a
mapFirstInit f = mapFirstR (f,id)


mapSecondR ::
   (Disp.T b a0 -> Disp.T b a1, b -> b) ->
   Uniform.T a0 b -> Uniform.T a1 b
mapSecondR f = uncurry snocSecond . mapPair f . viewSecondR

mapSecondLast ::
   (b -> b) ->
   Uniform.T a b -> Uniform.T a b
mapSecondLast f = mapSecondR (id,f)

mapSecondInit ::
   (Disp.T b a0 -> Disp.T b a1) ->
   Uniform.T a0 b -> Uniform.T a1 b
mapSecondInit f = mapSecondR (f,id)




appendUniformUniform :: Uniform.T a b -> Uniform.T b a -> Disp.T b a
appendUniformUniform xs ys =
   Uniform.foldr consSecond consFirst ys xs

appendDisparateUniform :: Disp.T b a -> Uniform.T a b -> Uniform.T a b
appendDisparateUniform xs ys =
   Disp.foldr consSecond consFirst ys xs

appendUniformDisparate :: Uniform.T a b -> Disp.T a b -> Uniform.T a b
appendUniformDisparate xs ys =
   mapSecondTail (flip Disp.append ys) xs


concatDisparate :: Disp.T (Uniform.T b a) (Uniform.T a b) -> Disp.T a b
concatDisparate =
   Disp.foldr appendUniformUniform appendUniformDisparate Disp.empty

concatUniform :: Uniform.T (Uniform.T b a) (Uniform.T a b) -> Uniform.T a b
concatUniform =
   switchSecondL
   (\ b xs -> appendUniformDisparate b (concatDisparate xs))



splitAtDisparateUniform :: Int -> Uniform.T a b -> (Disp.T b a, Uniform.T a b)
splitAtDisparateUniform 0 = (,) Disp.empty
splitAtDisparateUniform n =
   (\ ~(prefix,suffix) ->
       maybe
          (error "splitAtDisparateUniform: empty list")
          (mapFst (snocFirst prefix))
          (viewFirstL suffix)) .
   splitAtUniformDisparate (pred n)

splitAtUniformDisparate :: Int -> Uniform.T a b -> (Uniform.T a b, Disp.T a b)
splitAtUniformDisparate n (Uniform.Cons b xs) =
   mapFst (consSecond b) $ Disp.splitAt n xs


splitAtUniformUniform ::
   Int -> Disp.T b a -> Maybe (Uniform.T a b, Uniform.T b a)
splitAtUniformUniform n =
   (\ ~(xs,ys) ->
        fmap
           (mapFst (snocSecond xs))
           (viewFirstL ys)) .
   Disp.splitAt n


takeDisparate :: Int -> Uniform.T a b -> Disp.T b a
takeDisparate n =
   fst . viewSecondR . takeUniform n

takeUniform :: Int -> Uniform.T a b -> Uniform.T a b
takeUniform n (Uniform.Cons b xs) =
   consSecond b $ Disp.take n xs

dropDisparate :: Int -> Uniform.T a b -> Disp.T a b
dropDisparate n = Disp.drop n . snd . viewSecondL

dropUniform :: Int -> Uniform.T a b -> Uniform.T a b
dropUniform 0 = id
dropUniform n =
   switchFirstL (error "dropUniform: empty list") (flip const) .
   dropDisparate (pred n)


{-
breakDisparateFirst :: (a -> Bool) ->
   Disp.T a b -> (Disp.T a b, Disp.T a b)
breakDisparateFirst p = Disp.spanFirst (not . p)

breakUniformFirst :: (a -> Bool) ->
   Uniform.T a b -> (Uniform.T a b, Disp.T a b)
breakUniformFirst p =
   let recourse xs0 =
          (\(b,xs) ->
              if p b
                then (empty, xs0)
                else
                  maybe
                     (\(a,ys) ->)
                  let (as,) = recourse  xs
                  in  ) $
          viewSecondL xs0
-}

{-
spanSecond :: (b -> Bool) -> Uniform.T a b -> (Uniform.T a b, Disp.T b a)
spanSecond p (Uniform.Cons b xs) =
   mapFst (consSecond b) (Disp.span p xs)

spanDisparate :: (b -> Bool) -> Disp.T a b -> (Uniform.T b a, Uniform.T a b)
spanDisparate p =
   mapPair (consSecond, consSecond) . List.span (p . pairFirst) . toPairList
-}