{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
-- | Boolean instances
module Csound.Dynamic.Build.Logic(
    when1, whens,
    ifExp,
    ifElseBlock,
    -- ifBegin, ifEnd, elseBegin,
    untilBlock,
    whileBlock,

    -- untilDo,
    -- untilBegin, untilEnd,
    -- whileDo,
    -- whileBegin,
    whileRef, whileEnd
) where

import Control.Monad
import Control.Monad.Trans.State.Strict (State, state, evalState, runStateT, StateT(..))
import qualified Data.IntMap as IM(fromList)

import Data.Boolean
import Csound.Dynamic.Types
import Csound.Dynamic.Build(onExp, toExp)
import Data.List qualified as List
import Data.Fix

ifT :: forall m . Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E
ifT :: forall (m :: * -> *).
Monad m =>
IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E
ifT IfRate
ifRate E
check (DepT StateT LocalHistory m (CodeBlock E)
th) (DepT StateT LocalHistory m (CodeBlock E)
el) = StateT LocalHistory m E -> DepT m E
forall (m :: * -> *) a. StateT LocalHistory m a -> DepT m a
DepT (StateT LocalHistory m E -> DepT m E)
-> StateT LocalHistory m E -> DepT m E
forall a b. (a -> b) -> a -> b
$ (LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E)
-> (LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E
forall a b. (a -> b) -> a -> b
$ \LocalHistory
s -> do
  (CodeBlock E
_thE, LocalHistory
thS) <- StateT LocalHistory m (CodeBlock E)
-> LocalHistory -> m (CodeBlock E, LocalHistory)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT LocalHistory m (CodeBlock E)
th (LocalHistory -> LocalHistory
startSt LocalHistory
s)
  (CodeBlock E
_elE, LocalHistory
elS) <- StateT LocalHistory m (CodeBlock E)
-> LocalHistory -> m (CodeBlock E, LocalHistory)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT LocalHistory m (CodeBlock E)
el (LocalHistory -> LocalHistory
startSt LocalHistory
thS)
  let thDeps :: E
thDeps = LocalHistory -> E
expDependency LocalHistory
thS
      elDeps :: E
elDeps = LocalHistory -> E
expDependency LocalHistory
elS
      a :: E
a  = Exp E -> E
noRate (Exp E -> E) -> Exp E -> E
forall a b. (a -> b) -> a -> b
$ IfRate
-> CondInfo (PrimOr E)
-> CodeBlock (PrimOr E)
-> CodeBlock (PrimOr E)
-> Exp E
forall a.
IfRate -> CondInfo a -> CodeBlock a -> CodeBlock a -> MainExp a
IfElseBlock IfRate
ifRate (E -> CondInfo (PrimOr E)
condInfo (E -> CondInfo (PrimOr E)) -> E -> CondInfo (PrimOr E)
forall a b. (a -> b) -> a -> b
$ IfRate -> E -> E
setIfRate IfRate
ifRate E
check) (PrimOr E -> CodeBlock (PrimOr E)
forall a. a -> CodeBlock a
CodeBlock (PrimOr E -> CodeBlock (PrimOr E))
-> PrimOr E -> CodeBlock (PrimOr E)
forall a b. (a -> b) -> a -> b
$ Either Prim E -> PrimOr E
forall a. Either Prim a -> PrimOr a
PrimOr (Either Prim E -> PrimOr E) -> Either Prim E -> PrimOr E
forall a b. (a -> b) -> a -> b
$ E -> Either Prim E
forall a b. b -> Either a b
Right E
thDeps) (PrimOr E -> CodeBlock (PrimOr E)
forall a. a -> CodeBlock a
CodeBlock (PrimOr E -> CodeBlock (PrimOr E))
-> PrimOr E -> CodeBlock (PrimOr E)
forall a b. (a -> b) -> a -> b
$ Either Prim E -> PrimOr E
forall a. Either Prim a -> PrimOr a
PrimOr (Either Prim E -> PrimOr E) -> Either Prim E -> PrimOr E
forall a b. (a -> b) -> a -> b
$ E -> Either Prim E
forall a b. b -> Either a b
Right E
elDeps)
      a1 :: E
a1 = E -> E
rehashE (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ RatedExp E -> E
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (RatedExp E -> E) -> RatedExp E -> E
forall a b. (a -> b) -> a -> b
$ (E -> RatedExp E
forall (f :: * -> *). Fix f -> f (Fix f)
unFix E
a) { ratedExpDepends = Just (newLineNum elS) }
      s1 :: LocalHistory
s1 = LocalHistory
elS
            { newLineNum = succ $ newLineNum elS
            , expDependency = a1
            -- depends (expDependency thS) (depends (expDependency elS) a1)
            }
  (E, LocalHistory) -> m (E, LocalHistory)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (E
a1, LocalHistory
s1)
  where
    startSt :: LocalHistory -> LocalHistory
startSt LocalHistory
s = LocalHistory
s
      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }
      , newLineNum = succ $ newLineNum s
      }


ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E

ifT1 :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1 = (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
(IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E
forall a. IfRate -> CondInfo a -> CodeBlock a -> MainExp a
IfBlock
untilT :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
untilT = (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
(IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E
forall a. IfRate -> CondInfo a -> CodeBlock a -> MainExp a
UntilBlock
whileT :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
whileT = (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
(IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E
forall a. IfRate -> CondInfo a -> CodeBlock a -> MainExp a
WhileBlock

ifT1By :: Monad m
  => (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
  -> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By :: forall (m :: * -> *).
Monad m =>
(IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
-> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E
cons IfRate
ifRate E
check (DepT StateT LocalHistory m (CodeBlock E)
th) = StateT LocalHistory m E -> DepT m E
forall (m :: * -> *) a. StateT LocalHistory m a -> DepT m a
DepT (StateT LocalHistory m E -> DepT m E)
-> StateT LocalHistory m E -> DepT m E
forall a b. (a -> b) -> a -> b
$ (LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E)
-> (LocalHistory -> m (E, LocalHistory)) -> StateT LocalHistory m E
forall a b. (a -> b) -> a -> b
$ \LocalHistory
s -> do
  (CodeBlock E
_thE, LocalHistory
thS)  <- StateT LocalHistory m (CodeBlock E)
-> LocalHistory -> m (CodeBlock E, LocalHistory)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT LocalHistory m (CodeBlock E)
th (LocalHistory -> LocalHistory
startSt LocalHistory
s)
  let thDeps :: E
thDeps = LocalHistory -> E
expDependency LocalHistory
thS
      a :: E
a  = Exp E -> E
noRate (Exp E -> E) -> Exp E -> E
forall a b. (a -> b) -> a -> b
$ IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E
cons IfRate
ifRate (E -> CondInfo (PrimOr E)
condInfo (E -> CondInfo (PrimOr E)) -> E -> CondInfo (PrimOr E)
forall a b. (a -> b) -> a -> b
$ IfRate -> E -> E
setIfRate IfRate
ifRate E
check) (PrimOr E -> CodeBlock (PrimOr E)
forall a. a -> CodeBlock a
CodeBlock (PrimOr E -> CodeBlock (PrimOr E))
-> PrimOr E -> CodeBlock (PrimOr E)
forall a b. (a -> b) -> a -> b
$ Either Prim E -> PrimOr E
forall a. Either Prim a -> PrimOr a
PrimOr (Either Prim E -> PrimOr E) -> Either Prim E -> PrimOr E
forall a b. (a -> b) -> a -> b
$ E -> Either Prim E
forall a b. b -> Either a b
Right E
thDeps)
      a1 :: E
a1 = E -> E
rehashE (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ RatedExp E -> E
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (RatedExp E -> E) -> RatedExp E -> E
forall a b. (a -> b) -> a -> b
$ (E -> RatedExp E
forall (f :: * -> *). Fix f -> f (Fix f)
unFix E
a) { ratedExpDepends = Just (newLineNum thS) }
      s1 :: LocalHistory
s1 = LocalHistory
thS
            { newLineNum = succ $ newLineNum thS
            , expDependency = a1
            -- depends (expDependency thS) (depends (expDependency elS) a1)
            }
  (E, LocalHistory) -> m (E, LocalHistory)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (E
a1, LocalHistory
s1)
  where
    startSt :: LocalHistory -> LocalHistory
startSt LocalHistory
s = LocalHistory
s
      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }
      , newLineNum = succ $ newLineNum s
      }



------------------------------------------------------
-- imperative if-then-else

setIfRate :: IfRate -> E -> E
setIfRate :: IfRate -> E -> E
setIfRate IfRate
rate = Rate -> E -> E
setRate (IfRate -> Rate
fromIfRate IfRate
rate)

when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
when1 :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
when1 IfRate
ifRate E
p DepT m (CodeBlock E)
body = DepT m E -> DepT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DepT m E -> DepT m ()) -> DepT m E -> DepT m ()
forall a b. (a -> b) -> a -> b
$ IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1 IfRate
ifRate E
p DepT m (CodeBlock E)
body

whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()
whens :: forall (m :: * -> *).
Monad m =>
IfRate
-> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()
whens IfRate
rate [(E, DepT m (CodeBlock E))]
bodies DepT m (CodeBlock E)
el =
  DepT m (CodeBlock E) -> DepT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DepT m (CodeBlock E) -> DepT m ())
-> DepT m (CodeBlock E) -> DepT m ()
forall a b. (a -> b) -> a -> b
$ (DepT m (CodeBlock E)
 -> (E, DepT m (CodeBlock E)) -> DepT m (CodeBlock E))
-> DepT m (CodeBlock E)
-> [(E, DepT m (CodeBlock E))]
-> DepT m (CodeBlock E)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' DepT m (CodeBlock E)
-> (E, DepT m (CodeBlock E)) -> DepT m (CodeBlock E)
go DepT m (CodeBlock E)
el ([(E, DepT m (CodeBlock E))] -> [(E, DepT m (CodeBlock E))]
forall a. [a] -> [a]
List.reverse [(E, DepT m (CodeBlock E))]
bodies)
  where
    go :: DepT m (CodeBlock E)
-> (E, DepT m (CodeBlock E)) -> DepT m (CodeBlock E)
go DepT m (CodeBlock E)
res (E
check, DepT m (CodeBlock E)
th) = E -> CodeBlock E
forall a. a -> CodeBlock a
CodeBlock (E -> CodeBlock E) -> DepT m E -> DepT m (CodeBlock E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E
ifT IfRate
rate E
check DepT m (CodeBlock E)
th DepT m (CodeBlock E)
res

ifElseBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
ifElseBlock :: forall (m :: * -> *).
Monad m =>
IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
ifElseBlock IfRate
rate E
p DepT m (CodeBlock E)
th DepT m (CodeBlock E)
el = DepT m () -> DepT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DepT m () -> DepT m ()) -> DepT m () -> DepT m ()
forall a b. (a -> b) -> a -> b
$ IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
forall (m :: * -> *).
Monad m =>
IfRate
-> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
ifElseBlock IfRate
rate E
p DepT m (CodeBlock E)
th DepT m (CodeBlock E)
el

{-
ifElseBlock' :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m (CodeBlock E)
ifElseBlock' ifRate p th el = do
  thE <- th
  elE <- el
  fmap CodeBlock $ depT $ noRate $
    IfElseBlock ifRate
      (condInfo $ setIfRate ifRate p)
      (PrimOr . Right <$> thE)
      (PrimOr . Right <$> elE)
-}
-- withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)

{-
ifBegin :: Monad m => IfRate -> E -> DepT m ()
ifBegin ifRate = withCond ifRate $ (IfBegin ifRate)

elseBegin :: Monad m => DepT m ()
elseBegin = stmtOnlyT ElseBegin

ifEnd :: Monad m => DepT m ()
ifEnd = stmtOnlyT IfEnd
-}

untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
untilBlock :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
untilBlock IfRate
ifRate E
p DepT m (CodeBlock E)
body = DepT m E -> DepT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DepT m E -> DepT m ()) -> DepT m E -> DepT m ()
forall a b. (a -> b) -> a -> b
$ IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
untilT IfRate
ifRate E
p DepT m (CodeBlock E)
body

whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
whileBlock :: forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
whileBlock IfRate
ifRate E
p DepT m (CodeBlock E)
body = DepT m E -> DepT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DepT m E -> DepT m ()) -> DepT m E -> DepT m ()
forall a b. (a -> b) -> a -> b
$ IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
forall (m :: * -> *).
Monad m =>
IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
whileT IfRate
ifRate E
p DepT m (CodeBlock E)
body

{-
untilDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
untilDo ifRate p body = do
    untilBegin ifRate p
    body
    untilEnd

untilBegin :: Monad m => IfRate -> E -> DepT m ()
untilBegin ifRate = withCond ifRate (UntilBegin ifRate)

untilEnd :: Monad m => DepT m ()
untilEnd = stmtOnlyT UntilEnd
-}

{-
whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
whileDo ifRate p body = do
    whileBegin ifRate p
    body
    whileEnd

whileBegin :: Monad m => IfRate -> E -> DepT m ()
whileBegin ifRate = withCond IfKr (WhileBegin ifRate)
-}

whileRef :: Monad m => Var -> DepT m ()
whileRef :: forall (m :: * -> *). Monad m => Var -> DepT m ()
whileRef Var
var = Exp E -> DepT m ()
forall (m :: * -> *). Monad m => Exp E -> DepT m ()
stmtOnlyT (Exp E -> DepT m ()) -> Exp E -> DepT m ()
forall a b. (a -> b) -> a -> b
$ Var -> Exp E
forall a. Var -> MainExp a
WhileRefBegin Var
var

whileEnd :: Monad m => DepT m ()
whileEnd :: forall (m :: * -> *). Monad m => DepT m ()
whileEnd = Exp E -> DepT m ()
forall (m :: * -> *). Monad m => Exp E -> DepT m ()
stmtOnlyT Exp E
forall a. MainExp a
WhileEnd

{-
withCond :: Monad m => IfRate -> (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()
withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)
-}

instance Boolean E where
    true :: E
true = CondOp -> E
boolOp0 CondOp
TrueOp
    false :: E
false = CondOp -> E
boolOp0 CondOp
FalseOp
    notB :: E -> E
notB = E -> E
notE
    &&* :: E -> E -> E
(&&*) = CondOp -> E -> E -> E
boolOp2 CondOp
And
    ||* :: E -> E -> E
(||*) = CondOp -> E -> E -> E
boolOp2 CondOp
Or

-- instances

type instance BooleanOf E = E

instance EqB E where
    ==* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(==*) = CondOp -> E -> E -> E
boolOp2 CondOp
Equals
    /=* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(/=*) = CondOp -> E -> E -> E
boolOp2 CondOp
NotEquals

instance OrdB E where
    <* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(<*) = CondOp -> E -> E -> E
boolOp2 CondOp
Less
    >* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(>*) = CondOp -> E -> E -> E
boolOp2 CondOp
Greater
    <=* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(<=*) = CondOp -> E -> E -> E
boolOp2 CondOp
LessEquals
    >=* :: forall bool. (bool ~ BooleanOf E) => E -> E -> bool
(>=*) = CondOp -> E -> E -> E
boolOp2 CondOp
GreaterEquals

--------------------------------------------------------------------------
-- if-then-else
--
-- performs inlining of the boolean expressions

boolExp :: a -> [b] -> PreInline a b
boolExp :: forall a b. a -> [b] -> PreInline a b
boolExp = a -> [b] -> PreInline a b
forall a b. a -> [b] -> PreInline a b
PreInline

ifExp :: IfRate -> E -> E -> E -> E
ifExp :: IfRate -> E -> E -> E -> E
ifExp IfRate
ifRate E
c = CondInfo (PrimOr E) -> E -> E -> E
mkCond (E -> CondInfo (PrimOr E)
condInfo (IfRate -> E -> E
setIfRate IfRate
ifRate E
c))
    where mkCond :: CondInfo (PrimOr E) -> E -> E -> E
          mkCond :: CondInfo (PrimOr E) -> E -> E -> E
mkCond CondInfo (PrimOr E)
pr E
th E
el
            | CondInfo (PrimOr E) -> Bool
forall a. CondInfo a -> Bool
isTrue CondInfo (PrimOr E)
pr = E
th
            | CondInfo (PrimOr E) -> Bool
forall a. CondInfo a -> Bool
isFalse CondInfo (PrimOr E)
pr = E
el
            | Bool
otherwise = Exp E -> E
noRate (Exp E -> E) -> Exp E -> E
forall a b. (a -> b) -> a -> b
$ IfRate -> CondInfo (PrimOr E) -> PrimOr E -> PrimOr E -> Exp E
forall a. IfRate -> CondInfo a -> a -> a -> MainExp a
If IfRate
ifRate CondInfo (PrimOr E)
pr (E -> PrimOr E
toPrimOr E
th) (E -> PrimOr E
toPrimOr E
el)

condInfo :: E -> CondInfo (PrimOr E)
condInfo :: E -> CondInfo (PrimOr E)
condInfo E
p = PrimOr E -> CondInfo (PrimOr E)
go (PrimOr E -> CondInfo (PrimOr E))
-> PrimOr E -> CondInfo (PrimOr E)
forall a b. (a -> b) -> a -> b
$ E -> PrimOr E
toPrimOr E
p
    where
        go :: PrimOr E -> CondInfo (PrimOr E)
        go :: PrimOr E -> CondInfo (PrimOr E)
go PrimOr E
expr = (\(InlineExp CondOp
a, [(Int, PrimOr E)]
b) -> InlineExp CondOp -> IntMap (PrimOr E) -> CondInfo (PrimOr E)
forall op arg. InlineExp op -> IntMap arg -> Inline op arg
Inline InlineExp CondOp
a ([(Int, PrimOr E)] -> IntMap (PrimOr E)
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int, PrimOr E)]
b)) ((InlineExp CondOp, [(Int, PrimOr E)]) -> CondInfo (PrimOr E))
-> (InlineExp CondOp, [(Int, PrimOr E)]) -> CondInfo (PrimOr E)
forall a b. (a -> b) -> a -> b
$ State Int (InlineExp CondOp, [(Int, PrimOr E)])
-> Int -> (InlineExp CondOp, [(Int, PrimOr E)])
forall s a. State s a -> s -> a
evalState (PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
condInfo' PrimOr E
expr) Int
0

        condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
        condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
condInfo' PrimOr E
e = State Int (InlineExp CondOp, [(Int, PrimOr E)])
-> ((CondOp, [PrimOr E])
    -> State Int (InlineExp CondOp, [(Int, PrimOr E)]))
-> Maybe (CondOp, [PrimOr E])
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall {m :: * -> *} {b} {op}.
Monad m =>
b -> StateT Int m (InlineExp op, [(Int, b)])
onLeaf PrimOr E
e) (PrimOr E
-> (CondOp, [PrimOr E])
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall {p}.
p
-> (CondOp, [PrimOr E])
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
onExpr PrimOr E
e) (Maybe (CondOp, [PrimOr E])
 -> State Int (InlineExp CondOp, [(Int, PrimOr E)]))
