> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls, GeneralizedNewtypeDeriving, GADTs, PatternGuards #-}

| Core data type for the game.

> module Core.Constraints
>      where


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

> import Data.SetClass hiding (null, empty, intersection)
> import qualified Data.SetClass as S
> import Data.Domain

> import Core.SetContainer
> import Core.Constraint 

> import Data.Binary
> import Data.Data

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

> class Constraints a where

>   type ConstraintDomain a 

>   emptyConstraints :: a
>   impossible      :: a
>   solutions       :: a -> Integer
>   addConstraint   :: Constraint (ConstraintDomain a) -> a -> a

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

> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b) => Constraints (Maybe a) where

>   type ConstraintDomain (Maybe a) =  Domain (SetContainerElem a)

>   emptyConstraints = Just empty

>   impossible = Nothing

>   solutions Nothing = 0
>   solutions (Just x) = product $ map f $ components x  where
>
>     f :: Component (SetContainerElem a) -> Integer
>     f (OneElem x)      
>         = sizeConstraint x
>     f (TwoElems c d y)
>         = sum [ solutions $ foldr addConstraint (Just y) e | e <- intersection c d ]

>   addConstraint _ Nothing = Nothing     -- nincs megoldás
>   addConstraint n (Just c)
>     | any (null . snd) strength 
>         = Nothing
>     | (c', [y]): _ <- filter (null . tail . snd) strength
>         = foldr addConstraint (Just c') y
>     | otherwise 
>         = Just (insert n c)
>    where
>     strength = 
>        [ (c', intersection n x) 
>        | (x, c') <- relatedElems n c
>        ]


Cached Size Implementation
--------------------------

> newtype CachedSize a
>     = CachedSize (Integer, a) 
>         deriving (Read, Show, Binary, Typeable, Data)

| smart constructor

> cachedSize :: Constraints c => c -> CachedSize c
> cachedSize c = cachedSize_ (solutions c) c

> cachedSize_ 0 _ = impossible
> cachedSize_ n c = CachedSize (n, c)


> instance Constraints c => Constraints (CachedSize c)  where

>     type ConstraintDomain (CachedSize c)    = ConstraintDomain c

>     solutions (CachedSize (i, _)) = i

>     emptyConstraints = cachedSize emptyConstraints

>     addConstraint z x@(CachedSize (n, c)) 
>           = if n == solutions y then x else y 
>       where y = cachedSize $ addConstraint z c

>     impossible  = CachedSize (0, impossible)


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

> class IntFunction a where
>   intFunction :: a -> Int -> Int

> data Const0Fun deriving (Typeable)
> data IdFun deriving (Typeable)

> instance IntFunction IdFun     where intFunction _ = id
> instance IntFunction Const0Fun where intFunction _ = const 0

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

> data (IntFunction x, SetContainer a) => DetachExtreme x a
>     = DetachExtreme (Domain (SetContainerElem a)) a
>       deriving (Typeable)

> appFunction :: forall x a. IntFunction x => DetachExtreme x a -> Int -> Int
> appFunction _ = intFunction (undefined :: x)

> instance Show (DetachExtreme x a) where
>     show = error "show not defined on DetachExtreme"

> instance (SetContainer a, Binary (Domain (SetContainerElem a)), Binary a) => Binary (DetachExtreme x a) where

>     put (DetachExtreme a b) = put (a, b)
>     get = do (a,b) <- get
>              return (DetachExtreme a b)

> instance (SetContainer a, Data (Domain (SetContainerElem a)), Data a, Typeable x) => Data (DetachExtreme x a) where
>   gunfold = error "gunfold not defined for DetachExtreme"
>   toConstr = error "toConstr not defined for DetachExtreme"
>   dataTypeOf = error "dataTypeOf not defined for DetachExtreme"


> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b, IntFunction x) 
>       => SetContainer (DetachExtreme x a) where

>     type SetContainerElem (DetachExtreme x a) = SetContainerElem a

>     empty = DetachExtreme S.empty empty

>     components d@(DetachExtreme ex o)
>       = [OneElem (Constraint ex (appFunction d (size ex))) | not (S.null ex)] 
>       ++ components o

>     insert c@(Constraint s n) d@(DetachExtreme ex o)
>         | n == appFunction d (size s)      
>           = DetachExtreme (ex `union` s) o
>         | otherwise   
>           = DetachExtreme ex (insert c o)

>     relatedElems c@(Constraint s _) d@(DetachExtreme ex o)
>       =  [ (Constraint e (appFunction d (size e)), DetachExtreme (ex \\ e) o) 
>          | let e = s `S.intersection` ex, not (S.null e) ]
>       ++ [ (x, DetachExtreme ex o') | (x, o') <- relatedElems c o ]