> {-# LANGUAGE UndecidableInstances #-}

| Core data type for the game.

> module Data.PContainer
>      where


Import List
-----------

   #ifdef TEST

   > import Test.LazySmallCheck hiding (empty)
   > import Number.Peano

   #endif

 import Control.Monad

> import Data.Binary
> import Data.DeriveTH
> import Data.Derive.Binary
> import Data.Derive.Functor

> import qualified Data.Map as M
> import qualified Data.Set as S

 import Data.Monoid
 import Data.Function
 import Data.Maybe

> import Data.List

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

> class Ord (P a) => Particles a where

>     type P a
>     particles :: a -> S.Set (P a)


> class Particles (CElem c) => Container c where

>     type CElem c
> 
>     emptyC       :: c
>     fromC        :: c -> [CElem c]
>     insertL      :: CElem c -> c -> c
>     deleteL      :: CElem c -> c -> c
>     relatedElems :: CElem c -> c -> [CElem c]


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

> instance (Eq a, Particles a) => Container [a] where

>     type CElem [a]  = a

>     emptyC          = []
>     fromC           = id
>     insertL         = (:)
>     deleteL         = delete
>     relatedElems x l = [y | y<-l, not (particles x `disjunct` particles y)] 


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

> 
> class Decision a where
>     type DecisionDomain a
>     holds :: a -> DecisionDomain a -> Bool

> data SmallStuff a

> instance Particles a => Decision (SmallStuff a) where
>     type DecisionDomain (SmallStuff a) = a
>     holds _ x = S.size (particles x) <= limit

> limit :: Int
> limit = 8

> data {- (Decision p, Container a, Container b, ...) => -} EitherC p a b
>     = EitherC a b
>         deriving (Show)

> instance forall a b p. (Container a, Container b, CElem a ~ CElem b, Decision p, DecisionDomain p ~ CElem a) 
>       => Container (EitherC p a b) where

>     type CElem (EitherC p a b)      = CElem a

>     emptyC                          = EitherC emptyC emptyC

>     fromC (EitherC i o)             =  fromC i ++ fromC o

>     insertL c (EitherC i o)
>         | holds (undefined :: p) c  = EitherC (insertL c i) o
>         | otherwise                 = EitherC i (insertL c o)

>     deleteL c (EitherC i o)
>         | holds (undefined :: p) c  = EitherC (deleteL c i) o
>         | otherwise                 = EitherC i (deleteL c o)

>     relatedElems c (EitherC i o)    =  relatedElems c i ++ relatedElems c o


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



> class Bijection x  where

>   type From x
>   type To x
> 
>   fw :: x -> From x -> To x
>   bw :: x -> To x -> From x

> newtype Tr b x = Tr { unTr :: b }

> instance Show (Tr b x) where


> instance (Container b, Bijection x, CElem b ~ From x, Particles (To x)) => Container (Tr b x) where

>     type CElem (Tr b x)  = To x
> 
>     emptyC                = Tr emptyC
>     fromC                 = map (fw (undefined :: x)) . fromC . unTr
>     insertL x             = Tr . insertL (bw (undefined :: x) x) . unTr
>     deleteL x             = Tr . deleteL (bw (undefined :: x) x) . unTr
>     relatedElems x        = map (fw (undefined :: x)) . relatedElems (bw (undefined :: x) x) . unTr
> 

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

> {- class Fork a where
>     type FromA a
>     type FromB a
>     type To a
>     bw :: a -> To a -> (Maybe (FromA a), Maybe (FromB a))
>     fw :: a -> Either (FromA a) (FromB a) -> To a


> data {- (Decision p, Container a, Container b, ...) => -} EitherC p a b
>     = EitherC a b
>         deriving (Show)

> instance forall a b p. (Container a, Container b, Fork p, CElem a ~ FromA p, CElem b ~ FromB p, Particles (To p)) 
>       => Container (EitherC p a b) where

>     type CElem (EitherC p a b)      = To p

>     emptyC                          = EitherC emptyC emptyC

>     fromC (EitherC i o)             = map (fw (undefined :: p)) $ map Left (fromC i) ++ map Right (fromC o)

>     insertL c (EitherC i o) = case bw (undefined :: p) c of
>         Left x  ->  EitherC (insertL x i) o
>         Right x ->  EitherC i (insertL x o)

>     deleteL c (EitherC i o) = case bw (undefined :: p) c of
>         Left x  ->  EitherC (deleteL x i) o
>         Right x ->  EitherC i (deleteL x o)

>     relatedElems c (EitherC i o)    =  map (fw (undefined :: p)) $ map Left (relatedElems c i) ++ map Right (relatedElems c o)


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

> data SizeFork a

> instance Particles a => Fork (SizeFork a) where
>     type FromA (SizeFork a) = a
>     type FromB (SizeFork a) = a
>     type To (SizeFork a) = a
>     bw _ x = if S.size (particles x) <= limit then  x else Right x
>     fw (Left x) = x
>     fw (Right x) = x


> limit :: Int
> limit = 8 -}


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

> data Particles a => Index a
>     = Index { unIndex :: M.Map (P a) [a] }

> instance Show (Index a) where


> instance (Binary a, Particles a, Binary (P a)) => Binary (Index a) where

>     put = put . unIndex
>     get = fmap Index get

> instance (Particles a, Ord (P a), Eq a) => Container (Index a) where

>     type CElem (Index a) = a

>     emptyC   = Index M.empty

>     fromC = nub . concat . M.elems . unIndex

>     insertL c cs = Index $ foldr f (unIndex cs) $ S.toList $ particles c
>      where
>         f p m' = case M.lookup p m' of
>             Nothing     -> M.insert p [c] m'
>             Just cs     -> M.insert p (c:cs) m'

>     deleteL c cs = Index $ foldr f (unIndex cs) $ S.toList $ particles c
>      where
>         f p m' = case M.lookup p m' of
>             Just cs -> case delete c cs of
>                 []      -> M.delete p m'
>                 l       -> M.insert p l m'

>     relatedElems c cs = nub $ concatMap f $ S.toList $ particles c
>      where  
>         f p = case M.lookup p (unIndex cs) of
>             Just cs     -> cs
>             Nothing     -> []

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

> instance Container c => Container (Maybe c) where

>     type CElem (Maybe c) = CElem c

>     emptyC      = Just emptyC
>     fromC       = maybe (error "fromC") fromC
>     insertL e   = fmap (insertL e)
>     deleteL e   = fmap (deleteL e)
>     relatedElems e = maybe undefined (relatedElems e)

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

> instance Ord a => Particles (S.Set a) where
>   type P (S.Set a) = a
>   particles = id


> instance Ord c => Container (S.Set c) where

>     type CElem (S.Set c)  = S.Set c
> 
>     emptyC                = S.empty
>     fromC d               = [ d | not $ S.null d ]
>     insertL c d           = d `S.union` particles c      
>     deleteL c d           = d S.\\ particles c         
>     relatedElems c d      = [ e | let e = d `S.intersection` particles c, not $ S.null e ]

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


| Test whether two sets have common elements.

> disjunct :: Ord a => S.Set a -> S.Set a -> Bool
> disjunct a b = S.null (S.intersection a b)



> $( derive makeBinary ''EitherC )