module Data.Number.ER.Real.DomainBox.IntMap
(
VarID, Box
)
where
import qualified Data.Number.ER.Real.Approx as RA
import qualified Data.Number.ER.Real.DomainBox as DBox
import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox)
import qualified Data.IntMap as IMap
import qualified Data.Set as Set
type VarID = Int
type Box ira = IMap.IntMap ira
instance VariableID VarID
where
newVarID prevVars
| Set.null prevVars = 0
| otherwise =
1 + (Set.findMax prevVars)
showVar v
| v == 0 = "x"
| otherwise = "x" ++ show v
instance (Show val) => (DomainBox (Box val) VarID val)
where
noinfo = IMap.empty
isNoinfo = IMap.null
unary r = IMap.singleton defaultVar r
singleton = IMap.singleton
toList = IMap.toList
fromList = IMap.fromList
toAscList = IMap.toAscList
fromAscList = IMap.fromAscList
insert = IMap.insert
insertWith = IMap.insertWith
delete = IMap.delete
member = IMap.member
notMember = IMap.notMember
union = IMap.union
unionWith = IMap.unionWith
elems = IMap.elems
keys = IMap.keys
filter = IMap.filter
fold = IMap.fold
foldWithKey = IMap.foldWithKey
zipWith f b1 b2 =
applyF (IMap.toAscList b1) (IMap.toAscList b2)
where
applyF [] _ = []
applyF _ [] = []
applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2)
| k1 == k2 =
(k1, f v1 v2) : (applyF rest1 rest2)
| k1 < k2 = applyF rest1 bl2
| otherwise = applyF bl1 rest2
zipWithDefault defaultValue f b1 b2 =
applyF (IMap.toAscList b1) (IMap.toAscList b2)
where
applyF [] [] = []
applyF bl1@((k1,v1):rest1) [] =
(k1, f v1 defaultValue) : (applyF rest1 [])
applyF [] bl2@((k2,v2):rest2) =
(k2, f defaultValue v2) : (applyF [] rest2)
applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2)
| k1 == k2 =
(k1, f v1 v2) : (applyF rest1 rest2)
| k1 < k2 =
(k1, f v1 defaultValue) : (applyF rest1 bl2)
| otherwise =
(k2, f defaultValue v2) : (applyF bl1 rest2)
zipWithDefaultSecond defaultValue f b1 b2 =
applyF (IMap.toAscList b1) (IMap.toAscList b2)
where
applyF [] _ = []
applyF bl1@((k1,v1):rest1) [] =
(k1, f v1 defaultValue) : (applyF rest1 [])
applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2)
| k1 == k2 =
(k1, f v1 v2) : (applyF rest1 rest2)
| k1 < k2 =
(k1, f v1 defaultValue) : (applyF rest1 bl2)
| otherwise =
applyF bl1 rest2
findWithDefault = IMap.findWithDefault
lookup locspec var dom =
IMap.findWithDefault err var dom
where
err =
error $
locspec ++ "DomainBox.IntMap lookup: domain box " ++ show dom
++ " ignores variable " ++ show var
instance (Show val1, Show val2) =>
(DomainBoxMappable (Box val1) (Box val2) VarID val1 val2)
where
map = IMap.map
mapWithKey = IMap.mapWithKey
intersectionWith = IMap.intersectionWith
difference = IMap.difference
instance (RA.ERIntApprox ira) => DomainIntBox (Box ira) VarID ira
where
compatible dom1 dom2 =
foldl (&&) True $ map snd $
DBox.zipWith RA.equalIntervals dom1 dom2
unify locspec dom1 dom2
| DBox.compatible dom1 dom2 =
IMap.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) $ IMap.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
split dom var pt =
(IMap.insert var varDomL dom, IMap.insert var varDomR dom)
where
varDomL = varDomLO RA.\/ varDomMid
varDomR = varDomMid RA.\/ varDomHI
(varDomLO, varDomMid, varDomHI, _) = RA.exactMiddle varDom
varDom = DBox.lookup "DomainBox.IntMap: split: " var dom
classifyPosition dom sdom =
(away, touch, intersect, inside)
where
(away, touch, inside, intersect) =
foldl 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 snd $
DBox.zipWith 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