-----------------------------------------------------------------------------
-- |
-- Module    : Documentation.SBV.Examples.Queries.Concurrency
-- Copyright : (c) Jeffrey Young
--                 Levent Erkok
-- License   : BSD3
-- Maintainer: erkokl@gmail.com
-- Stability : experimental
--
-- When we would like to solve a set of related problems we can use query mode
-- to perform push's and pop's. However performing a push and a pop is still
-- single threaded and so each solution will need to wait for the previous
-- solution to be found. In this example we show a class of functions
-- 'Data.SBV.satConcurrentAll' and 'Data.SBV.satConcurrentAny' which spin up
-- independent solver instances and runs query computations concurrently. The
-- children query computations are allowed to communicate with one another as
-- demonstrated in the second demo
-----------------------------------------------------------------------------

{-# OPTIONS_GHC -Wall -Werror #-}

module Documentation.SBV.Examples.Queries.Concurrency where

import Data.SBV
import Data.SBV.Control
import Control.Concurrent
import Control.Monad.IO.Class (liftIO)

-- | Find all solutions to @x + y .== 10@ for positive @x@ and @y@, but at each
-- iteration we would like to ensure that the value of @x@ we get is at least
-- twice as large as the previous one. This is rather silly, but demonstrates
-- how we can dynamically query the result and put in new constraints based on
-- those.
shared :: MVar (SInteger, SInteger) -> Symbolic ()
shared :: MVar (SInteger, SInteger) -> Symbolic ()
shared MVar (SInteger, SInteger)
v = do
  SInteger
x <- String -> Symbolic SInteger
sInteger String
"x"
  SInteger
y <- String -> Symbolic SInteger
sInteger String
"y"
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
y forall a. OrdSymbolic a => a -> a -> SBool
.<= SInteger
10
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. OrdSymbolic a => a -> a -> SBool
.<= SInteger
10
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. Num a => a -> a -> a
+ SInteger
y forall a. EqSymbolic a => a -> a -> SBool
.== SInteger
10
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (SInteger, SInteger)
v (SInteger
x,SInteger
y)

-- | In our first query we'll define a constraint that will not be known to the
-- shared or second query and then solve for an answer that will differ from the
-- first query. Note that we need to pass an MVar in so that we can operate on
-- the shared variables. In general, the variables you want to operate on should
-- be defined in the shared part of the query and then passed to the children
-- queries via channels, MVars, or TVars. In this query we constrain x to be
-- less than y and then return the sum of the values. We add a threadDelay just
-- for demonstration purposes
queryOne :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryOne :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryOne MVar (SInteger, SInteger)
v = do
  forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"[One]: Waiting"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
5000000
  forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"[One]: Done"
  (SInteger
x,SInteger
y) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (SInteger, SInteger)
v
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. OrdSymbolic a => a -> a -> SBool
.< SInteger
y

  CheckSatResult
cs <- Query CheckSatResult
checkSat
  case CheckSatResult
cs of
    CheckSatResult
Unk    -> forall a. HasCallStack => String -> a
error String
"Too bad, solver said unknown.." -- Won't happen
    DSat{} -> forall a. HasCallStack => String -> a
error String
"Unexpected dsat result.."       -- Won't happen
    CheckSatResult
Unsat  -> do forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No other solution!"
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    CheckSatResult
Sat    -> do Integer
xv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
x
                 Integer
yv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
y
                 forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[One]: Current solution is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
xv, Integer
yv)
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Integer
xv forall a. Num a => a -> a -> a
+ Integer
yv)

-- | In the second query we constrain for an answer where y is smaller than x,
-- and then return the product of the found values.
queryTwo :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryTwo :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryTwo MVar (SInteger, SInteger)
v = do
  (SInteger
x,SInteger
y) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (SInteger, SInteger)
v
  forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[Two]: got values" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SInteger
x,SInteger
y)
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
y forall a. OrdSymbolic a => a -> a -> SBool
.< SInteger
x

  CheckSatResult
