event-list-0.0.7: src/Data/AlternatingList/List/Disparate.hs

{- |
Copyright   :  (c) Henning Thielemann 2007

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

Lists of elements of alternating type.
This module is based on the standard list type
and may benefit from list optimizations.
-}
module Data.AlternatingList.List.Disparate
   (T,
    fromPairList, toPairList,
    map, mapFirst, mapSecond,
    sequence, sequence_,
    mapM, mapM_, mapFirstM, mapSecondM,
    getFirsts, getSeconds, length, genericLength,
    empty, singleton, null,
    cons, snoc, viewL, viewR, mapHead, mapLast,
    foldr, foldrPair,
    format,
    append, concat, cycle,
    splitAt, take, drop,
    genericSplitAt, genericTake, genericDrop,
    spanFirst, spanSecond,
    zipWithFirst, zipWithSecond,
   ) where

import qualified Data.EventList.Utility as Utility

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

import qualified Data.List as List
import qualified Control.Monad as Monad

import Test.QuickCheck (Arbitrary, arbitrary, coarbitrary)

import Prelude hiding
   (null, foldr, map, concat, cycle, length, take, drop, splitAt,
    sequence, sequence_, mapM, mapM_)


data Pair a b =
     Pair {pairFirst  :: a,
           pairSecond :: b}
   deriving (Eq, Ord, Show)

newtype T a b = Cons {decons :: [Pair a b]}
   deriving (Eq, Ord)


format :: (Show a, Show b) =>
   String -> String -> Int -> T a b -> ShowS
format first second p xs =
   showParen (p>=5) $
   flip (foldr
      (\a -> showsPrec 5 a . showString first)
      (\b -> showsPrec 5 b . showString second))
      xs .
      showString "empty"

instance (Show a, Show b) => Show (T a b) where
   showsPrec = format " /. " " ./ "


instance (Arbitrary a, Arbitrary b) =>
             Arbitrary (Pair a b) where
   arbitrary = Monad.liftM2 Pair arbitrary arbitrary
   coarbitrary = undefined

instance (Arbitrary a, Arbitrary b) =>
             Arbitrary (T a b) where
   arbitrary = Monad.liftM Cons arbitrary
   coarbitrary = undefined


fromPairList :: [(a,b)] -> T a b
fromPairList = Cons . List.map (uncurry Pair)

toPairList :: T a b -> [(a,b)]
toPairList = List.map (\ ~(Pair a b) -> (a,b)) . decons


lift :: ([Pair a0 b0] -> [Pair a1 b1]) -> (T a0 b0 -> T a1 b1)
lift f = Cons . f . decons

mapPairFirst :: (a0 -> a1) -> Pair a0 b -> Pair a1 b
mapPairFirst f e = e{pairFirst = f (pairFirst e)}

mapPairSecond :: (b0 -> b1) -> Pair a b0 -> Pair a b1
mapPairSecond f e = e{pairSecond = f (pairSecond e)}

map :: (a0 -> a1) -> (b0 -> b1) -> T a0 b0 -> T a1 b1
map f g = lift (List.map (mapPairFirst f . mapPairSecond g))

mapFirst :: (a0 -> a1) -> T a0 b -> T a1 b
mapFirst f = lift (List.map (mapPairFirst f))

mapSecond :: (b0 -> b1) -> T a b0 -> T a b1
mapSecond g = lift (List.map (mapPairSecond g))



sequence :: Monad m =>
   T (m a) (m b) -> m (T a b)
sequence =
   Monad.liftM Cons .
   Monad.mapM (\(Pair a b) -> Monad.liftM2 Pair a b) .
   decons

sequence_ :: Monad m =>
   T (m ()) (m ()) -> m ()
sequence_ =
   Monad.mapM_ (\(Pair a b) -> a >> b) . decons


mapM :: Monad m =>
   (a0 -> m a1) -> (b0 -> m b1) ->
   T a0 b0 -> m (T a1 b1)
mapM aAction bAction =
   sequence . map aAction bAction

mapM_ :: Monad m =>
   (a -> m ()) -> (b -> m ()) -> T a b -> m ()
mapM_ aAction bAction =
   sequence_ . map aAction bAction


mapFirstM :: Monad m =>
   (a0 -> m a1) -> T a0 b -> m (T a1 b)
