{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE FlexibleInstances  #-}

{-# OPTIONS_GHC -Wno-orphans        #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Language.Fixpoint.Horn.Transformations (
    uniq
  , flatten
  , elim
  , elimPis
  , solveEbs
  , cstrToExpr
) where

import           Language.Fixpoint.Horn.Types
import           Language.Fixpoint.Horn.Info
import           Language.Fixpoint.Smt.Theories as F
import qualified Language.Fixpoint.Types      as F
import qualified Language.Fixpoint.Types.Config as F
import           Language.Fixpoint.Graph      as FG
import qualified Data.HashMap.Strict          as M
import           Data.String                  (IsString (..))
import           Data.Either                  (partitionEithers, rights)
import           Data.List                    (nub, foldl')
import qualified Data.Set                     as S
import qualified Data.HashSet                 as HS
import qualified Data.Graph                   as DG
import           Control.Monad.State
import           Data.Maybe                   (catMaybes, mapMaybe, fromMaybe)
import           Language.Fixpoint.Types.Visitor as V
import           System.Console.CmdArgs.Verbosity
import           Data.Bifunctor (first, second)
import System.IO (hFlush, stdout)
-- import qualified Debug.Trace as DBG

-- $setup
-- >>> :l src/Language/Fixpoint/Horn/Transformations.hs src/Language/Fixpoint/Horn/Parse.hs
-- >>> :m + *Language.Fixpoint.Horn.Parse
-- >>> import Language.Fixpoint.Parse
-- >>> :set -XOverloadedStrings

---------------
-- Debugging
---------------
trace :: String -> a -> a
-- trace _msg v = DBG.trace _msg v
trace :: forall a. [Char] -> a -> a
trace [Char]
_msg a
v = a
v

printPiSols :: (F.PPrint a1, F.PPrint a2, F.PPrint a3) =>
               M.HashMap a1 ((a4, a2), a3) -> IO ()
printPiSols :: forall a1 a2 a3 a4.
(PPrint a1, PPrint a2, PPrint a3) =>
HashMap a1 ((a4, a2), a3) -> IO ()
printPiSols HashMap a1 ((a4, a2), a3)
piSols =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(a1
piVar, ((a4
_, a2
args), a3
cstr)) -> do
                  [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp a1
piVar
                  [Char] -> IO ()
putStr [Char]
" := "
                  [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp a2
args
                  [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp a3
cstr
                  [Char] -> IO ()
putStr [Char]
"\n"
                  Handle -> IO ()
hFlush Handle
stdout)
    (forall k v. HashMap k v -> [(k, v)]
M.toList HashMap a1 ((a4, a2), a3)
piSols)
---------------

-- type Sol a = M.HashMap F.Symbol (Either (Either [[Bind]] (Cstr a)) F.Expr)

-- | solveEbs takes a query and returns a query with the ebinds solved out
--
-- it has some preconditions
-- - pi -> k -> pi structure. That is, there are no cycles, and while ks
-- can depend on other ks, pis cannot directly depend on other pis
-- - predicate for exists binder is `true`. (TODO: is this pre stale?)

solveEbs :: (F.PPrint a) => F.Config -> Query a -> IO (Query a)
------------------------------------------------------------------------------
solveEbs :: forall a. PPrint a => Config -> Query a -> IO (Query a)
solveEbs Config
cfg query :: Query a
query@(Query [Qualifier]
qs [Var a]
vs Cstr a
c HashMap Symbol Sort
cons HashMap Symbol Sort
dist [Equation]
eqns [Rewrite]
mats [DataDecl]
dds) = do
  -- clean up
  let normalizedC :: Cstr a
normalizedC = forall a. Flatten a => a -> a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cstr a -> Cstr a
pruneTauts forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Cstr a
hornify Cstr a
c
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Normalized EHC:"
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
normalizedC

  -- short circuit if no ebinds are present
  if forall a. Cstr a -> Bool
isNNF Cstr a
c then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
[Qualifier]
-> [Var a]
-> Cstr a
-> HashMap Symbol Sort
-> HashMap Symbol Sort
-> [Equation]
-> [Rewrite]
-> [DataDecl]
-> Query a
Query [Qualifier]
qs [Var a]
vs Cstr a
normalizedC HashMap Symbol Sort
cons HashMap Symbol Sort
dist [Equation]
eqns [Rewrite]
mats [DataDecl]
dds else do
  let kvars :: Set Symbol
kvars = forall a. Cstr a -> Set Symbol
boundKvars Cstr a
normalizedC

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Skolemized:"
  let poked :: Cstr a
poked = forall a. Cstr a -> Cstr a
pokec Cstr a
normalizedC
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
poked

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Skolemized + split:"
  let (Cstr a
_horn, Cstr a
_side) = case forall a. Cstr a -> (Maybe (Cstr a), Maybe (Cstr a))
split Cstr a
poked of
                        (Just Cstr a
h, Just Cstr a
s) -> (Cstr a
h, Cstr a
s)
                        (Maybe (Cstr a), Maybe (Cstr a))
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Couldn't split poked in solveEbs"

  let horn :: Cstr a
horn = forall a. Flatten a => a -> a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cstr a -> Cstr a
pruneTauts forall a b. (a -> b) -> a -> b
$ Cstr a
_horn
  let side :: Cstr a
side = forall a. Flatten a => a -> a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cstr a -> Cstr a
pruneTauts forall a b. (a -> b) -> a -> b
$ Cstr a
_side

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp (Cstr a
horn, Cstr a
side)

  -- collect predicate variables
  let pivars :: Set Symbol
pivars = forall a. Cstr a -> Set Symbol
boundKvars Cstr a
poked forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Symbol
kvars

  let cuts :: Set Symbol
cuts = forall a. Config -> Query a -> Cstr a -> Set Symbol
calculateCuts Config
cfg Query a
query (forall a. Set Symbol -> Cstr a -> Cstr a
forgetPiVars Set Symbol
pivars Cstr a
horn)
  let acyclicKs :: Set Symbol
acyclicKs = Set Symbol
kvars forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Symbol
cuts

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"solved acyclic kvars:"
  let (Cstr a
horn', Cstr a
side') = forall a. [Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimKs' (forall a. Set a -> [a]
S.toList Set Symbol
acyclicKs) (Cstr a
horn, Cstr a
side)
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
horn'
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
side'

  -- if not $ S.null cuts then error $ F.showpp $ S.toList cuts else pure ()
  let elimCutK :: Symbol -> Cstr a -> Cstr a
elimCutK Symbol
k Cstr a
c = forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [] Cstr a
c
  Cstr a
horn' <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. Symbol -> Cstr a -> Cstr a
elimCutK Cstr a
horn' Set Symbol
cuts
  Cstr a
side' <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. Symbol -> Cstr a -> Cstr a
elimCutK Cstr a
side' Set Symbol
cuts

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"pi defining constraints:"
  let piSols :: HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Symbol
pivar -> (Symbol
pivar, forall a. Symbol -> Cstr a -> ((Symbol, [Symbol]), Cstr a)
piDefConstr Symbol
pivar Cstr a
horn')) (forall a. Set a -> [a]
S.toList Set Symbol
pivars)
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ forall a1 a2 a3 a4.
(PPrint a1, PPrint a2, PPrint a3) =>
HashMap a1 ((a4, a2), a3) -> IO ()
printPiSols HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"solved pis:"
  let solvedPiCstrs :: HashMap Symbol Pred
solvedPiCstrs = forall a.
Set Symbol
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> HashMap Symbol Pred
solPis (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
M.keys HashMap Symbol Sort
cons forall a. [a] -> [a] -> [a]
++ forall k v. HashMap k v -> [k]
M.keys HashMap Symbol Sort
dist) HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp HashMap Symbol Pred
solvedPiCstrs

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"solved horn:"
  let solvedHorn :: Cstr a
solvedHorn = forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
solvedPiCstrs Cstr a
horn'
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
solvedHorn

  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"solved side:"
  let solvedSide :: Cstr a
solvedSide = forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
solvedPiCstrs Cstr a
side'
  IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => a -> [Char]
F.showpp Cstr a
solvedSide

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
[Qualifier]
-> [Var a]
-> Cstr a
-> HashMap Symbol Sort
-> HashMap Symbol Sort
-> [Equation]
-> [Rewrite]
-> [DataDecl]
-> Query a
Query [Qualifier]
qs [Var a]
vs (forall a. [Cstr a] -> Cstr a
CAnd [Cstr a
solvedHorn, Cstr a
solvedSide]) HashMap Symbol Sort
cons HashMap Symbol Sort
dist [Equation]
eqns [Rewrite]
mats [DataDecl]
dds)

-- | Collects the defining constraint for π
-- that is, given `∀ Γ.∀ n.π => c`, returns `((π, n:Γ), c)`
piDefConstr :: F.Symbol -> Cstr a -> ((F.Symbol, [F.Symbol]), Cstr a)
piDefConstr :: forall a. Symbol -> Cstr a -> ((Symbol, [Symbol]), Cstr a)
piDefConstr Symbol
k Cstr a
c = ((forall a. [a] -> a
head [Symbol]
ns, forall a. [a] -> a
head [[Symbol]]
formals), Cstr a
defC)
  where
    ([Symbol]
ns, [[Symbol]]
formals, Cstr a
defC) = case forall a. Cstr a -> ([Symbol], [[Symbol]], Maybe (Cstr a))
go Cstr a
c of
      ([Symbol]
ns, [[Symbol]]
formals, Just Cstr a
defC) -> ([Symbol]
ns, [[Symbol]]
formals, Cstr a
defC)
      ([Symbol]
_, [[Symbol]]
_, Maybe (Cstr a)
Nothing) -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"pi variable " forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp Symbol
k forall a. Semigroup a => a -> a -> a
<> [Char]
" has no defining constraint."

    go :: Cstr a -> ([F.Symbol], [[F.Symbol]], Maybe (Cstr a))
    go :: forall a. Cstr a -> ([Symbol], [[Symbol]], Maybe (Cstr a))
go (CAnd [Cstr a]
cs) = (\([[Symbol]]
as, [[[Symbol]]]
bs, [Maybe (Cstr a)]
cs) -> (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Symbol]]
as, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Symbol]]]
bs, forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
cAndMaybes [Maybe (Cstr a)]
cs)) forall a b. (a -> b) -> a -> b
$ forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> ([Symbol], [[Symbol]], Maybe (Cstr a))
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
    go (All b :: Bind a
b@(Bind Symbol
n Sort
_ (Var Symbol
k' [Symbol]
xs) a
_) Cstr a
c')
      | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k' = ([Symbol
n], [forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList [Symbol]
xs forall a. Ord a => Set a -> Set a -> Set a
`S.difference` forall a. a -> Set a
S.singleton Symbol
n], forall a. a -> Maybe a
Just Cstr a
c')
      | Bool
