Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Algorithm implemented, compiles but not tested. XXX: add API that pli…

…es susbt
  • Loading branch information...
commit a3082cf102d7914859ef6c7c788b8976d7cad717 1 parent 97ec00a
@yav authored
Showing with 239 additions and 101 deletions.
  1. +175 −100 src/Data/Integer/Presburger/Omega.hs
  2. +64 −1 src/Data/Integer/Presburger/Term.hs
View
275 src/Data/Integer/Presburger/Omega.hs
@@ -1,30 +1,62 @@
+{-# LANGUAGE PatternGuards #-}
module Data.Integer.Presburger.Omega where
import Data.Integer.Presburger.Term
import Data.IntMap (IntMap)
import qualified Data.IntMap as Map
-import Data.Ord(comparing)
-import Data.List(sortBy,partition)
+import Data.List(partition)
+import Data.Maybe(maybeToList)
import Control.Applicative
import Control.Monad
-import Debug.Trace
+data RW = RW { nameSource :: !Int
+ , todo :: WorkQ
+ , inerts :: Inerts
+ } deriving Show
+solveAll :: S ()
+solveAll =
+ do mbEq <- getIs0
+ case mbEq of
+ Just eq -> solveIs0 eq >> solveAll
+ Nothing ->
+ do mbLt <- getIsNeg
+ case mbLt of
+ Just lt -> solveIsNeg lt >> solveAll
+ Nothing -> return ()
-data Ct = Term :=: Term | Term :<: Term | Ct :\/: Ct
- deriving Show
-data RW = RW { nameSource :: !Int
- , inerts :: Inerts
- , todo :: [Ct]
- } deriving Show
+
+--------------------------------------------------------------------------------
+-- The work queue
+
+data WorkQ = WorkQ { zeroTerms :: [Term] -- ^ t == 0
+ , negTerms :: [Term] -- ^ t < 0
+ } deriving Show
+
+qEmpty :: WorkQ
+qEmpty = WorkQ { zeroTerms = [], negTerms = [] }
+
+qLet :: Name -> Term -> WorkQ -> WorkQ
+qLet x t q = WorkQ { zeroTerms = map (tLet x t) (zeroTerms q)
+ , negTerms = map (tLet x t) (negTerms q)
+ }
+
+ctLt :: Term -> Term -> Term
+ctLt t1 t2 = t1 - t2
+
+ctGt :: Term -> Term -> Term
+ctGt t1 t2 = ctLt t2 t1
+
+--------------------------------------------------------------------------------
+
data Inerts = Inerts
- { upperBounds :: IntMap [(Integer,Term)] -- a |-> (c,t) <=> c*a < t
- , lowerBounds :: IntMap [(Integer,Term)] -- a |-> (c,t) <=> t < c*a
- , solved :: IntMap Term -- idempotent subst
+ { upperBounds :: IntMap [(Integer,Term)] -- ^ a |-> (c,t) <=> c*a < t
+ , lowerBounds :: IntMap [(Integer,Term)] -- ^ a |-> (c,t) <=> t < c*a
+ , solved :: IntMap Term -- ^ a |-> t, idempotent subst
} deriving Show
noInerts :: Inerts
@@ -33,114 +65,138 @@ noInerts = Inerts { upperBounds = Map.empty
, solved = Map.empty
}
+-- | Add a simple equality.
+-- Assumes substitution has already been applied.
+-- Returns: (restarted lessThan0 constraints, and new inerts)
+-- The lessThan0 constraints are NOT rewritten.
+iSolved :: Name -> Term -> Inerts -> ([Term], Inerts)
+iSolved x t i =
+ ( kickedOutL ++ kickedOutU
+ , Inerts { upperBounds = otherU
+ , lowerBounds = otherL
+ , solved = Map.insert x t $ Map.map (tLet x t) $ solved i
+ }
+ )
+ where
+ (kickedOutU, otherU) = upd ctLt (upperBounds i)
+ (kickedOutL, otherL) = upd ctGt (lowerBounds i)
+
+ upd f mp =
+ -- xc * x < t
+ let (mb, mp1) = Map.updateLookupWithKey (\_ _ -> Nothing) x mp
+
+ -- xy * y < t(x)
+ mp2 = fmap (partition (tHasVar x . snd)) mp1
+ in ( [ f (xc |*| t) t1 | (xc,t1) <- concat (maybeToList mb) ]
+ ++ [ f (yc |*| tVar y) (tLet x t t1) | (y,(vs,_)) <- Map.toList mp2,
+ (yc,t1) <- vs ]
+ , Map.filter (not . null) (fmap snd mp2)
+ )
+
+
-- Assumes substitution has already been applied
addSolved :: Name -> Term -> S ()
addSolved x t = updS_ $ \rw ->
- let i = inerts rw
- (kickedOutU, otherU) = Map.partitionWithKey kickOut (upperBounds i)
- (kickedOutL, otherL) = Map.partitionWithKey kickOut (lowerBounds i)
-
- in rw { inerts =
- Inerts { upperBounds = otherU
- , lowerBounds = otherL
- , solved = Map.insert x t $ Map.map (tLet x t) $ solved i
- }
- , todo = cvt (:<:) kickedOutU ++
- cvt (flip (:<:)) kickedOutL ++
- todo rw
+ let (newWork,newInerts) = iSolved x t (inerts rw)
+ in rw { inerts = newInerts
+ , todo = qLet x t $
+ let work = todo rw
+ in work { negTerms = newWork ++ negTerms work }
}
- where
- kickOut y (_,s) = x == y || tHasVar x s
- kickOut y (_,s) = x == y || tHasVar x s
-
- toC f (y,(c,s)) = if x == y then f (c |*| t) (tLet x t s)
- else f (c |*| tVar y) (tLet x t s)
- cvt f = map (toC f) . Map.toList
+-- Add equality work
+is0 :: Term -> S ()
+is0 t = updS_ $ \rw -> rw { todo = let work = todo rw
+ in work { zeroTerms = t : zeroTerms work } }
+-- Add non-equality work
+isNeg :: Term -> S ()
+isNeg t = updS_ $ \rw -> rw { todo = let work = todo rw
+ in work { negTerms = t : negTerms work } }
-- Assumes substitution has already been applied
-- c + xs = 0
-addEq :: Integer -> [(Name,Integer)] -> S ()
-
-addEq 0 [] = return ()
+solveIs0 :: Term -> S ()
+solveIs0 t
-addEq _ [] = fail "impossible" -- XXX: do properly
+ -- A == 0
+ | Just a <- isConst t = guard (a == 0)
-addEq c [(x,xc)] = case divMod (-c) xc of
- (q,0) -> addSolved x (fromInteger q)
- _ -> fail "impossible"
+ -- A + B * x = 0
+ | Just (a,b,x) <- tIsOneVar t =
+ case divMod (-a) b of
+ (q,0) -> addSolved x (fromInteger q)
+ _ -> mzero
-addEq c xs
- | ((x,xc) : ys, zs) <- partition ((1 ==) . abs . snd) xs =
- addSolved x $ let te = T c $ Map.fromList $ ys ++ zs
- in if xc > 0 then negate te else te
+ -- x + S = 0
+ | Just (xc,x,s) <- tGetSimpleCoeff t =
+ addSolved x (if xc > 0 then negate s else s)
-addEq c xs =
- case common (c : map snd xs) of
- Just d -> addEq (div c d) [ (x, div xc d) | (x,xc) <- xs ]
+ -- K * S = 0
+ | Just (_, s) <- tFactor t = is0 s
- -- See page 6 of paper
- Nothing ->
- do let (x,cx) : rest = sortBy (comparing snd) xs
- m = abs cx + 1
+ -- See Section 3.1 of paper for details.
+ -- We obtain an equivalent formulation but with smaller coefficients.
+ | Just (ak,xk,s) <- tLeastAbsCoeff t =
+ do let m = abs ak + 1
v <- newVar
- let sgn = signum cx
- soln = sum $ (negate sgn * m) |*| tVar v
- : fromInteger (sgn * modulus c m)
- : [ (sgn * modulus cy m) |*| tVar y | (y,cy) <- rest ]
- addSolved x soln
+ let sgn = signum ak
+ soln = (negate sgn * m) |*| tVar v
+ + tMapCoeff (\c -> sgn * modulus c m) s
+ addSolved xk soln
let upd i = div (2*i + m) (2*m) + modulus i m
- addEq (upd c) $ (v, negate (abs cx)) : [ (y, upd cy) | (y,cy) <- rest ]
+ is0 (negate (abs ak) |*| tVar v + tMapCoeff upd s)
+
+ | otherwise = error "solveIs0: unreachable"
modulus :: Integer -> Integer -> Integer
modulus a m = a - m * div (2 * a + m) (2 * m)
--- Find a common factor for all the given inputs.
-common :: [Integer] -> Maybe Integer
-common [] = Nothing
-common [x] = Just x
-common (x : y : zs) =
- case gcd x y of
- 1 -> Nothing
- n -> common (n : zs)
-
--- Assumes variables in the term part are sorted
-- Assumes that substitution has been applied
--- c + xs < 0
-addLt c []
- | c < 0 = return ()
- | otherwise = fail "impossible"
-
-addLt c0 xs0 =
- let (c,(y,yc) : ys) =
- case common (c0 : map snd xs0) of
- Just d -> (div c0 d, [ (x, div xc d) | (x,xc) <- xs0 ])
- Nothing -> (c0, xs0)
- in undefined
-
--- a * x < alpha /\ beta < b * x
-shadows :: Name -> Integer -> Term -> Term -> Integer -> (Ct,Ct,[Ct])
+solveIsNeg :: Term -> S ()
+solveIsNeg t
+
+ -- A < 0
+ | Just a <- isConst t = guard (a < 0)
+
+ -- K * S < 0
+ | Just (_,s) <- tFactor t = isNeg s
+
+ -- See Section 5.1 of the paper
+ | Just (xc,x,s) <- tLeastVar t =
+
+ if xc < 0
+ -- -XC*x + S < 0
+ -- S < XC*x
+ then do ubs <- getUBs x
+ let b = negate xc
+ beta = s
+ addShadows [ shadows x a alpha beta b | (a,alpha) <- ubs ]
+ -- XC*x + S < 0
+ -- XC*x < -S
+ else do lbs <- getLBs x
+ let a = xc
+ alpha = negate s
+ addShadows [ shadows x a alpha beta b | (b,beta) <- lbs ]
+
+ | otherwise = error "solveIsNeg: unreachable"
+
+addShadows :: [(S (), S ())] -> S ()
+addShadows shs =
+ do let (reals,dark_grays) = unzip shs
+ sequence_ reals
+ sequence_ dark_grays
+
+
+-- a * x < alpha /\ beta < b * x
+shadows :: Name -> Integer -> Term -> Term -> Integer -> (S (), S())
shadows x a alpha beta b =
- let diff = b |*| alpha - a |*| beta
- real = fromInteger 0 :<: diff
- dark = fromInteger (a * b) :<: diff
- gray = [ (b |*| tVar x) :=: (i |+| beta) | i <- [ 1 .. b - 1 ] ]
- in (real,dark,gray)
-
--- 2 * x < 1
-
--- 2 * x < y
---
--- 1 < x
---
--- shadows a=2 alpha=y beta=1 b=1
--- diff = y - 2
--- real = 0 < y - 2 = 2 < y
--- dark = 2 < y - 2 = 4 < y
--- gray = [ ]
+ let real = ctLt (a |*| beta) (b |*| alpha)
+ dark = ctLt (fromInteger (a * b)) (b |*| alpha - a |*| beta)
+ gray = [ b |*| tVar x - i |+| beta | i <- [ 1 .. b - 1 ] ]
+ in (isNeg real, isNeg dark `mplus` mapM_ is0 gray)
--------------------------------------------------------------------------------
@@ -162,7 +218,9 @@ instance MonadPlus Answer where
mplus x y = Choice x y
instance Functor Answer where
- fmap = liftM
+ fmap _ None = None
+ fmap f (One x) = One (f x)
+ fmap f (Choice x1 x2) = Choice (fmap f x1) (fmap f x2)
instance Applicative Answer where
pure = return
@@ -195,15 +253,32 @@ updS_ f = S $ \s -> return ((), f s)
updS :: (RW -> (a,RW)) -> S a
updS f = S $ \s -> return (f s)
+get :: (RW -> a) -> S a
+get f = S $ \s -> return (f s, s)
+
newVar :: S Name
newVar = updS $ \rw -> (nameSource rw, rw { nameSource = nameSource rw - 1 })
getUBs :: Name -> S [(Integer, Term)]
-getUBs x = S $ \rw -> return (Map.findWithDefault [] x (upperBounds rw), rw)
+getUBs x = get $ Map.findWithDefault [] x . upperBounds . inerts
getLBs :: Name -> S [(Integer, Term)]
-getLBs x = S $ \rw -> return (Map.findWithDefault [] x (lowerBounds rw), rw)
+getLBs x = get $ Map.findWithDefault [] x . lowerBounds . inerts
+
+getIs0 :: S (Maybe Term)
+getIs0 = updS $ \rw ->
+ let work = todo rw
+ in case zeroTerms work of
+ [] -> (Nothing, rw)
+ t : ts -> (Just t, rw { todo = work { zeroTerms = ts } })
+
+getIsNeg :: S (Maybe Term)
+getIsNeg = updS $ \rw ->
+ let work = todo rw
+ in case negTerms work of
+ [] -> (Nothing, rw)
+ t : ts -> (Just t, rw { todo = work { negTerms = ts } })
-testRun (S m) = m RW { nameSource = -1, inerts = noInerts, todo = [] }
+testRun (S m) = m RW { nameSource = -1, inerts = noInerts, todo = qEmpty }
View
65 src/Data/Integer/Presburger/Term.hs
@@ -3,15 +3,22 @@ module Data.Integer.Presburger.Term
( PP(..)
, pp
, Name
- , Term(..)
+ , Term
, tVar
, tSplit
, tSplitVar
, tCoeff
, tHasVar
, isConst
+ , tIsOneVar
+ , tGetSimpleCoeff
+ , tAllCoeffs
+ , tFactor
+ , tLeastAbsCoeff
+ , tLeastVar
, (|+|)
, (|*|)
+ , tMapCoeff
, tLet
, tLetNum
, tLetNums
@@ -142,11 +149,67 @@ isConst (T n m)
| Map.null m = Just n
| otherwise = Nothing
+-- | Returns: @Just (a, b, x)@ if the term is the form: @a + b * x@
+tIsOneVar :: Term -> Maybe (Integer, Integer, Name)
+tIsOneVar (T a m) = case Map.toList m of
+ [ (x,b) ] -> Just (a, b, x)
+ _ -> Nothing
+
+-- | Returns all coefficient in the term, including the constant as long
+-- as it is not 0
+tAllCoeffs :: Term -> [Integer]
+tAllCoeffs (T a m) = if a == 0 then Map.elems m else a : Map.elems m
+
+-- | Spots terms that contain variables with unit coefficients
+-- (i.e., of the form @x + t@ or @t - x@).
+-- Returns (coeff, var, rest of term)
+tGetSimpleCoeff :: Term -> Maybe (Integer, Name, Term)
+tGetSimpleCoeff (T a m) =
+ do let (m1,m2) = Map.partition (\x -> x == 1 || x == -1) m
+ ((x,xc), m3) <- Map.minViewWithKey m1
+ return (xc, x, T a (Map.union m3 m2))
+
-- | The variables mentioned in this term.
tVars :: Term -> IntSet
tVars (T _ m) = Map.keysSet m
+-- | Try to factor-out a common consant (> 1) from a term.
+-- For example, @2 + 4x@ becomes @2 * (1 + 2x)@.
+tFactor :: Term -> Maybe (Integer, Term)
+tFactor (T c m) =
+ do d <- common (c : Map.elems m)
+ return (d, T (div c d) (fmap (`div` d) m))
+ where
+ common :: [Integer] -> Maybe Integer
+ common [] = Nothing
+ common [x] = Just x
+ common (x : y : zs) =
+ case gcd x y of
+ 1 -> Nothing
+ n -> common (n : zs)
+
+-- | Extract a variable with a coefficient whose absolute value is minimal.
+tLeastAbsCoeff :: Term -> Maybe (Integer, Name, Term)
+tLeastAbsCoeff (T c m) = do (xc,x,m1) <- Map.foldWithKey step Nothing m
+ return (xc, x, T c m1)
+ where
+ step x xc Nothing = Just (xc, x, Map.delete x m)
+ step x xc (Just (yc,_,_))
+ | abs xc < abs yc = Just (xc, x, Map.delete x m)
+ step _ _ it = it
+
+-- | Extract the least variable from a term
+tLeastVar :: Term -> Maybe (Integer, Name, Term)
+tLeastVar (T c m) =
+ do ((x,xc), m1) <- Map.minViewWithKey m
+ return (xc, x, T c m1)
+
+-- | Apply a function to all coefficients, including the constnat
+tMapCoeff :: (Integer -> Integer) -> Term -> Term
+tMapCoeff f (T c m) = T (f c) (fmap f m)
+
+
--------------------------------------------------------------------------------
class PP t where
Please sign in to comment.
Something went wrong with that request. Please try again.