minesweeper-0.8.8.4: Data/PContainer.lhs
> {-# 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 )