-- |
-- Module      : Data.Manifold.Griddable
-- Copyright   : (c) Justus Sagemüller 2015
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 
{-# 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 (a -> GridAxis m b -> GridAxis m a
(a -> b) -> GridAxis m a -> GridAxis m b
(forall a b. (a -> b) -> GridAxis m a -> GridAxis m b)
-> (forall a b. a -> GridAxis m b -> GridAxis m a)
-> Functor (GridAxis m)
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
<$ :: a -> GridAxis m b -> GridAxis m a
$c<$ :: forall m a b. a -> GridAxis m b -> GridAxis m a
fmap :: (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 :: (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap Shade m -> Shade n
f (GridAxInterval Shade m
i) = Shade n -> GridAxis n g
forall m g. Shade m -> GridAxis m g
GridAxInterval (Shade n -> GridAxis n g) -> Shade n -> GridAxis n g
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) = Shade n -> g -> GridAxis n g -> GridAxis n g
forall m g. Shade m -> g -> GridAxis m g -> GridAxis m g
GridAxCons (Shade m -> Shade n
f Shade m
i) g
g (GridAxis n g -> GridAxis n g) -> GridAxis n g -> GridAxis n g
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
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) = g -> GridAxis n g -> GridAxis n g
forall m g. g -> GridAxis m g -> GridAxis m g
GridAxisClosed g
g (GridAxis n g -> GridAxis n g) -> GridAxis n g -> GridAxis n g
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
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 :: (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo ℝ -> a
f ℝ
l ℝ
st ℝ
r
    | ℝ
l' ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> ℝ
r   = Shade ℝ -> GridAxis ℝ a
forall m g. Shade m -> GridAxis m g
GridAxInterval (Shade ℝ -> GridAxis ℝ a) -> Shade ℝ -> GridAxis ℝ a
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  = Shade ℝ -> a -> GridAxis ℝ a -> GridAxis ℝ a
forall m g. Shade m -> g -> GridAxis m g -> GridAxis m g
GridAxCons (Interval -> Shade ℝ
intvl2Shade (Interval -> Shade ℝ) -> Interval -> Shade ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> ℝ -> Interval
Interval ℝ
l ℝ
l')
                              (ℝ -> a
f ℝ
l') (GridAxis ℝ a -> GridAxis ℝ a) -> GridAxis ℝ a -> GridAxis ℝ a
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
forall a. (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo ℝ -> a
f ℝ
l' ℝ
st ℝ
r
 where l' :: ℝ
l' = ℝ
lℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
st

axisGrLength :: GridAxis m a -> Int
axisGrLength :: GridAxis m a -> Int
axisGrLength (GridAxInterval Shade m
_) = Int
0
axisGrLength (GridAxCons Shade m
_ a
_ GridAxis m a
ax) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ GridAxis m a -> Int
forall m a. GridAxis m a -> Int
axisGrLength GridAxis m a
ax
axisGrLength (GridAxisClosed a
_ GridAxis m a
ax) = GridAxis m a -> Int
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
ℝ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 = Norm ℝ -> ℝ
forall s. RealFrac' s => Norm s -> s
normalLength Norm ℝ
Metric' ℝ
expa'
         
         (Just GridAxis ℝ String
ax) = (GridAxis ℝ String -> Bool)
-> [GridAxis ℝ String] -> Maybe (GridAxis ℝ String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
n) (Int -> Bool)
-> (GridAxis ℝ String -> Int) -> GridAxis ℝ String -> Bool
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
. GridAxis ℝ String -> Int
forall m a. GridAxis m a -> Int
axisGrLength)
                ([GridAxis ℝ String] -> Maybe (GridAxis ℝ String))
-> [GridAxis ℝ String] -> Maybe (GridAxis ℝ String)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [ let qe :: ℝ
qe = ℝ
10ℝ -> Int -> ℝ
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
lqe' ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ℝ
nb
                    in (ℝ -> String) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ String
forall a. (ℝ -> a) -> ℝ -> ℝ -> ℝ -> GridAxis ℝ a
axisEnumFromStepTo (Int -> ℝ -> String
prettyFloatShow Int
lqe')
                         ( ℝ
qe ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* Integer -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ℝ -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (ℝ -> Integer) -> ℝ -> Integer
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
lqe Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 ..], ℝ
nb <- [ℝ
5, ℝ
2, ℝ
1] ]
         
         lqe :: Int
lqe = ℝ -> Int
forall a p. (RealFrac a, Integral p, Floating a) => a -> p
lqef ℝ
expa :: Int
         lqef :: a -> p
lqef a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0      = a -> p
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> p) -> a -> p
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a -> a
forall a. Floating a => a -> a
lg   a
n
                | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0      = a -> p
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> p) -> a -> p
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a -> a
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 {
               GriddingParameters (m, n) a -> GriddingParameters m a
fstGriddingParams :: GriddingParameters m 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 p₁ p₂) Int
n (Shade (m
c₁,n
c₂) Metric' (m, n)
e₁e₂)
          = ( (Shade m -> Shade (m, n)) -> GridAxis m a -> GridAxis (m, n) a
forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap ( ((m, n)
 -> Norm (DualVector (Needle m), DualVector (Needle n))
 -> Shade (m, n))
-> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
-> Shade (m, n)
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 (m, n)
-> Norm (DualVector (Needle m), DualVector (Needle n))
-> Shade (m, n)
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade (((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
 -> Shade (m, n))
-> (Shade m
    -> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n))))
-> Shade m
-> Shade (m, 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
. (                  (,n
c₂)(m -> (m, n)) -> (Shade m -> m) -> Shade m -> (m, 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
.(Shade m -> Getting m (Shade m) m -> m
forall s a. s -> Getting a s a -> a
^.Getting m (Shade m) m
forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr)
                                         (Shade m -> (m, n))
-> (Shade m -> Norm (DualVector (Needle m), DualVector (Needle n)))
-> Shade m
-> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& (Norm (DualVector (Needle m))
-> Norm (DualVector (Needle n))
-> Norm (DualVector (Needle m), DualVector (Needle n))
forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
`sumSubspaceNorms`Norm (DualVector (Needle n))
e₂)(Norm (DualVector (Needle m))
 -> Norm (DualVector (Needle m), DualVector (Needle n)))
-> (Shade m -> Norm (DualVector (Needle m)))
-> Shade m
-> Norm (DualVector (Needle m), DualVector (Needle 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
.(Shade m
-> Getting
     (Norm (DualVector (Needle m)))
     (Shade m)
     (Norm (DualVector (Needle m)))
-> Norm (DualVector (Needle m))
forall s a. s -> Getting a s a -> a
^.Getting
  (Norm (DualVector (Needle m)))
  (Shade m)
  (Norm (DualVector (Needle m)))
forall x. Lens' (Shade x) (Metric' x)
shadeExpanse)) )
              (GridAxis m a -> GridAxis (m, n) a)
-> [GridAxis m a] -> [GridAxis (m, n) a]
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 )
         [GridAxis (m, n) a] -> [GridAxis (m, n) a] -> [GridAxis (m, n) a]
forall a. [a] -> [a] -> [a]
++ ( (Shade n -> Shade (m, n)) -> GridAxis n a -> GridAxis (m, n) a
forall m n g. (Shade m -> Shade n) -> GridAxis m g -> GridAxis n g
gshmap ( ((m, n)
 -> Norm (DualVector (Needle m), DualVector (Needle n))
 -> Shade (m, n))
-> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
-> Shade (m, n)
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 (m, n)
-> Norm (DualVector (Needle m), DualVector (Needle n))
-> Shade (m, n)
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade (((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
 -> Shade (m, n))
-> (Shade n
    -> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n))))
-> Shade n
-> Shade (m, 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
. (                  (m
c₁,)(n -> (m, n)) -> (Shade n -> n) -> Shade n -> (m, 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
.(Shade n -> Getting n (Shade n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (Shade n) n
forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr)
                                         (Shade n -> (m, n))
-> (Shade n -> Norm (DualVector (Needle m), DualVector (Needle n)))
-> Shade n
-> ((m, n), Norm (DualVector (Needle m), DualVector (Needle n)))
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& ( Norm (DualVector (Needle m))
-> Norm (DualVector (Needle n))
-> Norm (DualVector (Needle m), DualVector (Needle n))
forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
sumSubspaceNorms Norm (DualVector (Needle m))
e₁)(Norm (DualVector (Needle n))
 -> Norm (DualVector (Needle m), DualVector (Needle n)))
-> (Shade n -> Norm (DualVector (Needle n)))
-> Shade n
-> Norm (DualVector (Needle m), DualVector (Needle 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
.(Shade n
-> Getting
     (Norm (DualVector (Needle n)))
     (Shade n)
     (Norm (DualVector (Needle n)))
-> Norm (DualVector (Needle n))
forall s a. s -> Getting a s a -> a
^.Getting
  (Norm (DualVector (Needle n)))
  (Shade n)
  (Norm (DualVector (Needle n)))
forall x. Lens' (Shade x) (Metric' x)
shadeExpanse)) )
              (GridAxis n a -> GridAxis (m, n) a)
-> [GridAxis n a] -> [GridAxis (m, n) a]
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 = GriddingParameters m a -> Int -> Shade m -> [GridAxis m a]
forall m g.
Griddable m g =>
GriddingParameters m g -> Int -> Shade m -> [GridAxis m g]
mkGridding GriddingParameters m a
p₁ Int
n (Shade m -> [GridAxis m a]) -> Shade m -> [GridAxis m a]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ m -> Norm (DualVector (Needle m)) -> Shade m
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 = GriddingParameters n a -> Int -> Shade n -> [GridAxis n a]
forall m g.
Griddable m g =>
GriddingParameters m g -> Int -> Shade m -> [GridAxis m g]
mkGridding GriddingParameters n a
p₂ Int
n (Shade n -> [GridAxis n a]) -> Shade n -> [GridAxis n a]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ n -> Norm (DualVector (Needle n)) -> Shade n
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 ( DualSpaceWitness (Needle m)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness m
                        , DualSpaceWitness (Needle n)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness n ) of
                (DualSpaceWitness (Needle m)
DualSpaceWitness, DualSpaceWitness (Needle n)
DualSpaceWitness) -> Norm (DualVector (Needle m), DualVector (Needle n))
-> (Norm (DualVector (Needle m)), Norm (DualVector (Needle n)))
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (DualVector (Needle m), DualVector (Needle n))
Metric' (m, n)
e₁e₂ 

prettyFloatShow :: Int -> Double -> String
prettyFloatShow :: Int -> ℝ -> String
prettyFloatShow Int
_ ℝ
0 = String
"0"
prettyFloatShow Int
preci ℝ
x
    | Int
preci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0, Int
preci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4  = Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
x
    | Int
preci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0, Int
preci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
2  = String -> ℝ -> String
forall r. PrintfType r => String -> r
printf String
"%.1f" ℝ
x
    | Bool
otherwise   = case ℝ -> Int
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 ℝ
xℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
10ℝ -> Int -> ℝ
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Int
preciInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
preci of
                        Int
0    | Int
preci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  -> String -> ℝ -> String
forall r. PrintfType r => String -> r
printf (String
"%."String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show(-Int
preci)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"f") ℝ
x
                        Int
expn | Int
expnInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
preci -> String -> ℝ -> Int -> String
forall r. PrintfType r => String -> r
printf (String
"%."String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show(Int
expnInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
preci)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"f*10^%i")
                                                      (ℝ
xℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
10ℝ -> Int -> ℝ
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
expn)                 Int
expn
                             | Bool
otherwise  -> String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf (String
"%i*10^%i")
                                                      (ℝ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (ℝ -> Int) -> ℝ -> Int
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
xℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
10ℝ -> Int -> ℝ
forall 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 Shade ℝ -> Getting ℝ (Shade ℝ) ℝ -> ℝ
forall s a. s -> Getting a s a -> a
^. Getting ℝ (Shade ℝ) ℝ
forall (shade :: * -> *) x. IsShade shade => Lens' (shade x) x
shadeCtr
       expa :: ℝ
expa = Norm ℝ -> ℝ
forall s. RealFrac' s => Norm s -> s
normalLength (Norm ℝ -> ℝ) -> Norm ℝ -> ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade ℝ
sh Shade ℝ -> Getting (Norm ℝ) (Shade ℝ) (Norm ℝ) -> Norm ℝ
forall s a. s -> Getting a s a -> a
^. Getting (Norm ℝ) (Shade ℝ) (Norm ℝ)
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) = ℝ -> Metric' ℝ -> Shade ℝ
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade ℝ
c ([DualVector ℝ] -> Norm ℝ
forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ℝ
DualVector ℝ
expa])
 where c :: ℝ
c = (ℝ
lℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
r) ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ ℝ
2
       expa :: ℝ
expa = (ℝ
rℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
l) ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ ℝ
2
       

lg :: Floating a => a -> a
lg :: a -> a
lg = a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
10