cs <- Query CheckSatResult
checkSat
  case CheckSatResult
cs of
    CheckSatResult
Unk    -> forall a. HasCallStack => String -> a
error String
"Too bad, solver said unknown.." -- Won't happen
    DSat{} -> forall a. HasCallStack => String -> a
error String
"Unexpected dsat result.."       -- Won't happen
    CheckSatResult
Unsat  -> do forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No other solution!"
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    CheckSatResult
Sat    -> do Integer
yv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
y
                 Integer
xv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
x
                 forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[Two]: Current solution is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
xv, Integer
yv)
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Integer
xv forall a. Num a => a -> a -> a
* Integer
yv)

-- | Run the demo several times to see that the children threads will change ordering.
demo :: IO ()
demo :: IO ()
demo = do
  MVar (SInteger, SInteger)
v <- forall a. IO (MVar a)
newEmptyMVar
  String -> IO ()
putStrLn String
"[Main]: Hello from main, kicking off children: "
  [(Solver, NominalDiffTime, SatResult)]
results <- forall a b.
Provable a =>
SMTConfig
-> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)]
satConcurrentWithAll SMTConfig
z3 [MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryOne MVar (SInteger, SInteger)
v, MVar (SInteger, SInteger) -> Query (Maybe Integer)
queryTwo MVar (SInteger, SInteger)
v] (MVar (SInteger, SInteger) -> Symbolic ()
shared MVar (SInteger, SInteger)
v)
  String -> IO ()
putStrLn String
"[Main]: Children spawned, waiting for results"
  String -> IO ()
putStrLn String
"[Main]: Here they are: "
  forall a. Show a => a -> IO ()
print [(Solver, NominalDiffTime, SatResult)]
results

-- | Example computation.
sharedDependent :: MVar (SInteger, SInteger) -> Symbolic ()
sharedDependent :: MVar (SInteger, SInteger) -> Symbolic ()
sharedDependent MVar (SInteger, SInteger)
v = do -- constrain positive and sum:
  SInteger
x <- String -> Symbolic SInteger
sInteger String
"x"
  SInteger
y <- String -> Symbolic SInteger
sInteger String
"y"
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
y forall a. OrdSymbolic a => a -> a -> SBool
.<= SInteger
10
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. OrdSymbolic a => a -> a -> SBool
.<= SInteger
10
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. Num a => a -> a -> a
+ SInteger
y forall a. EqSymbolic a => a -> a -> SBool
.== SInteger
10
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (SInteger, SInteger)
v (SInteger
x,SInteger
y)

-- | In our first query we will make a constrain, solve the constraint and
-- return the values for our variables, then we'll mutate the MVar sending
-- information to the second query. Note that you could use channels, or TVars,
-- or TMVars, whatever you need here, we just use MVars for demonstration
-- purposes. Also note that this effectively creates an ordering between the
-- children queries
firstQuery :: MVar (SInteger, SInteger) -> MVar (SInteger , SInteger) -> Query (Maybe Integer)
firstQuery :: MVar (SInteger, SInteger)
-> MVar (SInteger, SInteger) -> Query (Maybe Integer)
firstQuery MVar (SInteger, SInteger)
v1 MVar (SInteger, SInteger)
v2 = do
  (SInteger
x,SInteger
y) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (SInteger, SInteger)
v1
  forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"[One]: got vars...working..."
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
x forall a. OrdSymbolic a => a -> a -> SBool
.< SInteger
y

  CheckSatResult
cs <- Query CheckSatResult
checkSat
  case CheckSatResult
cs of
    CheckSatResult
Unk    -> forall a. HasCallStack => String -> a
error String
"Too bad, solver said unknown.." -- Won't happen
    DSat{} -> forall a. HasCallStack => String -> a
error String
"Unexpected dsat result.."       -- Won't happen
    CheckSatResult
