minesweeper-0.8.9: Core/BitField.lhs

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

| Core data type for the game.

> module Core.BitField
>      where


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

> import Core.SetContainer
> import Core.Constraint (Constraint, constraint, sizeConstraint, intersectionC)

> import Data.Binary

> -- import Data.Maybe
> --import Data.List
> import Data.SetClass hiding (null)

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

> class Layouts a where
>
>   type BitFieldElem a 
>
>   numOfLayouts    :: a -> Integer
>   newLayout       :: BitFieldElem a -> Int -> a
>   addConstraint   :: BitFieldElem a -> Int -> a -> a
>   impossible      :: a

> 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
> 
>   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


> 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
>        ]

> thd :: (a,b,c) -> c
> thd (_,_,x) = x


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

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

| smart constructor

> cachedSize :: Layouts c => c -> CachedSize c
> cachedSize c = cachedSize_ (numOfLayouts c) c

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

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

>     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)