module Data.Number.ER.RnToRm.Approx.Tuple
(
ERFnTuple(..)
)
where
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.BasicTypes
import Data.Typeable
import Data.Generics.Basics
import Data.Binary
data ERFnTuple fa =
ERFnTuple { erfnTuple :: [fa] }
deriving (Typeable, Data)
instance (Binary a) => Binary (ERFnTuple a) where
put (ERFnTuple a) = put a
get = get >>= \a -> return (ERFnTuple a)
tuplesLift1 ::
(fa -> fa) ->
(ERFnTuple fa) -> (ERFnTuple fa)
tuplesLift1 op (ERFnTuple fas) =
ERFnTuple (map op fas)
tuplesLift2 ::
(Show fa) =>
String ->
(fa -> fa -> fa) ->
(ERFnTuple fa) -> (ERFnTuple fa) -> (ERFnTuple fa)
tuplesLift2 callerLocation op f1@(ERFnTuple fas1) f2@(ERFnTuple fas2)
| length fas1 == length fas2 =
ERFnTuple $ zipWith op fas1 fas2
| otherwise =
error $
callerLocation ++ "incompatible lengths: "
++ show (length fas1) ++ " != " ++ show (length fas2)
++ "\n first argument = \n" ++ show fas1
++ "\n second argument = \n" ++ show fas2
tuplesSplit ::
(fa -> (fa, fa)) ->
(ERFnTuple fa) -> (ERFnTuple fa, ERFnTuple fa)
tuplesSplit op f@(ERFnTuple fas) =
(ERFnTuple fas1, ERFnTuple fas2)
where
(fas1, fas2) = unzip $ map op fas
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
Show (ERFnTuple fa)
where
show f@(ERFnTuple fas) =
concat $ map showFA $ zip [0,1..] fas
where
showFA (fnname, fa) =
"\n>>> Function " ++ show fnname ++ ":" ++ show fa
instance
(FA.ERFnApprox box varid domra ranra fa) =>
Eq (ERFnTuple fa)
where
(ERFnTuple fas1) == (ERFnTuple fas2) =
fas1 == fas2
instance
(FA.ERFnApprox box varid domra ranra fa, Ord fa) =>
Ord (ERFnTuple fa)
where
compare (ERFnTuple fas1) (ERFnTuple fas2) =
compare fas1 fas2
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
Num (ERFnTuple fa)
where
fromInteger n = ERFnTuple [fromInteger n]
negate = tuplesLift1 negate
(+) = tuplesLift2 "ERFnTuple: +: " (+)
(*) = tuplesLift2 "ERFnTuple: *: " (*)
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
Fractional (ERFnTuple fa)
where
fromRational r = ERFnTuple [fromRational r]
recip = tuplesLift1 recip
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
RA.ERApprox (ERFnTuple fa)
where
getGranularity (ERFnTuple fas) =
foldl max 10 $ map RA.getGranularity fas
setGranularity gran = tuplesLift1 (RA.setGranularity gran)
setMinGranularity gran = tuplesLift1 (RA.setMinGranularity gran)
f1 /\ f2 = tuplesLift2 "ERFnTuple: /\\: " (RA./\) f1 f2
intersectMeasureImprovement ix f1@(ERFnTuple fas1) f2@(ERFnTuple fas2)
| length fas1 == length fas2 =
(ERFnTuple fasIsect, ERFnTuple fasImpr)
| otherwise =
error $ show $ f1 RA./\ f2
where
(fasIsect, fasImpr) = unzip $ zipWith (RA.intersectMeasureImprovement ix) fas1 fas2
leqReals f1@(ERFnTuple fas1) f2@(ERFnTuple fas2)
| length fas1 == length fas2 =
leqTuple $ zipWith RA.leqReals fas1 fas2
| otherwise =
error $ show $ f1 RA./\ f2
where
leqTuple [] = Just True
leqTuple _ =
error $ "ERFnTuple: leqReals not implemented"
instance
(FA.ERFnDomApprox box varid domra ranra fa, RA.ERIntApprox fa) =>
RA.ERIntApprox (ERFnTuple fa)
where
bisectDomain maybePt f@(ERFnTuple fas) =
case maybePt of
Nothing ->
tuplesSplit (RA.bisectDomain Nothing) f
Just (ERFnTuple fasPt) ->
(ERFnTuple fas1, ERFnTuple fas2)
where
(fas1, fas2) =
unzip $
map (\(fa, pt) -> RA.bisectDomain (Just pt) fa) $
zip fas fasPt
bounds = tuplesSplit RA.bounds
f1 \/ f2 = tuplesLift2 "ERFnTuple: \\/: " (RA.\/) f1 f2
instance
(FA.ERFnDomApprox box varid domra ranra fa, RAEL.ERApproxElementary fa) =>
RAEL.ERApproxElementary (ERFnTuple fa)
where
abs ix = tuplesLift1 $ RAEL.abs ix
exp ix = tuplesLift1 $ RAEL.exp ix
log ix = tuplesLift1 $ RAEL.log ix
sin ix = tuplesLift1 $ RAEL.sin ix
cos ix = tuplesLift1 $ RAEL.cos ix
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
FA.ERFnApprox box varid domra ranra (ERFnTuple fa)
where
check prgLocation (ERFnTuple fs) =
ERFnTuple $ map checkComp $ zip [0..] fs
where
checkComp (n, f) =
FA.check (prgLocation ++ "fn" ++ show n ++ ": ") f
domra2ranra (ERFnTuple (fa:_)) d =
FA.domra2ranra fa d
ranra2domra (ERFnTuple (fa:_)) r =
FA.ranra2domra fa r
setMaxDegree maxDegree = tuplesLift1 (FA.setMaxDegree maxDegree)
getTupleSize (ERFnTuple fas) = length fas
tuple fs
| sameDomains doms =
ERFnTuple $ concat $ map erfnTuple fs
| otherwise =
error $
"ERFnTuple: FA.tuple: incompatible domains:\n "
++ (unlines $ map show fs)
where
sameDomains [_] = True
sameDomains (a : rest@(b : _)) =
sameab && (sameDomains rest)
where
sameab =
and $ map snd $ DBox.zipWithDefault RA.bottomApprox RA.equalApprox a b
doms = map FA.dom fs
applyTupleFn tupleFn (ERFnTuple fs) =
FA.tuple $ tupleFn $ map (\fa -> ERFnTuple [fa]) fs
volume (ERFnTuple fas) = sum $ map (FA.volume) fas
scale ratio = tuplesLift1 (FA.scale ratio)
partialIntersect ix substitutions =
tuplesLift2 "ERFnTuple: partialIntersect: " $ FA.partialIntersect ix substitutions
eval ptBox (ERFnTuple fas) =
concat $ map (FA.eval ptBox) fas
partialEval substitutions = tuplesLift1 $ FA.partialEval substitutions
instance
(FA.ERFnDomApprox box varid domra ranra fa) =>
FA.ERFnDomApprox box varid domra ranra (ERFnTuple fa)
where
dom (ERFnTuple (fa:_)) = FA.dom fa
bottomApprox domB tupleSize =
ERFnTuple $ replicate tupleSize $ FA.bottomApprox domB 1
const domB vals =
ERFnTuple $ map (\v -> FA.const domB [v]) vals
proj domB i =
ERFnTuple [FA.proj domB i]
bisect var maybePt =
tuplesSplit $ FA.bisect var maybePt
integrate ix (ERFnTuple fasD) x integdomBox origin (ERFnTuple fasInit) =
ERFnTuple $ map integ $ zip fasD fasInit
where
integ (faD, faInit) =
FA.integrate ix faD x integdomBox origin faInit
integrateMeasureImprovement ix (ERFnTuple fasD) x integdomBox origin (ERFnTuple fasP) =
(ERFnTuple fasIsect, ERFnTuple fasImpr)
where
(fasIsect, fasImpr) =
unzip $ map integ $ zip fasD fasP
integ (faD, faP) =
FA.integrateMeasureImprovement ix faD x integdomBox origin faP