mapFirstM aAction =
   mapM aAction return

mapSecondM :: Monad m =>
   (b0 -> m b1) -> T a b0 -> m (T a b1)
mapSecondM bAction =
   mapM return bAction


getFirsts :: T a b -> [a]
getFirsts = List.map pairFirst . decons

getSeconds :: T a b -> [b]
getSeconds = List.map pairSecond . decons

length :: T a b -> Int
length = List.length . getFirsts

genericLength :: Integral i => T a b -> i
genericLength = List.genericLength . getFirsts



empty :: T a b
empty = Cons []

singleton :: a -> b -> T a b
singleton a b = Cons [Pair a b]

null :: T a b -> Bool
null = List.null . decons


cons :: a -> b -> T a b -> T a b
cons a b = lift (Pair a b : )

snoc :: T a b -> a -> b -> T a b
snoc (Cons xs) a b = Cons (xs ++ [Pair a b])


viewL :: T a b -> Maybe ((a, b), T a b)
viewL (Cons ys) =
   case ys of
      (Pair a b : xs) -> Just ((a, b), Cons xs)
      [] -> Nothing

mapHead :: ((a,b) -> (a,b)) -> T a b -> T a b
mapHead f =
   maybe empty (uncurry (uncurry cons) . mapFst f) . viewL


viewR :: T a b -> Maybe (T a b, (a, b))
viewR =
   fmap (mapPair (Cons, \ ~(Pair a b) -> (a, b))) .
   Utility.viewR . decons

mapLast :: ((a,b) -> (a,b)) -> T a b -> T a b
mapLast f =
   maybe empty (uncurry (uncurry . snoc) . mapSnd f) . viewR


foldr :: (a -> c -> d) -> (b -> d -> c) -> d -> T a b -> d
foldr f g =
   foldrPair (\ a b -> f a . g b)

foldrPair :: (a -> b -> c -> c) -> c -> T a b -> c
foldrPair f x =
   List.foldr (\ ~(Pair a b) -> f a b) x . decons


append :: T a b -> T a b -> T a b
append (Cons xs) = lift (xs++)

concat :: [T a b] -> T a b
concat = Cons . List.concat . List.map decons

cycle :: T a b -> T a b
cycle = Cons . List.cycle . decons



{- |
Currently it is not checked, whether n is too big.
Don't rely on the current behaviour of @splitAt n x@ for @n > length x@.
-}
splitAt :: Int -> T a b -> (T a b, T a b)
splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons

take :: Int -> T a b -> T a b
take n = Cons . List.take n . decons

drop :: Int -> T a b -> T a b
drop n = Cons . List.drop n . decons


genericSplitAt :: Integral i => i -> T a b -> (T a b, T a b)
genericSplitAt n = mapPair (Cons, Cons) . List.genericSplitAt n . decons

genericTake :: Integral i => i -> T a b -> T a b
genericTake n = Cons . List.genericTake n . decons

genericDrop :: Integral i => i -> T a b -> T a b
genericDrop n = Cons . List.genericDrop n . decons


spanFirst :: (a -> Bool) -> T a b -> (T a b, T a b)
spanFirst p =
   mapPair (Cons, Cons) . List.span (p . pairFirst) . decons

spanSecond :: (b -> Bool) -> T a b -> (T a b, T a b)
spanSecond p =
   mapPair (Cons, Cons) . List.span (p . pairSecond) . decons

{-
filterFirst :: (a -> Bool) -> T a b -> T a [b]
filterFirst =
   foldr
      (\time ->
          if time==0
            then id
            else consBody [] . consTime time)
      (\body ->
          maybe
             (consBody [body] $ consTime 0 $ empty)
             (\(bodys,xs) -> consBody (body:bodys) xs) .
          viewBodyL)
      empty
-}

zipWithFirst :: (a0 -> a1 -> a2) -> [a0] -> T a1 b -> T a2 b
zipWithFirst f xs =
   Cons . zipWith (\x (Pair a b) -> Pair (f x a) b) xs . decons

zipWithSecond :: (b0 -> b1 -> b2) -> [b0] -> T a b1 -> T a b2
zipWithSecond f xs =
   Cons . zipWith (\x (Pair a b) -> Pair a (f x b)) xs . decons