diff --git a/Configuration.hs b/Configuration.hs
--- a/Configuration.hs
+++ b/Configuration.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Configuration 
     ( Configuration
         ( Configuration
diff --git a/Core/BitField.lhs b/Core/BitField.lhs
--- a/Core/BitField.lhs
+++ b/Core/BitField.lhs
@@ -1,6 +1,5 @@
 
-> {-# LANGUAGE FlexibleInstances #-}
-> {-# LANGUAGE UndecidableInstances #-}
+> {-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, PatternGuards, TemplateHaskell, EmptyDataDecls, GADTs, GeneralizedNewtypeDeriving #-}
 
 | Core data type for the game.
 
@@ -11,448 +10,87 @@
 Import List
 -----------
 
-> import Data.PContainer
-
-#ifdef TEST
-
-> import Test.LazySmallCheck hiding (empty)
-> import Number.Peano
-
-#endif
+> import Core.SetContainer
+> import Core.Constraint (Constraint, constraint, sizeConstraint, intersectionC)
 
-> import Control.Monad
 > import Data.Binary
-> import Data.DeriveTH
-> import Data.Derive.Binary
-> import Data.Derive.Functor
 
-> import qualified Data.Set as S
-
-> import Data.Monoid
-> import Data.Function
-> import Data.Maybe
-> import Data.List
-
-
-
-> type Set a = S.Set a
-
-
-Subset of Subsets
------------------
-
-
-| @Subsets c@: @c@ is a data structure which represents a subset of all subsets of a given set.
-
-> class Ord (Elem c) => Subsets c where
-
->     type Elem c
-
->     domain        :: c -> Set (Elem c)
-#ifdef TEST
->     subsets       :: c -> [Set (Elem c)]
-#endif
->     subsetsNum    :: c -> Integer
-
->     empty         :: Set (Elem c) -> c
-
-| @isTriviallyEmpty@ should be fast but may give @False@ also for empty subsets.
-
->     isTriviallyEmpty :: c -> Bool
-
-| All subsets of the empty set.
-
->     emptySubsets  :: Set (Elem c) -> c
-
-
-
-#ifdef TEST
-Properties
-----------
-
-all subsets ⊂ domain
-
-> prop_subsetsNum :: Subsets c => c -> Bool
-> prop_subsetsNum e
->     = subsetsNum e == genericLength (subsets e)
-
-> prop_empty :: Subsets a => a -> Set (Elem a) -> Bool
-> prop_empty a d
->     = subsetsNum (empty d `asTypeOf` a) == 0
-
-isTriviallyEmpty ==> isEmpty
-
-> prop_emptySubsets :: Subsets a => a -> Set (Elem a) -> Bool
-> prop_emptySubsets a d
->     = domain e == d  && subsets e == [S.empty]  where e = emptySubsets d `asTypeOf` a
-
-| Test helper function.
-
-> isEmpty :: Subsets c => c -> Bool
-> isEmpty 
->     = null . subsets
-#endif
-
-
-#ifdef TEST
-Simple Implementation
----------------------
+> -- import Data.Maybe
+> --import Data.List
+> import Data.SetClass hiding (null)
 
-| Subset of all subsets of a given set.
+-------------------------------------------------------
 
-> data SimpleSubsets a 
->     = SimpleSubsets (Set a) [Set a]
->         deriving (Show)
+> class Layouts a where
+>
+>   type BitFieldElem a 
+>
+>   numOfLayouts    :: a -> Integer
+>   newLayout       :: BitFieldElem a -> Int -> a
+>   addConstraint   :: BitFieldElem a -> Int -> a -> a
+>   impossible      :: a
 
-> instance Ord a => Eq (SimpleSubsets a) where
+> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b) => Layouts (Maybe a) where
+>
+>   type BitFieldElem (Maybe a) =  Domain (SetContainerElem a)
+>
+>   newLayout = curry $ Just . (`insertL` emptyC) . uncurry constraint
 > 
->     SimpleSubsets da sa == SimpleSubsets db sb
->         = da == db && sort sa == sort sb
+>   numOfLayouts Nothing = 0
+>   numOfLayouts (Just x) = product $ map f $ decomp x  where
+>     f :: Decomp (SetContainerElem a) -> Integer
+>     f (OneElem x)      
+>         = sizeConstraint x
+>     f (Dependents c d y)
+>         = sum [ numOfLayouts $ foldr addConstraint' (Just y) e | e <- intersectionC c d ]
+>
+>   addConstraint = curry $ addConstraint' . uncurry constraint
+>
+>   impossible = Nothing
 
-> instance Ord a => Subsets (SimpleSubsets a) where
-> 
->     type Elem (SimpleSubsets a) = a
-> 
->     domain  (SimpleSubsets d _) = d
->     subsets (SimpleSubsets _ s) = s
->     subsetsNum                  = genericLength . subsets
->     empty d                     = SimpleSubsets d []
->     isTriviallyEmpty            = null . subsets
->     emptySubsets d              = SimpleSubsets d [S.empty]
 
-> toSimple :: (Subsets c) => c -> SimpleSubsets (Elem c)
-> toSimple x 
->     = SimpleSubsets (domain x) (subsets x)
+> addConstraint' n Nothing = Nothing     -- nincs megoldás
+> addConstraint' n (Just c)
+>     | any (null . thd) strength 
+>         = Nothing
+>     | (x, c', [y]): _ <- filter (null . tail . thd) strength
+>         = foldr addConstraint' (Just c') y
+>     | otherwise 
+>         = Just (insertL n c)
+>    where
+>     strength = 
+>        [ (x, c', intersectionC n x) 
+>        | (x, c') <- relatedElems n c
+>        ]
 
-| This property states that @Simple@ is universal.
+> thd :: (a,b,c) -> c
+> thd (_,_,x) = x
 
-> prop_Simple :: Subsets c => (forall d. Subsets d => d -> Bool) -> c -> Bool
-> prop_Simple p a
->   = p a  <==>  p (toSimple a)
-#endif
 
 Cached Size Implementation
 --------------------------
 
-> data CachedSize a
->     = CachedSize a Integer
->         deriving (Read, Show)
+> newtype CachedSize a
+>     = CachedSize (Integer, a) 
+>         deriving (Read, Show, Binary)
 
 | smart constructor
 
-> cachedSize :: Subsets c => c -> CachedSize c
-> cachedSize c 
->     | s == 0    = CachedSize (empty $ domain c) s
->     | otherwise = CachedSize c s
->  where
->     s = subsetsNum c
-
-> instance Subsets c => Subsets (CachedSize c)  where
-
->     type Elem (CachedSize c)    = Elem c
-
-#ifdef TEST
->     subsets (CachedSize x _)    = subsets x
-#endif
->     domain (CachedSize x _)     = domain x
->     subsetsNum (CachedSize _ i) = i
->     emptySubsets                = cachedSize . emptySubsets
->     empty                       = cachedSize . empty
->     isTriviallyEmpty c          = subsetsNum c == 0
-
-> instance SetSum a c => SetSum a (CachedSize c) where
->     setSum' e (CachedSize c _)  = cachedSize $ setSum' e c
-
-
-
-#ifdef TEST
-Combining Sets of Subsets
--------------------------
-
-Definition:
-
-> prop_mappend :: (Monoid c, Subsets c) => c -> c -> Bool
-> prop_mappend a b
->   =   domain (a `mappend` b) == domain a `S.union` domain b
->   &&  all (\s -> 
->                   s `elem` subsets (a `mappend` b)  
->           <==>   (s `S.intersection` domain a) `elem` subsets a  
->               && (s `S.intersection` domain b) `elem` subsets b 
->           ) (allSubsets $ domain $ a `mappend` b)
-
-> allSubsets 
->     = map (S.fromList . concat) . sequence . map (\x -> [[],[x]]) . S.toList   
-
-Properties:
-
-> prop_monoid :: (Eq c, Monoid c) => c -> c -> c -> Bool
-> prop_monoid a b c
->   =   a `mappend` b == b `mappend` a
->   &&  a `mappend` (b `mappend` c) == (a `mappend` b) `mappend` c
->   &&  mempty `mappend` a == a
-
-     isEmpty a ==> isEmpty (a `mappend` b)
-
-
-Implementation for @SimpleSubsets@:
-
-> instance (Ord a) => Monoid (SimpleSubsets a) where
-
->     mempty 
->         = emptySubsets S.empty
-
->     SimpleSubsets da sa `mappend` SimpleSubsets db sb 
->         = SimpleSubsets (da `S.union` db) 
->             [a `S.union` b | a <- sa, b <- sb, a `S.intersection` c == b `S.intersection` c, c S.\\ a == c S.\\ b]
->      where
->         c = da `S.intersection` db
-
-
-> tests = do
->     smallCheck 20 (prop_subsetsNum :: Equal Char -> Bool)
-> --    smallCheck 5 (prop_mappend :: SimpleSubsets Char -> SimpleSubsets Char -> Bool)
-#endif
-
-
-> class Subsets c => Inters c where
->     intersection :: c -> c -> [[c]]
-
-#ifdef TEST
-> prop_intersection a b 
->   = unions [mconcat $ map toSimple x | x <- a `intersection` b] == toSimple a `mappend` toSimple b
-
-> unions l = SimpleSubsets (S.unions $ map domain l) (concat $ map subsets l)
-#endif
-
---------------------------
-
-
-| @Equal a@ represents some subsets of a given set.
-
-> data Equal a
->     = Equal (Set a) Int
->         deriving (Eq, Read, Show)
-
-> instance (Ord a, Binary a) => Binary (Equal a) where
-> 
->     put (Equal a b) = put (a, b)
->     get = do (a,b) <- get
->              return (Equal a b)
-
-> instance Ord a => Particles (Equal a) where
->     type P (Equal a) = a
->     particles = domain
-
-
-
-| Semantics
-
-> instance Ord a => Subsets (Equal a) where
-
->     type Elem (Equal a) 
->         = a
-
->     domain (Equal d _) 
->         = d
-
-#ifdef TEST
->     subsets (Equal d n) 
->         = map S.fromDistinctAscList (f (S.toList d) n)  where
-
->         f as 0 = [[]]
->         f as n = [x:bl | (x: xs) <- tails as, bl <- f xs (n-1)]
-#endif
-
->     subsetsNum (Equal d n) 
->         = binomial (S.size d) n
-
->     emptySubsets d
->         = Equal d 0
-
->     empty d
->         = Equal d (-1)
-
->     isTriviallyEmpty (Equal d n)
->         = n<0 || n> S.size d
-
-
-#ifdef TEST
-| For testing
-
-> instance Serial (Equal Char) where
->     series = cons1 f where
-
->         f :: Nat -> Equal Char
->         f i = Equal (S.fromList $ take n ['a'..]) m   where
-
->             (n, m) = [(n, m) | n <- [0..], m <- [0..n]] !! fromIntegral i
-#endif
-
-
-
-> instance Ord a => Inters (Equal a)  where
-
->     Equal a av `intersection` Equal b bv
->         = [ [ Equal (a S.\\ c) (av - cv)
->             , Equal  c          cv
->             , Equal (b S.\\ c) (bv - cv) 
->             ] 
->           | cv <- [min' .. max'] ]     where 
-> 
->         c = S.intersection a b      -- a
-> 
->         min' = 0 `max` (av - (S.size a - S.size c)) `max` (bv - (S.size b - S.size c))      -- av `max` (bv - (size b - size a))
->         max' = S.size c `min` av `min` bv       -- av `min` bv
-
-
-> {-
-> prop_factor a b
->     = b `subDomain` a  
->     ==>  toSimple a `mappend` toSimple b  ==  toSimple (a `factor` b) `mappend` toSimple b
-> -}
-
------------------------------------------
-
-> class (Subsets a, Subsets c {-, Elem a ~ Elem c -}) => SetSum a c  where
-> 
->     setSum'  :: a -> c -> c
-
-
-
------------------------------------------------------------
-
-> a_limit = 3
-> b_limit = 3
-
-
-> subsetsNumStep 
->     :: (Container c, Subsets c, Inters (CElem c))
->      => c -> Integer
-> subsetsNumStep x | isTriviallyEmpty x = 0
-> subsetsNumStep x = case fromC x of
->     [] -> 1
->     l  -> snd $ minimumBy (compare `on` fst) $ take a_limit $ map cont l
->  where
->     cont c = case relatedElems c x' of
->         [] -> (0, subsetsNum c * subsetsNum x' )
->         b ->
->             let ll = [ subsetsNum $ foldr addToContainer x'' y
->                      | let (d, ys) = minimumBy (compare `on` (length . snd)) $ take b_limit $ map (\d -> (d, intersection c d)) b
->                      , let x'' = deleteL d x'
->                      , y <- ys]
->             in (length ll, sum ll)  
-> 
->         where  x' = deleteL c x
-
-
-> addToContainer 
->     :: (Container c, Subsets c, Inters (CElem c))
->     => CElem c -> c -> c
-> addToContainer n c
->     |  isTriviallyEmpty n
->     || isTriviallyEmpty c
->     || any (null . snd) strength 
->         = empty $ domain c
->     | (x, y): _ <- [(x, y) | (x, [y]) <- strength]
->         = foldr addToContainer (deleteL x c) y
->     | otherwise 
->         = insertL n c 
->  where
->     strength = [(x, intersection n x) | x <- relatedElems n c]
-
-
---------------------------------------------------------------------------------------------
-
-
-> instance (Container c, Inters (CElem c)) => Subsets (Maybe c) where
->     type Elem (Maybe c) = Elem (CElem c)
-
->     domain      = maybe (error "domain vanished") (S.unions . map domain . fromC)
-#ifdef TEST
->     subsets     = maybe [] (subsets . mconcat . map toSimple . fromC)
-#endif
->     empty _     = Nothing
-
->     emptySubsets d 
->           | S.null d  = Just emptyC
->           | otherwise = Just $ insertL (emptySubsets d) emptyC
-
->     subsetsNum  = subsetsNumStep
-
->     isTriviallyEmpty Nothing = True
->     isTriviallyEmpty _  = False
-
-
-> instance (Inters a, Container c, a ~ CElem c) => SetSum a (Maybe c) where
->     setSum'     = addToContainer
-
-
-
-
----------------------------------------------------------------
-
-> data EmptyEqual a
-
-> instance Decision (EmptyEqual a) where
->     type DecisionDomain (EmptyEqual a) = Equal a
->     holds _ (Equal _ n) = n == 0
-
-> data SetAsEmptyEqual a
-
-> instance Ord a => Bijection (SetAsEmptyEqual a) where
-> 
->   type From (SetAsEmptyEqual a) = S.Set a
->   type To (SetAsEmptyEqual a) = Equal a
-> 
->   fw _ d = Equal d 0
->   bw _ (Equal d 0) = d
->   bw _ _ = S.empty        
-
-
----------------------------------------------------------------
-
-
-Auxiliary Definitions
----------------------
-
-
-#ifdef TEST
-| Natural number type with @Serial@ instance for testing.
-
-> type Nat = Number.Peano.T
-
-> instance Serial Number.Peano.T where
->     series = cons0 Zero \/ cons1 Succ
-
-> infix 1 <==>
-> (<==>) :: Bool -> Bool -> Bool
-> (<==>) = (==)
-#endif
-
-
-
-| Cached binomial numbers. The first arguent should be non-negative.
-
-> binomial :: Int -> Int -> Integer
-> binomial m n 
->     | n' < 0    = 0
->     | otherwise = pascalsTriangle !! m !! n'
->  where
->     n' = min n (m-n)
-
-| Pascal's triangle. It has to be a global constant to be cached.
-
-> pascalsTriangle :: [[Integer]]
-> pascalsTriangle 
->     = iterate nextRow [1]  where nextRow r = zipWith (+) (0:r) (r++[0])
+> cachedSize :: Layouts c => c -> CachedSize c
+> cachedSize c = cachedSize_ (numOfLayouts c) c
 
+> cachedSize_ 0 c = impossible
+> cachedSize_ n c = CachedSize (n, c)
 
-Derived Instances
------------------
+> instance Layouts c => Layouts (CachedSize c)  where
 
-> $( derive makeBinary ''CachedSize )
-> $( derive makeBinary ''Tr )
+>     type BitFieldElem (CachedSize c)    = BitFieldElem c
 
+>     numOfLayouts (CachedSize (i, _)) = i
+>     newLayout    = curry $ cachedSize . uncurry newLayout
+>     addConstraint e f x@(CachedSize (n, c)) = if n == numOfLayouts y then x else y 
+>       where y = cachedSize $ addConstraint e f c
+>     impossible  = CachedSize (0, impossible)
 
 
 
diff --git a/Core/Constraint.lhs b/Core/Constraint.lhs
new file mode 100644
--- /dev/null
+++ b/Core/Constraint.lhs
@@ -0,0 +1,144 @@
+
+> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls #-}
+
+| Core data type for the game.
+
+> module Core.Constraint
+>      where
+
+
+Import List
+-----------
+
+> import Core.SetContainer
+> import Core.Square
+
+> import Data.Binary
+> import Data.SetClass
+
+> --import Data.List hiding (null, union, (\\))
+> import Prelude hiding (null)
+
+
+-------------------------------------
+
+| @Constraint a@ represents ...
+
+> data Constraint c
+>     = Constraint c Int
+>         deriving (Eq, Read, Show)
+
+> -- should always hold
+> constraint_invariant :: Set a => Constraint a -> Bool
+> constraint_invariant (Constraint d n) = n >= 0 && n <= size d && size d > 0
+
+> sizeConstraint :: Set a => Constraint a -> Integer
+> sizeConstraint (Constraint d n) = binomial (size d) n
+
+
+> instance Binary a => Binary (Constraint a) where
+> 
+>     put (Constraint a b) = put (a, b)
+>     get = do (a,b) <- get
+>              return (Constraint a b)
+
+> instance Set a => HasDomain (Constraint a) where
+
+>   type Domain (Constraint a) = a
+
+>   domain (Constraint a b) = a
+
+> constraint :: Set a => a -> Int -> Constraint a
+> constraint d i 
+>       | constraint_invariant c = c
+>       | otherwise = error $ "makeConstraint: " ++ show (size d, i)
+>    where 
+>       c = Constraint d i
+>
+> intersectionC :: Set a => Constraint a -> Constraint a -> [[Constraint a]]
+> Constraint a av `intersectionC` Constraint b bv
+>         = [ filter valid
+>              [ Constraint (a `fastMinus` c) (av - cv)
+>              , Constraint  c                 cv
+>              , Constraint (b `fastMinus` c) (bv - cv) 
+>              ] 
+>           | cv <- [min' .. max'] ]     
+>       where 
+> 
+>         c = intersection a b     
+> 
+>         min' = 0 `max` (av - (size a - size c)) `max` (bv - (size b - size c))      
+>
+>         max' = size c `min` av `min` bv     
+>
+>         valid (Constraint d n) = not (null d)
+>
+>         x `fastMinus` y 
+>           | size x == size y = empty
+>           | otherwise = x \\ y
+
+-----------------------------------------
+
+> data Clear
+> data Bomb
+
+> class Decide a where
+>   num :: Set b => a -> b -> Int
+
+> instance Decide Bomb where num _ = size
+> instance Decide Clear where num _ = const 0
+
+> data (SetContainer a) => EitherC x a
+>     = EitherC (Domain (SetContainerElem a)) a
+> --        deriving (Show)
+
+> instance Show (EitherC x a) where
+
+> instance (SetContainer a, Binary (Domain (SetContainerElem a)), Binary a) => Binary (EitherC x a) where
+> 
+>     put (EitherC a b) = put (a, b)
+>     get = do (a,b) <- get
+>              return (EitherC a b)
+
+
+> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b, Decide x) 
+>       => SetContainer (EitherC x a) where
+
+>     type SetContainerElem (EitherC x a) = SetContainerElem a
+
+>     emptyC = EitherC empty emptyC
+
+>     decomp (EitherC i o) = [OneElem (Constraint i (num (undefined :: x) i)) | not (null i)] ++ decomp o
+
+>     insertL c@(Constraint s n) (EitherC i o)
+>         | n == num (undefined :: x) s      = EitherC (i `union` s) o
+>         | otherwise   = EitherC i (insertL c o)
+
+>     relatedElems c@(Constraint s _) (EitherC i o)
+>       =  [ (Constraint e (num (undefined :: x) e), EitherC (i \\ e) o) 
+>          | let e = s `intersection` i, not (null e) ]
+>       ++ [ (x, EitherC i o') | (x, o') <- relatedElems c o ]
+
+
+
+Auxiliary Definitions
+---------------------
+
+| Cached binomial numbers. The first arguent should be non-negative.
+
+> binomial :: Int -> Int -> Integer
+> binomial m n 
+>     | n' < 0    = 0
+>     | otherwise = pascalsTriangle !! m !! n'
+>  where
+>     n' = min n (m-n)
+
+| Pascal's triangle. It has to be a global constant to be cached.
+
+> pascalsTriangle :: [[Integer]]
+> pascalsTriangle 
+>     = iterate nextRow [1]  where nextRow r = 1: zipWith (+) r (tail r) ++ [1]
+
+
+
+
diff --git a/Core/Constraints.lhs b/Core/Constraints.lhs
--- a/Core/Constraints.lhs
+++ b/Core/Constraints.lhs
@@ -9,56 +9,56 @@
 >     , clearProb
 >     ) where
 
+> import Data.SetClass (fromList, size)
+
 > import Core.Square
 > import Core.BitField
-> import Data.PContainer
-> import qualified Data.Set as S
+> import Core.SetContainer
+> import Core.Constraint
 
 --------------------------------
 
 > type Constraints 
->     = CachedSize 
->         (Maybe 
->            (EitherC (EmptyEqual Square)
->              (Tr (S.Set Square) (SetAsEmptyEqual Square))
->              (EitherC (SmallStuff (Equal Square))
->                (Index (Equal Square))
->                [Equal Square]
->              )
->            )
->         )
+>   = CachedSize
+>       (Maybe 
+>           (EitherC Clear
+>               (EitherC Bomb
+>                   [Constraint SquareSet]
+>               )
+>           )
+>       )
 
 > solutions :: Constraints -> Integer
-> solutions = subsetsNum
+> solutions = numOfLayouts
 
-> setSum :: [Square] -> Int -> Constraints -> Constraints
+> setSum :: SquareSet -> Int -> Constraints -> Constraints
 > setSum ps v c
->     = setSum' (Equal (S.fromList ps) v) c
+>     = addConstraint ps v c
 
 
 > initConstraints :: Board -> Int -> Constraints
 > initConstraints s m 
->     = setSum (squares s) m $ emptySubsets S.empty
+>     = newLayout (squares s) m
 
 > clearProb :: Square -> Constraints -> Rational
 > clearProb p g
->    = fromIntegral (solutions $ setSum [p] 0 g) / fromIntegral (solutions g)
+>    = fromIntegral (solutions $ setSum (fromList [p]) 0 g) / fromIntegral (solutions g)
 
-> distribution :: [Square] -> Constraints -> [Constraints]
+> distribution :: SquareSet -> Constraints -> [Constraints]
 > distribution ps cs 
 >     = at ((/=0) . solutions) 
 >          (takeWhile ((/=0) . solutions))
->          [setSum ps i cs | i<-[0..length ps]]
+>          [setSum ps i cs | i<-[0..size ps]]
 
 
 Auxiliary
 ---------
 
-> foldrTill :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b
-> foldrTill p c n (x:xs) | p x = x `c` foldrTill p c n xs
-> foldrTill _ _ n xs = n xs
+> foldrUntil :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b
+> foldrUntil p c n (x:xs) | p x = x `c` foldrUntil p c n xs
+> foldrUntil _ _ n xs = n xs
 
 > at :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a]
-> at p = foldrTill (not . p) (:)
+> at p = foldrUntil (not . p) (:)
 
 
diff --git a/Core/SetContainer.lhs b/Core/SetContainer.lhs
new file mode 100644
--- /dev/null
+++ b/Core/SetContainer.lhs
@@ -0,0 +1,69 @@
+
+> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls, RankNTypes, ExistentialQuantification #-}
+
+| Core data type for the game.
+
+> module Core.SetContainer
+>      where
+
+
+Import List
+-----------
+
+> import Data.Binary
+> import Data.DeriveTH
+> import Data.Derive.Binary
+> import Data.Derive.Functor
+
+> import Data.SetClass
+
+> import Data.Maybe
+> import Data.List
+
+
+------------------------------
+
+> class Set (Domain a) => HasDomain a where
+
+>   type Domain a
+
+>   domain :: a -> Domain a
+
+------------------------------
+
+> class HasDomain (SetContainerElem c) => SetContainer c where
+>
+>     type SetContainerElem c   
+> 
+>     emptyC       :: c                
+>     decomp       :: c -> [Decomp (SetContainerElem c)]
+>     insertL      :: SetContainerElem c -> c -> c     
+>     relatedElems :: SetContainerElem c -> c -> [(SetContainerElem c, c)] 
+
+> data Decomp e
+>   = OneElem e
+>   | forall b. (SetContainer b, SetContainerElem b ~ e) => Dependents (SetContainerElem b) (SetContainerElem b) b
+
+-------------------------------------
+
+> instance HasDomain a => SetContainer [a] where
+>
+>     type SetContainerElem [a]  = a
+>
+>     emptyC          = []
+>     insertL         = (:)
+>     decomp [] = []
+>     decomp [a] = [OneElem a]
+>     decomp (a:as) = case relatedElems a as of
+>       []  -> OneElem a: decomp as
+>       (b, c): _ -> [Dependents a b c]
+>     relatedElems x l = [(y, d) | (y, d) <- takeOut l, not (domain x `disjunct` domain y)] 
+
+
+> takeOut l = [(y, xs ++ ys) | (xs, y:ys) <- zip (inits l) (tails l)]
+
+
+
+
+
+
diff --git a/Core/Square.hs b/Core/Square.hs
--- a/Core/Square.hs
+++ b/Core/Square.hs
@@ -1,6 +1,8 @@
 
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- | Squares.
 module Core.Square 
@@ -17,21 +19,23 @@
     , restrictSquare
     , squares
     , neighbours
+
+    , SquareSet
     ) where
 
-import Control.Monad
 import Data.Binary
-import Data.DeriveTH
-import Data.Derive.Binary
 import Data.Bits
 import Data.Maybe
+import Data.SetClass
+import qualified Data.IntSet as IS
+import Prelude hiding (null)
 
 -----------
 
 -- | Board of a board.
 newtype Board 
     = S { unS :: Int }
-        deriving (Eq, Ord)
+        deriving (Eq, Ord, Binary)
 
 instance Show Board where
     show = show . unS
@@ -47,8 +51,8 @@
 
 -- | Square on a board.
 newtype Square 
-    = P Int 
-        deriving (Eq, Ord)
+    = P { unP :: Int } 
+        deriving (Eq, Ord, Binary)
 
 instance Show Square where
     show = show . coords 
@@ -68,13 +72,13 @@
 -----------------------------------
 
 -- | Squares of a board.
-squares :: Board -> [Square]
-squares s = [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]]
+squares :: Board -> SquareSet
+squares s = fromList [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]]
 
 -- | Neighbours of a square on a board.
-neighbours :: Board -> Square -> [Square]
+neighbours :: Board -> Square -> SquareSet
 neighbours s (coords -> (i, j))
-    = catMaybes 
+    = fromList $ catMaybes 
         [square s (i+a) (j+b) | (a, b) <- [(-1,0),(-1,-1),(0,-1),(1,-1),(1,0),(1,1),(0,1),(-1,1)]]
 
 ----------------------- auxiliary functions
@@ -88,9 +92,23 @@
 pack :: Int -> Int -> Int
 pack i j = shiftL i 8 .|. j
 
-
 ---------------------------------
 
-$( derive makeBinary ''Square )
-$( derive makeBinary ''Board )
+newtype SquareSet = SS { unSS :: IS.IntSet } deriving (Show, Binary)
+
+instance Set SquareSet where
+
+   type SetElem SquareSet = Square
+
+   toList      = map P . toList . unSS
+   fromList    = SS . fromList . map unP
+   size        = size . unSS
+   intersection = bi intersection
+   (\\)        = bi (\\)
+   union       = bi union
+   null        = null . unSS
+   empty       = SS empty
+
+bi f a b = SS $ f (unSS a) (unSS b)
+
 
diff --git a/Data/ChangeSet.hs b/Data/ChangeSet.hs
--- a/Data/ChangeSet.hs
+++ b/Data/ChangeSet.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
 module Data.ChangeSet
     ( Set
     , changes
diff --git a/Data/PContainer.lhs b/Data/PContainer.lhs
deleted file mode 100644
--- a/Data/PContainer.lhs
+++ /dev/null
@@ -1,267 +0,0 @@
-
-> {-# 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 )
-
diff --git a/Data/SetClass.lhs b/Data/SetClass.lhs
new file mode 100644
--- /dev/null
+++ b/Data/SetClass.lhs
@@ -0,0 +1,64 @@
+
+> {-# LANGUAGE TypeFamilies #-}
+
+> module Data.SetClass
+>      where
+
+
+Import List
+-----------
+
+> import qualified Data.Set as S
+> import qualified Data.IntSet as IS
+
+> import Prelude hiding (null)
+
+
+-------------------------------------
+
+> class Set a where
+
+>   type SetElem a
+
+>   toList      :: a -> [SetElem a]
+>   fromList    :: [SetElem a] -> a
+>   size        :: a -> Int
+>   intersection  :: a -> a -> a
+>   (\\)        :: a -> a -> a
+>   union       :: a -> a -> a
+>   null        :: a -> Bool
+>   empty       :: a
+
+
+> instance Ord a => Set (S.Set a) where
+
+>   type SetElem (S.Set a) = a
+
+>   toList      = S.toList
+>   fromList    = S.fromList
+>   size        = S.size
+>   intersection = S.intersection
+>   (\\)        = (S.\\)
+>   union       = S.union
+>   null        = S.null
+>   empty       = S.empty
+
+
+> instance Set IS.IntSet where
+
+>   type SetElem IS.IntSet = Int
+
+>   toList      = IS.toList
+>   fromList    = IS.fromList
+>   size        = IS.size
+>   intersection = IS.intersection
+>   (\\)        = (IS.\\)
+>   union       = IS.union
+>   null        = IS.null
+>   empty       = IS.empty
+
+
+> disjunct :: Set a => a -> a -> Bool
+> disjunct a b = null (intersection a b)
+
+
diff --git a/Driver.hs b/Driver.hs
--- a/Driver.hs
+++ b/Driver.hs
@@ -17,29 +17,29 @@
 
 --------------
 
-type Transition st a 
-    = st -> ([a], [Timed a], UTCTime -> IO (), st)
+type Transition st event 
+    = st -> ([event], [Timed event], UTCTime -> IO (), st)
 
-newtype DriverState st a 
-    = DriverState (MVar (M.Map a ThreadId, st))
+newtype DriverState st event
+    = DriverState (MVar (M.Map event ThreadId, st))
 
 -----------------
  
-initDriverState :: st -> IO (DriverState st a)
+initDriverState :: st -> IO (DriverState st event)
 initDriverState st = do
     state <- newMVar (M.empty, st)
     return $ DriverState state
 
-takeState :: DriverState st a -> IO ([a], st)
+takeState :: DriverState st event -> IO ([event], st)
 takeState (DriverState dst) = do
     (ma, st) <- takeMVar dst
     return (M.keys ma, st)
 
 applyTransition
-    :: (Eq a, Ord a, Show a) 
-    => DriverState st a
-    -> (a -> Transition st a) 
-    -> Transition st a
+    :: (Ord event, Show event) 
+    => DriverState st event
+    -> (event -> Transition st event) 
+    -> Transition st event
     -> IO ()
 
 applyTransition (DriverState dst) action transition     = appTransition Nothing transition     
diff --git a/Driver/Simplified.hs b/Driver/Simplified.hs
--- a/Driver/Simplified.hs
+++ b/Driver/Simplified.hs
@@ -21,13 +21,13 @@
 -----------------
 
 applyTransition
-    :: (Eq a, Ord a, Show a, Show b) 
+    :: (Ord event, Show event, Show b) 
     => LogState
-    -> DriverState st a
-    -> [(st -> Bool, a, st -> When)]
+    -> DriverState st event
+    -> [(st -> Bool, event, st -> When)]
     -> (UTCTime -> b -> IO ())
-    -> (a -> Transition st) 
-    -> a
+    -> (event -> Transition st) 
+    -> event
     -> IO ()
 
 applyTransition logState dst triggers handleResponse transition a
diff --git a/State.hs b/State.hs
--- a/State.hs
+++ b/State.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module State where
 
 import Configuration
diff --git a/State/Functions.hs b/State/Functions.hs
--- a/State/Functions.hs
+++ b/State/Functions.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternGuards #-}
+
 module State.Functions where
 
 import Configuration
@@ -6,6 +8,7 @@
 import Core.Constraints
 
 import Data.Maybe
+import Data.SetClass (toList)
 import Control.Monad
 import System.Random 
 import Data.List
@@ -19,7 +22,7 @@
 resetHiddenProbs c gs = gs
     { maxHiddenProb     = Nothing
     , hiddenProbs       = M.empty
-    , noHiddenProbs     = squares (size c) \\ M.keys (revealResults gs)
+    , noHiddenProbs     = toList (squares (size c)) \\ M.keys (revealResults gs)
     }
 
 
@@ -136,12 +139,14 @@
 
 -- reveal / mark / hint can be done
 revealCanBeDone st
-    =  markCanBeDone st
+    =  isNothing (interrupt st)
+    && not (isFinished st)
     && isNothing (revealing st) 
 
 -- mark can be done
 markCanBeDone st
     =  isNothing (interrupt st)
+    && mines_left st > 0
     && not (isFinished st)
 
 -- the timer is active
@@ -169,19 +174,36 @@
 
 information :: State -> Double
 information st 
-    | b == 1    = 1
-    | otherwise = luckFunction a / luckFunction b
+    | all == 1  || s == 1  = 1
+    | otherwise = 1 - logBase 2 (fromIntegral s) / logBase 2 (fromIntegral all)
  where
-    i = fromIntegral $ allSolutions st
-    a = fromIntegral (solutions $ constraints $ game st) / i
-    b = 1 / i
+    all = allSolutions st
+    s = solutions $ constraints $ game st
 
+    prec = 100
+
+-- base 2 logarithm for large numbers
+log2 :: (Ord a, Num a) => Int -> a -> Double
+log2 prec n = f 0 1 1 1 n where
+
+    f :: (Ord a, Num a) => Int -> Int -> a -> a -> a -> Double
+    f a b twoa twoam1 nb = case twoa `compare` nb of
+        LT              -> f (a+1) b (2*twoa) twoa nb
+        GT | b < prec   -> f (2*a-1) (2*b) (twoam1 * twoa) (twoam1 * twoam1) (nb*nb)
+        _ -> fromIntegral a / fromIntegral b
+
+
 allSquares 
     = squares . size . configuration
 
 luck :: State -> Double
 luck = luckFunction . alive . game
 
+luckFunction :: Rational -> Double
+luckFunction x 
+    = max (- 1/2 * logBase 2 (realToFrac x)) 0
+
+
 -------------- other
 
 free g p 
@@ -283,10 +305,6 @@
 
 
 -----------------------
-
-luckFunction :: Rational -> Double
-luckFunction x 
-    = max (- 1/2 * logBase 2 (realToFrac x)) 0
 
 -- megmondja hogy óránként várhatóan hányszor tudnánk teljesíteni egy klasszikus játékot
 successFunction :: Int -> Rational -> Rational
diff --git a/Step.hs b/Step.hs
--- a/Step.hs
+++ b/Step.hs
@@ -11,6 +11,7 @@
 
 import Data.Ratio
 import Data.List
+import Data.SetClass (fromList)
 import Data.Maybe
 import System.Random
 import Data.Binary
@@ -36,10 +37,10 @@
 
 step :: Configuration -> Square -> Constraints -> StdGen -> RevealResult
 step conf p cs r 
-    | dead = RevealResult prob Nothing (setSum [p] 1 cs) r_
+    | dead = RevealResult prob Nothing (setSum (fromList [p]) 1 cs) r_
     | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r'
  where
-    cs' = setSum [p] 0 cs
+    cs' = setSum (fromList [p]) 0 cs
 
     l = distribution (neighbours (size conf) p) cs'
 
diff --git a/Transition/Managed.hs b/Transition/Managed.hs
--- a/Transition/Managed.hs
+++ b/Transition/Managed.hs
@@ -18,6 +18,7 @@
 import qualified State as S
 import Driver.Log
 
+import Data.SetClass (toList)
 import Data.List
 import Data.Maybe
 
@@ -97,7 +98,7 @@
         = []
  where
     ch  | isNothing (changes ost) || e == UpdateTable
-            = [(p, f p) | p <- squares . size_ . state $ st]
+            = [(p, f p) | p <- toList . squares . size_ . state $ st]
         | Just (ost', l) <- changes ost
         , f' <- squareState ost' 
             = [(p, q) | p <- nub $ newChanges ++ l, let q = f p, q /= f' p]
diff --git a/Transition/Response.hs b/Transition/Response.hs
--- a/Transition/Response.hs
+++ b/Transition/Response.hs
@@ -13,6 +13,7 @@
 import Transition.Graphics
 
 import Data.Maybe
+import Data.SetClass (toList)
 import Data.List
 import qualified Data.ChangeMap as M
 import qualified Data.ChangeSet as S
@@ -76,7 +77,7 @@
         -- new table simptoms:
         || length (undo st) < length (undo ost)
         || size_ st /= size_ ost
-        -> allSquares st
+        -> toList $ allSquares st
 
     _   -> concat       -- nub lesz később
         [ catMaybes $ diff [mouseFocus ost, mouseFocus st]
diff --git a/Transition/State.hs b/Transition/State.hs
--- a/Transition/State.hs
+++ b/Transition/State.hs
@@ -11,6 +11,7 @@
 import Core.Constraints
 
 import Data.Maybe
+import Data.SetClass (toList)
 import Data.List
 import Control.Monad (join)
 import qualified Data.ChangeMap as M
@@ -311,7 +312,7 @@
     f g = g { hiddenProbs = M.fromList l, noHiddenProbs = [], maxHiddenProb = Just (maximum $ map snd l) }
      where
         h p = (p, round $ 100 * clearProb p (constraints g))
-        l = map h $ allSquares st \\ M.keys (revealResults g)
+        l = map h $ toList (allSquares st) \\ M.keys (revealResults g)
 
 
 degradeHint st = st { hint = f $ hint st } where
@@ -365,7 +366,7 @@
     = [p]
 revTarget p st
     | Just (Just n) <- M.lookup p $ revealResults $ game st
-    , ng <- neighbours (size_ st) p
+    , ng <- toList $ neighbours (size_ st) p
     , n == length [x | x <- ng, S.member x $ marked $ game st ]
     = filter (free $ game st) ng
 revTarget _ _ 
@@ -414,7 +415,7 @@
     neigh 
         | Just 0 <- mi
         , recursive rev
-        = [p | p<- neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev]
+        = [p | p<- toList $ neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev]
         | otherwise 
         = []
 
diff --git a/minesweeper.cabal b/minesweeper.cabal
--- a/minesweeper.cabal
+++ b/minesweeper.cabal
@@ -1,5 +1,5 @@
 name:                minesweeper
-version:             0.8.8.5
+version:             0.8.9
 category:            Game
 synopsis:            Minesweeper game which is always solvable without guessing
 description:         
@@ -46,7 +46,7 @@
     derive,
     gtk >= 0.10, 
     cairo >= 0.10,
-    glade
+    glade >= 0.10
 
   if flag(tests)
     build-depends:
@@ -61,10 +61,12 @@
   other-modules:    
     Data.ChangeMap,
     Data.ChangeSet,
-    Data.PContainer,
+    Data.SetClass,
     System.Random.Instances,
 
     Core.Square,
+    Core.SetContainer,
+    Core.Constraint,
     Core.BitField,
     Core.Constraints,