-- | Core data types and functions for the game.
module Core
( MMap
, emptyMMap
, setSum
, solutions'
) where
-------------------------------------------
import Place
import PlaceSet
import qualified PlaceMap as M
import Data.Function
import Data.Maybe
import Data.List hiding ((\\), insert, delete)
import qualified Data.List as List
-------------------------------------------
data Constraint
= Constraint
{ places_ :: PlaceSet
, value :: Int
}
deriving Eq
data ConstraintView
= BigConstraint PlaceSet Int
| SmallConstraint PlaceSet Int
| Clear Place
| Mine Place
view :: Constraint -> ConstraintView
view (Constraint ps v)
| size ps == 1 && v == 1 = Mine $ head $ placeSetToList ps
| size ps == 1 && v == 0 = Clear $ head $ placeSetToList ps
| size ps > big = BigConstraint ps v
| otherwise = SmallConstraint ps v
big :: Int
big = 10
---------------------------------------
constraint :: [Place] -> Int -> Constraint
constraint ps v
= Constraint (listToPlaceSet ps) v
subConstraint :: Constraint -> Constraint -> Bool
subConstraint a b = places_ a `isSubsetOf` places_ b
similarConstraint :: Constraint -> Constraint -> Bool
similarConstraint a b = places_ a == places_ b
-- csak akkor, ha subConstraint!
(.-.) :: Constraint -> Constraint -> Constraint
Constraint ps v .-. Constraint ps' v' = Constraint (ps \\ ps') (v-v')
connectionStrength :: Constraint -> Constraint -> [Constraint]
connectionStrength (Constraint ps v) (Constraint ps' v') = [Constraint l i | i<-[min_ .. max_]] where
min_ = maximum [0, v - (size ps - m), v' - (size ps' - m)]
max_ = minimum [m, v, v']
m = size l
l = intersection ps ps'
constraintSolutions :: Constraint -> Integer
constraintSolutions (Constraint ps v) = binom (size ps) v
binom :: Int -> Int -> Integer
binom m n = binoms !! m !! min n (m-n)
binoms :: [[Integer]]
binoms = iterate f [1] where f l = zipWith (+) (l++[0]) ([0]++l)
-------------------------------------------
data Constraints
= Unsolvable
| Solvable
[Constraint] -- big constraints (usually one)
PlaceSet -- cleared places
PlaceSet -- places with mines
(M.PlaceMap [Constraint]) -- other constraints
---------------------------------------
addConstraintSimple :: Constraint -> Constraints -> Constraints
addConstraintSimple _ Unsolvable = Unsolvable
addConstraintSimple c (Solvable bc cl mi m) = case view c of
Clear p -> Solvable bc (insert p cl) mi m
Mine p -> Solvable bc cl (insert p mi) m
BigConstraint _ _ -> Solvable (c:bc) cl mi m
SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps
where
f p m' = case M.lookup p m' of
Nothing -> M.insert p [c] m'
Just cs -> M.insert p (c:cs) m'
deleteConstraint :: Constraint -> Constraints -> Constraints
deleteConstraint _ Unsolvable = Unsolvable
deleteConstraint c (Solvable bc cl mi m) = case view c of
Clear p -> Solvable bc (delete p cl) mi m
Mine p -> Solvable bc cl (delete p mi) m
BigConstraint _ _ -> Solvable (deleteBy similarConstraint c bc) cl mi m
SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps
where
f p m' = case M.lookup p m' of
Just cs -> case deleteBy similarConstraint c cs of
[] -> M.delete p m'
l -> M.insert p l m'
deleteConstraints :: [Constraint] -> Constraints -> Constraints
deleteConstraints cs m = foldr deleteConstraint m cs
dependentConstraints :: Constraint -> Constraints -> [Constraint]
dependentConstraints c@(Constraint ps _) (Solvable bc cl mi m)
= List.delete c $ l ++ filter (not . disjunct ps . places_) bc
where
l = map toClear (placeSetToList $ intersection cl ps)
++ map toMine (placeSetToList $ intersection mi ps)
++ nub (concatMap f $ placeSetToList ps)
toClear p = constraint [p] 0
toMine p = constraint [p] 1
f p = case M.lookup p m of
Just cs -> cs
Nothing -> []
---------------------------------------
-- calculate number of different solutions
solutions :: Constraints -> Integer
solutions Unsolvable = 0
solutions (Solvable bc _ _ cs) = product (map (constraintSolutions . fst) indep) * case dep of
[] -> 1
((c, xs): _) -> let
cs' = minimumBy (compare `on` length) $ map (connectionStrength c) xs
in sum [solutions (addConstraint y s'') | y<-cs']
where
s' = Solvable bc empty empty cs
s'' = deleteConstraints (map fst indep) s'
(indep, dep) = partition (null . snd) $ map (`dependentConstraints_` s') $ nub (concatMap snd $ M.toList cs) ++ bc
dependentConstraints_ c cs = (c, dependentConstraints c cs)
solvable :: Constraints -> Bool
solvable Unsolvable = False
solvable (Solvable bc _ _ cs) = case concatMap snd (M.toList cs) ++ bc of
[] -> True
(c: _) -> case dependentConstraints c s' of
[] -> solvable (deleteConstraint c s')
(x:_) -> let
cs' = connectionStrength c x
in or [solvable (addConstraint y s') | y<-cs']
where
s' = Solvable bc empty empty cs
-- may be faster?
omittable :: Constraint -> Constraints -> Bool
omittable c@(Constraint ps v) cs = all (not . solvable) [addConstraint (Constraint ps i) cs | i <- [v-1,v-2..0] ++ [v+1..size ps]]
{-
- if p1 + ... + pI = n has no solution except for n = n0, then p1 + ... + pI = n0 is not needed:
pA + pB = 1, pB + pC = 1, pC + pD = 1, pD + pA = 1
--> pA + pB = 1, pB + pC = 1, pC + pD = 1
- ...
-}
---------------------------------------
addConstraintSmart :: Constraint -> Constraints -> Constraints
addConstraintSmart c cs
| not (solvable cs') = Unsolvable
-- | omittable c cs = cs -- not really needed
| otherwise = cs'
where
cs' = addConstraint c cs
addConstraint :: Constraint -> Constraints -> Constraints
addConstraint _ Unsolvable = Unsolvable
addConstraint n@(Constraint ps v) c
| v<0 || v>s = Unsolvable
| s==0 = c
| s>1 && v==0 = addConstraints [constraint [p] 0 | p<- placeSetToList ps] c
| s>1 && v==s = addConstraints [constraint [p] 1 | p<- placeSetToList ps] c
| any ((/= v) . value) similar = Unsolvable
| not (null similar) = c
| any (==0) str = Unsolvable
| ((x, [y]): _) <- oneStrength
= addConstraints [n .-. y, x .-. y, y] $ deleteConstraint x c
| otherwise = addConstraints [x .-. n | x <- supDomains] $ addConstraintSimple n $ deleteConstraints supDomains c
where
s = size ps
supDomains = [x | x <- dep, n `subConstraint` x]
oneStrength = filter ((==1) . length . snd) strength
str = map (length . snd) strength
strength = [(x, connectionStrength n x) | x <- dep, x `subConstraint` n]
(similar, dep) = partition (similarConstraint n) $ dependentConstraints n c
addConstraints :: [Constraint] -> Constraints -> Constraints
addConstraints l c = foldr addConstraint c l
-----------------------------------------------
data MMap = MMap Constraints Integer
emptyMMap :: MMap
emptyMMap = mkMMap $ Solvable [] empty empty M.empty
mkMMap :: Constraints -> MMap
mkMMap c = MMap (if s==0 then Unsolvable else c) s
where
s = solutions c
solutions' :: MMap -> Integer
solutions' (MMap _ i) = i
setSum :: PlaceSet -> Int -> MMap -> MMap
setSum ps v (MMap c _) = mkMMap $ addConstraint (Constraint ps v) c
---------------------------------------