module Numeric.Interpolation.NodeList (
   T(Interval, Node),
   fromList,
   toList,
   singleton,
   lookup,
   ) where

import Data.Tuple.HT (mapFst)

import Data.Traversable (Traversable, traverse)
import Data.Foldable (Foldable, foldMap)
import Data.Monoid (mempty, (<>))

import Control.Applicative (liftA3, pure)

import Prelude hiding (lookup)

{- $setup
>>> import qualified Numeric.Interpolation.NodeList as Nodes
>>> import qualified Data.Traversable as Trav
>>> import qualified Data.Foldable as Fold
>>> import qualified Data.List as List
>>> import Data.Tuple.HT (mapSnd)
>>> import Data.Char (ord)
-}


data T x y = Interval | Node (x, y) (T x y) (T x y)
   deriving (T x y -> T x y -> Bool
(T x y -> T x y -> Bool) -> (T x y -> T x y -> Bool) -> Eq (T x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y. (Eq x, Eq y) => T x y -> T x y -> Bool
/= :: T x y -> T x y -> Bool
$c/= :: forall x y. (Eq x, Eq y) => T x y -> T x y -> Bool
== :: T x y -> T x y -> Bool
$c== :: forall x y. (Eq x, Eq y) => T x y -> T x y -> Bool
Eq, Eq (T x y)
Eq (T x y)
-> (T x y -> T x y -> Ordering)
-> (T x y -> T x y -> Bool)
-> (T x y -> T x y -> Bool)
-> (T x y -> T x y -> Bool)
-> (T x y -> T x y -> Bool)
-> (T x y -> T x y -> T x y)
-> (T x y -> T x y -> T x y)
-> Ord (T x y)
T x y -> T x y -> Bool
T x y -> T x y -> Ordering
T x y -> T x y -> T x y
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x y. (Ord x, Ord y) => Eq (T x y)
forall x y. (Ord x, Ord y) => T x y -> T x y -> Bool
forall x y. (Ord x, Ord y) => T x y -> T x y -> Ordering
forall x y. (Ord x, Ord y) => T x y -> T x y -> T x y
min :: T x y -> T x y -> T x y
$cmin :: forall x y. (Ord x, Ord y) => T x y -> T x y -> T x y
max :: T x y -> T x y -> T x y
$cmax :: forall x y. (Ord x, Ord y) => T x y -> T x y -> T x y
>= :: T x y -> T x y -> Bool
$c>= :: forall x y. (Ord x, Ord y) => T x y -> T x y -> Bool
> :: T x y -> T x y -> Bool
$c> :: forall x y. (Ord x, Ord y) => T x y -> T x y -> Bool
<= :: T x y -> T x y -> Bool
$c<= :: forall x y. (Ord x, Ord y) => T x y -> T x y -> Bool
< :: T x y -> T x y -> Bool
$c< :: forall x y. (Ord x, Ord y) => T x y -> T x y -> Bool
compare :: T x y -> T x y -> Ordering
$ccompare :: forall x y. (Ord x, Ord y) => T x y -> T x y -> Ordering
$cp1Ord :: forall x y. (Ord x, Ord y) => Eq (T x y)
Ord, Int -> T x y -> ShowS
[T x y] -> ShowS
T x y -> String
(Int -> T x y -> ShowS)
-> (T x y -> String) -> ([T x y] -> ShowS) -> Show (T x y)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x y. (Show x, Show y) => Int -> T x y -> ShowS
forall x y. (Show x, Show y) => [T x y] -> ShowS
forall x y. (Show x, Show y) => T x y -> String
showList :: [T x y] -> ShowS
$cshowList :: forall x y. (Show x, Show y) => [T x y] -> ShowS
show :: T x y -> String
$cshow :: forall x y. (Show x, Show y) => T x y -> String
showsPrec :: Int -> T x y -> ShowS
$cshowsPrec :: forall x y. (Show x, Show y) => Int -> T x y -> ShowS
Show)

{- |
prop> \xs -> map (mapSnd ord) xs == Nodes.toList (fmap ord (Nodes.fromList (xs::[(Integer,Char)])))
-}
instance Functor (T x) where
   fmap :: (a -> b) -> T x a -> T x b
fmap a -> b
f =
      let go :: T x a -> T x b
go T x a
Interval = T x b
forall x y. T x y
Interval
          go (Node (x
x,a
y) T x a
l T x a
r) = (x, b) -> T x b -> T x b -> T x b
forall x y. (x, y) -> T x y -> T x y -> T x y
Node (x
x, a -> b
f a
y) (T x a -> T x b
go T x a
l) (T x a -> T x b
go T x a
r)
      in  T x a -> T x b
forall x. T x a -> T x b
go

{- |
prop> \xs -> map snd xs == Fold.toList (Nodes.fromList (xs::[(Integer,Char)]))
-}
instance Foldable (T x) where
   foldMap :: (a -> m) -> T x a -> m
foldMap a -> m
f =
      let go :: T x a -> m
go T x a
Interval = m
forall a. Monoid a => a
mempty
          go (Node (x
_x,a
y) T x a
l T x a
r) = T x a -> m
go T x a
l m -> m -> m
forall a. Semigroup a => a -> a -> a
<> a -> m
f a
y m -> m -> m
forall a. Semigroup a => a -> a -> a
<> T x a -> m
go T x a
r
      in  T x a -> m
forall x. T x a -> m
go

{- |
prop> \x xs -> let f acc y = (acc+y,acc) in List.mapAccumL f x (map snd xs) == mapSnd Fold.toList (Trav.mapAccumL f x (Nodes.fromList (xs::[(Int,Integer)])))
-}
instance Traversable (T x) where
   traverse :: (a -> f b) -> T x a -> f (T x b)
traverse a -> f b
f =
      let go :: T x a -> f (T x b)
go T x a
Interval = T x b -> f (T x b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure T x b
forall x y. T x y
Interval
          go (Node (x
x,a
y) T x a
l0 T x a
r0) =
             (T x b -> b -> T x b -> T x b)
-> f (T x b) -> f b -> f (T x b) -> f (T x b)
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (\T x b
l b
m T x b
r -> (x, b) -> T x b -> T x b -> T x b
forall x y. (x, y) -> T x y -> T x y -> T x y
Node (x
x,b
m) T x b
l T x b
r) (T x a -> f (T x b)
go T x a
l0) (a -> f b
f a
y) (T x a -> f (T x b)
go T x a
r0)
      in  T x a -> f (T x b)
forall x. T x a -> f (T x b)
go


{- |
list must be sorted with respect to first element
-}
fromList :: [(x,y)] -> T x y
fromList :: [(x, y)] -> T x y
fromList =
   let merge :: T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
merge T x y
n0 [((x, y), T x y)]
xys0 =
          case [((x, y), T x y)]
xys0 of
             ((x, y)
xy0,T x y
n1):((x, y)
xy1,T x y
n2):[((x, y), T x y)]
xys ->
                ((x, y) -> T x y -> T x y -> T x y
forall x y. (x, y) -> T x y -> T x y -> T x y
Node (x, y)
xy0 T x y
n0 T x y
n1,
                 (((x, y), T x y) -> [((x, y), T x y)] -> [((x, y), T x y)])
-> (((x, y), T x y), [((x, y), T x y)]) -> [((x, y), T x y)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((((x, y), T x y), [((x, y), T x y)]) -> [((x, y), T x y)])
-> (((x, y), T x y), [((x, y), T x y)]) -> [((x, y), T x y)]
forall a b. (a -> b) -> a -> b
$ (T x y -> ((x, y), T x y))
-> (T x y, [((x, y), T x y)])
-> (((x, y), T x y), [((x, y), T x y)])
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((,) (x, y)
xy1) ((T x y, [((x, y), T x y)])
 -> (((x, y), T x y), [((x, y), T x y)]))
-> (T x y, [((x, y), T x y)])
-> (((x, y), T x y), [((x, y), T x y)])
forall a b. (a -> b) -> a -> b
$ T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
merge T x y
n2 [((x, y), T x y)]
xys)
             ((x, y)
xy0,T x y
n1):[] -> ((x, y) -> T x y -> T x y -> T x y
forall x y. (x, y) -> T x y -> T x y -> T x y
Node (x, y)
xy0 T x y
n0 T x y
n1, [])
             [] -> (T x y
n0, [])
       rep :: (T x y, [((x, y), T x y)]) -> T x y
rep (T x y
n,[((x, y), T x y)]
xyns) = if [((x, y), T x y)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((x, y), T x y)]
xyns then T x y
n else (T x y, [((x, y), T x y)]) -> T x y
rep ((T x y, [((x, y), T x y)]) -> T x y)
-> (T x y, [((x, y), T x y)]) -> T x y
forall a b. (a -> b) -> a -> b
$ T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
forall x y.
T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
merge T x y
n [((x, y), T x y)]
xyns
   in  (T x y, [((x, y), T x y)]) -> T x y
forall x y. (T x y, [((x, y), T x y)]) -> T x y
rep ((T x y, [((x, y), T x y)]) -> T x y)
-> ([(x, y)] -> (T x y, [((x, y), T x y)])) -> [(x, y)] -> T x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
forall x y.
T x y -> [((x, y), T x y)] -> (T x y, [((x, y), T x y)])
merge T x y
forall x y. T x y
Interval ([((x, y), T x y)] -> (T x y, [((x, y), T x y)]))
-> ([(x, y)] -> [((x, y), T x y)])
-> [(x, y)]
-> (T x y, [((x, y), T x y)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((x, y) -> ((x, y), T x y)) -> [(x, y)] -> [((x, y), T x y)]
forall a b. (a -> b) -> [a] -> [b]
map (((x, y) -> T x y -> ((x, y), T x y))
-> T x y -> (x, y) -> ((x, y), T x y)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) T x y
forall x y. T x y
Interval)

{- |
prop> \x y -> Nodes.singleton x y == Nodes.fromList [(x,y)::(Integer,Char)]
-}
singleton :: x -> y -> T x y
singleton :: x -> y -> T x y
singleton x
x y
y = (x, y) -> T x y -> T x y -> T x y
forall x y. (x, y) -> T x y -> T x y -> T x y
Node (x
x,y
y) T x y
forall x y. T x y
Interval T x y
forall x y. T x y
Interval

{- |
prop> \xs -> xs == Nodes.toList (Nodes.fromList (xs::[(Integer,Char)]))
-}
toList :: T x y -> [(x,y)]
toList :: T x y -> [(x, y)]
toList =
   let go :: T x y -> [(x, y)]
go T x y
Interval = []
       go (Node (x, y)
p T x y
l T x y
r) = T x y -> [(x, y)]
go T x y
l [(x, y)] -> [(x, y)] -> [(x, y)]
forall a. [a] -> [a] -> [a]
++ (x, y)
p (x, y) -> [(x, y)] -> [(x, y)]
forall a. a -> [a] -> [a]
: T x y -> [(x, y)]
go T x y
r
   in  T x y -> [(x, y)]
forall x y. T x y -> [(x, y)]
go

{- |
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2::Int,'b')])) (-1)
(Nothing,Just (0,'a'))
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2::Int,'b')])) 0
(Just (0,'a'),Just (2,'b'))
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2::Int,'b')])) 1
(Just (0,'a'),Just (2,'b'))
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2::Int,'b')])) 2
(Just (2,'b'),Nothing)
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2::Int,'b')])) 3
(Just (2,'b'),Nothing)
>>> Nodes.lookup (Nodes.fromList ([(0,'a'),(2,'b'),(5::Int,'c')])) 3
(Just (2,'b'),Just (5,'c'))
-}
lookup :: Ord x => T x y -> x -> (Maybe (x,y), Maybe (x,y))
lookup :: T x y -> x -> (Maybe (x, y), Maybe (x, y))
lookup T x y
nodes0 x
x0 =
   let go :: Maybe (x, y)
