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 Data.Number.ER.Misc
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
compare compareVals b1 b2 =
compareListsWith comparePairs (IMap.toList b1) (IMap.toList b2)
where
comparePairs (k1,v1) (k2,v2) =
compareComposeMany
[
compare k1 k2,
compareVals v1 v2
]
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