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