Unsat  -> do forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No other solution!"
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    CheckSatResult
Sat    -> do Integer
xv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
x
                 Integer
yv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
y
                 forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[One]: Current solution is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
xv, Integer
yv)
                 forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn   String
"[One]: Place vars for [Two]"
                 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (SInteger, SInteger)
v2 (forall a. SymVal a => a -> SBV a
literal (Integer
xv forall a. Num a => a -> a -> a
+ Integer
yv), forall a. SymVal a => a -> SBV a
literal (Integer
xv forall a. Num a => a -> a -> a
* Integer
yv))
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Integer
xv forall a. Num a => a -> a -> a
+ Integer
yv)

-- | In the second query we create a new variable z, and then a symbolic query
-- using information from the first query and return a solution that uses the
-- new variable and the old variables. Each child query is run in a separate
-- instance of z3 so you can think of this query as driving to a point in the
-- search space, then waiting for more information, once it gets that
-- information it will run a completely separate computation from the first one
-- and return its results.
secondQuery :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
secondQuery :: MVar (SInteger, SInteger) -> Query (Maybe Integer)
secondQuery MVar (SInteger, SInteger)
v2 = do
  (SInteger
x,SInteger
y) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (SInteger, SInteger)
v2
  forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[Two]: got values" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SInteger
x,SInteger
y)
  SInteger
z <- forall a. SymVal a => String -> Query (SBV a)
freshVar String
"z"
  forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain forall a b. (a -> b) -> a -> b
$ SInteger
z forall a. OrdSymbolic a => a -> a -> SBool
.> SInteger
x forall a. Num a => a -> a -> a
+ SInteger
y

  CheckSatResult
cs <- Query CheckSatResult
checkSat
  case CheckSatResult
cs of
    CheckSatResult
Unk    -> forall a. HasCallStack => String -> a
error String
"Too bad, solver said unknown.." -- Won't happen
    DSat{} -> forall a. HasCallStack => String -> a
error String
"Unexpected dsat result.."       -- Won't happen
    CheckSatResult
Unsat  -> do forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No other solution!"
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    CheckSatResult
Sat    -> do Integer
yv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
y
                 Integer
xv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
x
                 Integer
zv <- forall a. SymVal a => SBV a -> Query a
getValue SInteger
z
                 forall a. IO a -> Query a
io forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"[Two]: My solution is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
zv forall a. Num a => a -> a -> a
+ Integer
xv, Integer
zv forall a. Num a => a -> a -> a
+ Integer
yv)
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Integer
zv forall a. Num a => a -> a -> a
* Integer
xv forall a. Num a => a -> a -> a
* Integer
yv)

-- | In our second demonstration we show how through the use of concurrency
-- constructs the user can have children queries communicate with one another.
-- Note that the children queries are independent and so anything side-effectual
-- like a push or a pop will be isolated to that child thread, unless of course
-- it happens in shared.
demoDependent :: IO ()
demoDependent :: IO ()
demoDependent = do
  MVar (SInteger, SInteger)
v1 <- forall a. IO (MVar a)
newEmptyMVar
  MVar (SInteger, SInteger)
v2 <- forall a. IO (MVar a)
newEmptyMVar
  [(Solver, NominalDiffTime, SatResult)]
results <- forall a b.
Provable a =>
SMTConfig
-> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)]
satConcurrentWithAll SMTConfig
z3 [MVar (SInteger, SInteger)
-> MVar (SInteger, SInteger) -> Query (Maybe Integer)
firstQuery MVar (SInteger, SInteger)
v1 MVar (SInteger, SInteger)
v2, MVar (SInteger, SInteger) -> Query (Maybe Integer)
secondQuery MVar (SInteger, SInteger)
v2] (MVar (SInteger, SInteger) -> Symbolic ()
sharedDependent MVar (SInteger, SInteger)
v1)
  forall a. Show a => a -> IO ()
print [(Solver, NominalDiffTime, SatResult)]
results

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}