@@ -18,7 +18,9 @@ ucheck = void . solve 10 . filter (not . ignore)
18newtype Var = Var Int
18newtype Var = Var Int
19 deriving (Eq, Ord, Show)
19 deriving (Eq, Ord, Show)
21−type Domain = (Int, Int)
21+data Domain = Domain {-# UNPACK #-} !Int
23+ deriving (Eq, Ord, Show)
23data SolverState =
25data SolverState =
24 SolverState
26 SolverState
@@ -40,7 +42,7 @@ solve maxUniverseLevel inpConstraints =
40 initSolverState = SolverState
42 initSolverState = SolverState
41 { queue = S.fromList inpConstraints
43 { queue = S.fromList inpConstraints
42 , domainStore = M.fromList
44 , domainStore = M.fromList
43− [ (v, ((0, maxUniverseLevel), S.empty))
45+ [ (v, (Domain 0 maxUniverseLevel, S.empty))
44 | v <- ordNub [ v
46 | v <- ordNub [ v
45 | (c, _) <- inpConstraints
47 | (c, _) <- inpConstraints
46 , v <- varsIn c
48 , v <- varsIn c
@@ -71,22 +73,25 @@ solve maxUniverseLevel inpConstraints =
71 Just (cons, fc) -> do
73 Just (cons, fc) -> do
72 case cons of
74 case cons of
73 ULE a b -> do
75 ULE a b -> do
74− (lowerA, upperA) <- domainOf a
76+ Domain lowerA upperA <- domainOf a
75− (lowerB, upperB) <- domainOf b
77+ Domain lowerB upperB <- domainOf b
76− when (upperB < upperA) $ updateDomainOf (cons, fc) a (lowerA, upperB)
78+ when (upperB < upperA) $ updateDomainOf (cons, fc) a (Domain lowerA upperB)
77− when (lowerA > lowerB) $ updateDomainOf (cons, fc) b (lowerA, upperB)
79+ when (lowerA > lowerB) $ updateDomainOf (cons, fc) b (Domain lowerA upperB)
78 ULT a b -> do
80 ULT a b -> do
79− (lowerA, upperA) <- domainOf a
81+ Domain lowerA upperA <- domainOf a
80− (lowerB, upperB) <- domainOf b
82+ Domain lowerB upperB <- domainOf b
81 let upperB_pred = pred upperB
83 let upperB_pred = pred upperB
82 let lowerA_succ = succ lowerA
84 let lowerA_succ = succ lowerA
83− when (upperB_pred < upperA) $ updateDomainOf (cons, fc) a (lowerA, upperB_pred)
85+ when (upperB_pred < upperA) $ updateDomainOf (cons, fc) a (Domain lowerA upperB_pred)
84− when (lowerA_succ > lowerB) $ updateDomainOf (cons, fc) b (lowerA_succ, upperB)
86+ when (lowerA_succ > lowerB) $ updateDomainOf (cons, fc) b (Domain lowerA_succ upperB)
87 -- | extract a solution from the state.
89 -- | extract a solution from the state.
88 extractSolution :: (MonadState SolverState m, Functor m) => m (M.Map Var Int)
90 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
93+ extractValue :: Domain -> Int
94+ extractValue (Domain x _) = x
91 -- | dequeue the first constraint.
96 -- | dequeue the first constraint.
92 nextConstraint :: MonadState SolverState m => m (Maybe (UConstraint, FC))
97 nextConstraint :: MonadState SolverState m => m (Maybe (UConstraint, FC))
@@ -100,13 +105,13 @@ solve maxUniverseLevel inpConstraints =
101 -- | look up the domain of a variable from the state.
106 -- | look up the domain of a variable from the state.
102 -- for convenience, this function also accepts UVal's and returns a singleton domain for them.
107 -- 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
104 domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)
109 domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)
105− domainOf (UVal val) = return (val, val)
110+ domainOf (UVal val) = return (Domain val val)
107 -- | updates the domain of a variable.
112 -- | updates the domain of a variable.
108 -- this function is also where we fail, inc ase of a domain wipe-out.
113 -- 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 ()
110 updateDomainOf suspect (UVar var) newDom = do
115 updateDomainOf suspect (UVar var) newDom = do
111 doms <- gets domainStore
116 doms <- gets domainStore
112 let (oldDom, suspects) = doms M.! Var var
117 let (oldDom, suspects) = doms M.! Var var
@@ -129,8 +134,8 @@ solve maxUniverseLevel inpConstraints =
129 Just cs -> modify $ \ st -> st { queue = S.union cs (queue st) }
134 Just cs -> modify $ \ st -> st { queue = S.union cs (queue st) }
131 -- | check if a domain is wiped out.
136 -- | check if a domain is wiped out.
132− wipeOut :: (Int, Int) -> Bool
137+ wipeOut :: Domain -> Bool
133− wipeOut (l, u) = l > u
138+ wipeOut (Domain l u) = l > u
135ordNub :: Ord a => [a] -> [a]
140ordNub :: Ord a => [a] -> [a]
136ordNub = S.toList . S.fromList
141ordNub = S.toList . S.fromList