{-# LANGUAGE RankNTypes #-}
module Clingo.ProgramBuilding
(
Backend,
ProgramBuilder,
Node (..),
Literal,
Atom,
ExternalType (..),
HeuristicType (..),
assume,
GroundStatement,
addGroundStatements,
acycEdge,
atom,
atomAspifLiteral,
negateAspifLiteral,
external,
heuristic,
minimize,
rule,
weightedRule,
project,
addStatements
)
where
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Foldable
import Foreign
import Numeric.Natural
import qualified Clingo.Raw as Raw
import Clingo.AST (Statement)
import Clingo.Internal.AST (rawStatement, freeStatement)
import Clingo.Internal.Types
import Clingo.Internal.Utils
newtype Node = Node { unNode :: Int }
newtype GroundStatement s =
GStmt { addGStmt :: forall m. (MonadIO m, MonadThrow m)
=> Backend s -> m () }
acycEdge :: Foldable t
=> Node -> Node -> t (Literal s) -> GroundStatement s
acycEdge a b lits = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawLiteral . toList $ lits) $ \len arr ->
Raw.backendAcycEdge h (fromIntegral $ unNode a)
(fromIntegral $ unNode b) arr (fromIntegral len)
atom :: (MonadIO m, MonadThrow m)
=> Backend s -> m (Atom s)
atom (Backend h) = Atom <$> marshall1 (Raw.backendAddAtom h)
atomAspifLiteral :: Atom s -> AspifLiteral s
atomAspifLiteral (Atom x) = AspifLiteral (fromIntegral x)
negateAspifLiteral :: AspifLiteral s -> AspifLiteral s
negateAspifLiteral (AspifLiteral x) = AspifLiteral (negate x)
assume :: Foldable t
=> t (AspifLiteral s) -> GroundStatement s
assume lits = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawAspifLiteral . toList $ lits) $ \len arr ->
Raw.backendAssume h arr (fromIntegral len)
external :: Atom s -> ExternalType -> GroundStatement s
external a t = GStmt $ \(Backend h) -> marshall0 $
Raw.backendExternal h (rawAtom a) (rawExtT t)
heuristic :: (Foldable t)
=> Atom s
-> HeuristicType
-> Int
-> Natural
-> t (AspifLiteral s)
-> GroundStatement s
heuristic a t bias pri cs = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawAspifLiteral . toList $ cs) $ \len arr ->
Raw.backendHeuristic h (rawAtom a) (rawHeuT t)
(fromIntegral bias) (fromIntegral pri) arr (fromIntegral len)
minimize :: Foldable t
=> Integer
-> t (WeightedLiteral s)
-> GroundStatement s
minimize priority lits = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawWeightedLiteral . toList $ lits) $ \len arr ->
Raw.backendMinimize h (fromIntegral priority) arr (fromIntegral len)
rule :: Foldable t
=> Bool
-> t (Atom s)
-> t (AspifLiteral s)
-> GroundStatement s
rule choice hd bd = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawAtom . toList $ hd) $ \hlen harr ->
withArrayLen (map rawAspifLiteral . toList $ bd) $ \blen barr ->
Raw.backendRule h (fromBool choice) harr (fromIntegral hlen)
barr (fromIntegral blen)
weightedRule :: Foldable t
=> Bool
-> t (Atom s)
-> Natural
-> t (WeightedLiteral s)
-> GroundStatement s
weightedRule choice hd weight bd = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawAtom . toList $ hd) $ \hlen harr ->
withArrayLen (map rawWeightedLiteral . toList $ bd) $ \blen barr ->
Raw.backendWeightRule h (fromBool choice) harr (fromIntegral hlen)
(fromIntegral weight)
barr (fromIntegral blen)
project :: Foldable t
=> t (Atom s) -> GroundStatement s
project atoms = GStmt $ \(Backend h) -> marshall0 $
withArrayLen (map rawAtom . toList $ atoms) $ \len arr ->
Raw.backendProject h arr (fromIntegral len)
addGroundStatements :: Foldable t
=> Backend s
-> t (GroundStatement s)
-> Clingo s ()
addGroundStatements b xs = mapM_ (`addGStmt` b) (toList xs)
addStatements :: Traversable t
=> ProgramBuilder s
-> t (Statement (Symbol s) (Signature s))
-> Clingo s ()
addStatements (ProgramBuilder b) stmts = do
marshall0 (Raw.programBuilderBegin b)
mapM_ go stmts `finally` marshall0 (Raw.programBuilderEnd b)
where go stmt = do
stmt' <- liftIO (rawStatement stmt)
marshall0 $
with stmt' $ \ptr ->
Raw.programBuilderAdd b ptr
liftIO (freeStatement stmt')