-> Maybe (x, y) -> T x y -> (Maybe (x, y), Maybe (x, y))
go Maybe (x, y)
lb Maybe (x, y)
rb T x y
Interval = (Maybe (x, y)
lb, Maybe (x, y)
rb)
       go Maybe (x, y)
lb Maybe (x, y)
rb (Node n :: (x, y)
n@(x
x,y
_y) T x y
ln T x y
rn) =
          if x
x0x -> x -> Bool
forall a. Ord a => a -> a -> Bool
>=x
x
            then Maybe (x, y)
-> Maybe (x, y) -> T x y -> (Maybe (x, y), Maybe (x, y))
go ((x, y) -> Maybe (x, y)
forall a. a -> Maybe a
Just (x, y)
n) Maybe (x, y)
rb T x y
rn
            else Maybe (x, y)
-> Maybe (x, y) -> T x y -> (Maybe (x, y), Maybe (x, y))
go Maybe (x, y)
lb ((x, y) -> Maybe (x, y)
forall a. a -> Maybe a
Just (x, y)
n) T x y
ln
   in  Maybe (x, y)
-> Maybe (x, y) -> T x y -> (Maybe (x, y), Maybe (x, y))
forall y.
Maybe (x, y)
-> Maybe (x, y) -> T x y -> (Maybe (x, y), Maybe (x, y))
go Maybe (x, y)
forall a. Maybe a
Nothing Maybe (x, y)
forall a. Maybe a
Nothing T x y
nodes0