minesweeper-0.9: Core/Constraint.lhs

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

| Core data type for the game.

> module Core.Constraint
>      where


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

> import Prelude hiding (null)
> import Data.Binary

> import Data.Domain
> import Data.SetClass hiding (intersection)
> import qualified Data.SetClass as S
> -- import Core.SetContainer hiding (empty, intersection)
> import Data.Data

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

| @Constraint a@ represents ...

> data Constraint c
>     = Constraint c Int
>         deriving (Eq, Read, Show, Typeable, Data)

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


> intersection :: Set a => Constraint a -> Constraint a -> [[Constraint a]]
> Constraint a av `intersection` Constraint b bv
>         = [ filter (not . null . domain)
>              [ Constraint (a `fastMinus` c) (av - cv)
>              , Constraint  c                 cv
>              , Constraint (b `fastMinus` c) (bv - cv) 
>              ] 
>           | cv <- [min' .. max'] ]     
>       where 
> 
>         c = S.intersection a b     
> 
>         min' = 0 `max` (av - (size a - size c)) `max` (bv - (size b - size c))      
>
>         max' = size c `min` av `min` bv     
>
>         x `fastMinus` y 
>           | size x == size y = empty
>           | otherwise = x \\ y


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]