-> Maybe (CondOp, [PrimOr E])
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall a b. (a -> b) -> a -> b
$ PrimOr E -> Maybe (CondOp, [PrimOr E])
parseNode PrimOr E
e

        onLeaf :: b -> StateT Int m (InlineExp op, [(Int, b)])
onLeaf b
e = (Int -> ((InlineExp op, [(Int, b)]), Int))
-> StateT Int m (InlineExp op, [(Int, b)])
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int -> ((InlineExp op, [(Int, b)]), Int))
 -> StateT Int m (InlineExp op, [(Int, b)]))
-> (Int -> ((InlineExp op, [(Int, b)]), Int))
-> StateT Int m (InlineExp op, [(Int, b)])
forall a b. (a -> b) -> a -> b
$ \Int
n -> ((Int -> InlineExp op
forall op. Int -> InlineExp op
InlinePrim Int
n, [(Int
n, b
e)]), Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

        onExpr :: p
-> (CondOp, [PrimOr E])
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
onExpr  p
_ (CondOp
op, [PrimOr E]
args) = ([(InlineExp CondOp, [(Int, PrimOr E)])]
 -> (InlineExp CondOp, [(Int, PrimOr E)]))
-> StateT Int Identity [(InlineExp CondOp, [(Int, PrimOr E)])]
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall a b.
(a -> b) -> StateT Int Identity a -> StateT Int Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(InlineExp CondOp, [(Int, PrimOr E)])]
-> (InlineExp CondOp, [(Int, PrimOr E)])
mkNode (StateT Int Identity [(InlineExp CondOp, [(Int, PrimOr E)])]
 -> State Int (InlineExp CondOp, [(Int, PrimOr E)]))
