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

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