module Csound.Dynamic.Build.Logic(
when1, whens,
ifBegin, ifEnd, elseBegin, elseIfBegin
) where
import Control.Monad.Trans.State(State, state, evalState)
import qualified Data.IntMap as IM(fromList)
import Data.Boolean
import Csound.Dynamic.Types
import Csound.Dynamic.Build(onExp, toExp)
when1 :: Monad m => E -> DepT m () -> DepT m ()
when1 p body = do
ifBegin p
body
ifEnd
whens :: Monad m => [(E, DepT m ())] -> DepT m () -> DepT m ()
whens bodies el = case bodies of
[] -> el
a:as -> do
ifBegin (fst a)
snd a
elseIfs as
elseBegin
el
ifEnd
where elseIfs = mapM_ (\(p, body) -> elseIfBegin p >> body)
ifBegin :: Monad m => E -> DepT m ()
ifBegin = withCond IfBegin
elseIfBegin :: Monad m => E -> DepT m ()
elseIfBegin = withCond ElseIfBegin
elseBegin :: Monad m => DepT m ()
elseBegin = stmtOnlyT ElseBegin
ifEnd :: Monad m => DepT m ()
ifEnd = stmtOnlyT IfEnd
withCond :: Monad m => (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()
withCond stmt p = depT_ $ noRate $ stmt (condInfo p)
instance Boolean E where
true = boolOp0 TrueOp
false = boolOp0 FalseOp
notB = notE
(&&*) = boolOp2 And
(||*) = boolOp2 Or
type instance BooleanOf E = E
instance IfB E where
ifB = condExp
instance EqB E where
(==*) = boolOp2 Equals
(/=*) = boolOp2 NotEquals
instance OrdB E where
(<*) = boolOp2 Less
(>*) = boolOp2 Greater
(<=*) = boolOp2 LessEquals
(>=*) = boolOp2 GreaterEquals
boolExp :: a -> [b] -> PreInline a b
boolExp = PreInline
condExp :: E -> E -> E -> E
condExp = mkCond . condInfo
where mkCond :: CondInfo (PrimOr E) -> E -> E -> E
mkCond pr th el
| isTrue pr = th
| isFalse pr = el
| otherwise = noRate $ If pr (toPrimOr th) (toPrimOr el)
condInfo :: E -> CondInfo (PrimOr E)
condInfo p = go $ toPrimOr p
where
go :: PrimOr E -> CondInfo (PrimOr E)
go expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0
condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e
onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1)
onExpr _ (op, args) = fmap mkNode $ mapM condInfo' args
where mkNode as = (InlineExp op (map fst as), concat $ map snd as)
parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])
parseNode x = case unPrimOr $ fmap toExp x of
Right (ExpBool (PreInline op args)) -> Just (op, args)
_ -> Nothing
boolOps :: CondOp -> [E] -> E
boolOps op as = noRate $ ExpBool $ boolExp op $ fmap toPrimOr as
boolOp0 :: CondOp -> E
boolOp2 :: CondOp -> E -> E -> E
boolOp0 op = boolOps op []
boolOp2 op a b = boolOps op [a, b]
notE :: E -> E
notE x = onExp phi x
where phi (ExpBool (PreInline op args)) = ExpBool $ case op of
TrueOp -> boolExp FalseOp []
FalseOp -> boolExp TrueOp []
And -> boolExp Or $ fmap (fmap notE) args
Or -> boolExp And $ fmap (fmap notE) args
Equals -> boolExp NotEquals args
NotEquals -> boolExp Equals args
Less -> boolExp GreaterEquals args
Greater -> boolExp LessEquals args
LessEquals -> boolExp Greater args
GreaterEquals -> boolExp Less args
phi _ = error "Logic.hs:notE - expression is not Boolean"