{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-|
    Module      :  Data.Number.ER.Real.DomainBox.IntMap
    Description :  implementation of DomainBox based on Data.Map   
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  portable

    A simple implementation of the 'VariableID' and 'DomainBox' classes.
-}
module Data.Number.ER.Real.DomainBox.IntMap 
(
    VarID, Box
)
where

import qualified Data.Number.ER.Real.Approx as RA
import Data.Number.ER.Real.DomainBox

import qualified Data.Map as Map
import qualified Data.Set as Set

type VarID = Int
type Box ira = Map.Map VarID ira

instance VariableID VarID
    where
    newVarID prevVars 
        | Set.null prevVars = 0
        | otherwise =
            1 + (Set.findMax prevVars)
    showVar v = "x" ++ show v

instance (Show ira) => (DomainBox (Box ira) VarID ira)
    where
    noinfo = Map.empty
    isNoinfo = Map.null
    unary r = Map.singleton defaultVar r
    singleton = Map.singleton
    toList = Map.toList
    fromList = Map.fromList
    toAscList = Map.toAscList
    fromAscList = Map.fromAscList
    toMap = id
    fromMap = id
    insert = Map.insert
    insertWith = Map.insertWith
    delete = Map.delete
    member = Map.member 
    notMember = Map.notMember
    union = Map.union 
    unionWith = Map.unionWith 
    elems = Map.elems
    keys = Map.keys
    map = Map.map
    fold = Map.fold
    foldWithKey = Map.foldWithKey
    zipWith f b1 b2 = Map.toList $ Map.intersectionWith f b1 b2
    intersectionWith = Map.intersectionWith
    findWithDefault = Map.findWithDefault
    lookup locspec var dom =
        Map.findWithDefault err var dom
        where
        err =
            error $
                locspec ++ "DomainBox.IntMap lookup: domain box " ++ show dom 
                ++ " ignores variable " ++ show var

instance (RA.ERIntApprox ira) => DomainIntBox (Box ira) VarID ira
    where
    compatible dom1 dom2 =
        Map.fold (&&) True $
            Map.intersectionWith RA.equalIntervals dom1 dom2
    unify locspec dom1 dom2
        | compatible dom1 dom2 =
            Map.union dom1 dom2
        | otherwise =
            error $
                locspec ++ "incompatible domains " ++ show dom1 ++ " and " ++ show dom2
    bestSplit dom =
        (var, pt)
        where
        pt = 
            RA.defaultBisectPt varDom
        (_, (varDom, var)) = 
            foldl findWidestVar (0, err) $ Map.toList dom
        err =
            error $ "DomainBox: bestSplit: failed to find a split for " ++ show dom 
        findWidestVar (prevWidth, prevRes) (v, d)
            | currWidth `RA.leqSingletons` prevWidth = (prevWidth, prevRes)
            | otherwise = (currWidth, (d, v))
            where
            currWidth = snd $ RA.bounds $ domHI - domLO
            (domLO, domHI) = RA.bounds d
    classifyPosition dom sdom =    
        (away, touch, intersect, inside)
            where
            (away, touch, inside, intersect) =
                Map.fold addDimension (True, True, True, False) awayTouchInsides
            addDimension 
                    (prevAway, prevTouch, prevInside, prevIntersect) 
                    (thisAway, thisTouch, thisInside, thisIntersect) =
                (prevAway && thisAway, 
                 (prevTouch || prevAway) && (thisTouch || thisAway) && (prevTouch || thisTouch),
                 prevInside && thisInside,
                 prevIntersect || thisIntersect)
            awayTouchInsides =
                Map.intersectionWith classifyRA dom sdom
            classifyRA d sd =
                (outsideNoTouch, outsideTouch, inside,
                 not (outsideNoTouch || outsideTouch || inside))
                 where
                 outsideNoTouch = sdR < dL || dR < sdL
                 outsideTouch = sdR == dL || dR == sdL
                 inside = sdL =< dL && dR =< sdR
                 (==) = RA.eqSingletons
                 (<) = RA.ltSingletons
                 (=<) = RA.leqSingletons
                 (dL, dR) = RA.bounds d 
                 (sdL, sdR) = RA.bounds sd