otherwise = forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
map3 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b)) (forall a. Cstr a -> ([Symbol], [[Symbol]], Maybe (Cstr a))
go Cstr a
c')
    go (All Bind a
b Cstr a
c') = forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
map3 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b)) (forall a. Cstr a -> ([Symbol], [[Symbol]], Maybe (Cstr a))
go Cstr a
c')
    go Cstr a
_ = ([], [], forall a. Maybe a
Nothing)

    cAndMaybes :: [Maybe (Cstr a)] -> Maybe (Cstr a)
    cAndMaybes :: forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
cAndMaybes [Maybe (Cstr a)]
maybeCs = case forall a. [Maybe a] -> [a]
catMaybes [Maybe (Cstr a)]
maybeCs of
      [] -> forall a. Maybe a
Nothing
      [Cstr a]
cs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [Cstr a] -> Cstr a
CAnd [Cstr a]
cs

map3 :: (c -> d) -> (a, b, c) -> (a, b, d)
map3 :: forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
map3 c -> d
f (a
x, b
y, c
z) = (a
x, b
y, c -> d
f c
z)

-- | Solve out the given pivars
solPis :: S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> M.HashMap F.Symbol Pred
solPis :: forall a.
Set Symbol
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> HashMap Symbol Pred
solPis Set Symbol
measures HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols = forall {a}.
[(Symbol, ((Symbol, [Symbol]), Cstr a))]
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> HashMap Symbol Pred
go (forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols) HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols
  where
    go :: [(Symbol, ((Symbol, [Symbol]), Cstr a))]
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> HashMap Symbol Pred
go ((Symbol
pi, ((Symbol
n, [Symbol]
xs), Cstr a
c)):[(Symbol, ((Symbol, [Symbol]), Cstr a))]
pis) HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Symbol
pi Pred
solved forall a b. (a -> b) -> a -> b
$ [(Symbol, ((Symbol, [Symbol]), Cstr a))]
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> HashMap Symbol Pred
go [(Symbol, ((Symbol, [Symbol]), Cstr a))]
pis HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols
      where solved :: Pred
solved = forall a.
Set Symbol
-> Symbol
-> Symbol
-> Set Symbol
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> Cstr a
-> Pred
solPi Set Symbol
measures Symbol
pi Symbol
n (forall a. Ord a => [a] -> Set a
S.fromList [Symbol]
xs) HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols Cstr a
c
    go [] HashMap Symbol ((Symbol, [Symbol]), Cstr a)
_ = forall a. Monoid a => a
mempty

-- TODO: rewrite to use CC
solPi :: S.Set F.Symbol -> F.Symbol -> F.Symbol -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> Cstr a -> Pred
solPi :: forall a.
Set Symbol
-> Symbol
-> Symbol
-> Set Symbol
-> HashMap Symbol ((Symbol, [Symbol]), Cstr a)
-> Cstr a
-> Pred
solPi Set Symbol
measures Symbol
basePi Symbol
n Set Symbol
args HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols Cstr a
c = forall a. [Char] -> a -> a
trace ([Char]
"\n\nsolPi: " forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp Symbol
basePi forall a. Semigroup a => a -> a -> a
<> [Char]
"\n\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp Symbol
n forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp (forall a. Set a -> [a]
S.toList Set Symbol
args) forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp ((\((Symbol, [Expr])
a, Symbol
_, [Symbol]
c) -> ((Symbol, [Expr])
a, [Symbol]
c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Symbol, [Expr]), Symbol, [Symbol])]
edges) forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp (Symbol -> [Expr]
sols Symbol
n) forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp [Pred]
rewritten forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp Cstr a
c forall a. Semigroup a => a -> a -> a
<> [Char]
"\n\n") forall a b. (a -> b) -> a -> b
$ [Pred] -> Pred
PAnd [Pred]
rewritten
  where
    rewritten :: [Pred]
rewritten = Set Symbol -> Symbol -> Set Symbol -> [(Symbol, Expr)] -> [Pred]
rewriteWithEqualities Set Symbol
measures Symbol
n Set Symbol
args [(Symbol, Expr)]
equalities
    equalities :: [(Symbol, Expr)]
equalities = (forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go (forall a. a -> Set a
S.singleton Symbol
basePi) Cstr a
c
    edges :: [((Symbol, [Expr]), Symbol, [Symbol])]
edges = Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
args forall a. Monoid a => a
mempty [(Symbol, Expr)]
equalities
    (Graph
eGraph, Int -> ((Symbol, [Expr]), Symbol, [Symbol])
vf, Symbol -> Maybe Int
lookupVertex) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
DG.graphFromEdges [((Symbol, [Expr]), Symbol, [Symbol])]
edges
    sols :: Symbol -> [Expr]
sols Symbol
x = case Symbol -> Maybe Int
lookupVertex Symbol
x of
      Maybe Int
Nothing -> []
      Just Int
vertex -> forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Symbol -> Expr
F.EVar Symbol
x) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [[Expr]
es | ((Symbol
_, [Expr]
es), Symbol
_, [Symbol]
_) <- Int -> ((Symbol, [Expr]), Symbol, [Symbol])
vf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> Int -> [Int]
DG.reachable Graph
eGraph Int
vertex]

    go :: S.Set F.Symbol -> Cstr a -> ([(F.Symbol, F.Expr)], S.Set F.Symbol)
    go :: forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go Set Symbol
visited (Head Pred
p a
_) = (Pred -> [(Symbol, Expr)]
collectEqualities Pred
p, Set Symbol
visited)
    go Set Symbol