-> StateT Int Identity [(InlineExp CondOp, [(Int, PrimOr E)])]
-> State Int (InlineExp CondOp, [(Int, PrimOr E)])
forall a b. (a -> b) -> a -> b
$ (PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)]))
-> [PrimOr E]
-> StateT Int Identity [(InlineExp CondOp, [(Int, PrimOr E)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
condInfo' [PrimOr E]
args
            where mkNode :: [(InlineExp CondOp, [(Int, PrimOr E)])]
-> (InlineExp CondOp, [(Int, PrimOr E)])
mkNode [(InlineExp CondOp, [(Int, PrimOr E)])]
as = (CondOp -> [InlineExp CondOp] -> InlineExp CondOp
forall op. op -> [InlineExp op] -> InlineExp op
InlineExp CondOp
op (((InlineExp CondOp, [(Int, PrimOr E)]) -> InlineExp CondOp)
-> [(InlineExp CondOp, [(Int, PrimOr E)])] -> [InlineExp CondOp]
forall a b. (a -> b) -> [a] -> [b]
map (InlineExp CondOp, [(Int, PrimOr E)]) -> InlineExp CondOp
forall a b. (a, b) -> a
fst [(InlineExp CondOp, [(Int, PrimOr E)])]
as), [[(Int, PrimOr E)]] -> [(Int, PrimOr E)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Int, PrimOr E)]] -> [(Int, PrimOr E)])
-> [[(Int, PrimOr E)]] -> [(Int, PrimOr E)]
forall a b. (a -> b) -> a -> b
$ ((InlineExp CondOp, [(Int, PrimOr E)]) -> [(Int, PrimOr E)])
-> [(InlineExp CondOp, [(Int, PrimOr E)])] -> [[(Int, PrimOr E)]]
forall a b. (a -> b) -> [a] -> [b]
map (InlineExp CondOp, [(Int, PrimOr E)]) -> [(Int, PrimOr E)]
forall a b. (a, b) -> b
snd [(InlineExp CondOp, [(Int, PrimOr E)])]
as)

        parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])
        parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])
