minesweeper-0.8.9: Core/Constraint.lhs

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