visited (CAnd [Cstr a]
cs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\([(Symbol, Expr)]
eqs, Set Symbol
visited) Cstr a
c -> let ([(Symbol, Expr)]
eqs', Set Symbol
visited') = forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go Set Symbol
visited Cstr a
c in ([(Symbol, Expr)]
eqs' forall a. Semigroup a => a -> a -> a
<> [(Symbol, Expr)]
eqs, Set Symbol
visited')) (forall a. Monoid a => a
mempty, Set Symbol
visited) [Cstr a]
cs
    go Set Symbol
visited (All (Bind Symbol
_ Sort
_ (Var Symbol
pi [Symbol]
_) a
_) Cstr a
c)
      | forall a. Ord a => a -> Set a -> Bool
S.member Symbol
pi Set Symbol
visited = forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go Set Symbol
visited Cstr a
c
      | Bool
otherwise = let ((Symbol, [Symbol])
_, Cstr a
defC) = (HashMap Symbol ((Symbol, [Symbol]), Cstr a)
piSols forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! Symbol
pi)
                        ([(Symbol, Expr)]
eqs', Set Symbol
newVisited) = forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go (forall a. Ord a => a -> Set a -> Set a
S.insert Symbol
pi Set Symbol
visited) Cstr a
defC
                        ([(Symbol, Expr)]
eqs'', Set Symbol
newVisited') = forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go Set Symbol
newVisited Cstr a
c in
          ([(Symbol, Expr)]
eqs' forall a. Semigroup a => a -> a -> a
<> [(Symbol, Expr)]
eqs'', Set Symbol
newVisited')
    go Set Symbol
visited (All (Bind Symbol
_ Sort
_ Pred
p a
_) Cstr a
c) = let ([(Symbol, Expr)]
eqs, Set Symbol
visited') = forall a. Set Symbol -> Cstr a -> ([(Symbol, Expr)], Set Symbol)
go Set Symbol
visited Cstr a
c in
      ([(Symbol, Expr)]
eqs forall a. Semigroup a => a -> a -> a
<> Pred -> [(Symbol, Expr)]
collectEqualities Pred
p, Set Symbol
visited')
    go Set Symbol
_ Any{} = forall a. HasCallStack => [Char] -> a
error [Char]
"exists should not be present in piSols"

------------------------------------------------------------------------------
{- | pokec skolemizes the EHC into an HC + side condition
>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind01.smt2"
>>> F.pprint $ pokec (qCstr q)
(and
 (forall ((m int) (true))
  (and
   (forall ((x1 int) (πx1 x1))
    (and
     (forall ((v int) (v == m + 1))
      (((v == x1))))
     (forall ((v int) (v == x1 + 1))
      (((v == 2 + m))))))
   (exists ((x1 int) (true))
    ((πx1 x1))))))

>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind02.smt2"
>>> F.pprint $ pokec (qCstr q)
(and
 (forall ((m int) (true))
  (forall ((z int) (z == m - 1))
   (and
    (forall ((v1 int) (v1 == z + 2))
     ((k v1)))
    (and
     (forall ((x1 int) (πx1 x1))
      (and
       (forall ((v2 int) (k v2))
        (((v2 == x1))))
       (forall ((v3 int) (v3 == x1 + 1))
        (((v3 == m + 2))))))
     (exists ((x1 int) (true))
      ((πx1 x1))))))))

>>> let c = doParse' hCstrP "" "(forall ((a Int) (p a)) (exists ((b Int) (q b)) (and (($k a)) (($k b)))))"
>>> F.pprint $ pokec c
(forall ((a int) (p a))
 (and
  (forall ((b int) (πb b))
   (and
    ((k a))
    ((k b))))
  (exists ((b int) (q b))
   ((πb b)))))
-}

pokec :: Cstr a -> Cstr a
pokec :: forall a. Cstr a -> Cstr a
pokec = forall {a}. [Symbol] -> Cstr a -> Cstr a
go forall a. Monoid a => a
mempty
  where
    go :: [Symbol] -> Cstr a -> Cstr a
go [Symbol]
_ (Head Pred
c a
l) = forall a. Pred -> a -> Cstr a
Head Pred
c a
l
    go [Symbol]
xs (CAnd [Cstr a]
c)   = forall a. [Cstr a] -> Cstr a
CAnd ([Symbol] -> Cstr a -> Cstr a
go [Symbol]
xs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
c)
    go [Symbol]
xs (All Bind a
b Cstr a
c2) = forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall a b. (a -> b) -> a -> b
$ [Symbol] -> Cstr a -> Cstr a
go (forall a. Bind a -> Symbol
bSym Bind a
b forall a. a -> [a] -> [a]
: [Symbol]
xs) Cstr a
c2
    go [Symbol]
xs (Any b :: Bind a
b@(Bind Symbol
x Sort
t Pred
p a
ann) Cstr a
c2) = forall a. [Cstr a] -> Cstr a
CAnd [forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b' forall a b. (a -> b) -> a -> b
$ forall a. [Cstr a] -> Cstr a
CAnd [forall a. Pred -> a -> Cstr a
Head Pred
p a
l, [Symbol] -> Cstr a -> Cstr a
go (Symbol
xforall a. a -> [a] -> [a]
:[Symbol]
xs) Cstr a
c2], forall a. Bind a -> Cstr a -> Cstr a
Any Bind a
b (forall a. Pred -> a -> Cstr a
Head Pred
pi a
l)]
      -- TODO: actually use the renamer?
      where
        b' :: Bind a
b' = forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t Pred
pi a
ann
        pi :: Pred
pi = Symbol -> [Symbol] -> Pred
piVar Symbol
x [Symbol]
xs
        l :: a
l  = forall a. Cstr a -> a
cLabel Cstr a
c2

piVar :: F.Symbol -> [F.Symbol] -> Pred
piVar :: Symbol -> [Symbol] -> Pred
piVar Symbol
x [Symbol]
xs = Symbol -> [Symbol] -> Pred
Var (Symbol -> Symbol
piSym Symbol
x) (Symbol
xforall a. a -> [a] -> [a]
:[Symbol]
xs)

piSym :: F.Symbol -> F.Symbol
piSym :: Symbol -> Symbol
piSym Symbol
s = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"π" forall a. [a] -> [a] -> [a]
++ Symbol -> [Char]
F.symbolString Symbol
s

{- |

Now we split the poked constraint into the side conditions and the meat of
the constraint

>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind01.smt2"
>>> F.pprint $ qCstr q
(and
 (forall ((m int) (true))
  (exists ((x1 int) (true))
   (and
    (forall ((v int) (v == m + 1))
     (((v == x1))))
    (forall ((v int) (v == x1 + 1))
     (((v == 2 + m))))))))

>>> let (Just noside, Just side) = split $ pokec $ qCstr q
>>> F.pprint side
(forall ((m int) (true))
 (exists ((x1 int) (true))
  ((πx1 x1))))
>>> F.pprint noside
(forall ((m int) (true))
 (forall ((x1 int) (πx1 x1))
  (and
   (forall ((v int) (v == m + 1))
    (((v == x1))))
   (forall ((v int) (v == x1 + 1))
    (((v == 2 + m)))))))


>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind02.smt2"
>>> F.pprint $ qCstr q
(and
 (forall ((m int) (true))
  (forall ((z int) (z == m - 1))
   (and
    (forall ((v1 int) (v1 == z + 2))
     ((k v1)))
    (exists ((x1 int) (true))
     (and
      (forall ((v2 int) (k v2))
       (((v2 == x1))))
      (forall ((v3 int) (v3 == x1 + 1))
       (((v3 == m + 2))))))))))

>>> let (Just noside, Just side) = split $ pokec $ qCstr q
>>> F.pprint side
(forall ((m int) (true))
 (forall ((z int) (z == m - 1))
  (exists ((x1 int) (true))
   ((πx1 x1)))))
>>> F.pprint noside
(forall ((m int) (true))
 (forall ((z int) (z == m - 1))
  (and
   (forall ((v1 int) (v1 == z + 2))
    ((k v1)))
   (forall ((x1 int) (πx1 x1))
    (and
     (forall ((v2 int) (k v2))
      (((v2 == x1))))
     (forall ((v3 int) (v3 == x1 + 1))
      (((v3 == m + 2)))))))))
-}

split :: Cstr a -> (Maybe (Cstr a), Maybe (Cstr a))
split :: forall a. Cstr a -> (Maybe (Cstr a), Maybe (Cstr a))
split (CAnd [Cstr a]
cs) = (forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
andMaybes [Maybe (Cstr a)]
nosides, forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
andMaybes [Maybe (Cstr a)]
sides)
  where ([Maybe (Cstr a)]
nosides, [Maybe (Cstr a)]
sides) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> (Maybe (Cstr a), Maybe (Cstr a))
split forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
split (All Bind a
b Cstr a
c) = (forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Cstr a)
c', forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Cstr a)
c'')
    where (Maybe (Cstr a)
c',Maybe (Cstr a)
c'') = forall a. Cstr a -> (Maybe (Cstr a), Maybe (Cstr a))
split Cstr a
c
split c :: Cstr a
c@Any{} = (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Cstr a
c)
split c :: Cstr a
c@Head{} = (forall a. a -> Maybe a
Just Cstr a
c, forall a. Maybe a
Nothing)

andMaybes :: [Maybe (Cstr a)] -> Maybe (Cstr a)
andMaybes :: forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
andMaybes [Maybe (Cstr a)]
cs = case forall a. [Maybe a] -> [a]
catMaybes [Maybe (Cstr a)]
cs of
                 [] -> forall a. Maybe a
Nothing
                 [Cstr a
c] -> forall a. a -> Maybe a
Just Cstr a
c
                 [Cstr a]
cs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [Cstr a] -> Cstr a
CAnd [Cstr a]
cs

------------------------------------------------------------------------------
{- |
>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind01.smt2"
>>> let (Just noside, Just side) = split $ pokec $ qCstr q
>>> F.pprint $ elimPis ["x1"] (noside, side )
(forall ((m int) (true))
 (forall ((x1 int) (forall [v : int]
  . v == m + 1 => v == x1
&& forall [v : int]
     . v == x1 + 1 => v == 2 + m))
  (and
   (forall ((v int) (v == m + 1))
    (((v == x1))))
   (forall ((v int) (v == x1 + 1))
    (((v == 2 + m))))))) : (forall ((m int) (true))
                            (exists ((x1 int) (true))
                             ((forall [v : int]
                                 . v == m + 1 => v == x1
                               && forall [v : int]
                                    . v == x1 + 1 => v == 2 + m))))

>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind02.smt2"
>>> let (Just noside, Just side) = split $ pokec $ qCstr q
>>> F.pprint $ elimPis ["x1"] (noside, side )
(forall ((m int) (true))
 (forall ((z int) (z == m - 1))
  (and
   (forall ((v1 int) (v1 == z + 2))
    ((k v1)))
   (forall ((x1 int) (forall [v2 : int]
  . $k[fix$36$$954$arg$36$k$35$1:=v2] => v2 == x1
&& forall [v3 : int]
     . v3 == x1 + 1 => v3 == m + 2))
    (and
     (forall ((v2 int) (k v2))
      (((v2 == x1))))
     (forall ((v3 int) (v3 == x1 + 1))
      (((v3 == m + 2))))))))) : (forall ((m int) (true))
                                 (forall ((z int) (z == m - 1))
                                  (exists ((x1 int) (true))
                                   ((forall [v2 : int]
                                       . $k[fix$36$$954$arg$36$k$35$1:=v2] => v2 == x1
                                     && forall [v3 : int]
                                          . v3 == x1 + 1 => v3 == m + 2)))))

-}

elimPis :: [F.Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimPis :: forall a. [Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimPis [] (Cstr a, Cstr a)
cc = (Cstr a, Cstr a)
cc
elimPis (Symbol
n:[Symbol]
ns) (Cstr a
horn, Cstr a
side) = forall a. [Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimPis [Symbol]
ns (Cstr a -> Cstr a
apply Cstr a
horn, Cstr a -> Cstr a
apply Cstr a
side)
-- TODO: handle this error?
  where nSol :: Cstr a
nSol = case forall a. Symbol -> Cstr a -> Maybe (Cstr a)
defs Symbol
n Cstr a
horn of
                 Just Cstr a
nSol -> Cstr a
nSol
                 Maybe (Cstr a)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected nothing elimPis"

        apply :: Cstr a -> Cstr a
apply = forall a. Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi (Symbol -> Symbol
piSym Symbol
n) Cstr a
nSol

-- TODO: PAnd may be a problem
applyPi :: F.Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi :: forall a. Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi Symbol
k Cstr a
defs (All (Bind Symbol
x Sort
t (Var Symbol
k' [Symbol]
_xs) a
ann) Cstr a
c)
  | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k'
  = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t (Expr -> Pred
Reft forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Expr
cstrToExpr Cstr a
defs) a
ann) Cstr a
c
applyPi Symbol
k Cstr a
bp (CAnd [Cstr a]
cs)
  = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi Symbol
k Cstr a
bp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
applyPi Symbol
k Cstr a
bp (All Bind a
b Cstr a
c)
  = forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b (forall a. Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi Symbol
k Cstr a
bp Cstr a
c)
applyPi Symbol
k Cstr a
bp (Any Bind a
b Cstr a
c)
  = forall a. Bind a -> Cstr a -> Cstr a
Any Bind a
b (forall a. Symbol -> Cstr a -> Cstr a -> Cstr a
applyPi Symbol
k Cstr a
bp Cstr a
c)
applyPi Symbol
k Cstr a
defs (Head (Var Symbol
k' [Symbol]
_xs) a
a)
  | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k'
  -- what happens when pi's appear inside the defs for other pis?
  -- this shouldn't happen because there should be a strict
  --  pi -> k -> pi structure
  -- but that comes from the typing rules, not this format, so let's make
  -- it an invariant of solveEbs above
  = forall a. Pred -> a -> Cstr a
Head (Expr -> Pred
Reft forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Expr
cstrToExpr Cstr a
defs) a
a
applyPi Symbol
_ Cstr a
_ (Head Pred
p a
a) = forall a. Pred -> a -> Cstr a
Head Pred
p a
a

-- | The defining constraints for a pivar
--
-- The defining constraints are those that bound the value of pi_x.
--
-- We're looking to lower-bound the greatest solution to pi_x.
-- If we eliminate pivars before we eliminate kvars (and then apply the kvar
-- solutions to the side conditions to solve out the pis), then we know
-- that the only constraints that mention pi in the noside case are those
-- under the corresponding pivar binder. A greatest solution for this pivar
-- can be obtained as the _weakest precondition_ of the constraints under
-- the binder
--
-- The greatest Pi that implies the constraint under it is simply that
-- constraint itself. We can leave off constraints that don't mention n,
-- see https://photos.app.goo.gl/6TorPprC3GpzV8PL7
--
-- Actually, we can really just throw away any constraints we can't QE,
-- can't we?

{- |
>>> :{
let c = doParse' hCstrP "" "\
\(forall ((m int) (true))                  \
\ (forall ((x1 int) (and (true) (πx1 x1))) \
\  (and                                    \
\   (forall ((v int) (v == m + 1))         \
\    (((v == x1))))                        \
\   (forall ((v int) (v == x1 + 1))        \
\    (((v == 2 + m)))))))"
:}

>>> F.pprint $ defs "x1" c
Just (and
      (forall ((v int) (v == m + 1))
       ((v == x1)))
      (forall ((v int) (v == x1 + 1))
       ((v == 2 + m))))

>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind02.smt2"
>>> let (Just noside, _) = split $ pokec $ qCstr q
>>> F.pprint $ defs "x1" noside
Just (and
      (forall ((v2 int) (k v2))
       ((v2 == x1)))
      (forall ((v3 int) (v3 == x1 + 1))
       ((v3 == m + 2))))

-}

defs :: F.Symbol -> Cstr a -> Maybe (Cstr a)
defs :: forall a. Symbol -> Cstr a -> Maybe (Cstr a)
defs Symbol
x (CAnd [Cstr a]
cs) = forall a. [Maybe (Cstr a)] -> Maybe (Cstr a)
andMaybes forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> Cstr a -> Maybe (Cstr a)
defs Symbol
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
defs Symbol
x (All (Bind Symbol
x' Sort
_ Pred
_ a
_) Cstr a
c)
  | Symbol
x' forall a. Eq a => a -> a -> Bool
== Symbol
x
  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Cstr a
c
defs Symbol
x (All Bind a
_ Cstr a
c) = forall a. Symbol -> Cstr a -> Maybe (Cstr a)
defs Symbol
x Cstr a
c
defs Symbol
_ (Head Pred
_ a
_) = forall a. Maybe a
Nothing
defs Symbol
_ (Any Bind a
_ Cstr a
_) =  forall a. HasCallStack => [Char] -> a
error [Char]
"defs should be run only after noside and poke"

cstrToExpr :: Cstr a -> F.Expr
cstrToExpr :: forall a. Cstr a -> Expr
cstrToExpr (Head Pred
p a
_) = Pred -> Expr
predToExpr Pred
p
cstrToExpr (CAnd [Cstr a]
cs) = [Expr] -> Expr
F.PAnd forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Expr
cstrToExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
cstrToExpr (All (Bind Symbol
x Sort
t Pred
p a
_) Cstr a
c) = [(Symbol, Sort)] -> Expr -> Expr
F.PAll [(Symbol
x,Sort
t)] forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
F.PImp (Pred -> Expr
predToExpr Pred
p) forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Expr
cstrToExpr Cstr a
c
cstrToExpr (Any (Bind Symbol
x Sort
t Pred
p a
_) Cstr a
c) = [(Symbol, Sort)] -> Expr -> Expr
F.PExist [(Symbol
x,Sort
t)] forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
F.PImp (Pred -> Expr
predToExpr Pred
p) forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Expr
cstrToExpr Cstr a
c

predToExpr :: Pred -> F.Expr
predToExpr :: Pred -> Expr
predToExpr (Reft Expr
e) = Expr
e
predToExpr (Var Symbol
k [Symbol]
xs) = KVar -> Subst -> Expr
F.PKVar (Symbol -> KVar
F.KV Symbol
k) (HashMap Symbol Expr -> Subst
F.Su forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Symbol, Expr)]
su)
  where su :: [(Symbol, Expr)]
su = forall a b. [a] -> [b] -> [(a, b)]
zip (Symbol -> [Symbol]
kargs Symbol
k) (Symbol -> Expr
F.EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol]
xs)
predToExpr (PAnd [Pred]
ps) = [Expr] -> Expr
F.PAnd forall a b. (a -> b) -> a -> b
$ Pred -> Expr
predToExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps

------------------------------------------------------------------------------
{- |

Takes noside, side, piSols and solves a set of kvars in them

>>> (q, opts) <- parseFromFile hornP "tests/horn/pos/ebind02.smt2"
>>> let (Just noside, Just side) = split $ pokec $ qCstr q
>>> F.pprint $ elimKs ["k"] $ elimPis ["x1"] (noside, side)
(forall ((m int) (true))
 (forall ((z int) (z == m - 1))
  (and
   (forall ((v1 int) (v1 == z + 2))
    ((true)))
   (forall ((x1 int) (forall [v2 : int]
  . exists [v1 : int]
      . (v2 == v1)
        && v1 == z + 2 => v2 == x1
&& forall [v3 : int]
     . v3 == x1 + 1 => v3 == m + 2))
    (and
     (forall ((v1 int) (v1 == z + 2))
      (forall ((v2 int) (v2 == v1))
       (((v2 == x1)))))
     (forall ((v3 int) (v3 == x1 + 1))
      (((v3 == m + 2))))))))) : (forall ((m int) (true))
                                 (forall ((z int) (z == m - 1))
                                  (exists ((x1 int) (true))
                                   ((forall [v2 : int]
                                       . exists [v1 : int]
                                           . (v2 == v1)
                                             && v1 == z + 2 => v2 == x1
                                     && forall [v3 : int]
                                          . v3 == x1 + 1 => v3 == m + 2)))))
-}

-- TODO: make this elimKs and update tests for elimKs
elimKs' :: [F.Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimKs' :: forall a. [Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimKs' [] (Cstr a, Cstr a)
cstrs = (Cstr a, Cstr a)
cstrs
elimKs' (Symbol
k:[Symbol]
ks) (Cstr a
noside, Cstr a
side) = forall a. [Symbol] -> (Cstr a, Cstr a) -> (Cstr a, Cstr a)
elimKs' (forall a. [Char] -> a -> a
trace ([Char]
"solved kvar " forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp Symbol
k forall a. Semigroup a => a -> a -> a
<> [Char]
":\n" forall a. Semigroup a => a -> a -> a
<> forall a. PPrint a => a -> [Char]
F.showpp [([Bind a], [Expr])]
sol) [Symbol]
ks) (Cstr a
noside', Cstr a
side')
  where
    sol :: [([Bind a], [Expr])]
sol = forall a. Symbol -> Cstr a -> [([Bind a], [Expr])]
sol1 Symbol
k forall a b. (a -> b) -> a -> b
$ forall {a}. Symbol -> Cstr a -> Cstr a
scope Symbol
k Cstr a
noside
    noside' :: Cstr a
noside' = forall a. Cstr a -> Cstr a
simplify forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
sol Cstr a
noside
    side' :: Cstr a
side' = forall a. Cstr a -> Cstr a
simplify forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
sol Cstr a
side

-- [NOTE-elimK-positivity]:
--
-- uh-oh I suspect this traversal is WRONG. We can build an
-- existentialPackage as a solution to a K in a negative position, but in
-- the *positive* position, the K should be solved to FALSE.
--
-- Well, this may be fine --- semantically, this is all the same, but the
-- exists in the positive positions (which will stay exists when we go to
-- prenex) may give us a lot of trouble during _quantifier elimination_
-- tx :: F.Symbol -> [[Bind]] -> Pred -> Pred
-- tx k bss = trans (defaultVisitor { txExpr = existentialPackage, ctxExpr = ctxKV }) M.empty ()
--   where
--   splitBinds xs = unzip $ (\(Bind x t p) -> ((x,t),p)) <$> xs
--   cubeSol su (Bind _ _ (Reft eqs):xs)
--     | (xts, es) <- splitBinds xs
--     = F.PExist xts $ F.PAnd (F.subst su eqs : map predToExpr es)
--   cubeSol _ _ = error "cubeSol in doelim'"
--   -- This case is a HACK. In actuality, we need some notion of
--   -- positivity...
--   existentialPackage _ (F.PAll _ (F.PImp _ (F.PKVar (F.KV k') _)))
--     | k' == k
--     = F.PTrue
--   existentialPackage m (F.PKVar (F.KV k') su)
--     | k' == k
--     , M.lookupDefault 0 k m < 2
--     = F.PAnd $ cubeSol su . reverse <$> bss
--   existentialPackage _ e = e
--   ctxKV m (F.PKVar (F.KV k) _) = M.insertWith (+) k 1 m
--   ctxKV m _ = m

-- Visitor only visit Exprs in Pred!
instance V.Visitable Pred where
  visit :: forall a c. Monoid a => Visitor a c -> c -> Pred -> VisitM a Pred
visit Visitor a c
v c
c (PAnd [Pred]
ps) = [Pred] -> Pred
PAnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
c) [Pred]
ps
  visit Visitor a c
v c
c (Reft Expr
e) = Expr -> Pred
Reft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
c Expr
e
  visit Visitor a c
_ c
_ Pred
var      = forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
var

instance V.Visitable (Cstr a) where
  visit :: forall a c.
Monoid a =>
Visitor a c -> c -> Cstr a -> VisitM a (Cstr a)
visit Visitor a c
v c
c (CAnd [Cstr a]
cs) = forall a. [Cstr a] -> Cstr a
CAnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
c) [Cstr a]
cs
  visit Visitor a c
v c
c (Head Pred
p a
a) = forall a. Pred -> a -> Cstr a
Head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
c Pred
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  visit Visitor a c
v c
ctx (All (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
All forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
ctx Pred
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
l) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
ctx Cstr a
c
  visit Visitor a c
v c
ctx (Any (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
All forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
ctx Pred
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
l) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t a c.
(Visitable t, Monoid a) =>
Visitor a c -> c -> t -> VisitM a t
visit Visitor a c
v c
ctx Cstr a
c

------------------------------------------------------------------------------
-- | Quantifier elimination for use with implicit solver
-- qe :: Cstr a -> Cstr a
------------------------------------------------------------------------------
-- Initially this QE seemed straightforward, and does seem so in the body:
--
--    \-/ v . v = t -> r
--    ------------------
--          r[t/v]
--
-- And this works. However, the mixed quantifiers get pretty bad in the
-- side condition, which generally looks like
--    forall a1 ... an . exists n . forall v1 . ( exists karg . p ) => q
--

-- NEW STRATEGY: look under each FORALL, bottom up, compile a list of all equalities that
-- are negative, and apply some relevant one to the whole thinger.
--
-- we do first need to make the foralls from exists... so instead let's
-- just start out with foralls in doElim. They're in the wrong polarity,
-- but that's not visible from the other side of QE, so that's fine.
------------------------------------------------------------------------------
-- Now, we go through each pivar, and try to do QE in it. If there's
-- a Pi or a kvar under it, then we need to go and get the solution.
-- Since we're doing this SEPARATELY from the AD search, we can memoize.
-- In fact, we have to, because at the end of the day, we do want a
-- fully solved map.
--
-- QE:
--   (given some constraint c from an unsolved pi, we want to squash it into an expr)
--   if it's head -> if head is a kvar then lookup the kvarsol for these args and QE that
--                -> if head is a pred return that expr
--                -> if head is a pand recursive and conjunct
--   if it's any --> throw an error?
--   if it's forall equality => pred         (how do we actually find the
--     QE in pred, then apply the equality   equalities?)
--   if it's forall kvar => pred
--     lookup and then QE
--   if it's And
--      recurse and then conjunct
--
-- lookup recursively:
--   (when I want the solution for some k or pivar `x`)
--   lookup the Cstr that solves it
--   if it's an unsolved pi
--     run QE on the cstr
--     store it
--   return it

-- qe :: F.Symbol -> S.Set F.Symbol -> Cstr a -> Pred
-- qe n args c = PAnd $ ps
--   where
--     equalities = collectEqualities c
--     ps = rewriteWithEqualities n args equalities

rewriteWithEqualities :: S.Set F.Symbol -> F.Symbol -> S.Set F.Symbol -> [(F.Symbol, F.Expr)] -> [Pred]
rewriteWithEqualities :: Set Symbol -> Symbol -> Set Symbol -> [(Symbol, Expr)] -> [Pred]
rewriteWithEqualities Set Symbol
measures Symbol
n Set Symbol
args [(Symbol, Expr)]
equalities = [Pred]
preds
  where
    (Graph
eGraph, Int -> ((Symbol, [Expr]), Symbol, [Symbol])
vf, Symbol -> Maybe Int
lookupVertex) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
DG.graphFromEdges forall a b. (a -> b) -> a -> b
$ Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
args forall a. Monoid a => a
mempty [(Symbol, Expr)]
equalities

    nResult :: (Symbol, [Expr])
nResult = (Symbol
n, Int -> [Expr] -> [Expr]
makeWellFormed Int
15 forall a b. (a -> b) -> a -> b
$ Symbol -> [Expr]
sols Symbol
n)
    argResults :: [(Symbol, [Expr])]
argResults = forall a b. (a -> b) -> [a] -> [b]
map (\Symbol
arg -> (Symbol
arg, Int -> [Expr] -> [Expr]
makeWellFormed Int
15 forall a b. (a -> b) -> a -> b
$ Symbol -> [Expr]
sols Symbol
arg)) (forall a. Set a -> [a]
S.toList Set Symbol
args)

    preds :: [Pred]
preds = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (\(Symbol
x, [Expr]
es) -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Symbol -> Expr -> [Pred]
mkEquality Symbol
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr]
es) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Symbol, [Expr])
nResultforall a. a -> [a] -> [a]
:[(Symbol, [Expr])]
argResults)

    mkEquality :: Symbol -> Expr -> [Pred]
mkEquality Symbol
x Expr
e = [Expr -> Pred
Reft (Brel -> Expr -> Expr -> Expr
F.PAtom Brel
F.Eq (Symbol -> Expr
F.EVar Symbol
x) Expr
e)]

    sols :: F.Symbol -> [F.Expr]
    sols :: Symbol -> [Expr]
sols Symbol
x = case Symbol -> Maybe Int
lookupVertex Symbol
x of
      Maybe Int
Nothing -> []
      Just Int
vertex -> forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Symbol -> Expr
F.EVar Symbol
x) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [[Expr]
es | ((Symbol
_, [Expr]
es), Symbol
_, [Symbol]
_) <- Int -> ((Symbol, [Expr]), Symbol, [Symbol])
vf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> Int -> [Int]
DG.reachable Graph
eGraph Int
vertex]

    argsAndPrims :: Set Symbol
argsAndPrims = Set Symbol
args forall a. Ord a => Set a -> Set a -> Set a
`S.union` forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. SEnv a -> [(Symbol, a)]
F.toListSEnv forall a b. (a -> b) -> a -> b
$ [DataDecl] -> SEnv TheorySymbol
F.theorySymbols []) forall a. Ord a => Set a -> Set a -> Set a
`S.union`Set Symbol
measures

    isWellFormed :: F.Expr -> Bool
    isWellFormed :: Expr -> Bool
isWellFormed Expr
e = forall a. Ord a => [a] -> Set a
S.fromList (forall a. Subable a => a -> [Symbol]
F.syms Expr
e) forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` Set Symbol
argsAndPrims

    makeWellFormed :: Int -> [F.Expr] -> [F.Expr]
    makeWellFormed :: Int -> [Expr] -> [Expr]
makeWellFormed Int
0 [Expr]
es = forall a. (a -> Bool) -> [a] -> [a]
filter Expr -> Bool
isWellFormed [Expr]
es -- We solved it. Maybe.
    makeWellFormed Int
n [Expr]
es = Int -> [Expr] -> [Expr]
makeWellFormed (Int
n forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Expr -> [Expr]
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr]
es
      where
        go :: Expr -> [Expr]
go Expr
e = if Expr -> Bool
isWellFormed Expr
e then [Expr
e] else forall {a}. Subable a => [(Symbol, [Expr])] -> [a] -> [a]
rewrite [(Symbol, [Expr])]
rewrites [Expr
e]
          where
            needSolving :: Set Symbol
needSolving = forall a. Ord a => [a] -> Set a
S.fromList (forall a. Subable a => a -> [Symbol]
F.syms Expr
e) forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Symbol
argsAndPrims
            rewrites :: [(Symbol, [Expr])]
rewrites = (\Symbol
x -> (Symbol
x, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Symbol -> Expr
F.EVar Symbol
x) forall a b. (a -> b) -> a -> b
$ Symbol -> [Expr]
sols Symbol
x)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set Symbol
needSolving
            rewrite :: [(Symbol, [Expr])] -> [a] -> [a]
rewrite [] [a]
es = [a]
es
            rewrite ((Symbol
x, [Expr]
rewrites):[(Symbol, [Expr])]
rewrites') [a]
es = [(Symbol, [Expr])] -> [a] -> [a]
rewrite [(Symbol, [Expr])]
rewrites' forall a b. (a -> b) -> a -> b
$ [forall a. Subable a => Subst -> a -> a
F.subst ([(Symbol, Expr)] -> Subst
F.mkSubst [(Symbol
x, Expr
e')]) a
e | Expr
e' <- [Expr]
rewrites, a
e <- [a]
es]

eqEdges :: S.Set F.Symbol ->
           M.HashMap F.Symbol ([F.Symbol], [F.Expr]) ->
           [(F.Symbol, F.Expr)] ->
           [((F.Symbol, [F.Expr]), F.Symbol, [F.Symbol])]
eqEdges :: Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
_args HashMap Symbol ([Symbol], [Expr])
edgeMap [] = forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
M.foldrWithKey (\Symbol
x ([Symbol]
ys, [Expr]
es) [((Symbol, [Expr]), Symbol, [Symbol])]
edges -> ((Symbol
x, [Expr]
es), Symbol
x, [Symbol]
ys)forall a. a -> [a] -> [a]
:[((Symbol, [Expr]), Symbol, [Symbol])]
edges) [] HashMap Symbol ([Symbol], [Expr])
edgeMap
eqEdges Set Symbol
args HashMap Symbol ([Symbol], [Expr])
edgeMap ((Symbol
x, Expr
e):[(Symbol, Expr)]
eqs)
  | F.EVar Symbol
y <- Expr
e
  , forall a. Ord a => a -> Set a -> Bool
S.member Symbol
y Set Symbol
args = Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
args (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith forall a. Semigroup a => a -> a -> a
(<>) Symbol
x ([Symbol
y], [Symbol -> Expr
F.EVar Symbol
y]) HashMap Symbol ([Symbol], [Expr])
edgeMap) [(Symbol, Expr)]
eqs
  | F.EVar Symbol
y <- Expr
e   = Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
args (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith forall a. Semigroup a => a -> a -> a
(<>) Symbol
x ([Symbol
y], []) HashMap Symbol ([Symbol], [Expr])
edgeMap) [(Symbol, Expr)]
eqs
  | Bool
otherwise       = Set Symbol
-> HashMap Symbol ([Symbol], [Expr])
-> [(Symbol, Expr)]
-> [((Symbol, [Expr]), Symbol, [Symbol])]
eqEdges Set Symbol
args (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith forall a. Semigroup a => a -> a -> a
(<>) Symbol
x ([], [Expr
e]) HashMap Symbol ([Symbol], [Expr])
edgeMap) [(Symbol, Expr)]
eqs

collectEqualities :: Pred -> [(F.Symbol, F.Expr)]
collectEqualities :: Pred -> [(Symbol, Expr)]
collectEqualities = Pred -> [(Symbol, Expr)]
goP
  where
    goP :: Pred -> [(Symbol, Expr)]
goP (Reft Expr
e) = Expr -> [(Symbol, Expr)]
goE Expr
e
    goP (PAnd [Pred]
ps) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Pred -> [(Symbol, Expr)]
goP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps
    goP Pred
_ = forall a. Monoid a => a
mempty

    goE :: Expr -> [(Symbol, Expr)]
goE (F.PAtom Brel
F.Eq Expr
left Expr
right) = Expr -> Expr -> [(Symbol, Expr)]
extractEquality Expr
left Expr
right
    goE (F.PAnd [Expr]
es) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Expr -> [(Symbol, Expr)]
goE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr]
es
    goE Expr
_ = forall a. Monoid a => a
mempty

extractEquality :: F.Expr -> F.Expr -> [(F.Symbol, F.Expr)]
extractEquality :: Expr -> Expr -> [(Symbol, Expr)]
extractEquality Expr
left Expr
right
  | F.EVar Symbol
x <- Expr
left, F.EVar Symbol
y <- Expr
right, Symbol
x forall a. Eq a => a -> a -> Bool
== Symbol
y = forall a. Monoid a => a
mempty
  | F.EVar Symbol
x <- Expr
left, F.EVar Symbol
y <- Expr
right  = [(Symbol
x, Expr
right), (Symbol
y, Expr
left)]
  | F.EVar Symbol
x <- Expr
left = [(Symbol
x, Expr
right)]
  | F.EVar Symbol
x <- Expr
right = [(Symbol
x, Expr
left)]
  | Bool
otherwise = forall a. Monoid a => a
mempty

substPiSols :: M.HashMap F.Symbol Pred -> Cstr a -> Cstr a
substPiSols :: forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
_ c :: Cstr a
c@Head{} = Cstr a
c
substPiSols HashMap Symbol Pred
piSols (CAnd [Cstr a]
cs) = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
piSols forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
substPiSols HashMap Symbol Pred
piSols (All (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c)
  | Var Symbol
k [Symbol]
_ <- Pred
p = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t (forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault Pred
p Symbol
k HashMap Symbol Pred
piSols) a
l) (forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
piSols Cstr a
c)
  | Bool
otherwise = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t Pred
p a
l) (forall a. HashMap Symbol Pred -> Cstr a -> Cstr a
substPiSols HashMap Symbol Pred
piSols Cstr a
c)
substPiSols HashMap Symbol Pred
piSols (Any (Bind Symbol
n Sort
_ Pred
p a
_) Cstr a
c)
  | Head (Var Symbol
pi [Symbol]
_) a
label <- Cstr a
c, Just Pred
sol <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Symbol
pi HashMap Symbol Pred
piSols =
    case Symbol -> Pred -> Maybe Expr
findSol Symbol
n Pred
sol of
      Just Expr
e -> forall a. Pred -> a -> Cstr a
Head (forall a. Flatten a => a -> a
flatten forall a b. (a -> b) -> a -> b
$ [Pred] -> Pred
PAnd forall a b. (a -> b) -> a -> b
$ (\Pred
pred -> forall a. Subable a => a -> (Symbol, Expr) -> a
F.subst1 Pred
pred (Symbol
n, Expr
e)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred
p, Pred
sol]) a
label
      Maybe Expr
Nothing -> forall a. Pred -> a -> Cstr a
Head (Expr -> Pred
Reft forall a b. (a -> b) -> a -> b
$ [Expr] -> Expr
F.PAnd []) a
label
  | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"missing piSol"

findSol :: F.Symbol -> Pred -> Maybe F.Expr
findSol :: Symbol -> Pred -> Maybe Expr
findSol Symbol
x = Pred -> Maybe Expr
go
  where
    go :: Pred -> Maybe Expr
go (Reft Expr
e) = Expr -> Maybe Expr
findEq Expr
e
    go Var{} = forall a. Maybe a
Nothing
    go (PAnd [Pred]
ps) = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Pred -> Maybe Expr
go [Pred]
ps of
      [] -> forall a. Maybe a
Nothing
      Expr
x:[Expr]
_ -> forall a. a -> Maybe a
Just Expr
x

    findEq :: Expr -> Maybe Expr
findEq (F.PAtom Brel
F.Eq Expr
left Expr
right)
      | F.EVar Symbol
y <- Expr
left, Symbol
y forall a. Eq a => a -> a -> Bool
== Symbol
x = forall a. a -> Maybe a
Just Expr
right
      | F.EVar Symbol
y <- Expr
right, Symbol
y forall a. Eq a => a -> a -> Bool
== Symbol
x = forall a. a -> Maybe a
Just Expr
left
    findEq Expr
_ = forall a. Maybe a
Nothing

------------------------------------------------------------------------------
-- | uniq makes sure each binder has a unique name
------------------------------------------------------------------------------
type RenameMap = M.HashMap F.Symbol (Integer, [Integer]) -- the first component is how many times we've seen this name. the second is the name mappings

uniq :: Cstr a -> Cstr a
uniq :: forall a. Cstr a -> Cstr a
uniq Cstr a
c = forall s a. State s a -> s -> a
evalState (forall a. Cstr a -> State RenameMap (Cstr a)
uniq' Cstr a
c) forall k v. HashMap k v
M.empty

uniq' :: Cstr a -> State RenameMap (Cstr a)
uniq' :: forall a. Cstr a -> State RenameMap (Cstr a)
uniq' (Head Pred
c a
a) = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Pred -> a -> Cstr a
Head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> RenameMap -> Pred
rename Pred
c) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
uniq' (CAnd [Cstr a]
c) = forall a. [Cstr a] -> Cstr a
CAnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Cstr a -> State RenameMap (Cstr a)
uniq' [Cstr a]
c
uniq' (All b :: Bind a
b@(Bind Symbol
x Sort
_ Pred
_ a
_) Cstr a
c2) = do
    Bind a
b' <- forall a. Bind a -> State RenameMap (Bind a)
uBind Bind a
b
    Cstr a
c2' <- forall a. Cstr a -> State RenameMap (Cstr a)
uniq' Cstr a
c2
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ Symbol -> RenameMap -> RenameMap
popName Symbol
x
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b' Cstr a
c2'
uniq' (Any b :: Bind a
b@(Bind Symbol
x Sort
_ Pred
_ a
_) Cstr a
c2) = do
    Bind a
b' <- forall a. Bind a -> State RenameMap (Bind a)
uBind Bind a
b
    Cstr a
c2' <- forall a. Cstr a -> State RenameMap (Cstr a)
uniq' Cstr a
c2
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ Symbol -> RenameMap -> RenameMap
popName Symbol
x
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Bind a -> Cstr a -> Cstr a
Any Bind a
b' Cstr a
c2'

popName :: F.Symbol -> RenameMap -> RenameMap
popName :: Symbol -> RenameMap -> RenameMap
popName Symbol
x RenameMap
m = forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
M.adjust (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. [a] -> [a]
tail) Symbol
x RenameMap
m

pushName :: Maybe (Integer, [Integer]) -> Maybe (Integer, [Integer])
pushName :: Maybe (Integer, [Integer]) -> Maybe (Integer, [Integer])
pushName Maybe (Integer, [Integer])
Nothing = forall a. a -> Maybe a
Just (Integer
0, [Integer
0])
pushName (Just (Integer
i, [Integer]
is)) = forall a. a -> Maybe a
Just (Integer
i forall a. Num a => a -> a -> a
+ Integer
1, (Integer
i forall a. Num a => a -> a -> a
+ Integer
1)forall a. a -> [a] -> [a]
:[Integer]
is)

uBind :: Bind a -> State RenameMap (Bind a)
uBind :: forall a. Bind a -> State RenameMap (Bind a)
uBind (Bind Symbol
x Sort
t Pred
p a
l) = do
   Symbol
x' <- forall a. IsString a => Symbol -> State RenameMap a
uVariable Symbol
x
   Pred
p' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Pred -> RenameMap -> Pred
rename Pred
p)
   forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x' Sort
t Pred
p' a
l

uVariable :: IsString a => F.Symbol -> State RenameMap a
uVariable :: forall a. IsString a => Symbol -> State RenameMap a
uVariable Symbol
x = do
   forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
M.alter Maybe (Integer, [Integer]) -> Maybe (Integer, [Integer])
pushName Symbol
x)
   Integer
i <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! Symbol
x))
   forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Symbol -> Integer -> a
numSym Symbol
x Integer
i

rename :: Pred -> RenameMap -> Pred
rename :: Pred -> RenameMap -> Pred
rename Pred
e RenameMap
m = HashMap Symbol Symbol -> Pred -> Pred
substPred (forall k v1 v2.
(k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
M.mapMaybeWithKey (\Symbol
k (Integer, [Integer])
v -> case (Integer, [Integer])
v of
                                              (Integer
_, Integer
n:[Integer]
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Symbol -> Integer -> a
numSym Symbol
k Integer
n
                                              (Integer, [Integer])
_ -> forall a. Maybe a
Nothing) RenameMap
m) Pred
e

numSym :: IsString a => F.Symbol -> Integer -> a
numSym :: forall a. IsString a => Symbol -> Integer -> a
numSym Symbol
s Integer
0 = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Symbol -> [Char]
F.symbolString Symbol
s
numSym Symbol
s Integer
i = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Symbol -> [Char]
F.symbolString Symbol
s forall a. [a] -> [a] -> [a]
++ [Char]
"#" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
i

substPred :: M.HashMap F.Symbol F.Symbol -> Pred -> Pred
substPred :: HashMap Symbol Symbol -> Pred -> Pred
substPred HashMap Symbol Symbol
su (Reft Expr
e) = Expr -> Pred
Reft forall a b. (a -> b) -> a -> b
$ forall a. Subable a => Subst -> a -> a
F.subst (HashMap Symbol Expr -> Subst
F.Su forall a b. (a -> b) -> a -> b
$ Symbol -> Expr
F.EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Symbol Symbol
su) Expr
e
substPred HashMap Symbol Symbol
su (PAnd [Pred]
ps) = [Pred] -> Pred
PAnd forall a b. (a -> b) -> a -> b
$ HashMap Symbol Symbol -> Pred -> Pred
substPred HashMap Symbol Symbol
su forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps
substPred HashMap Symbol Symbol
su (Var Symbol
k [Symbol]
xs) = Symbol -> [Symbol] -> Pred
Var Symbol
k forall a b. (a -> b) -> a -> b
$ Symbol -> Symbol
upd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol]
xs
  where upd :: Symbol -> Symbol
upd Symbol
x = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault Symbol
x Symbol
x HashMap Symbol Symbol
su

------------------------------------------------------------------------------
-- | elim solves all of the KVars in a Cstr (assuming no cycles...)
-- >>> elim . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test00.smt2"
-- (and (forall ((x int) (x > 0)) (forall ((y int) (y > x)) (forall ((v int) (v == x + y)) ((v > 0))))))
-- >>> elim . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test01.smt2"
-- (and (forall ((x int) (x > 0)) (and (forall ((y int) (y > x)) (forall ((v int) (v == x + y)) ((v > 0)))) (forall ((z int) (z > 100)) (forall ((v int) (v == x + z)) ((v > 100)))))))
-- >>> elim . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test02.smt2"
-- (and (forall ((x int) (x > 0)) (and (forall ((y int) (y > x + 100)) (forall ((v int) (v == x + y)) ((true)))) (forall ((y int) (y > x + 100)) (forall ((v int) (v == x + y)) (forall ((z int) (z == v)) (forall ((v int) (v == x + z)) ((v > 100)))))))))
------------------------------------------------------------------------------
elim :: Cstr a -> Cstr a
------------------------------------------------------------------------------
elim :: forall a. Cstr a -> Cstr a
elim Cstr a
c = if forall a. Set a -> Bool
S.null forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Set Symbol
boundKvars Cstr a
res then Cstr a
res else forall a. HasCallStack => [Char] -> a
error [Char]
"called elim on cyclic constraint"
  where
  res :: Cstr a
res = forall a b. (a -> b -> a) -> a -> Set b -> a
S.foldl' forall a. Cstr a -> Symbol -> Cstr a
elim1 Cstr a
c (forall a. Cstr a -> Set Symbol
boundKvars Cstr a
c)

elim1 :: Cstr a -> F.Symbol -> Cstr a
-- Find a `sol1` solution to a kvar `k`, and then subsitute in the solution for
-- each rhs occurrence of k.
elim1 :: forall a. Cstr a -> Symbol -> Cstr a
elim1 Cstr a
c Symbol
k = forall a. Cstr a -> Cstr a
simplify forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
sol Cstr a
c
  where sol :: [([Bind a], [Expr])]
sol = forall a. Symbol -> Cstr a -> [([Bind a], [Expr])]
sol1 Symbol
k (forall {a}. Symbol -> Cstr a -> Cstr a
scope Symbol
k Cstr a
c)

-- |
-- >>> sc <- scope "k0" . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test02.smt2"
-- >>> sc
-- (forall ((x ... (and (forall ((y ... (forall ((v ... ((k0 v)))) (forall ((z ...

-- scope is lca
scope :: F.Symbol -> Cstr a -> Cstr a
scope :: forall {a}. Symbol -> Cstr a -> Cstr a
scope Symbol
k Cstr a
cstr = case forall {a}. Cstr a -> Either a (Cstr a)
go Cstr a
cstr of
                 Right Cstr a
c -> Cstr a
c
                 Left a
l -> forall a. Pred -> a -> Cstr a
Head (Expr -> Pred
Reft Expr
F.PTrue) a
l
  where
    go :: Cstr a -> Either a (Cstr a)
go c :: Cstr a
c@(Head (Var Symbol
k' [Symbol]
_) a
_)
      | Symbol
k' forall a. Eq a => a -> a -> Bool
== Symbol
k = forall a b. b -> Either a b
Right Cstr a
c
    go (Head Pred
_ a
l) = forall a b. a -> Either a b
Left a
l
    go c :: Cstr a
c@(All (Bind Symbol
_ Sort
_ Pred
p a
_) Cstr a
c') =
      if Symbol
k forall a. Ord a => a -> Set a -> Bool
`S.member` Pred -> Set Symbol
pKVars Pred
p then forall a b. b -> Either a b
Right Cstr a
c else Cstr a -> Either a (Cstr a)
go Cstr a
c'
    go Any{} = forall a. HasCallStack => [Char] -> a
error [Char]
"any should not appear after poke"

    -- if kvar doesn't appear, then just return the left
    -- if kvar appears in one child, that is the lca
    -- but if kvar appear in multiple chlidren, this is the lca
    go c :: Cstr a
c@(CAnd [Cstr a]
cs) = case forall a b. [Either a b] -> [b]
rights (Cstr a -> Either a (Cstr a)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs) of
                       [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> a
cLabel Cstr a
c
                       [Cstr a
c] -> forall a b. b -> Either a b
Right Cstr a
c
                       [Cstr a]
_ -> forall a b. b -> Either a b
Right Cstr a
c


-- | A solution is a Hyp of binders (including one anonymous binder
-- that I've singled out here).
-- (What does Hyp stand for? Hypercube? but the dims don't line up...)
--
-- >>> c <- qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test02.smt2"
-- >>> sol1 ("k0") (scope "k0" c)
-- [[((y int) (y > x + 100)),((v int) (v == x + y)),((_ bool) (κarg$k0#1 == v))]]
-- >>> c <- qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test03.smt2"
-- >>> sol1 ("k0") (scope "k0" c)
-- [[((x int) (x > 0)),((v int) (v == x)),((_ bool) (κarg$k0#1 == v))],[((y int) (k0 y)),((v int) (v == y + 1)),((_ bool) (κarg$k0#1 == v))]]
-- >>> let c = doParse' hCstrP "" "(forall ((a Int) (p a)) (forall ((b Int) (q b)) (and (($k a)) (($k b)))))"
-- >>> sol1 "k" c
-- [[((a int) (p a)),((b int) (q b)),((_ bool) (κarg$k#1 == a))],[((a int) (p a)),((b int) (q b)),((_ bool) (κarg$k#1 == b))]]

-- Naming conventions:
--  - `b` is a binder `forall . x:t .p =>`
--  - `bs` is a list of binders, or a "cube" that tracks all of the
--     information on the rhs of a given constraint
--  - `bss` is a Hyp, that tells us the solution to a Var, that is,
--     a collection of cubes that we'll want to disjunct

sol1 :: F.Symbol -> Cstr a -> [([Bind a], [F.Expr])]
sol1 :: forall a. Symbol -> Cstr a -> [([Bind a], [Expr])]
sol1 Symbol
k (CAnd [Cstr a]
cs) = forall a. Symbol -> Cstr a -> [([Bind a], [Expr])]
sol1 Symbol
k forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Cstr a]
cs
sol1 Symbol
k (All Bind a
b Cstr a
c) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bind a
b forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Symbol -> Cstr a -> [([Bind a], [Expr])]
sol1 Symbol
k Cstr a
c
sol1 Symbol
k (Head (Var Symbol
k' [Symbol]
ys) a
_) | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k'
  = [([], forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Brel -> Expr -> Expr -> Expr
F.PAtom Brel
F.Eq) (Symbol -> Expr
F.EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol]
xs) (Symbol -> Expr
F.EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol]
ys))]
  where xs :: [Symbol]
xs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. a -> b -> a
const (Symbol -> [Symbol]
kargs Symbol
k) [Symbol]
ys
sol1 Symbol
_ (Head Pred
_ a
_) = []
sol1 Symbol
_ (Any Bind a
_ Cstr a
_) =  forall a. HasCallStack => [Char] -> a
error [Char]
"ebinds don't work with old elim"

kargs :: F.Symbol -> [F.Symbol]
kargs :: Symbol -> [Symbol]
kargs Symbol
k = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
"κarg$" forall a. [a] -> [a] -> [a]
++ Symbol -> [Char]
F.symbolString Symbol
k forall a. [a] -> [a] -> [a]
++ [Char]
"#") forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Integer
1 :: Integer ..]

-- |
-- >>> LET c = doParse' hCstrP "" "(forall ((z Int) ($k0 z)) ((z = x)))"
-- >>> doelim "k0" [[Bind "v" F.boolSort (Reft $ F.EVar "v"), Bind "_" F.boolSort (Reft $ F.EVar "donkey")]]  c
-- (forall ((v bool) (v)) (forall ((z int) (donkey)) ((z == x))))

doelim :: F.Symbol -> [([Bind a], [F.Expr])] -> Cstr a -> Cstr a
doelim :: forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss (CAnd [Cstr a]
cs)
  = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
doelim Symbol
k [([Bind a], [Expr])]
bss (All (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) =
  case Symbol -> Pred -> Either ([(Symbol, [Symbol])], [Pred]) Pred
findKVarInGuard Symbol
k Pred
p of
    Right Pred
_ -> forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t Pred
p a
l) (forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss Cstr a
c)
    Left ([(Symbol, [Symbol])]
kvars, [Pred]
preds) -> forall a.
Symbol
-> Sort
-> a
-> [(Symbol, [Symbol])]
-> [Pred]
-> Cstr a
-> [([Bind a], [Expr])]
-> Cstr a
demorgan Symbol
x Sort
t a
l [(Symbol, [Symbol])]
kvars [Pred]
preds (forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss Cstr a
c) [([Bind a], [Expr])]
bss
  where
    demorgan :: F.Symbol -> F.Sort -> a -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind a], [F.Expr])] -> Cstr a
    demorgan :: forall a.
Symbol
-> Sort
-> a
-> [(Symbol, [Symbol])]
-> [Pred]
-> Cstr a
-> [([Bind a], [Expr])]
-> Cstr a
demorgan Symbol
x Sort
t a
ann [(Symbol, [Symbol])]
kvars [Pred]
preds Cstr a
c [([Bind a], [Expr])]
bss = forall a. [Cstr a] -> Cstr a
mkAnd forall a b. (a -> b) -> a -> b
$ ([Bind a], [Expr]) -> Cstr a
cubeSol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Bind a], [Expr])]
bss
      where su :: Subst
su = HashMap Symbol Expr -> Subst
F.Su forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Symbol
k, [Symbol]
xs) -> forall a b. [a] -> [b] -> [(a, b)]
zip (Symbol -> [Symbol]
kargs Symbol
k) (Symbol -> Expr
F.EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol]
xs)) [(Symbol, [Symbol])]
kvars
            mkAnd :: [Cstr a] -> Cstr a
mkAnd [Cstr a
c] = Cstr a
c
            mkAnd [Cstr a]
cs = forall a. [Cstr a] -> Cstr a
CAnd [Cstr a]
cs
            cubeSol :: ([Bind a], [Expr]) -> Cstr a
cubeSol (Bind a
b:[Bind a]
bs, [Expr]
eqs) = forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall a b. (a -> b) -> a -> b
$ ([Bind a], [Expr]) -> Cstr a
cubeSol ([Bind a]
bs, [Expr]
eqs)
            cubeSol ([], [Expr]
eqs) = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t ([Pred] -> Pred
PAnd forall a b. (a -> b) -> a -> b
$ (Expr -> Pred
Reft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Subable a => Subst -> a -> a
F.subst Subst
su [Expr]
eqs) forall a. [a] -> [a] -> [a]
++ (forall a. Subable a => Subst -> a -> a
F.subst Subst
su forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
preds)) a
ann) Cstr a
c
doelim Symbol
k [([Bind a], [Expr])]
_ (Head (Var Symbol
k' [Symbol]
_) a
a)
  | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k'
  = forall a. Pred -> a -> Cstr a
Head (Expr -> Pred
Reft Expr
F.PTrue) a
a
doelim Symbol
_ [([Bind a], [Expr])]
_ (Head Pred
p a
a) = forall a. Pred -> a -> Cstr a
Head Pred
p a
a

doelim Symbol
k [([Bind a], [Expr])]
bss (Any (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) =
  case Symbol -> Pred -> Either ([(Symbol, [Symbol])], [Pred]) Pred
findKVarInGuard Symbol
k Pred
p of
    Right Pred
_ -> forall a. Bind a -> Cstr a -> Cstr a
Any (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t Pred
p a
l) (forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss Cstr a
c)
    Left ([(Symbol, [Symbol])]
_, [Pred]
rights) -> forall a. Bind a -> Cstr a -> Cstr a
Any (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t ([Pred] -> Pred
PAnd [Pred]
rights) a
l) (forall a. Symbol -> [([Bind a], [Expr])] -> Cstr a -> Cstr a
doelim Symbol
k [([Bind a], [Expr])]
bss Cstr a
c) -- TODO: for now we set the kvar to true. not sure if this is correct

-- If k is in the guard then returns a Left list of that k and the remaining preds in the guard
-- If k is not in the guard returns a Right of the pred
findKVarInGuard :: F.Symbol -> Pred -> Either ([(F.Symbol, [F.Symbol])], [Pred]) Pred
findKVarInGuard :: Symbol -> Pred -> Either ([(Symbol, [Symbol])], [Pred]) Pred
findKVarInGuard Symbol
k (PAnd [Pred]
ps) =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([(Symbol, [Symbol])], [Pred])]
lefts
    then forall a b. b -> Either a b
Right ([Pred] -> Pred
PAnd [Pred]
ps) -- kvar not found
    else forall a b. a -> Either a b
Left ([(Symbol, [Symbol])]
newLefts, [Pred]
newRights)
  where findResults :: [Either ([(Symbol, [Symbol])], [Pred]) Pred]
findResults = Symbol -> Pred -> Either ([(Symbol, [Symbol])], [Pred]) Pred
findKVarInGuard Symbol
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps
        ([([(Symbol, [Symbol])], [Pred])]
lefts, [Pred]
rights) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ([(Symbol, [Symbol])], [Pred]) Pred]
findResults
        newLefts :: [(Symbol, [Symbol])]
newLefts = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([(Symbol, [Symbol])], [Pred])]
lefts
        newRights :: [Pred]
newRights = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [([(Symbol, [Symbol])], [Pred])]
lefts forall a. [a] -> [a] -> [a]
++ [Pred]
rights
findKVarInGuard Symbol
k p :: Pred
p@(Var Symbol
k' [Symbol]
xs)
  | Symbol
k forall a. Eq a => a -> a -> Bool
== Symbol
k' = forall a b. a -> Either a b
Left ([(Symbol
k', [Symbol]
xs)], [])
  | Bool
otherwise = forall a b. b -> Either a b
Right Pred
p
findKVarInGuard Symbol
_ Pred
p = forall a b. b -> Either a b
Right Pred
p

-- | Returns a list of KVars with their arguments that are present as
--
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/ebind01.smt2"
-- ... []
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/ebind02.smt2"
-- ... ["k"]
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test00.smt2"
-- ... []
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test01.smt2"
-- ... []
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test02.smt2"
-- ... ["k0"]
-- >>> boundKvars . qCstr . fst <$> parseFromFile hornP "tests/horn/pos/test03.smt2"
-- ... ["k0"]

boundKvars :: Cstr a -> S.Set F.Symbol
boundKvars :: forall a. Cstr a -> Set Symbol
boundKvars (Head Pred
p a
_)           = Pred -> Set Symbol
pKVars Pred
p
boundKvars (CAnd [Cstr a]
c)             = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Set Symbol
boundKvars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
c
boundKvars (All (Bind Symbol
_ Sort
_ Pred
p a
_) Cstr a
c) = Pred -> Set Symbol
pKVars Pred
p forall a. Semigroup a => a -> a -> a
<> forall a. Cstr a -> Set Symbol
boundKvars Cstr a
c
boundKvars (Any (Bind Symbol
_ Sort
_ Pred
p a
_) Cstr a
c) = Pred -> Set Symbol
pKVars Pred
p forall a. Semigroup a => a -> a -> a
<> forall a. Cstr a -> Set Symbol
boundKvars Cstr a
c

pKVars :: Pred -> S.Set F.Symbol
pKVars :: Pred -> Set Symbol
pKVars (Var Symbol
k [Symbol]
_) = forall a. a -> Set a
S.singleton Symbol
k
pKVars (PAnd [Pred]
ps) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Pred -> Set Symbol
pKVars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps
pKVars Pred
_         = forall a. Set a
S.empty

-- | Returns true if the constraint does not contain any existential binders
isNNF :: Cstr a -> Bool
isNNF :: forall a. Cstr a -> Bool
isNNF Head{} = Bool
True
isNNF (CAnd [Cstr a]
cs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Cstr a -> Bool
isNNF [Cstr a]
cs
isNNF (All Bind a
_ Cstr a
c) = forall a. Cstr a -> Bool
isNNF Cstr a
c
isNNF Any{} = Bool
False

calculateCuts :: F.Config -> Query a -> Cstr a -> S.Set F.Symbol
calculateCuts :: forall a. Config -> Query a -> Cstr a -> Set Symbol
calculateCuts Config
cfg (Query [Qualifier]
qs [Var a]
vs Cstr a
_ HashMap Symbol Sort
cons HashMap Symbol Sort
dist [Equation]
eqns [Rewrite]
mats [DataDecl]
dds) Cstr a
nnf = HashSet KVar -> Set Symbol
convert forall a b. (a -> b) -> a -> b
$ forall a. Elims a -> HashSet a
FG.depCuts Elims KVar
deps
  where
    ([CEdge]
_, Elims KVar
deps) = forall (c :: * -> *) a.
TaggedC c a =>
Config -> GInfo c a -> ([CEdge], Elims KVar)
elimVars Config
cfg (forall a. Config -> Query a -> FInfo a
hornFInfo Config
cfg forall a b. (a -> b) -> a -> b
$ forall a.
[Qualifier]
-> [Var a]
-> Cstr a
-> HashMap Symbol Sort
-> HashMap Symbol Sort
-> [Equation]
-> [Rewrite]
-> [DataDecl]
-> Query a
Query [Qualifier]
qs [Var a]
vs Cstr a
nnf HashMap Symbol Sort
cons HashMap Symbol Sort
dist [Equation]
eqns [Rewrite]
mats [DataDecl]
dds)
    convert :: HashSet KVar -> Set Symbol
convert HashSet KVar
hashset = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ KVar -> Symbol
F.kv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HashSet a -> [a]
HS.toList HashSet KVar
hashset

forgetPiVars :: S.Set F.Symbol -> Cstr a -> Cstr a
forgetPiVars :: forall a. Set Symbol -> Cstr a -> Cstr a
forgetPiVars Set Symbol
_ c :: Cstr a
c@Head{} = Cstr a
c
forgetPiVars Set Symbol
pis (CAnd [Cstr a]
cs) = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ forall a. Set Symbol -> Cstr a -> Cstr a
forgetPiVars Set Symbol
pis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
forgetPiVars Set Symbol
pis (All (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c)
  | Var Symbol
k [Symbol]
_ <- Pred
p, Symbol
k forall a. Ord a => a -> Set a -> Bool
`S.member` Set Symbol
pis = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t ([Pred] -> Pred
PAnd []) a
l) forall a b. (a -> b) -> a -> b
$ forall a. Set Symbol -> Cstr a -> Cstr a
forgetPiVars Set Symbol
pis Cstr a
c
  | Bool
otherwise = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t Pred
p a
l) forall a b. (a -> b) -> a -> b
$ forall a. Set Symbol -> Cstr a -> Cstr a
forgetPiVars Set Symbol
pis Cstr a
c
forgetPiVars Set Symbol
_ Any{} = forall a. HasCallStack => [Char] -> a
error [Char]
"shouldn't be present"

-----------------------------------------------------------------------------------
-- | Cleanup Horn Constraint
-- We want to simplify the Query a little bit, and make sure it is Horn,
-- that is, only a kvar-free (ie concrete) predicate or a single kvar in
-- each head
-----------------------------------------------------------------------------------

simplify :: Cstr a -> Cstr a
simplify :: forall a. Cstr a -> Cstr a
simplify = forall a. Flatten a => a -> a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cstr a -> Cstr a
pruneTauts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cstr a -> Cstr a
removeDuplicateBinders

{- | flatten removes redundant `and`s and empty conjuncts.

For example:
>>> :{
flatten $ doParse' hCstrP "" "(forall ((VV##15 int) (VV##15 == anf##3)) \
            \      ((and (and \
            \        ($k13 VV##15 anf##3 moo##5) \
            \        (true)))))"
:}
(forall ((VV##15 int) (VV##15 == anf##3)) ((k13 VV##15 anf##3 moo##5)))
-}

class Flatten a where
  flatten :: a -> a

instance Flatten (Cstr a) where
  flatten :: Cstr a -> Cstr a
flatten (CAnd [Cstr a]
cs) = case forall a. Flatten a => a -> a
flatten [Cstr a]
cs of
                        [Cstr a
c] -> Cstr a
c
                        [Cstr a]
cs -> forall a. [Cstr a] -> Cstr a
CAnd [Cstr a]
cs
  flatten (Head Pred
p a
a) = forall a. Pred -> a -> Cstr a
Head (forall a. Flatten a => a -> a
flatten Pred
p) a
a
  flatten (All (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
All (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t (forall a. Flatten a => a -> a
flatten Pred
p) a
l) (forall a. Flatten a => a -> a
flatten Cstr a
c)
  flatten (Any (Bind Symbol
x Sort
t Pred
p a
l) Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
Any (forall a. Symbol -> Sort -> Pred -> a -> Bind a
Bind Symbol
x Sort
t (forall a. Flatten a => a -> a
flatten Pred
p) a
l) (forall a. Flatten a => a -> a
flatten Cstr a
c)

instance Flatten [Cstr a] where
  flatten :: [Cstr a] -> [Cstr a]
flatten (CAnd [Cstr a]
cs : [Cstr a]
xs) = forall a. Flatten a => a -> a
flatten [Cstr a]
cs forall a. [a] -> [a] -> [a]
++ forall a. Flatten a => a -> a
flatten [Cstr a]
xs
  flatten (Cstr a
x:[Cstr a]
xs)
    | Head (Reft Expr
p) a
_ <- Cstr a
fx
    , Expr -> Bool
F.isTautoPred Expr
p            = forall a. Flatten a => a -> a
flatten [Cstr a]
xs
    | Bool
otherwise                  = Cstr a
fxforall a. a -> [a] -> [a]
:forall a. Flatten a => a -> a
flatten [Cstr a]
xs
    where fx :: Cstr a
fx = forall a. Flatten a => a -> a
flatten Cstr a
x
  flatten [] = []

instance Flatten Pred where
  flatten :: Pred -> Pred
flatten (PAnd [Pred]
ps) = case forall a. Flatten a => a -> a
flatten [Pred]
ps of
                        [Pred
p] -> Pred
p
                        [Pred]
ps  -> [Pred] -> Pred
PAnd [Pred]
ps
  flatten Pred
p = Pred
p

instance Flatten [Pred] where
  flatten :: [Pred] -> [Pred]
flatten (PAnd [Pred]
ps' : [Pred]
ps) = forall a. Flatten a => a -> a
flatten [Pred]
ps' forall a. [a] -> [a] -> [a]
++ forall a. Flatten a => a -> a
flatten [Pred]
ps
  flatten (Pred
p : [Pred]
ps)
    | Reft Expr
e <- Pred
fp
    , Expr -> Bool
F.isTautoPred Expr
e     = forall a. Flatten a => a -> a
flatten [Pred]
ps
    | Bool
otherwise           = Pred
fp forall a. a -> [a] -> [a]
: forall a. Flatten a => a -> a
flatten [Pred]
ps
    where fp :: Pred
fp = forall a. Flatten a => a -> a
flatten Pred
p
  flatten []              = []

instance Flatten F.Expr where
  flatten :: Expr -> Expr
flatten (F.PAnd [Expr]
ps) = case forall a. Flatten a => a -> a
flatten [Expr]
ps of
                         [Expr
p] -> Expr
p
                         [Expr]
ps  -> [Expr] -> Expr
F.PAnd [Expr]
ps
  flatten Expr
p = Expr
p

instance Flatten [F.Expr] where
  flatten :: [Expr] -> [Expr]
flatten (F.PAnd [Expr]
ps' : [Expr]
ps) = forall a. Flatten a => a -> a
flatten [Expr]
ps' forall a. [a] -> [a] -> [a]
++ forall a. Flatten a => a -> a
flatten [Expr]
ps
  flatten (Expr
p : [Expr]
ps)
    | Expr -> Bool
F.isTautoPred Expr
fp    = forall a. Flatten a => a -> a
flatten [Expr]
ps
    | Bool
otherwise           = Expr
fp forall a. a -> [a] -> [a]
: forall a. Flatten a => a -> a
flatten [Expr]
ps
    where fp :: Expr
fp = forall a. Flatten a => a -> a
flatten Expr
p
  flatten []              = []

-- | Split heads into one for each kvar so that queries are always horn constraints
hornify :: Cstr a -> Cstr a
hornify :: forall a. Cstr a -> Cstr a
hornify (Head (PAnd [Pred]
ps) a
a) = forall a. [Cstr a] -> Cstr a
CAnd (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Pred -> a -> Cstr a
Head a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred]
ps')
  where ps' :: [Pred]
ps' = let ([Pred]
ks, [Pred]
qs) = [Pred] -> [Pred] -> [Pred] -> ([Pred], [Pred])
split [] [] (forall a. Flatten a => a -> a
flatten [Pred]
ps) in [Pred] -> Pred
PAnd [Pred]
qs forall a. a -> [a] -> [a]
: [Pred]
ks

        split :: [Pred] -> [Pred] -> [Pred] -> ([Pred], [Pred])
split [Pred]
kacc [Pred]
pacc ((Var Symbol
x [Symbol]
xs):[Pred]
qs) = [Pred] -> [Pred] -> [Pred] -> ([Pred], [Pred])
split (Symbol -> [Symbol] -> Pred
Var Symbol
x [Symbol]
xs forall a. a -> [a] -> [a]
: [Pred]
kacc) [Pred]
pacc [Pred]
qs
        split [Pred]
kacc [Pred]
pacc (Pred
q:[Pred]
qs) = [Pred] -> [Pred] -> [Pred] -> ([Pred], [Pred])
split [Pred]
kacc (Pred
qforall a. a -> [a] -> [a]
:[Pred]
pacc) [Pred]
qs
        split [Pred]
kacc [Pred]
pacc [] = ([Pred]
kacc, [Pred]
pacc)
hornify (Head (Reft Expr
r) a
a) = forall a. [Cstr a] -> Cstr a
CAnd (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Pred -> a -> Cstr a
Head a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pred
Reft ([Expr] -> Expr
F.PAnd [Expr]
ps)forall a. a -> [a] -> [a]
:(Expr -> Pred
Reft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr]
ks)))
  where ([Expr]
ks, [Expr]
ps) = [Expr] -> [Expr] -> [Expr] -> ([Expr], [Expr])
split [] [] forall a b. (a -> b) -> a -> b
$ Expr -> [Expr]
F.splitPAnd Expr
r
        split :: [Expr] -> [Expr] -> [Expr] -> ([Expr], [Expr])
split [Expr]
kacc [Expr]
pacc (r :: Expr
r@F.PKVar{}:[Expr]
rs) = [Expr] -> [Expr] -> [Expr] -> ([Expr], [Expr])
split (Expr
rforall a. a -> [a] -> [a]
:[Expr]
kacc) [Expr]
pacc [Expr]
rs
        split [Expr]
kacc [Expr]
pacc (Expr
r:[Expr]
rs) = [Expr] -> [Expr] -> [Expr] -> ([Expr], [Expr])
split [Expr]
kacc (Expr
rforall a. a -> [a] -> [a]
:[Expr]
pacc) [Expr]
rs
        split [Expr]
kacc [Expr]
pacc [] = ([Expr]
kacc,[Expr]
pacc)
hornify (Head Pred
h a
a) = forall a. Pred -> a -> Cstr a
Head Pred
h a
a
hornify (All Bind a
b Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Cstr a
hornify Cstr a
c
hornify (Any Bind a
b Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
Any Bind a
b forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Cstr a
hornify Cstr a
c
hornify (CAnd [Cstr a]
cs) = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ forall a. Cstr a -> Cstr a
hornify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs

removeDuplicateBinders :: Cstr a -> Cstr a
removeDuplicateBinders :: forall a. Cstr a -> Cstr a
removeDuplicateBinders = forall a. Set Symbol -> Cstr a -> Cstr a
go forall a. Set a
S.empty
  where
    go :: Set Symbol -> Cstr a -> Cstr a
go Set Symbol
_ c :: Cstr a
c@Head{} = Cstr a
c
    go Set Symbol
xs (CAnd [Cstr a]
cs) = forall a. [Cstr a] -> Cstr a
CAnd forall a b. (a -> b) -> a -> b
$ Set Symbol -> Cstr a -> Cstr a
go Set Symbol
xs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cstr a]
cs
    go Set Symbol
xs (All b :: Bind a
b@(Bind Symbol
x Sort
_ Pred
_ a
_) Cstr a
c) = if Symbol
x forall a. Ord a => a -> Set a -> Bool
`S.member` Set Symbol
xs then Set Symbol -> Cstr a -> Cstr a
go Set Symbol
xs Cstr a
c else forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b forall a b. (a -> b) -> a -> b
$ Set Symbol -> Cstr a -> Cstr a
go (forall a. Ord a => a -> Set a -> Set a
S.insert Symbol
x Set Symbol
xs) Cstr a
c
    go Set Symbol
xs (Any Bind a
b Cstr a
c) = forall a. Bind a -> Cstr a -> Cstr a
Any Bind a
b forall a b. (a -> b) -> a -> b
$ Set Symbol -> Cstr a -> Cstr a
go Set Symbol
xs Cstr a
c

pruneTauts :: Cstr a -> Cstr a
pruneTauts :: forall a. Cstr a -> Cstr a
pruneTauts = forall a. a -> Maybe a -> a
fromMaybe (forall a. [Cstr a] -> Cstr a
CAnd []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Cstr a -> Maybe (Cstr a)
go
  where
    go :: Cstr a -> Maybe (Cstr a)
go (Head Pred
p a
l) = do
      Pred
p' <- Pred -> Maybe Pred
goP Pred
p
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Pred -> a -> Cstr a
Head Pred
p' a
l
    go (CAnd [Cstr a]
cs) = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cstr a]
cs' then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [Cstr a] -> Cstr a
CAnd [Cstr a]
cs'
      where cs' :: [Cstr a]
cs' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Cstr a -> Maybe (Cstr a)
go [Cstr a]
cs
    go (All Bind a
b Cstr a
c) = do
      Cstr a
c' <- Cstr a -> Maybe (Cstr a)
go Cstr a
c
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Bind a -> Cstr a -> Cstr a
All Bind a
b Cstr a
c')
    go c :: Cstr a
c@Any{} = forall a. a -> Maybe a
Just Cstr a
c

    goP :: Pred -> Maybe Pred
goP (Reft Expr
e) = if Expr -> Bool
F.isTautoPred Expr
e then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Expr -> Pred
Reft Expr
e
    goP p :: Pred
p@Var{} = forall a. a -> Maybe a
Just Pred
p
    goP (PAnd [Pred]
ps) = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pred]
ps' then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Pred] -> Pred
PAnd [Pred]
ps'
      where ps' :: [Pred]
ps' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Pred -> Maybe Pred
goP [Pred]
ps