{-|
Module      : IT.Shape
Description : Measuring shape constraints with interval arithmetic
Copyright   : (c) Fabricio Olivetti de Franca, 2020
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

Support functions to measure imposed shape constraints into the image of the function and its derivatives.
-}

module IT.Shape where

import IT
import IT.Eval
import IT.Algorithms

import Control.Arrow
import Numeric.Interval

type ImgFun = [Interval Double] -> Expr -> [Double] -> Interval Double

data Shape   = Image (Double, Double) 
             | DiffImg Int (Double, Double) | NonIncreasing Int | NonDecreasing Int
             | PartialNonIncreasing Int (Double, Double) | PartialNonDecreasing Int (Double, Double)
             | Inflection Int Int | Convex Int Int | Concave Int Int -- (0,0), (0,Infinity), (-Infinitiy,0)
                    deriving (Int -> Shape -> ShowS
[Shape] -> ShowS
Shape -> String
(Int -> Shape -> ShowS)
-> (Shape -> String) -> ([Shape] -> ShowS) -> Show Shape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Shape] -> ShowS
$cshowList :: [Shape] -> ShowS
show :: Shape -> String
$cshow :: Shape -> String
showsPrec :: Int -> Shape -> ShowS
$cshowsPrec :: Int -> Shape -> ShowS
Show, ReadPrec [Shape]
ReadPrec Shape
Int -> ReadS Shape
ReadS [Shape]
(Int -> ReadS Shape)
-> ReadS [Shape]
-> ReadPrec Shape
-> ReadPrec [Shape]
-> Read Shape
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Shape]
$creadListPrec :: ReadPrec [Shape]
readPrec :: ReadPrec Shape
$creadPrec :: ReadPrec Shape
readList :: ReadS [Shape]
$creadList :: ReadS [Shape]
readsPrec :: Int -> ReadS Shape
$creadsPrec :: Int -> ReadS Shape
Read)

type Domains = Maybe [(Double, Double)]

-- * Constraint functions
unconstrained :: Constraint
unconstrained :: Constraint
unconstrained Expr
_ [Double]
_ = Double
0
                    
-- violationImg evalImage
-- violationImg (evalDiffImage ix)
violationImg :: ImgFun -> [Interval Double] -> Interval Double -> Constraint
violationImg :: ImgFun -> [Interval Double] -> Interval Double -> Constraint
violationImg ImgFun
imgfun [Interval Double]
domains Interval Double
img Expr
expr [Double]
ws 
  | Interval Double
img' Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise =
    let (Double
lo, Double
hi)   = (Interval Double -> Double
forall a. Interval a -> a
inf (Interval Double -> Double)
-> (Interval Double -> Double)
-> Interval Double
-> (Double, Double)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Interval Double -> Double
forall a. Interval a -> a
sup) Interval Double
img
        (Double
lo', Double
hi') = (Interval Double -> Double
forall a. Interval a -> a
inf (Interval Double -> Double)
-> (Interval Double -> Double)
-> Interval Double
-> (Double, Double)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Interval Double -> Double
forall a. Interval a -> a
sup) Interval Double
img' 
        loDiff :: Double
loDiff     = if Double
lo' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
lo Bool -> Bool -> Bool
&& Double
lo' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
hi then Double
0 else Double -> Double
forall a. Num a => a -> a
abs (Double
lo Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lo')
        hiDiff :: Double
hiDiff     = if Double
hi' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
hi Bool -> Bool -> Bool
&& Double
hi' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
lo then Double
0 else Double -> Double
forall a. Num a => a -> a
abs (Double
hi' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hi)
    in  Double
loDiff Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hiDiff
  where 
    img' :: Interval Double
img' = ImgFun
imgfun [Interval Double]
domains Expr
expr [Double]
ws

violationNonIncreasing, violationNonDecreasing :: Int -> [Interval Double] -> Constraint
violationNonIncreasing :: Int -> [Interval Double] -> Constraint
violationNonIncreasing Int
ix [Interval Double]
domains Expr
expr [Double]
ws  -- (-Infinity .. 0)
  | Interval Double
img Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise    = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Interval Double -> Double
forall a. Interval a -> a
sup Interval Double
img
  where img :: Interval Double
img = Int -> ImgFun
evalDiffImage Int
ix [Interval Double]
domains Expr
expr [Double]
ws

violationNonDecreasing :: Int -> [Interval Double] -> Constraint
violationNonDecreasing Int
ix [Interval Double]
domains Expr
expr [Double]
ws -- (0 .. Infinity)
  | Interval Double
img Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise    = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
0 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Interval Double -> Double
forall a. Interval a -> a
inf Interval Double
img
  where img :: Interval Double
img = Int -> ImgFun
evalDiffImage Int
ix [Interval Double]
domains Expr
expr [Double]
ws

violationInflection, violationConcave, violationConvex :: Int -> Int -> [Interval Double] -> Constraint
violationInflection :: Int -> Int -> [Interval Double] -> Constraint
violationInflection Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws -- (0 .. 0)
  | Interval Double
img Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise    = if Double -> Double
forall a. Num a => a -> a
abs (Interval Double -> Double
forall a. Interval a -> a
inf Interval Double
img) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
abs (Interval Double -> Double
forall a. Interval a -> a
sup Interval Double
img) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e-2 then Double
0 else Double -> Double
forall a. Num a => a -> a
abs (Interval Double -> Double
forall a. Interval a -> a
inf Interval Double
img) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
abs (Interval Double -> Double
forall a. Interval a -> a
sup Interval Double
img)
  where img :: Interval Double
img = Int -> Int -> ImgFun
evalSndDiffImage Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws

violationConvex :: Int -> Int -> [Interval Double] -> Constraint
violationConvex Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws -- (0 .. Infinity)
  | Interval Double
img Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise    = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
0 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Interval Double -> Double
forall a. Interval a -> a
inf Interval Double
img
  where img :: Interval Double
img = Int -> Int -> ImgFun
evalSndDiffImage Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws

violationConcave :: Int -> Int -> [Interval Double] -> Constraint
violationConcave Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws -- (-Infinity .. 0)
  | Interval Double
img Interval Double -> Interval Double -> Bool
forall a. Eq a => a -> a -> Bool
== Interval Double
forall a. Interval a
empty = Double
1e+10
  | Bool
otherwise    = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Interval Double -> Double
forall a. Interval a -> a
sup Interval Double
img
  where img :: Interval Double
img = Int -> Int -> ImgFun
evalSndDiffImage Int
ix Int
iy [Interval Double]
domains Expr
expr [Double]
ws

constraintFrom :: [Constraint] -> Constraint
constraintFrom :: [Constraint] -> Constraint
constraintFrom [Constraint]
funs Expr
expr [Double]
ws = let c :: Double
c = (Constraint -> Double -> Double)
-> Double -> [Constraint] -> Double
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Constraint
f Double
tot -> Double -> Double
forall a. Num a => a -> a
abs (Constraint
f Expr
expr [Double]
ws) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tot) Double
0 [Constraint]
funs
                              in if Double
c Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e-60 then Double
0 else Double
c

fromShapes :: [Shape] -> Domains -> Constraint
fromShapes :: [Shape] -> Domains -> Constraint
fromShapes [Shape]
_      Domains
Nothing        = Constraint
unconstrained
fromShapes []     Domains
_              = Constraint
unconstrained
fromShapes [Shape]
shapes (Just [(Double, Double)]
domains) = [Constraint] -> Constraint
constraintFrom ((Shape -> Constraint) -> [Shape] -> [Constraint]
forall a b. (a -> b) -> [a] -> [b]
map Shape -> Constraint
toFun [Shape]
shapes)
  where
    domains' :: [Interval Double]
domains' = ((Double, Double) -> Interval Double)
-> [(Double, Double)] -> [Interval Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double -> Interval Double)
-> (Double, Double) -> Interval Double
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Interval Double
forall a. Ord a => a -> a -> Interval a
(...)) [(Double, Double)]
domains
    replace :: [Interval a] -> Int -> (a, a) -> [Interval a]
