{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE CPP #-}
module Control.Search.Language where
import Text.PrettyPrint
import Data.Monoid hiding ((<>))
import Prelude hiding ((<>))
import qualified Data.Semigroup as DS
import Data.Int
import qualified Data.Map as Map
import Data.Map (Map)
spacetype ModeFZ = "FlatZincSpace"
spacetype ModeGecode = "State"
spacetype ModeMCP = "MCPProgram"
xsspace fl@(PrettyFlags ModeFZ) x str = prettyX fl (PField x str)
xsspace fl@(PrettyFlags ModeMCP) x str = prettyX fl (PField x str)
xsspace fl@(PrettyFlags ModeGecode) x str = text "((VarAccessorSpace*)msg.space(" <> prettyX fl x <> text "))->" <> text str
instance Monoid Statement where
mempty = Skip
mappend = (>>>)
instance DS.Semigroup Statement where
(<>) = (>>>)
data GenMode = ModeUnk | ModeGecode | ModeFZ | ModeMCP
deriving Eq
data PrettyFlags = PrettyFlags { genMode :: GenMode }
deriving Eq
renderVar :: PrettyFlags -> Value -> Doc
renderVar f@(PrettyFlags { genMode = ModeFZ }) x = case x of
(AVarElem vs s i) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i))
(AVarSize vs s) -> text "VAR_" <> text vs <> text ".size()"
(BAVarElem vs s i) -> xsspace f s "bv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i))
(BAVarSize vs s) -> text "VAR_" <> text vs <> text ".size()"
(IVar vs s) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs)
where pr_ :: Value -> Doc
pr_ = prettyX f
renderVar f@(PrettyFlags { genMode = ModeGecode }) x = case x of
(AVarElem vs s i) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i)
(AVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")
(BAVarElem vs s i) -> xsspace f s "va.bv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i)
(BAVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")
(IVar vs s) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\""))
where pr_ :: Value -> Doc
pr_ = prettyX f
renderVar f@(PrettyFlags { genMode = ModeMCP }) x = case x of
(AVarElem vs s i) -> xsspace f s vs <> brackets (pretty i)
(AVarSize vs s) -> xsspace f s vs <> text ".size()"
(BAVarElem vs s i) -> xsspace f s vs <> brackets (pretty i)
(BAVarSize vs s) -> xsspace f s vs <> text ".size()"
(IVar vs s) -> xsspace f s vs
renderVar f@(PrettyFlags { genMode = ModeUnk }) _ = error "Cannot generate variable without render mode!"
class Pretty x where
prettyX :: PrettyFlags -> x -> Doc
pretty :: x -> Doc
prettyX _ = pretty
pretty = prettyX (PrettyFlags { genMode = ModeUnk })
data Struct = Struct String [(Type,String)] deriving (Show, Eq, Ord)
instance Pretty Struct where
prettyX x (Struct name fields) =
text "struct" <+> text name <+> text "{"
$+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields])
$+$ text "};"
data Type = Pointer Type
| SpaceType
| Int
| Bool
| Union [(Type,String)]
| SType Struct
| THook String
deriving (Show, Eq, Ord)
data Value = IVal Int32
| BVal Bool
| RootSpace
| Minus Value Value
| Plus Value Value
| Mult Value Value
| Div Value Value
| Mod Value Value
| Abs Value
| Var String
| Ref Value
| Deref Value
| Clone Value
| Field String String
| Field' Value String
| PField Value String
| Lt Value Value
| Gq Value Value
| Gt Value Value
| Eq Value Value
| BaseContinue
| And Value Value
| Or Value Value
| Not Value
| VHook String
| Max Value Value
| AVarElem String Value Value
| AVarSize String Value
| BAVarElem String Value Value
| BAVarSize String Value
| IVar String Value
| MinDom Value
| MaxDom Value
| Degree Value
| WDegree Value
| UbRegret Value
| LbRegret Value
| Median Value
| Random
| Null
| New Struct
| Base
| Cond Value Value Value
| Assigned Value
| Dummy Int
| MaxVal
| MinVal
deriving (Show, Eq, Ord)
instance Num Value where
(-) = Minus
fromInteger = IVal . fromInteger
(+) = Plus
(*) = Mult
abs = Abs
signum = error "signum is not defined for Value"
divValue (IVal x) (IVal y) = IVal (x `div` y)
divValue x y = Div x y
true = BVal True
false = BVal False
(&&&) = And
(|||) = Or
(@>) = Gt
(@>=) = Gq
x @<= y = y `Gq` x
(@==) = Eq
(@->) = Field'
(@=>) = PField
(@<) = Lt
lex cmps l1 l2 = foldr (\(x,y,cmp) r -> (x `cmp` y) ||| ((x @== y) &&& r)) false (zip3 l1 l2 cmps)
simplValue :: Value -> Value
simplValue (Cond c t e) =
let c' = simplValue c
t' = simplValue t
e' = simplValue e
in case (c',t',e') of
(BVal True, _, _) -> t'
(BVal False, _, _) -> e'
_ | t' == e' -> t'
_ -> Cond c' t' e'
simplValue (Minus (IVal x) (IVal y)) = IVal (x - y)
simplValue (Lt x y) = Lt (simplValue x) (simplValue y)
simplValue (Gq x y) = Gq (simplValue x) (simplValue y)
simplValue (And x y) =
let x' = simplValue x
y' = simplValue y
in case (x',y') of
(x, (BVal True)) -> x
(x, (BVal False)) -> BVal False
_ -> And x' y'
simplValue (Not x) =
let x' = simplValue x
in case x' of
(BVal True) -> BVal False
(BVal False) -> BVal True
_ -> Not x'
simplValue (PField (Ref x) f) = Field' (simplValue x) f
simplValue v = v
instance Pretty Type where
prettyX x (Pointer t) = prettyX x t <> text "*"
prettyX x SpaceType = text $ spacetype (genMode x)
prettyX x Int = text "int"
prettyX x Bool = text "bool"
prettyX x (Union fields) =
text "union" <+> text "{"
$+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields])
$+$ text "}"
prettyX x (SType (Struct name fields)) =
text name
prettyX x (THook str) =
text str
instance Pretty Value where
prettyX x = prettyX_ x . simplValue
where
prettyX_ :: PrettyFlags -> Value -> Doc
prettyX_ _ (Cond c t e) = pr_ c <+> text "?" <+> pr_ t <+> text ":" <+> pr_ e
prettyX_ _ Base = text "<BASE>"
prettyX_ _ Null = text "NULL"
prettyX_ _ (IVal i) = int $ fromInteger $ toInteger i
prettyX_ _ (BVal True) = text "true"
prettyX_ _ (BVal False) = text "false"
prettyX_ _ (Abs x) = text "abs" <> parens (pr_ x)
prettyX_ fl RootSpace = case (genMode fl) of
ModeFZ -> text "root"
ModeGecode -> text "mgr.root()"
ModeMCP -> text "root"
prettyX_ _ (Minus v1 v2) = pr_ v1 <+> text "-" <+> pr_ v2
prettyX_ _ (Plus v1 v2) = pr_ v1 <+> text "+" <+> pr_ v2
prettyX_ _ (Mult v1 v2) = pr_ v1 <+> text "*" <+> pr_ v2
prettyX_ _ (Div v1 v2) = parens (pr_ v1) <+> text "/" <+> parens (pr_ v2)
prettyX_ _ (Mod v1 v2) = parens (pr_ v1) <+> text "%" <+> parens (pr_ v2)
prettyX_ _ (Ref x) = parens $ text "&" <> parens (pr_ x)
prettyX_ _ (Deref x) = parens $ text "*" <> parens (pr_ x)
prettyX_ _ (Var x) = text x
prettyX_ f (Clone x) = text ("static_cast<" ++ spacetype (genMode f) ++ "*>(") <> pr_ x <> text "->clone(true))"
prettyX_ _ (Field r f) = text r <> text "." <> text f
prettyX_ _ (Field' r f) = pr_ r <> text "." <> text f
prettyX_ _ (PField r f) = pr_ r <> text "->" <> text f
prettyX_ _ (Lt x y) = parens (pr_ x) <+> text "<" <+> parens (pr_ y)
prettyX_ _ (Gq x y) = parens (pr_ x) <+> text ">=" <+> parens (pr_ y)
prettyX_ _ (Gt x y) = parens (pr_ x) <+> text ">" <+> parens (pr_ y)
prettyX_ _ (Eq x y) = parens (pr_ x) <+> text "==" <+> parens (pr_ y)
prettyX_ _ BaseContinue = text "!st->queue->empty()"
prettyX_ _ (And x y) = parens (pr_ x) <+> text "&&" <+> parens (pr_ y)
prettyX_ _ (Or x y) = parens (pr_ x) <+> text "||" <+> parens (pr_ y)
prettyX_ _ (Not x) = text "!" <> parens (pr_ x)
prettyX_ _ (VHook s) = text s
prettyX_ _ (Max x y) = text "max" <> parens (pr_ x <> text "," <> pr_ y)
prettyX_ e v@(AVarElem _ _ _) = renderVar e v
prettyX_ e v@(AVarSize _ _) = renderVar e v
prettyX_ e v@(BAVarElem _ _ _) = renderVar e v
prettyX_ e v@(BAVarSize _ _) = renderVar e v
prettyX_ e v@(IVar _ _) = renderVar e v
prettyX_ _ (MinDom v) = pr_ v <> text ".min()"
prettyX_ _ (MaxDom v) = pr_ v <> text ".max()"
prettyX_ _ (Degree v) = pr_ v <> text ".degree()"
prettyX_ _ (WDegree v) = pr_ v <> text ".afc()"
prettyX_ _ (UbRegret v) = pr_ v <> text ".regret_max()"
prettyX_ _ (LbRegret v) = pr_ v <> text ".regret_min()"
prettyX_ _ (Median v) = pr_ v <> text ".med()"
prettyX_ _ MaxVal = text "Gecode::Int::Limits::max"
prettyX_ _ MinVal = text "Gecode::Int::Limits::min"
prettyX_ _ Random = text "rand()"
prettyX_ _ (New (Struct name _)) = text "new" <+> text name
prettyX_ _ (Assigned var) = pr_ var <> text ".assigned()"
pr :: Value -> Doc
pr = prettyX x
pr_ :: Value -> Doc
pr_ = prettyX_ x
data Constraint = EqC Value Value
| NqC Value Value
| LtC Value Value
| LqC Value Value
| GtC Value Value
| GqC Value Value
| TrueC
| FalseC
deriving (Eq, Ord, Show)
($==) = EqC
($/=) = NqC
($<) = LtC
($<=) = LqC
($>) = GtC
($>=) = GqC
neg (EqC x y) = NqC x y
neg (NqC x y) = EqC x y
neg (LtC x y) = GqC x y
neg (LqC x y) = GtC x y
neg (GtC x y) = LqC x y
neg (GqC x y) = LtC x y
instance Pretty Constraint where
prettyX f (EqC x y) =
prettyX f x <> text "," <> text "IRT_EQ" <> text "," <> prettyX f y
prettyX f (NqC x y) =
prettyX f x <> text "," <> text "IRT_NQ" <> text "," <> prettyX f y
prettyX f (LtC x y) =
prettyX f x <> text "," <> text "IRT_LE" <> text "," <> prettyX f y
prettyX f (LqC x y) =
prettyX f x <> text "," <> text "IRT_LQ" <> text "," <> prettyX f y
prettyX f (GtC x y) =
prettyX f x <> text "," <> text "IRT_GR" <> text "," <> prettyX f y
prettyX f (GqC x y) =
prettyX f x <> text "," <> text "IRT_GQ" <> text "," <> prettyX f y
prettyX f TrueC = error "true constraint can't be posted directly"
prettyX f FalseC = error "false constraint can't be posted directly"
data Statement = IfThenElse Value Statement Statement
| Push Value
| Skip
| Seq Statement Statement
| Assign Value Value
| Abort
| Print Value [String]
| SHook String
| Post Value Constraint
| Fold String Value Value Value (Value -> Value) (Value -> Value -> Value)
| IFold String Value Value Value (Value -> Value) (Value -> Value -> Value)
| BFold String Value Value Value (Value -> Value) (Value -> Value -> Value)
| BIFold String Value Value Value (Value -> Value) (Value -> Value -> Value)
| Delete Value
| Block Statement Statement
| DebugOutput String
| DebugValue String Value
deriving (Eq,Ord,Show)
inliner :: (Statement -> Maybe Statement) -> Statement -> Statement
inliner f s =
case f s of
Just x -> inliner f x
Nothing -> case s of
IfThenElse v s1 s2 -> IfThenElse v (inliner f s1) (inliner f s2)
Seq s1 s2 -> Seq (inliner f s1) (inliner f s2)
Block s1 s2 -> Block s1 (inliner f s2)
_ -> s
instance Ord (Value -> Value) where
compare a b = compare (a (Dummy 0)) (b (Dummy 0))
instance Eq (Value -> Value) where
a == b = (a (Dummy 1)) == (b (Dummy 1))
instance Show (Value -> Value) where
show a = show (a (Dummy 1))
instance Ord (Value -> Value -> Value) where
compare a b = compare (a (Dummy 2) (Dummy 3)) (b (Dummy 2) (Dummy 3))
instance Eq (Value -> Value -> Value) where
a == b = (a (Dummy 4) (Dummy 5)) == (b (Dummy 4) (Dummy 5))
instance Show (Value -> Value -> Value) where
show a = show (a (Dummy 1) (Dummy 2))
comment str = SHook ("// " ++ str)
dec var = Assign var (var - 1)
inc var = Assign var (var + 1)
(>>>) = Seq
(<==) = Assign
assign = flip Assign
ifthen c t = IfThenElse c t Skip
seqs = foldr (>>>) Skip
simplStmt :: Statement -> Statement
simplStmt (IfThenElse c t e)
= let c' = simplValue c
t' = simplStmt t
e' = simplStmt e
in go c' t' e'
where go (BVal True) t e = t
go (BVal False) t e = e
go c t e | t == e = t
go c Skip e = simplStmt $ IfThenElse (Not c) e t
go c1 (IfThenElse c2 t2 e2) e1
| e1 == e2 = simplStmt $ IfThenElse (c1 &&& c2) t2 e1
go c t e = IfThenElse c t e
simplStmt (Assign x y) | x==y = Skip
simplStmt (Seq Skip a) = simplStmt a
simplStmt (Seq a Skip) = simplStmt a
simplStmt s = s
instance Pretty Statement where
prettyX x = prettyX_ . simplStmt
where
prettyX_ (Push tstate) =
text "st->queue->push_back" <> parens (pr tstate) <> text ";"
prettyX_ (IfThenElse c t Skip) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "}"
prettyX_ (IfThenElse c t e) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "} else {" $+$ nest 2 (pr_ e) $+$ text "}"
prettyX_ Skip =
empty
prettyX_ (Assign var (Minus val 1))
| var == val
= pr var <> text "--;"
prettyX_ (Assign var (Plus val 1))
| var == val
= pr var <> text "++;"
prettyX_ (Block s1 s2) = pr s1 <+> text "{" $+$ nest 2 (pr s2) $+$ text "}"
prettyX_ (Seq s1 s2) =
pr s1 $+$ pr s2
prettyX_ (Assign x Null) = pr x <> text ";"
prettyX_ (Assign x y) = let y' = simplValue y
in if x == y'
then pr Skip
else pr x <+> text "=" <+> pr y' <> text ";"
prettyX_ Abort =
text "break;"
prettyX_ (Print space vs) =
(vcat $ map (\s -> text "std::cout << \"[\"; for (int i=0; i<" <> pr (AVarSize s space) <> text "; i++) { std::cout << " <> pr (AVarElem s space (Var "i")) <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;"
prettyX_ (DebugOutput str) =
text "cout << " <> text (show str) <> text " << endl;"
prettyX_ (DebugValue str val) =
text "cout << " <> text (show $ str ++ ": ") <> text " << " <> pr val <> text " << endl;"
prettyX_ (SHook s) =
text s
prettyX_ (Post space FalseC) = pr space <> text "->fail();"
prettyX_ (Post space TrueC) = empty
prettyX_ (Post space c) =
text "rel(*" <> parens (pr space) <> text "," <> pr c <> text ");"
prettyX_ (Fold vars state space m0 metric better) =
let
pos = Field' state "pos"
size = AVarSize vars space
in
text "int best_pos = -1;"
$+$ pr (Assign pos 0)
$+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"
$+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{"
$+$ nest 2 ( text "int current_metric = " <> pr (metric (AVarElem vars space pos)) <> text ";"
$+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")
(Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))
Skip
)
)
$+$ text "}"
)
$+$ text "}"
$+$ pr (Assign pos (Var "best_pos"))
prettyX_ (IFold vars state space m0 metric better) =
let
pos = Field' state "pos"
size = AVarSize vars state
in
text "int best_pos = -1;"
$+$ pr (Assign pos 0)
$+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"
$+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{"
$+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";"
$+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")
(Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))
Skip
)
)
$+$ text "}"
)
$+$ text "}"
$+$ pr (Assign pos (Var "best_pos"))
prettyX_ (BFold vars state space m0 metric better) =
let
pos = Field' state "pos"
size = BAVarSize vars space
in
text "int best_pos = -1;"
$+$ pr (Assign pos 0)
$+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"
$+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{"
$+$ nest 2 ( text "int current_metric = " <> pr (metric (BAVarElem vars space pos)) <> text ";"
$+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")
(Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))
Skip
)
)
$+$ text "}"
)
$+$ text "}"
$+$ pr (Assign pos (Var "best_pos"))
prettyX_ (BIFold vars state space m0 metric better) =
let
pos = Field' state "pos"
size = BAVarSize vars space
in
text "int best_pos = -1;"
$+$ pr (Assign pos 0)
$+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"
$+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{"
$+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";"
$+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")
(Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))
Skip
)
)
$+$ text "}"
)
$+$ text "}"
$+$ pr (Assign pos (Var "best_pos"))
prettyX_ (Delete value) =
text "delete" <+> pr value <> text ";"
pr :: Pretty x => x -> Doc
pr = prettyX x
pr_ :: Statement -> Doc
pr_ = prettyX_
class Simplifiable a where
simplify :: a -> a
instance Simplifiable Statement where
simplify = simplStmt
instance Simplifiable Value where
simplify = simplValue