Permalink
Browse files

Remove old implementation.

We may want to resurrect this later, as it supports arbitrary nesting
of quantifiers.
  • Loading branch information...
1 parent 40b33d9 commit b3aaf5bb93897fea4f054c720afa3042b977bc23 @yav committed Nov 4, 2013
@@ -1,194 +0,0 @@
-{-# LANGUAGE Safe #-}
-{-# LANGUAGE FlexibleInstances #-}
-module Data.Integer.Presburger
- ( Formula
- , bool, true, false, (/\), (\/), (==>), (<==>), neg, ite, divides
- , (|==|), (|/=|), (|<|), (|<=|), (|>|), (|>=|)
- , letDivMod
- , nat
- , forAll, bForAll, exists, bExists
-
- , Term
- , (|*|), tITE
-
- , isTrue
- ) where
-
-import qualified Data.Integer.Presburger.Term as T
-import qualified Data.Integer.Presburger.Formula as A
-import qualified Data.Integer.Presburger.Exists as E
-
-infixr 1 ==>
-infixr 2 \/
-infixr 3 /\
-infix 4 |==|, |/=|, |<|, |<=|, |>|, |>=|
-
--- | First-order formulas
-data Formula = F Int A.Formula -- ^ The Int is the largest bound var in body
-
-instance Show Formula where
- showsPrec p (F _ x) = showsPrec p x
-
-data Term = T T.Term
- | ITE Formula Term Term
- deriving Show
-instance Num Term where
- fromInteger n = T (fromInteger n)
- (+) = tBin (+)
- (-) = tBin (-)
- (*) = tBin (*)
- abs x = tITE (x |>=| 0) x (negate x)
- signum x = tITE (x |<| 0) (-1) (tITE (x |>| 0) 1 0)
-
--- For lifting binary operations
-tBin :: (T.Term -> T.Term -> T.Term) -> Term -> Term -> Term
-tBin f (T x) (T y) = T (f x y)
-tBin f (ITE p t1 t2) t = ITE p (tBin f t1 t) (tBin f t2 t)
-tBin f t (ITE p t1 t2) = ITE p (tBin f t t1) (tBin f t t2)
-
--- | A constant formula.
-bool :: Bool -> Formula
-bool b = F 0 $ A.fAtom $ A.mkBool b
-
--- | A true statement.
-true :: Formula
-true = bool True
-
--- | A false statement.
-false :: Formula
-false = bool False
-
--- | Conjunction.
-(/\) :: Formula -> Formula -> Formula
-F x p /\ F y q = F (max x y) (A.fConn A.And p q)
-
--- | Disjunction.
-(\/) :: Formula -> Formula -> Formula
-F x p \/ F y q = F (max x y) (A.fConn A.Or p q)
-
--- | Implication.
-(==>) :: Formula -> Formula -> Formula
-p ==> q = neg p \/ q
-
-(<==>) :: Formula -> Formula -> Formula
-p <==> q = (p ==> q) /\ (q ==> p)
-
--- | Negation.
-neg :: Formula -> Formula
-neg (F x fo) = F x (A.fNeg fo)
-
--- | If-then-else.
-ite :: Formula -> Formula -> Formula -> Formula
-ite p t e = (p /\ t) \/ (neg p /\ e)
-
--- | Multiple a term by a constant
-(|*|) :: Integer -> Term -> Term
-k |*| T t = T (k T.|*| t)
-k |*| ITE f t1 t2 = ITE f (k |*| t1) (k |*| t2)
-
--- | If-then-else term
-tITE :: Formula -> Term -> Term -> Term
-tITE = ITE
-
--- | Assert that terms are the same.
-(|==|) :: Term -> Term -> Formula
-t1 |==| t2 = atom A.Eq t1 t2
-
--- | Assert that the first term is strictly smaller.
-(|<|) :: Term -> Term -> Formula
-t1 |<| t2 = atom A.Lt t1 t2
-
--- | Assert that the first term is smaller than or equal to the second one.
-(|<=|) :: Term -> Term -> Formula
-t1 |<=| t2 = atom A.Leq t1 t2
-
--- | Assert that terms are different.
-(|/=|) :: Term -> Term -> Formula
-t1 |/=| t2 = neg (t1 |==| t2)
-
--- | Assert that the first term is strictly greater than the second.
-(|>|) :: Term -> Term -> Formula
-t1 |>| t2 = neg (t1 |<=| t2)
-
--- | Assert that the first term is greater than or equal to the second.
-(|>=|) :: Term -> Term -> Formula
-t1 |>=| t2 = neg (t1 |<| t2)
-
-atom :: A.PredS -> Term -> Term -> Formula
-atom op (T t1) (T t2) = F 0 $ A.fAtom $ A.mkAtom A.Pos op lhs rhs
- where (lhs,rhs) = T.tSplit (t2 - t1)
-atom op (ITE f t1 t2) t = ite f (atom op t1 t) (atom op t2 t)
-atom op t (ITE f t1 t2) = ite f (atom op t t1) (atom op t t2)
-
--- | Assert that the given integer divides the term.
-divides :: Integer -> Term -> Formula
-divides 0 t = t |==| 0
-divides m (T t) = F 0 $ A.fAtom $ A.mkDiv A.Pos (abs m) t
-divides m (ITE f t1 t2) = ite f (divides m t1) (divides m t2)
-
-{- | Simluate division and reminder.
-@letDivMod t m $ \q r -> p@ asserts that when we divide @t@ by @m@
-we get quotiont @q@ and reminder @r@, and also `p` holds. -}
-
-letDivMod :: Term -> Integer -> (Term -> Term -> Formula) -> Formula
-letDivMod t m p = exists $ \q r ->
- 0 |<=| r /\ r |<| fromInteger m /\ m |*| q + r |==| t /\ p q r
-
-
-class Quantifiable t where
- quantify :: ([Term] -> Formula -> Formula) -- This is used to tweak the
- -- final formula to negate (forall)
- -- and assertions about domain
- -> t -> Formula
-
-instance Quantifiable Bool where
- quantify f k = f [] (bool k)
-
-instance Quantifiable Formula where
- quantify f k = f [] k
-
-instance Quantifiable t => Quantifiable (Term -> t) where
- quantify f p = F name $ E.exists [name] body
- where
- F mx body = quantify (\xs -> f (term:xs)) $ p term
- term = T $ T.tVar name
- name = 1 + mx
-
--- | WARNING: mixing evaluation with formula construction
--- may lead to capture!
--- > test = exists $ \x -> bool $ isTrue $ forAll $ \y -> x |==| y
-exists :: Quantifiable formula => (Term -> formula) -> Formula
-exists p = quantify (\_ -> id) p
-
-bExists :: Quantifiable formula => (Term -> Formula) ->
- (Term -> formula) -> Formula
-bExists dom p = quantify (\ts f -> foldr (/\) f (map dom ts)) p
-
-forAll :: Quantifiable formula => (Term -> formula) -> Formula
-forAll p = neg $ quantify (\_ -> neg) p
-
-bForAll :: Quantifiable formula => (Term -> Formula)
- -> (Term -> formula) -> Formula
-bForAll dom p = neg $ quantify (\ts f -> neg $ foldr (==>) f (map dom ts)) p
-
--- | Assert that a term is a natural number
-nat :: Term -> Formula
-nat x = 0 |<=| x
-
---------------------------------------------------------------------------------
-isTrue :: Formula -> Bool
-isTrue (F _ fo0) = go fo0
- where
- go fo = case A.isBool =<< A.isFAtom fo of
- Just x -> x
- Nothing ->
- case A.isFConn fo of
- Just (c, f1, f2) -> case c of
- A.And -> go f1 && go f2
- A.Or -> go f1 || go f2
- _ -> error "Unexpected free variables in term"
-
-
-
-
-
@@ -1,148 +0,0 @@
-{-# LANGUAGE Safe #-}
-{-# LANGUAGE BangPatterns #-}
-module Data.Integer.Presburger.Div (Solution, DivCt, solve, instTerm) where
-
-import Data.Integer.Presburger.Term
-import Data.List(partition)
-
-{- | The extended Euclid's algorithm.
-It computes the GCD of two numbres as a linear combination of the inputs.
-If @gcd a b = (d, s, t)@, then @d@ is the GCD of a and b,
-and @d = s * a + t * b@. -}
-gcdE :: Integer -> Integer -> (Integer, Integer, Integer)
-gcdE u v = let (d,p,q) = go 1 0 0 1 (abs u) (abs v)
- in (d, signum u * p, signum v * q)
-
- where
- go !s2 !s1 !t2 !t1 !a !b
- | b == 0 = (a, s2, t2)
- | otherwise = let (q,r) = divMod a b
- in go s1 (next q s2 s1) t1 (next q t2 t1) b r
-
- next q a2 a1 = a2 - q * a1
-
-
--- | A solution assigns value to the variables in such a way that
--- all constraints are satisified.
-type Solution = [ (Name,Integer) ]
-
--- | A divisibility constraint.
-type DivCt = (Integer, Term)
-
-{- | Given a bunch of upper bounds on some variables, and a collection
-of divisibilty constraints, compute the possible values for the variables.
-We are only interested in values between 1 and the upper bound (inclusive). -}
-
-solve :: [(Name, Integer)] -> [DivCt] -> [[(Name, Integer)]]
-solve xs cs = solve' xs cs
-
-
-solve' :: [(Name, Integer)] -> [DivCt] -> [[(Name, Integer)]]
-solve' vs [] = go vs
- where
- go ((x,u) : rest) = [ (x,v) : su | su <- go rest, v <- [ 1 .. u ] ]
- go [] = [ [] ]
-
-solve' [] cs
- | all ok cs = [ [] ]
- | otherwise = []
- where
- ok (m,t) = let Just b = isConst t
- in mod b m == 0
-
-solve' ((x,u) : vars) cs
- | null cs_this = [ (x,v) : su | su <- solve' vars cs, v <- [ 1 .. u ] ]
- | otherwise = [ (x,v) : su | su <- solve' vars rest, v <- soln su ]
- where
- (cs_this, cs_more) = partition ((/= 0) . tCoeff x . snd) cs
-
- ((m,t),rest0) = joinCts x cs_this
- rest = cs_more ++ rest0
-
- soln su = let (a,t1) = tSplitVar x (instTerm su t)
- Just b = isConst t1
- in solveDiv u m a b
-
-
-
-instTerm :: Solution -> Term -> Term
-instTerm [] ty = ty
-instTerm ((y,n) : more) ty = instTerm more (tLetNum y n ty)
-
-{- | Join a (non-empty) list of constraints into a single constraint
-involvong the variable, and a bunch of other constraints that do not. -}
-joinCts :: Name -> [DivCt] -> (DivCt, [DivCt])
-joinCts x cs = go cs []
- where
- go (c1 : c2 : more) others = let (cX, other) = joinCts2 x c1 c2
- in go (cX : more) (other : others)
- go [c1] others = (c1, others)
- go _ _ = error "JoinCts: []"
-
-
-{- Given two constraints involving a variable, @x@, combine them into a
-single constraint on that variable and another one that does not mention it.
-
-The first component of the result mentions @x@ but the second does not.
--}
-joinCts2 :: Name -> DivCt -> DivCt -> (DivCt, DivCt)
-joinCts2 x (m, t1) (n, t2) =
- let (a,b) = tSplitVar x t1
- (a',b') = tSplitVar x t2
- (d,p,q) = gcdE (a * n) (a' * m)
- in ( ( m * n, d |*| tVar x + (p * n) |*| b + (q * m) |*| b' )
- , ( d, a' |*| b - a |*| b' )
- )
-
-
-
-{- | The solutions for @m | (a * x + b)@, where @x `elem` [ 1 .. u ]@.
-We assume that @m > 0@.
-
-The solutions are of the form:
-
-> do let (d,p,_) = gcdE a m
-> guard (mod b d == 0)
-> [ (-p) * div b d + t * div m d | t <- all_integers ]
-
-Note the @div m d@ is always positive, so we start from an initial
-value computed from the lower bound, 1, and then keep incrementing
-until we exceed the upper bound.
--}
-solveDiv :: Integer -> Integer -> Integer -> Integer -> [Integer]
-solveDiv u m a b
- | d == 0 = error ("SOLVEDIV 0: " ++ show (m,a,b))
- | r1 == 0 = takeWhile (<= u) $ iterate (step +) $ t0 * step - extra
- | otherwise = []
- where
- (d,p,_) = gcdE a m
- (k1,r1) = divMod b d
- step = div m d
- extra = p * k1
- t0 = case divMod (1 + extra) step of
- (q,r) -> if r == 0 then q else q + 1
-
-_checkSolveDiv :: Integer -> Integer -> Integer -> Integer ->
- Maybe ([Integer],[Integer])
-_checkSolveDiv u m a b =
- if proposed == correct then Nothing else Just (correct,proposed)
- where
- correct = [ x | x <- [ 1 .. u ], (a * x + b) `mod` m == 0 ]
- proposed = solveDiv u m a b
-
-
-
-_checkSolve :: [(Name,Integer)] -> [DivCt] -> Bool
-_checkSolve xs cts = all valid slns && all (`elem` slns) allSlns
- where
- slns = solve xs cts
-
- valid sln = all (checkCt sln) cts
-
- checkCt su (m,t) = case isConst (instTerm su t) of
- Just k | mod k m == 0 -> True
- _ -> False
-
- allSlns = filter valid (solve xs [])
-
-
Oops, something went wrong.

0 comments on commit b3aaf5b

Please sign in to comment.