{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
module Data.Manifold.Griddable (GridAxis(..), Griddable(..)) where
import Data.List hiding (filter, all, elem, sum)
import Data.Maybe
import Math.LinearMap.Category
import Data.Manifold.Types
import Data.Manifold.Types.Primitive ((^), (^.))
import Data.Manifold.PseudoAffine
import Data.Manifold.WithBoundary
import Data.Manifold.WithBoundary.Class
import Data.Manifold.TreeCover (Shade(..), fullShade, shadeCtr, shadeExpanse)
import Data.Embedding
import qualified Prelude as Hask hiding(foldl, sum, sequence)
import qualified Control.Applicative as Hask
import qualified Control.Monad as Hask hiding(forM_, sequence)
import qualified Data.Foldable as Hask
import Data.Foldable (all, elem, toList, sum)
import qualified Data.Traversable as Hask
import Data.Traversable (forM)
import Control.Category.Constrained.Prelude hiding
((^), all, elem, sum, forM, Foldable(..), Traversable)
import Control.Arrow.Constrained
import Control.Monad.Constrained hiding (forM)
import Data.Foldable.Constrained
import Text.Printf
data GridAxis m g = GridAxInterval (Shade m)
| GridAxCons (Shade m) g (GridAxis m g)
| GridAxisClosed g (GridAxis m g)
deriving (forall a b. a -> GridAxis m b -> GridAxis m a
forall a b. (a -> b) -> GridAxis m a -> GridAxis m b
forall m a b. a -> GridAxis m b -> GridAxis m a
forall m a b. (a -> b) -> GridAxis m a -> GridAxis m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GridAxis m b -> GridAxis m a
$c<$ :: forall m a b. a -> GridAxis m b -> GridAxis m a
fmap :: forall a b. (a -> b) -> GridAxis m a -> GridAxis m b
$cfmap :: forall m a b. (a -> b) -> GridAxis m a -> GridAxis m b
Hask.Functor)
gshmap :: (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap :: forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap Shade m -> Shade n
f (GridAxInterval Shade m
i) = forall m g. Shade m -> GridAxis m g
GridAxInterval forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade m -> Shade n
f Shade m
i
gshmap Shade m -> Shade n
f (GridAxCons Shade m
i g
g GridAxis m g
ax) = forall m g. Shade m -> g -> GridAxis m g -> GridAxis m g
GridAxCons (Shade m -> Shade n
f Shade m
i) g
g forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap Shade m -> Shade n
f GridAxis m g
ax
gshmap Shade m -> Shade n
f (GridAxisClosed g
g GridAxis m g
ax) = forall m g. g -> GridAxis m g -> GridAxis m g
GridAxisClosed g
g forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap Shade m -> Shade n
f GridAxis m g
ax
axisEnumFromStepTo :: (ℝ->a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo :: forall a. (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo ℝ -> a
f ℝ
l ℝ
st ℝ
r
| ℝ
l' forall a. Ord a => a -> a -> Bool
> ℝ
r = forall m g. Shade m -> GridAxis m g
GridAxInterval forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Interval -> Shade ℝ
intvl2Shade (ℝ -> ℝ -> Interval
Interval ℝ
l ℝ
l')
| Bool
otherwise = forall m g. Shade m -> g -> GridAxis m g -> GridAxis m g
GridAxCons (Interval -> Shade ℝ
intvl2Shade forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> ℝ -> Interval
Interval ℝ
l ℝ
l')
(ℝ -> a
f ℝ
l') forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo ℝ -> a
f ℝ
l' ℝ
st ℝ
r
where l' :: ℝ
l' = ℝ
lforall a. Num a => a -> a -> a
+ℝ
st
axisGrLength :: GridAxis m a -> Int
axisGrLength :: forall m a. GridAxis m a -> Int
axisGrLength (GridAxInterval Shade m
_) = Int
0
axisGrLength (GridAxCons Shade m
_ a
_ GridAxis m a
ax) = Int
1 forall a. Num a => a -> a -> a
+ forall m a. GridAxis m a -> Int
axisGrLength GridAxis m a
ax
axisGrLength (GridAxisClosed a
_ GridAxis m a
ax) = forall m a. GridAxis m a -> Int
axisGrLength GridAxis m a
ax
class (WithField ℝ PseudoAffine m) => Griddable m g where
data GriddingParameters m g :: *
mkGridding :: GriddingParameters m g -> Int -> Shade m -> [GridAxis m g]
instance Griddable ℝ String where
data GriddingParameters ℝ String = ℝGridParam
mkGridding :: GriddingParameters ℝ String
-> Int -> Shade ℝ -> [GridAxis ℝ String]
mkGridding GriddingParameters ℝ String
R:GriddingParametersDouble[]
ℝGridParam Int
n (Shade ℝ
c Metric' ℝ
expa') = [GridAxis ℝ String
ax]
where l :: ℝ
l = ℝ
c forall a. Num a => a -> a -> a
- ℝ
expa
r :: ℝ
r = ℝ
c forall a. Num a => a -> a -> a
+ ℝ
expa
expa :: ℝ
expa = forall s. RealFrac' s => Norm s -> s
normalLength Metric' ℝ
expa'
(Just GridAxis ℝ String
ax) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Ord a => a -> a -> Bool
>=Int
n) 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 m a. GridAxis m a -> Int
axisGrLength)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [ let qe :: ℝ
qe = ℝ
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
lqe' forall a. Num a => a -> a -> a
* ℝ
nb
in forall a. (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo (Int -> ℝ -> String
prettyFloatShow Int
lqe')
( ℝ
qe forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (RealFrac a, Integral b) => a -> b
floor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
l forall a. Fractional a => a -> a -> a
/ ℝ
qe) ) ℝ
qe ℝ
r
| Int
lqe' <- [Int
lqe forall a. Num a => a -> a -> a
- Int
1, Int
lqe forall a. Num a => a -> a -> a
- Int
2 ..], ℝ
nb <- [ℝ
5, ℝ
2, ℝ
1] ]
lqe :: Int
lqe = forall {a} {b}. (RealFrac a, Integral b, Floating a) => a -> b
lqef ℝ
expa :: Int
lqef :: a -> b
lqef a
n | a
n forall a. Ord a => a -> a -> Bool
> a
0 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Floating a => a -> a
lg a
n
| a
n forall a. Ord a => a -> a -> Bool
< a
0 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Floating a => a -> a
lg (-a
n)
instance ∀ m n a
. ( SimpleSpace (Needle m), SimpleSpace (Needle n), SimpleSpace (Needle a)
, Griddable m a, Griddable n a
, PseudoAffineWithBoundary (m,n)
, ProjectableBoundary (m,n)
)
=> Griddable (m,n) a where
data GriddingParameters (m,n) a = PairGriddingParameters {
forall m n a. GriddingParameters (m, n) a -> GriddingParameters m a
fstGriddingParams :: GriddingParameters m a
, forall m n a. GriddingParameters (m, n) a -> GriddingParameters n a
sndGriddingParams :: GriddingParameters n a }
mkGridding :: GriddingParameters (m, n) a
-> Int -> Shade (m, n) -> [GridAxis (m, n) a]
mkGridding (PairGriddingParameters GriddingParameters m a
p₁ GriddingParameters n a
p₂) Int
n (Shade (m
c₁,n
c₂) Metric' (m, n)
e₁e₂)
= ( forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap ( forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k a (k b c) -> k (a, b) c
uncurry forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade 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
. ( (,n
c₂)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 s a. s -> Getting a s a -> a
^.forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr)
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& (forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
`sumSubspaceNorms`Norm (DualVector (Needle n))
e₂)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 s a. s -> Getting a s a -> a
^.forall x. Lens' (Shade x) (Metric' x)
shadeExpanse)) )
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [GridAxis m a]
g₁s )
forall a. [a] -> [a] -> [a]
++ ( forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap ( forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k a (k b c) -> k (a, b) c
uncurry forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade 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
. ( (m
c₁,)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 s a. s -> Getting a s a -> a
^.forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr)
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& ( forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
sumSubspaceNorms Norm (DualVector (Needle m))
e₁)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 s a. s -> Getting a s a -> a
^.forall x. Lens' (Shade x) (Metric' x)
shadeExpanse)) )
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [GridAxis n a]
g₂s )
where g₁s :: [GridAxis m a]
g₁s = forall m g.
Griddable m g =>
GriddingParameters m g -> Int -> Shade m -> [GridAxis m g]
mkGridding GriddingParameters m a
p₁ Int
n forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade m
c₁ Norm (DualVector (Needle m))
e₁
g₂s :: [GridAxis n a]
g₂s = forall m g.
Griddable m g =>
GriddingParameters m g -> Int -> Shade m -> [GridAxis m g]
mkGridding GriddingParameters n a
p₂ Int
n forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade n
c₂ Norm (DualVector (Needle n))
e₂
(Norm (DualVector (Needle m))
e₁,Norm (DualVector (Needle n))
e₂) = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness m
, forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness n ) of
(DualSpaceWitness (Needle m)
DualSpaceWitness, DualSpaceWitness (Needle n)
DualSpaceWitness) -> forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Metric' (m, n)
e₁e₂
prettyFloatShow :: Int -> Double -> String
prettyFloatShow :: Int -> ℝ -> String
prettyFloatShow Int
_ ℝ
0 = String
"0"
prettyFloatShow Int
preci ℝ
x
| Int
preci forall a. Ord a => a -> a -> Bool
>= Int
0, Int
preci forall a. Ord a => a -> a -> Bool
< Int
4 = forall a. Show a => a -> String
show forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
x
| Int
preci forall a. Ord a => a -> a -> Bool
< Int
0, Int
preci forall a. Ord a => a -> a -> Bool
> -Int
2 = forall r. PrintfType r => String -> r
printf String
"%.1f" ℝ
x
| Bool
otherwise = case forall a b. (RealFrac a, Integral b) => a -> b
ceiling (ℝ
0.01 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
lg (forall a. Num a => a -> a
abs ℝ
xforall a. Fractional a => a -> a -> a
/ℝ
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Int
preciforall a. Num a => a -> a -> a
+Int
1))) forall a. Num a => a -> a -> a
+ Int
preci of
Int
0 | Int
preci forall a. Ord a => a -> a -> Bool
< Int
0 -> forall r. PrintfType r => String -> r
printf (String
"%."forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show(-Int
preci)forall a. [a] -> [a] -> [a]
++String
"f") ℝ
x
Int
expn | Int
expnforall a. Ord a => a -> a -> Bool
>Int
preci -> forall r. PrintfType r => String -> r
printf (String
"%."forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show(Int
expnforall a. Num a => a -> a -> a
-Int
preci)forall a. [a] -> [a] -> [a]
++String
"f*10^%i")
(ℝ
xforall a. Fractional a => a -> a -> a
/ℝ
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
expn) Int
expn
| Bool
otherwise -> forall r. PrintfType r => String -> r
printf (String
"%i*10^%i")
(forall a b. (RealFrac a, Integral b) => a -> b
round forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
xforall a. Fractional a => a -> a -> a
/ℝ
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
expn :: Int) Int
expn
data Interval = Interval { Interval -> ℝ
ivLBound, Interval -> ℝ
ivRBound :: ℝ }
shade2Intvl :: Shade ℝ -> Interval
shade2Intvl :: Shade ℝ -> Interval
shade2Intvl Shade ℝ
sh = ℝ -> ℝ -> Interval
Interval ℝ
l ℝ
r
where c :: ℝ
c = Shade ℝ
sh forall s a. s -> Getting a s a -> a
^. forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr
expa :: ℝ
expa = forall s. RealFrac' s => Norm s -> s
normalLength forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade ℝ
sh forall s a. s -> Getting a s a -> a
^. forall x. Lens' (Shade x) (Metric' x)
shadeExpanse
l :: ℝ
l = ℝ
c forall a. Num a => a -> a -> a
- ℝ
expa; r :: ℝ
r = ℝ
c forall a. Num a => a -> a -> a
+ ℝ
expa
intvl2Shade :: Interval -> Shade ℝ
intvl2Shade :: Interval -> Shade ℝ
intvl2Shade (Interval ℝ
l ℝ
r) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade ℝ
c (forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ℝ
expa])
where c :: ℝ
c = (ℝ
lforall a. Num a => a -> a -> a
+ℝ
r) forall a. Fractional a => a -> a -> a
/ ℝ
2
expa :: ℝ
expa = (ℝ
rforall a. Num a => a -> a -> a
-ℝ
l) forall a. Fractional a => a -> a -> a
/ ℝ
2
lg :: Floating a => a -> a
lg :: forall a. Floating a => a -> a
lg = forall a. Floating a => a -> a -> a
logBase a
10