{-# OPTIONS_GHC -fno-warn-missing-methods  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-|
    Module      :  Control.ERNet.Blocks.Real.Protocols
    Description :  protocols for communicating real functions
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  portable

    Basic protocols for transferring approximations of real functions. 

-}

module Control.ERNet.Blocks.RnToRm.Protocols where

import Control.ERNet.Foundations.Protocol
import Control.ERNet.Foundations.Protocol.StandardCombinators

import qualified Data.Number.ER.RnToRm.Approx as FA
import qualified Data.Number.ER.Real.Approx as RA
import qualified Data.Number.ER.Real.Approx.Elementary as RAEL

import qualified Data.Number.ER.Real.DomainBox as DBox
import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox)

import Data.Number.ER.Misc
import Data.Number.ER.BasicTypes

import Data.Number.ER.ShowHTML
import qualified Text.Html as H

import Data.Typeable


{- protocol for first-order functions -}

instance
    (FA.ERFnApprox box varid domra ranra fa,
     RAEL.ERApproxElementary domra, 
     RAEL.ERApproxElementary ranra,
     Typeable box, Show box,
     Typeable domra, Typeable ranra, Typeable fa,
     H.HTML fa) =>
    (QAProtocol (QAFn1Q box) (QAFn1A ranra fa))
    where
    qaMatch (QAFn1QAll) (QAFn1A _) = Nothing
    qaMatch (QAFn1QDom _) (QAFn1A _) = Nothing
    qaMatch (QAFn1QPt _) (QAFn1APt _) = Nothing
    qaMatch q a = 
        Just $ "function " ++ (qaMatchDefaultMessage q a)

data QAFn1Q box
    = QAFn1QAll
    | QAFn1QDom box
    | QAFn1QPt box
    deriving (Show, Typeable)
    
data QAFn1A ranra fa
    = QAFn1A fa
    | QAFn1APt [ranra]
    deriving (Show, Typeable)

chTFn1 :: 
    (FA.ERFnApprox box varid domra ranra fa,
     RAEL.ERApproxElementary domra, 
     RAEL.ERApproxElementary ranra,
     Typeable box, Show box,
     Typeable domra, Typeable ranra, Typeable fa,
     H.HTML fa) =>
    fa -> ChannelType
chTFn1 sampleFA = ChannelType QAFn1QAll (QAFn1A sampleFA)
    
instance (DomainBox box varid domra, RA.ERApprox domra) => Eq (QAFn1Q box)
    where
    (QAFn1QAll) == (QAFn1QAll) = True
    (QAFn1QDom dom1) == (QAFn1QDom dom2) =
        (and $ map snd $ DBox.zipWithDefault RA.bottomApprox RA.equalApprox dom1 dom2)
    (QAFn1QPt x1) == (QAFn1QPt x2) =
        (and $ map snd $ DBox.zipWithDefault RA.bottomApprox RA.equalApprox x1 x2)
    _ == _ = False

instance (DomainBox box varid domra, RA.ERApprox domra) => Ord (QAFn1Q box)
    where
    compare (QAFn1QAll) (QAFn1QAll) = EQ
    compare (QAFn1QDom dom1) (QAFn1QDom dom2) =
        compareComposeMany $ map snd $ 
            DBox.zipWithDefault RA.bottomApprox RA.compareApprox dom1 dom2 
    compare (QAFn1QPt pt1) (QAFn1QPt pt2) =
        compareComposeMany $ map snd $ 
            DBox.zipWithDefault RA.bottomApprox RA.compareApprox pt1 pt2 
    compare (QAFn1QAll) (QAFn1QDom _) = LT
    compare (QAFn1QDom _) (QAFn1QAll) = GT
    compare (QAFn1QAll) (QAFn1QPt _) = LT
    compare (QAFn1QPt _) (QAFn1QAll) = GT
    compare (QAFn1QDom _) (QAFn1QPt _) = LT
    compare (QAFn1QPt _) (QAFn1QDom _) = GT

instance (FA.ERFnApprox box varid domra ranra fa) => Eq (QAFn1A ranra fa)
    where
    (QAFn1A fa1) == (QAFn1A fa2) = RA.equalApprox fa1 fa2
    (QAFn1APt vals1) == (QAFn1APt vals2) =
        (and $ zipWith RA.equalApprox vals1 vals2)
    _ == _ = False