parseNode PrimOr E
x = case PrimOr (Exp E) -> Either Prim (Exp E)
forall a. PrimOr a -> Either Prim a
unPrimOr (PrimOr (Exp E) -> Either Prim (Exp E))
-> PrimOr (Exp E) -> Either Prim (Exp E)
forall a b. (a -> b) -> a -> b
$ (E -> Exp E) -> PrimOr E -> PrimOr (Exp E)
forall a b. (a -> b) -> PrimOr a -> PrimOr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> Exp E
toExp PrimOr E
x of
          Right (ExpBool (PreInline CondOp
op [PrimOr E]
args)) -> (CondOp, [PrimOr E]) -> Maybe (CondOp, [PrimOr E])
forall a. a -> Maybe a
Just (CondOp
op, [PrimOr E]
args)
          Either Prim (Exp E)
_ -> Maybe (CondOp, [PrimOr E])
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- constructors for boolean expressions

boolOps :: CondOp -> [E] -> E
boolOps :: CondOp -> [E] -> E
boolOps CondOp
op [E]
as = Exp E -> E
noRate (Exp E -> E) -> Exp E -> E
forall a b. (a -> b) -> a -> b
$ PreInline CondOp (PrimOr E) -> Exp E
forall a. BoolExp a -> MainExp a
ExpBool (PreInline CondOp (PrimOr E) -> Exp E)
-> PreInline CondOp (PrimOr E) -> Exp E
forall a b. (a -> b) -> a -> b
$ CondOp -> [PrimOr E] -> PreInline CondOp (PrimOr E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
op ([PrimOr E] -> PreInline CondOp (PrimOr E))
-> [PrimOr E] -> PreInline CondOp (PrimOr E)
forall a b. (a -> b) -> a -> b
$ (E -> PrimOr E) -> [E] -> [PrimOr E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> PrimOr E
toPrimOr [E]
as

boolOp0 :: CondOp -> E
boolOp2 :: CondOp -> E -> E -> E

boolOp0 :: CondOp -> E
boolOp0 CondOp
op = CondOp -> [E] -> E
boolOps CondOp
op []

boolOp2 :: CondOp -> E -> E -> E
boolOp2 CondOp
op E
a E
b = CondOp -> [E] -> E
boolOps CondOp
op [E
a, E
b]

-----------------------------------------------------------------------------
-- no support for not in csound so we perform not-elimination
notE :: E -> E
notE :: E -> E
notE E
x = (Exp E -> Exp E) -> E -> E
onExp Exp E -> Exp E
forall {f :: * -> *}. Functor f => MainExp (f E) -> MainExp (f E)
phi E
x
    where phi :: MainExp (f E) -> MainExp (f E)
phi (ExpBool (PreInline CondOp
op [f E]
args)) = PreInline CondOp (f E) -> MainExp (f E)
forall a. BoolExp a -> MainExp a
ExpBool (PreInline CondOp (f E) -> MainExp (f E))
-> PreInline CondOp (f E) -> MainExp (f E)
forall a b. (a -> b) -> a -> b
$ case CondOp
op of
            CondOp
TrueOp            -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
FalseOp        []
            CondOp
FalseOp           -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
TrueOp         []
            CondOp
And               -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
Or             ([f E] -> PreInline CondOp (f E))
-> [f E] -> PreInline CondOp (f E)
forall a b. (a -> b) -> a -> b
$ (f E -> f E) -> [f E] -> [f E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((E -> E) -> f E -> f E
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
notE) [f E]
args
            CondOp
Or                -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
And            ([f E] -> PreInline CondOp (f E))
-> [f E] -> PreInline CondOp (f E)
forall a b. (a -> b) -> a -> b
$ (f E -> f E) -> [f E] -> [f E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((E -> E) -> f E -> f E
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
notE) [f E]
args
            CondOp
Equals            -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
NotEquals      [f E]
args
            CondOp
NotEquals         -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
Equals         [f E]
args
            CondOp
Less              -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
GreaterEquals  [f E]
args
            CondOp
Greater           -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
LessEquals     [f E]
args
            CondOp
LessEquals        -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
Greater        [f E]
args
            CondOp
GreaterEquals     -> CondOp -> [f E] -> PreInline CondOp (f E)
forall a b. a -> [b] -> PreInline a b
boolExp CondOp
Less           [f E]
args

          phi MainExp (f E)
_ = [Char] -> MainExp (f E)
forall a. HasCallStack => [Char] -> a
error [Char]
"Logic.hs:notE - expression is not Boolean"