-- |
-- Module      : Data.Manifold.Function.Interpolation
-- Copyright   : (c) Justus Sagemüller 2017
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsagemue $ uni-koeln.de
-- Stability   : experimental
-- Portability : portable
-- 

{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE UnicodeSyntax            #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE TupleSections            #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE StandaloneDeriving       #-}
{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE ConstraintKinds          #-}

module Data.Manifold.Function.Interpolation (
      InterpolationFunction
    ) where


import Data.Manifold.Types
import Data.Manifold.Types.Primitive ((^))
import Data.Manifold.PseudoAffine
import Data.Manifold.Shade
import Data.Manifold.Web
import Data.Manifold.Web.Internal
import Data.Manifold.Function.LocalModel

import Data.VectorSpace
import Math.LinearMap.Category

import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE

import qualified Prelude as Hask

import Control.Category.Constrained.Prelude
import Control.Arrow.Constrained
import Control.Monad.Constrained

import Control.Lens
import Control.Lens.TH


newtype InterpolationFunction ㄇ x y = InterpolationFunction {
      forall (ㄇ :: * -> * -> *) x y.
InterpolationFunction ㄇ x y -> PointsWeb x (ㄇ x y)
_interpWeb :: PointsWeb x (ㄇ x y)
    }
makeLenses ''InterpolationFunction


fromPointsWeb :: (ModellableRelation x y, LocalModel ㄇ)
                 => PointsWeb x (Shade' y) -> InterpolationFunction ㄇ x y
fromPointsWeb :: forall x y (ㄇ :: * -> * -> *).
(ModellableRelation x y, LocalModel ㄇ) =>
PointsWeb x (Shade' y) -> InterpolationFunction ㄇ x y
fromPointsWeb = forall (ㄇ :: * -> * -> *) x y.
PointsWeb x (ㄇ x y) -> InterpolationFunction ㄇ x y
InterpolationFunction forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y z.
WithField ℝ Manifold x =>
(WebLocally x y -> z) -> PointsWeb x y -> PointsWeb x z
localFmapWeb (
                 \WebLocally x (Shade' y)
locInfo -> case forall (ㄇ :: * -> * -> *) x y.
(LocalModel ㄇ, ModellableRelation x y) =>
[(Needle x, Shade' y)] -> Maybe (ㄇ x y)
fitLocally forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
                                    (forall v. AdditiveGroup v => v
zeroV, WebLocally x (Shade' y)
locInfoforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) y
thisNodeData)
                                  forall a. a -> [a] -> [a]
: [ (Needle x
ngbx, WebLocally x (Shade' y)
ngbforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) y
thisNodeData)
                                    | (Needle x
ngbx,WebLocally x (Shade' y)
ngb) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y.
WithField ℝ Manifold x =>
WebLocally x y -> [WebNodeId] -> [[(Needle x, WebLocally x y)]]
localOnion WebLocally x (Shade' y)
locInfo []] of
                                 Just ㄇ x y
locModl -> ㄇ x y
locModl )


adjustMetricToModel :: ∀ x y ㄇ . (ModellableRelation x y, LocalModel ㄇ)
                 => InterpolationFunction ㄇ x y -> InterpolationFunction ㄇ x y
adjustMetricToModel :: forall x y (ㄇ :: * -> * -> *).
(ModellableRelation x y, LocalModel ㄇ) =>
InterpolationFunction ㄇ x y -> InterpolationFunction ㄇ x y
adjustMetricToModel = forall (ㄇ :: * -> * -> *) x y.
InterpolationFunction ㄇ x y -> PointsWeb x (ㄇ x y)
_interpWeb forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall x y.
WithField ℝ Manifold x =>
PointsWeb x y -> PointsWeb x (WebLocally x y)
webLocalInfo
    forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> \(PointsWeb Shaded x (Neighbourhood x (WebLocally x (ㄇ x y)))
w) -> forall (ㄇ :: * -> * -> *) x y.
PointsWeb x (ㄇ x y) -> InterpolationFunction ㄇ x y
InterpolationFunction forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a b. Shaded a (Neighbourhood a b) -> PointsWeb a b
PointsWeb forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap Neighbourhood x (WebLocally x (ㄇ x y)) -> Neighbourhood x (ㄇ x y)
remetricise Shaded x (Neighbourhood x (WebLocally x (ㄇ x y)))
w
 where remetricise :: Neighbourhood x (WebLocally x (ㄇ x y))
             -> Neighbourhood x (ㄇ x y)
       remetricise :: Neighbourhood x (WebLocally x (ㄇ x y)) -> Neighbourhood x (ㄇ x y)
remetricise Neighbourhood x (WebLocally x (ㄇ x y))
nd = Neighbourhood x (WebLocally x (ㄇ x y))
nd forall a b. a -> (a -> b) -> b
& forall x y1 y2.
Lens (Neighbourhood x y1) (Neighbourhood x y2) y1 y2
dataAtNode forall s t a b. ASetter s t a b -> b -> s -> t
.~ ㄇ x y
localModel
                           forall a b. a -> (a -> b) -> b
& forall x y. Lens' (Neighbourhood x y) (Metric x)
localScalarProduct forall s t a b. ASetter s t a b -> b -> s -> t
.~ Norm (Needle x)
newNorm
        where localModel :: ㄇ x y
localModel = Neighbourhood x (WebLocally x (ㄇ x y))
ndforall s a. s -> Getting a s a -> a
^.forall x y1 y2.
Lens (Neighbourhood x y1) (Neighbourhood x y2) y1 y2
dataAtNodeforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall x y. Lens' (WebLocally x y) y
thisNodeData
              newNorm :: Norm (Needle x)
newNorm = forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm
                  [ DualVector (Needle x)
dx forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ ((Scalar (DualVector (Needle x))
0.1 forall a. Num a => a -> a -> a
+ forall (shade :: * -> *) x s.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 s ~ Scalar (Needle x), RealFloat' s) =>
shade x -> x -> s
occlusion (WebLocally x (ㄇ x y)
ngbforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) y
thisNodeDataforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (ㄇ :: * -> * -> *) x y.
(LocalModel ㄇ, ModellableRelation x y) =>
Lens' (ㄇ x y) (Shade y)
tweakLocalOffset)
                                            y
ySynth)
                           forall a. Num a => a -> a -> a
* (DualVector (Needle x)
dxforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
δx))
                  | (Needle x
δx,WebLocally x (ㄇ x y)
ngb) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. WebNodeId -> [a] -> [a]
take WebNodeId
2 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y.
WithField ℝ Manifold x =>
WebLocally x y -> [WebNodeId] -> [[(Needle x, WebLocally x y)]]
localOnion (Neighbourhood x (WebLocally x (ㄇ x y))
ndforall s a. s -> Getting a s a -> a
^.forall x y1 y2.
Lens (Neighbourhood x y1) (Neighbourhood x y2) y1 y2
dataAtNode) []
                  , let dx :: DualVector (Needle x)
dx = Neighbourhood x (WebLocally x (ㄇ x y))
ndforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (Neighbourhood x y) (Metric x)
localScalarProductforall v. LSpace v => Norm v -> v -> DualVector v
<$|Needle x
δx
                        Shade' y
ySynth Metric y
_ = forall (ㄇ :: * -> * -> *) x y.
(LocalModel ㄇ, ModellableRelation x y) =>
ㄇ x y -> Needle x -> Shade' y
evalLocalModel ㄇ x y
localModel Needle x
δx ]
                      :: Metric x


upsampleAtLargeDist :: (ModellableRelation x y, LocalModel ㄇ)
        => ℝ -> (x -> ㄇ x y -> Needle x -> Shade' y)
            -> InterpolationFunction ㄇ x y -> PointsWeb x (Shade' y)
upsampleAtLargeDist :: forall x y (ㄇ :: * -> * -> *).
(ModellableRelation x y, LocalModel ㄇ) =>
ℝ
-> (x -> ㄇ x y -> Needle x -> Shade' y)
-> InterpolationFunction ㄇ x y
-> PointsWeb x (Shade' y)
upsampleAtLargeDist ℝ
dmax x -> ㄇ x y -> Needle x -> Shade' y
gapFillFunc (InterpolationFunction PointsWeb x (ㄇ x y)
web)
     = forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
MetricChoice x -> [(x, y)] -> PointsWeb x y
fromWebNodes (\(Shade x
x Metric' x
_) -> case forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
PointsWeb x y -> x -> Maybe (x, y)
nearestNeighbour PointsWeb x (WebLocally x (ㄇ x y))
webI x
x of
                         Just (x
_,WebLocally x (ㄇ x y)
nearest) -> WebLocally x (ㄇ x y)
nearest forall s a. s -> Getting a s a -> a
^. forall x y. Lens' (WebLocally x y) (Metric x)
nodeLocalScalarProduct) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ do
          WebLocally x (ㄇ x y)
local <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList PointsWeb x (WebLocally x (ㄇ x y))
webI
          (WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) x
thisNodeCoord, forall (ㄇ :: * -> * -> *) x y.
(LocalModel ㄇ, ModellableRelation x y) =>
ㄇ x y -> Needle x -> Shade' y
evalLocalModel (WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) y
thisNodeData) forall v. AdditiveGroup v => v
zeroV) forall a. a -> [a] -> [a]
: do 
             (WebNodeId
ngId, (Needle x
δx, WebLocally x (ㄇ x y)
ngb)) <- WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y.
Lens' (WebLocally x y) [(WebNodeId, (Needle x, WebLocally x y))]
nodeNeighbours
             forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (WebNodeId
ngId forall a. Ord a => a -> a -> Bool
> WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) WebNodeId
thisNodeId
                   Bool -> Bool -> Bool
&& (WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) (Metric x)
nodeLocalScalarProductforall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
δx) forall a. Ord a => a -> a -> Bool
> ℝ
dmax)
             forall (m :: * -> *) a. Monad m (->) => a -> m a
return ( WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) x
thisNodeCoord forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
δxforall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ℝ
2
                    , x -> ㄇ x y -> Needle x -> Shade' y
gapFillFunc (WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) x
thisNodeCoord)
                                  (WebLocally x (ㄇ x y)
localforall s a. s -> Getting a s a -> a
^.forall x y. Lens' (WebLocally x y) y
thisNodeData)
                                  (Needle x
δxforall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ℝ
2) )
 where webI :: PointsWeb x (WebLocally x (ㄇ x y))
webI = forall x y.
WithField ℝ Manifold x =>
PointsWeb x y -> PointsWeb x (WebLocally x y)
webLocalInfo PointsWeb x (ㄇ x y)
web

autoUpsampleAtLargeDist :: (ModellableRelation x y, LocalModel ㄇ)
        => ℝ -> InterpolationFunction ㄇ x y -> PointsWeb x (Shade' y)
autoUpsampleAtLargeDist :: forall x y (ㄇ :: * -> * -> *).
(ModellableRelation x y, LocalModel ㄇ) =>
ℝ -> InterpolationFunction ㄇ x y -> PointsWeb x (Shade' y)
autoUpsampleAtLargeDist ℝ
dmax = forall x y (ㄇ :: * -> * -> *).
(ModellableRelation x y, LocalModel ㄇ) =>
ℝ
-> (x -> ㄇ x y -> Needle x -> Shade' y)
-> InterpolationFunction ㄇ x y
-> PointsWeb x (Shade' y)
upsampleAtLargeDist ℝ
dmax forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const forall (ㄇ :: * -> * -> *) x y.
(LocalModel ㄇ, ModellableRelation x y) =>
ㄇ x y -> Needle x -> Shade' y
evalLocalModel