instance (Show box) => H.HTML (QAFn1Q box) where
    toHtml = toHtmlDefault
instance (Show ranra, H.HTML fa) => H.HTML (QAFn1A ranra fa)
    where
    toHtml (QAFn1APt doms) = 
        H.toHtml $ "QAFn1APt " ++ " " ++ show doms
    toHtml (QAFn1A fa) =
        H.toHtml $ 
            abovesTable [H.border 2]
                [
                 H.toHtml "QAFn1A"
                ,
                 H.toHtml fa
                ] 
{-|
    Construct an answer about a function, assuming
    they will not ask about a subdomain.
-}
makeAnswerFn1NoIx ::
    (FA.ERFnApprox box varid domra ranra fa) =>
    fa ->
    (QAFn1Q box) ->
    (QAFn1A ranra fa)
makeAnswerFn1NoIx fa qry =
    case qry of
        QAFn1QAll -> QAFn1A fa
        QAFn1QDom doms -> QAFn1A fa
        QAFn1QPt vals ->
            QAFn1APt $ FA.eval vals fa

{-|
    Construct an answer about a function, given
    as a Haskell real -> real function.
-}
makeAnswerFn1ByBoxesNoIx ::
    (FA.ERFnDomApprox box varid domra ranra fa) =>
    (box -> [ranra]) ->
    (QAFn1Q box) ->
    (QAFn1A ranra fa)
makeAnswerFn1ByBoxesNoIx computeBounds qry =
    case qry of
        (QAFn1QPt domB) ->
            QAFn1APt $ computeBounds domB
        (QAFn1QDom domB) ->
            QAFn1A $ FA.const domB $ computeBounds domB


 
{- protocol for functions (R^m -> R^n) -> (R^m -> R^n) -}

instance (FA.ERFnApprox box varid domra ranra fa, Typeable fa, H.HTML fa) =>
    (QAProtocol (QAFn2Q fa) (QAFn2A fa))
    where
    qaMatch _ _ = Nothing

data QAFn2Q fa
    = QAFn2QPt fa
    deriving (Show, Typeable)
    
data QAFn2A fa
    = QAFn2APt fa
    deriving (Show, Typeable)

chTFn2 :: 
    (FA.ERFnApprox box varid domra ranra fa,
     RAEL.ERApproxElementary domra, 
     RAEL.ERApproxElementary ranra,
     Typeable box, Show box,
     Typeable domra, Typeable ranra, Typeable fa,
     H.HTML fa) =>
    fa -> ChannelType
chTFn2 sampleFA = ChannelType (QAFn2QPt sampleFA) (QAFn2APt sampleFA)

instance (FA.ERFnApprox box varid domra ranra fa) =>  Eq (QAFn2Q fa)
    where
    (QAFn2QPt fn1) == (QAFn2QPt fn2) =  
        RA.equalApprox fn1 fn2

instance (FA.ERFnApprox box varid domra ranra fa) =>  Eq (QAFn2A fa)
    where
    (QAFn2APt fn1) == (QAFn2APt fn2) =  
        RA.equalApprox fn1 fn2

instance (FA.ERFnApprox box varid domra ranra fa) =>  Ord (QAFn2Q fa)
    where
    compare (QAFn2QPt fn1) (QAFn2QPt fn2) =
        RA.compareApprox fn1 fn2 

instance (H.HTML fa) => H.HTML (QAFn2Q fa)
    where
    toHtml (QAFn2QPt fa) =
        H.toHtml $
            abovesTable [H.border 2]
                [
                 H.toHtml "QAFn2QPt "
                ,
                 H.toHtml fa
                ] 

instance (H.HTML fa) => H.HTML (QAFn2A fa)
    where
    toHtml (QAFn2APt fa) = 
        H.toHtml $
            abovesTable [H.border 2]
                [
                 H.toHtml "QAFn2APt "
                ,
                 H.toHtml fa
                ]
    

-- TODO: rename the following reply... functions to makeAnswer... 
--       and unify them with existing makeAnswer... functions    
replyFn f (QAIxQ ix QAFn1QAll) =
    QAIxA $ QAFn1A (f ix)
    
replyFnNoIx f QAFn1QAll =
    QAFn1A f
    
replyFn2Fn f2f (QAIxQ ix (QAFn2QPt argFA)) =
    QAIxA $ QAFn2APt (f2f ix argFA)