{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}

module CsoundExpr.Translator.Cs.CsBoolean (CsBool) 
where

import Data.Boolean
import CsoundExpr.Translator.Cs.CsTree
import CsoundExpr.Translator.ExprTree.ExprTree

----------------------------------------------
-- low level operations

mkAnd, mkOr :: CsTree -> CsTree -> CsTree

mkAnd a b = pure (oprInfix "&&") [a, b]
mkOr  a b = pure (oprInfix "||") [a, b]

mkComp :: CompOp -> CsTree -> CsTree -> CsTree
mkComp op a b = pure (oprInfix $ show op) [a, b]

mkIf :: CsTree -> CsTree -> CsTree -> CsTree
mkIf cond th el = pure ifOpr [cond, th, el]

oprInfix :: Name -> CsExpr
oprInfix name = opr ["(", name, ")"]

ifOpr :: CsExpr 
ifOpr = opr ["(", "?", ":",")"]

-------------------------------------------------
-- Booleans

data CsBool = CsBPrim CsComp
            | CsTrue 
            | CsFalse 
            | CsNot CsBool 
            | CsAnd CsBool CsBool 
            | CsOr CsBool CsBool

data CsComp = CsComp CompOp CsTree CsTree

data CompOp = CsEq | CsNeq | CsLt | CsGt | CsElt | CsEgt

instance Show CompOp where
    show x = case x of
                CsEq  -> "=="
                CsNeq -> "!="
                CsLt  -> "<"
                CsGt  -> ">"
                CsElt -> "<="
                CsEgt -> ">="

notCompOp :: CompOp -> CompOp
notCompOp x = case x of
                CsEq  -> CsNeq
                CsNeq -> CsEq
                CsLt  -> CsEgt
                CsGt  -> CsElt
                CsElt -> CsGt
                CsEgt -> CsLt

instance Boolean CsBool where
    true    = CsTrue
    false   = CsFalse
    notB    = CsNot

    a &&* b = case (a, b) of
                (CsTrue,  _)  -> b
                (CsFalse, _)  -> CsFalse
                (_, CsTrue )  -> a
                (_, CsFalse)  -> CsFalse
                _             -> CsAnd a b

    a ||* b = case (a, b) of
                (CsTrue,  _)  -> CsTrue
                (CsFalse, _)  -> b
                (_, CsTrue )  -> CsTrue
                (_, CsFalse)  -> a
                _             -> CsOr a b


------------------------------------------------------
-- nots elimination

data Ctx = N | P

elimNots :: Ctx -> CsBool -> CsBool
elimNots P x = 
    case x of
        CsNot a   -> elimNots N a
        CsAnd a b -> CsAnd (elimNots P a) (elimNots P b)
        CsOr  a b -> CsOr  (elimNots P a) (elimNots P b)    
        _         -> x

elimNots N x =
    case x of
        CsBPrim (CsComp op a b) -> CsBPrim (CsComp (notCompOp op) a b)
        CsTrue                  -> CsFalse
        CsFalse                 -> CsTrue
        CsNot a                 -> elimNots P a
        CsAnd a b               -> CsOr  (elimNots N a) (elimNots N b)
        CsOr  a b               -> CsAnd (elimNots N a) (elimNots N b)

---------------------------------------------------

instance IfB CsBool CsTree where
    ifB cond a b = let cond' = elimNots P cond 
                   in  case cond' of
                          CsTrue  -> a
                          CsFalse -> b
                          CsNot c -> ifB c b a
                          _       -> mkIf (getCondCsTree cond') a b


getCondCsTree :: CsBool -> CsTree
getCondCsTree x = 
    case x of
        CsBPrim a -> getCompCsTree a
        CsAnd a b -> mkAnd (getCondCsTree a) (getCondCsTree b)
        CsOr  a b -> mkOr  (getCondCsTree a) (getCondCsTree b)

getCompCsTree :: CsComp -> CsTree
getCompCsTree (CsComp op a b) = mkComp op a b


bOp :: CompOp -> CsTree -> CsTree -> CsBool
bOp op a b = CsBPrim $ CsComp op a b


instance EqB CsBool CsTree where
    (==*) = bOp CsEq
    (/=*) = bOp CsNeq


instance OrdB CsBool CsTree where
    (<*)  = bOp CsLt
    (>*)  = bOp CsGt
    (<=*) = bOp CsElt
    (>=*) = bOp CsEgt