minesweeper-0.9: Core/Constraints.lhs
> {-# 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 ]