@@ -18,7 +18,9 @@ ucheck = void . solve 10 . filter (not . ignore)
1818newtype Var = Var Int
1919 deriving (Eq, Ord, Show)
2020
21−type Domain = (Int, Int)
21+data Domain = Domain {-# UNPACK #-} !Int
22+ {-# UNPACK #-} !Int
23+ deriving (Eq, Ord, Show)
2224
2325data SolverState =
2426 SolverState
@@ -40,7 +42,7 @@ solve maxUniverseLevel inpConstraints =
4042 initSolverState = SolverState
4143 { queue = S.fromList inpConstraints
4244 , domainStore = M.fromList
43− [ (v, ((0, maxUniverseLevel), S.empty))
45+ [ (v, (Domain 0 maxUniverseLevel, S.empty))
4446 | v <- ordNub [ v
4547 | (c, _) <- inpConstraints
4648 , v <- varsIn c
@@ -71,22 +73,25 @@ solve maxUniverseLevel inpConstraints =
7173 Just (cons, fc) -> do
7274 case cons of
7375 ULE a b -> do
74− (lowerA, upperA) <- domainOf a
75− (lowerB, upperB) <- domainOf b
76− when (upperB < upperA) $ updateDomainOf (cons, fc) a (lowerA, upperB)
77− when (lowerA > lowerB) $ updateDomainOf (cons, fc) b (lowerA, upperB)
76+ Domain lowerA upperA <- domainOf a
77+ Domain lowerB upperB <- domainOf b
78+ when (upperB < upperA) $ updateDomainOf (cons, fc) a (Domain lowerA upperB)
79+ when (lowerA > lowerB) $ updateDomainOf (cons, fc) b (Domain lowerA upperB)
7880 ULT a b -> do
79− (lowerA, upperA) <- domainOf a
80− (lowerB, upperB) <- domainOf b
81+ Domain lowerA upperA <- domainOf a
82+ Domain lowerB upperB <- domainOf b
8183 let upperB_pred = pred upperB
8284 let lowerA_succ = succ lowerA
83− when (upperB_pred < upperA) $ updateDomainOf (cons, fc) a (lowerA, upperB_pred)
84− when (lowerA_succ > lowerB) $ updateDomainOf (cons, fc) b (lowerA_succ, upperB)
85+ when (upperB_pred < upperA) $ updateDomainOf (cons, fc) a (Domain lowerA upperB_pred)
86+ when (lowerA_succ > lowerB) $ updateDomainOf (cons, fc) b (Domain lowerA_succ upperB)
8587 propagate
8688
8789 -- | extract a solution from the state.
8890 extractSolution :: (MonadState SolverState m, Functor m) => m (M.Map Var Int)
89− extractSolution = M.map (fst . fst) <$> gets domainStore
91+ extractSolution = M.map (extractValue . fst) <$> gets domainStore
92+
93+ extractValue :: Domain -> Int
94+ extractValue (Domain x _) = x
9095
9196 -- | dequeue the first constraint.
9297 nextConstraint :: MonadState SolverState m => m (Maybe (UConstraint, FC))
@@ -100,13 +105,13 @@ solve maxUniverseLevel inpConstraints =
100105
101106 -- | look up the domain of a variable from the state.
102107 -- for convenience, this function also accepts UVal's and returns a singleton domain for them.
103− domainOf :: MonadState SolverState m => UExp -> m (Int, Int)
108+ domainOf :: MonadState SolverState m => UExp -> m Domain
104109 domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)
105− domainOf (UVal val) = return (val, val)
110+ domainOf (UVal val) = return (Domain val val)
106111
107112 -- | updates the domain of a variable.
108113 -- this function is also where we fail, inc ase of a domain wipe-out.
109− updateDomainOf :: (UConstraint, FC) -> UExp -> (Int, Int) -> StateT SolverState TC ()
114+ updateDomainOf :: (UConstraint, FC) -> UExp -> Domain -> StateT SolverState TC ()
110115 updateDomainOf suspect (UVar var) newDom = do
111116 doms <- gets domainStore
112117 let (oldDom, suspects) = doms M.! Var var
@@ -129,8 +134,8 @@ solve maxUniverseLevel inpConstraints =
129134 Just cs -> modify $ \ st -> st { queue = S.union cs (queue st) }
130135
131136 -- | check if a domain is wiped out.
132− wipeOut :: (Int, Int) -> Bool
133− wipeOut (l, u) = l > u
137+ wipeOut :: Domain -> Bool
138+ wipeOut (Domain l u) = l > u
134139
135140ordNub :: Ord a => [a] -> [a]
136141ordNub = S.toList . S.fromList