{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# language DeriveGeneric #-}
{-# language LambdaCase #-}
{-# language DeriveFoldable, DeriveTraversable, DeriveFunctor #-}
module Data.VPTree.Internal where

import Control.Monad.ST (ST, runST)
import Data.Word (Word32)
import GHC.Generics (Generic(..))

-- deepseq
import Control.DeepSeq (NFData(..))
-- mwc-probability
import qualified System.Random.MWC.Probability as P (Gen, withSystemRandom, asGenIO, GenIO, create, initialize)
-- serialise
import Codec.Serialise (Serialise(..))
-- vector
import qualified Data.Vector as V (Vector)
import qualified Data.Vector.Generic as VG (Vector(..))

-- | Vantage point trees
data VPTree d a = VPT {
  VPTree d a -> VT d a
vpTree :: VT d a
  , VPTree d a -> a -> a -> d
vptDistFun :: a -> a -> d -- ^ Distance function used to construct the tree
                   } deriving ((forall x. VPTree d a -> Rep (VPTree d a) x)
-> (forall x. Rep (VPTree d a) x -> VPTree d a)
-> Generic (VPTree d a)
forall x. Rep (VPTree d a) x -> VPTree d a
forall x. VPTree d a -> Rep (VPTree d a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d a x. Rep (VPTree d a) x -> VPTree d a
forall d a x. VPTree d a -> Rep (VPTree d a) x
$cto :: forall d a x. Rep (VPTree d a) x -> VPTree d a
$cfrom :: forall d a x. VPTree d a -> Rep (VPTree d a) x
Generic)

instance (Eq d, Eq a) => Eq (VPTree d a) where
  (VPT VT d a
t1 a -> a -> d
_) == :: VPTree d a -> VPTree d a -> Bool
== (VPT VT d a
t2 a -> a -> d
_) = VT d a
t1 VT d a -> VT d a -> Bool
forall a. Eq a => a -> a -> Bool
== VT d a
t2
instance (Show d, Show a) => Show (VPTree d a) where
  show :: VPTree d a -> String
show (VPT VT d a
t a -> a -> d
_) = VT d a -> String
forall a. Show a => a -> String
show VT d a
t
instance (NFData d, NFData a) => NFData (VPTree d a) where
instance Foldable (VPTree d) where
  foldMap :: (a -> m) -> VPTree d a -> m
foldMap a -> m
f (VPT VT d a
t a -> a -> d
_) = (a -> m) -> VT d a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f VT d a
t


-- | Vantage point tree (internal representation)
data VT d a = Bin  {
  VT d a -> d
_mu :: !d -- ^ median distance to vantage point
  , VT d a -> a
_vp :: !a -- ^ vantage point
  , VT d a -> VT d a
_near :: !(VT d a) -- ^ points at a distance < mu
  , VT d a -> VT d a
_far :: !(VT d a) -- ^ points farther than mu
  }
            | Tip (V.Vector a)
            deriving (VT d a -> VT d a -> Bool
(VT d a -> VT d a -> Bool)
-> (VT d a -> VT d a -> Bool) -> Eq (VT d a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall d a. (Eq d, Eq a) => VT d a -> VT d a -> Bool
/= :: VT d a -> VT d a -> Bool
$c/= :: forall d a. (Eq d, Eq a) => VT d a -> VT d a -> Bool
== :: VT d a -> VT d a -> Bool
$c== :: forall d a. (Eq d, Eq a) => VT d a -> VT d a -> Bool
Eq, (forall x. VT d a -> Rep (VT d a) x)
-> (forall x. Rep (VT d a) x -> VT d a) -> Generic (VT d a)
forall x. Rep (VT d a) x -> VT d a
forall x. VT d a -> Rep (VT d a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d a x. Rep (VT d a) x -> VT d a
forall d a x. VT d a -> Rep (VT d a) x
$cto :: forall d a x. Rep (VT d a) x -> VT d a
$cfrom :: forall d a x. VT d a -> Rep (VT d a) x
Generic, a -> VT d b -> VT d a
(a -> b) -> VT d a -> VT d b
(forall a b. (a -> b) -> VT d a -> VT d b)
-> (forall a b. a -> VT d b -> VT d a) -> Functor (VT d)
forall a b. a -> VT d b -> VT d a
forall a b. (a -> b) -> VT d a -> VT d b
forall d a b. a -> VT d b -> VT d a
forall d a b. (a -> b) -> VT d a -> VT d b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> VT d b -> VT d a
$c<$ :: forall d a b. a -> VT d b -> VT d a
fmap :: (a -> b) -> VT d a -> VT d b
$cfmap :: forall d a b. (a -> b) -> VT d a -> VT d b
Functor, VT d a -> Bool
(a -> m) -> VT d a -> m
(a -> b -> b) -> b -> VT d a -> b
(forall m. Monoid m => VT d m -> m)
-> (forall m a. Monoid m => (a -> m) -> VT d a -> m)
-> (forall m a. Monoid m => (a -> m) -> VT d a -> m)
-> (forall a b. (a -> b -> b) -> b -> VT d a -> b)
-> (forall a b. (a -> b -> b) -> b -> VT d a -> b)
-> (forall b a. (b -> a -> b) -> b -> VT d a -> b)
-> (forall b a. (b -> a -> b) -> b -> VT d a -> b)
-> (forall a. (a -> a -> a) -> VT d a -> a)
-> (forall a. (a -> a -> a) -> VT d a -> a)
-> (forall a. VT d a -> [a])
-> (forall a. VT d a -> Bool)
-> (forall a. VT d a -> Int)
-> (forall a. Eq a => a -> VT d a -> Bool)
-> (forall a. Ord a => VT d a -> a)
-> (forall a. Ord a => VT d a -> a)
-> (forall a. Num a => VT d a -> a)
-> (forall a. Num a => VT d a -> a)
-> Foldable (VT d)
forall a. Eq a => a -> VT d a -> Bool
forall a. Num a => VT d a -> a
forall a. Ord a => VT d a -> a
forall m. Monoid m => VT d m -> m
forall a. VT d a -> Bool
forall a. VT d a -> Int
forall a. VT d a -> [a]
forall a. (a -> a -> a) -> VT d a -> a
forall d a. Eq a => a -> VT d a -> Bool
forall d a. Num a => VT d a -> a
forall d a. Ord a => VT d a -> a
forall m a. Monoid m => (a -> m) -> VT d a -> m
forall d m. Monoid m => VT d m -> m
forall d a. VT d a -> Bool
forall d a. VT d a -> Int
forall d a. VT d a -> [a]
forall b a. (b -> a -> b) -> b -> VT d a -> b
forall a b. (a -> b -> b) -> b -> VT d a -> b
forall d a. (a -> a -> a) -> VT d a -> a
forall d m a. Monoid m => (a -> m) -> VT d a -> m
forall d b a. (b -> a -> b) -> b -> VT d a -> b
forall d a b. (a -> b -> b) -> b -> VT d a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: VT d a -> a
$cproduct :: forall d a. Num a => VT d a -> a
sum :: VT d a -> a
$csum :: forall d a. Num a => VT d a -> a
minimum :: VT d a -> a
$cminimum :: forall d a. Ord a => VT d a -> a
maximum :: VT d a -> a
$cmaximum :: forall d a. Ord a => VT d a -> a
elem :: a -> VT d a -> Bool
$celem :: forall d a. Eq a => a -> VT d a -> Bool
length :: VT d a -> Int
$clength :: forall d a. VT d a -> Int
null :: VT d a -> Bool
$cnull :: forall d a. VT d a -> Bool
toList :: VT d a -> [a]
$ctoList :: forall d a. VT d a -> [a]
foldl1 :: (a -> a -> a) -> VT d a -> a
$cfoldl1 :: forall d a. (a -> a -> a) -> VT d a -> a
foldr1 :: (a -> a -> a) -> VT d a -> a
$cfoldr1 :: forall d a. (a -> a -> a) -> VT d a -> a
foldl' :: (b -> a -> b) -> b -> VT d a -> b
$cfoldl' :: forall d b a. (b -> a -> b) -> b -> VT d a -> b
foldl :: (b -> a -> b) -> b -> VT d a -> b
$cfoldl :: forall d b a. (b -> a -> b) -> b -> VT d a -> b
foldr' :: (a -> b -> b) -> b -> VT d a -> b
$cfoldr' :: forall d a b. (a -> b -> b) -> b -> VT d a -> b
foldr :: (a -> b -> b) -> b -> VT d a -> b
$cfoldr :: forall d a b. (a -> b -> b) -> b -> VT d a -> b
foldMap' :: (a -> m) -> VT d a -> m
$cfoldMap' :: forall d m a. Monoid m => (a -> m) -> VT d a -> m
foldMap :: (a -> m) -> VT d a -> m
$cfoldMap :: forall d m a. Monoid m => (a -> m) -> VT d a -> m
fold :: VT d m -> m
$cfold :: forall d m. Monoid m => VT d m -> m
Foldable, Functor (VT d)
Foldable (VT d)
Functor (VT d)
-> Foldable (VT d)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> VT d a -> f (VT d b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    VT d (f a) -> f (VT d a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> VT d a -> m (VT d b))
-> (forall (m :: * -> *) a. Monad m => VT d (m a) -> m (VT d a))
-> Traversable (VT d)
(a -> f b) -> VT d a -> f (VT d b)
forall d. Functor (VT d)
forall d. Foldable (VT d)
forall d (m :: * -> *) a. Monad m => VT d (m a) -> m (VT d a)
forall d (f :: * -> *) a. Applicative f => VT d (f a) -> f (VT d a)
forall d (m :: * -> *) a b.
Monad m =>
(a -> m b) -> VT d a -> m (VT d b)
forall d (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> VT d a -> f (VT d b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => VT d (m a) -> m (VT d a)
forall (f :: * -> *) a. Applicative f => VT d (f a) -> f (VT d a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> VT d a -> m (VT d b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> VT d a -> f (VT d b)
sequence :: VT d (m a) -> m (VT d a)
$csequence :: forall d (m :: * -> *) a. Monad m => VT d (m a) -> m (VT d a)
mapM :: (a -> m b) -> VT d a -> m (VT d b)
$cmapM :: forall d (m :: * -> *) a b.
Monad m =>
(a -> m b) -> VT d a -> m (VT d b)
sequenceA :: VT d (f a) -> f (VT d a)
$csequenceA :: forall d (f :: * -> *) a. Applicative f => VT d (f a) -> f (VT d a)
traverse :: (a -> f b) -> VT d a -> f (VT d b)
$ctraverse :: forall d (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> VT d a -> f (VT d b)
$cp2Traversable :: forall d. Foldable (VT d)
$cp1Traversable :: forall d. Functor (VT d)
Traversable)
instance (Show d, Show a) => Show (VT d a) where
  show :: VT d a -> String
show = \case
    -- Nil -> "<Nil>"
    Tip Vector a
x -> [String] -> String
unwords [String
"<Tip", Vector a -> String
forall a. Show a => a -> String
show Vector a
x, String
">"]
    Bin d
m a
v VT d a
ll VT d a
rr -> [String] -> String
unwords [String
"<Bin", d -> String
forall a. Show a => a -> String
show d
m, a -> String
forall a. Show a => a -> String
show a
v, String
":", VT d a -> String
forall a. Show a => a -> String
show VT d a
ll, VT d a -> String
forall a. Show a => a -> String
show VT d a
rr, String
">"]
instance (Serialise d, Serialise a) => Serialise (VT d a)

instance (NFData d, NFData a) => NFData (VT d a) where
  rnf :: VT d a -> ()
rnf (Bin d
d a
x VT d a
tl VT d a
tr) = d -> ()
forall a. NFData a => a -> ()
rnf d
d () -> () -> ()
`seq` a -> ()
forall a. NFData a => a -> ()
rnf a
x () -> () -> ()
`seq` VT d a -> ()
forall a. NFData a => a -> ()
rnf VT d a
tl () -> () -> ()
`seq` VT d a -> ()
forall a. NFData a => a -> ()
rnf VT d a
tr
  rnf (Tip Vector a
x) = Vector a -> ()
forall a. NFData a => a -> ()
rnf Vector a
x
  -- rnf Nil = ()



-- | Runs a PRNG action in IO
--
-- NB : uses 'withSystemRandom' internally
withIO :: (P.GenIO -> IO a) -- ^ Memory bracket for the PRNG
       -> IO a
withIO :: (GenIO -> IO a) -> IO a
withIO = (Gen RealWorld -> IO a) -> IO a
forall (m :: * -> *) a.
PrimBase m =>
(Gen (PrimState m) -> m a) -> IO a
P.withSystemRandom ((Gen RealWorld -> IO a) -> IO a)
-> ((Gen RealWorld -> IO a) -> Gen RealWorld -> IO a)
-> (Gen RealWorld -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gen RealWorld -> IO a) -> Gen RealWorld -> IO a
forall a. (GenIO -> IO a) -> GenIO -> IO a
P.asGenIO

-- | Runs a PRNG action in the 'ST' monad, using a fixed seed
--
-- NB : uses 'P.create' internally
withST_ :: (forall s . P.Gen s -> ST s a) -- ^ Memory bracket for the PRNG
        -> a
withST_ :: (forall s. Gen s -> ST s a) -> a
withST_ forall s. Gen s -> ST s a
st = (forall s. ST s a) -> a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s a) -> a) -> (forall s. ST s a) -> a
forall a b. (a -> b) -> a -> b
$ do
  Gen s
g <- ST s (Gen s)
forall (m :: * -> *). PrimMonad m => m (Gen (PrimState m))
P.create
  Gen s -> ST s a
forall s. Gen s -> ST s a
st Gen s
g

-- | Runs a PRNG action in the 'ST' monad, using a given random seed
--
-- NB : uses 'P.initialize' internally
withST :: (VG.Vector v Word32) =>
          v Word32 -- ^ Random seed
       -> (forall s . P.Gen s -> ST s a) -- ^ Memory bracket for the PRNG
       -> a
withST :: v Word32 -> (forall s. Gen s -> ST s a) -> a
withST v Word32
seed forall s. Gen s -> ST s a
st = (forall s. ST s a) -> a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s a) -> a) -> (forall s. ST s a) -> a
forall a b. (a -> b) -> a -> b
$ do
  Gen s
g <- v Word32 -> ST s (Gen (PrimState (ST s)))
forall (m :: * -> *) (v :: * -> *).
(PrimMonad m, Vector v Word32) =>
v Word32 -> m (Gen (PrimState m))
P.initialize v Word32
seed
  Gen s -> ST s a
forall s. Gen s -> ST s a
st Gen s
g


--

-- newtype App w m a = App {
--   unApp :: MaybeT (WriterT w m) a
--                         } deriving (Functor, Applicative, Monad, Alternative, MonadIO, MonadWriter w)

-- runApp :: App w m a -> m (Maybe a, w)
-- runApp a = runWriterT $ runMaybeT (unApp a)

-- runAppST :: (forall s . P.Gen s -> App w (ST s) a) -> (Maybe a, w)
-- runAppST a = withST_ (runApp . a)

-- -- testApp :: PrimMonad m => P.Gen (PrimState m) -> App m [Double] ()
-- testApp g = App $ do
--   z <- P.samples 5 (P.normal 0 1) g
--   tell z
--   pure z

-- sampleApp :: (Foldable f, PrimMonad m) =>
--              Int -> f a -> P.Gen (PrimState m) -> App m [String] [a]
-- sampleApp n ixs g = App $ do
--   zm <- sample n ixs g
--   case zm of
--     Nothing -> do
--       tell ["derp"]
--       empty
--     Just xs -> pure xs


-- runAppST :: (forall s . P.Gen s -> WriterT w (ST s) a) -> (a, w)
-- runAppST a = withST_ (runWriterT . a)