replace [Interval a]
ds Int
ix (a, a)
rng = let rng' :: Interval a
rng' = ((a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
rng a -> a -> Interval a
forall a. Ord a => a -> a -> Interval a
... (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
rng)
                        in  Int -> [Interval a] -> [Interval a]
forall a. Int -> [a] -> [a]
take Int
ix [Interval a]
ds [Interval a] -> [Interval a] -> [Interval a]
forall a. [a] -> [a] -> [a]
++ (Interval a
rng' Interval a -> [Interval a] -> [Interval a]
forall a. a -> [a] -> [a]
: Int -> [Interval a] -> [Interval a]
forall a. Int -> [a] -> [a]
drop (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Interval a]
ds)

    toFun :: Shape -> Constraint
toFun (Image (Double
lo, Double
hi))      = ImgFun -> [Interval Double] -> Interval Double -> Constraint
violationImg ImgFun
evalImage          [Interval Double]
domains' (Double
lo Double -> Double -> Interval Double
forall a. Ord a => a -> a -> Interval a
... Double
hi) 
    toFun (DiffImg Int
ix (Double
lo, Double
hi)) = ImgFun -> [Interval Double] -> Interval Double -> Constraint
violationImg (Int -> ImgFun
evalDiffImage Int
ix) [Interval Double]
domains' (Double
lo Double -> Double -> Interval Double
forall a. Ord a => a -> a -> Interval a
... Double
hi) 
    toFun (NonIncreasing Int
ix)    = Int -> [Interval Double] -> Constraint
violationNonIncreasing Int
ix [Interval Double]
domains' 
    toFun (NonDecreasing Int
ix)    = Int -> [Interval Double] -> Constraint
violationNonDecreasing Int
ix [Interval Double]
domains' 
    toFun (PartialNonIncreasing Int
ix (Double, Double)
range) = Int -> [Interval Double] -> Constraint
violationNonIncreasing Int
ix ([Interval Double] -> Constraint)
-> [Interval Double] -> Constraint
forall a b. (a -> b) -> a -> b
$ [Interval Double] -> Int -> (Double, Double) -> [Interval Double]
forall a. Ord a => [Interval a] -> Int -> (a, a) -> [Interval a]
replace [Interval Double]
domains' Int
ix (Double, Double)
range
    toFun (PartialNonDecreasing Int
ix (Double, Double)
range) = Int -> [Interval Double] -> Constraint
violationNonDecreasing Int
ix ([Interval Double] -> Constraint)
-> [Interval Double] -> Constraint
forall a b. (a -> b) -> a -> b
$ [Interval Double] -> Int -> (Double, Double) -> [Interval Double]
forall a. Ord a => [Interval a] -> Int -> (a, a) -> [Interval a]
replace [Interval Double]
domains' Int
ix (Double, Double)
range
    toFun (Inflection Int
ix Int
iy)    = Int -> Int -> [Interval Double] -> Constraint
violationInflection Int
ix Int
iy [Interval Double]
domains'
    toFun (Convex Int
ix Int
iy)        = Int -> Int -> [Interval Double] -> Constraint
violationConvex Int
ix Int
iy [Interval Double]
domains'
    toFun (Concave Int
ix Int
iy)       = Int -> Int -> [Interval Double] -> Constraint
violationConcave Int
ix Int
iy [Interval Double]
domains'