content: -- | This module provides an interface to the cover tree data structure.
  -- Cover trees are used for fast nearest neighbor queries.
  -- They are similar to kd-trees, but they are faster in high dimensions and can be used on more types of data.
  -- In particular, they can be used on anything that is an instance of "Metric".
  --
  -- See the paper <http://izbicki.me/public/papers/icml2015-faster-cover-trees.pdf Faster Cover Trees> for a detailed explanation of the theory.
  -- I'm happy to answer any questions you have about the implementation details here.
  module HLearn.Data.SpaceTree.CoverTree_Specialized
      ( BCoverTree
      , UCoverTree
      , CoverTree_
      , ValidCT
  
      -- * Debug interface
      -- | The functions below are not intended for standard use.
      -- They provide an advanced interface to assist with development.
      -- Instead, you should use the functions from the "Container" hierarchy of classes provided by subhask.
  
      -- ** Optimizations
      , ctAdoptNodes
      , setMaxDescendentDistance
      , sortChildren
      , cmp_numdp_distance
      , cmp_numdp_distance'
      , cmp_distance_numdp
      , cmp_distance_numdp'
      , setLeaves
      , packCT
  
      -- ** Alternative Construction Methods
      , trainMonoid
  
      , trainInsertOrig
      , trainInsertNoSort
      , trainInsert
  
      , insertCTOrig
      , insertCTNoSort
      , insertCT
  
      , AddChildMethod
      , addChild_nothing
      , addChild_parent
      , addChild_ancestor
  
      -- ** Performance Measures
      , ctAveCoverRatio
      , ctMaxCoverRatio
      , ctMovableParents
      , ctBetterMovableParents
      , ctMovableNodes
      , ctBetterMovableNodes
  
      -- ** Invariants
      , invariant_CoverTree_covering
      , invariant_CoverTree_tightCovering
      , invariant_CoverTree_maxDescendentDistance
      , invariant_CoverTree_separating
      )
      where
  
  import qualified Data.List as L
  import qualified Prelude as P
  
  import SubHask
  import SubHask.Monad
  import SubHask.Algebra.Array
  import SubHask.Algebra.Container
  import SubHask.Algebra.Ord
  import SubHask.Algebra.Vector
  import SubHask.Compatibility.Containers
  
  import HLearn.Data.SpaceTree
  import HLearn.Data.SpaceTree.CoverTree.Unsafe
  import HLearn.Models.Distributions
  
  -------------------------------------------------------------------------------
  
  -- | The type of boxed cover trees.
  type BCoverTree = CoverTree_ () BArray BArray
  
  -- | The type of unboxed cover trees.
  -- Typically more than 2x faster than boxed cover trees.
  type UCoverTree = CoverTree_ () BArray UArray
  
  -- | A generic type of cover tree that let's the user specify a number of internal parameters about how memory is represented internally.
  -- You probably don't want to use this type.
  data CoverTree_
          ( exprat                :: * ) -- FIXME: should be "Frac" from typeparams
          ( childC                :: * -> * )
          ( leafC                 :: * -> * )
          ( dp                    :: * )
      = Node
  --         { nodedp                :: !dp
  --         , level                 :: {-#UNPACK#-}!Int
  --         , nodeWeight            :: !(Scalar dp)
  --         , numdp                 :: !(Scalar dp)
  --         , maxDescendentDistance :: !(Scalar dp)
  --         , children              :: !(childC (CoverTree_ exprat childC leafC dp))
  --         , leaves                :: !(leafC dp)
          { nodedp                :: {-#UNPACK#-}!(Labeled' (UVector "dyn" Float) Int)
          , nodeWeight            :: {-#UNPACK#-}!Float
          , level                 :: {-#UNPACK#-}!Int
          , numdp                 :: {-#UNPACK#-}!Float
          , maxDescendentDistance :: {-#UNPACK#-}!Float
          , children              :: {-#UNPACK#-}!(BArray (CoverTree_ exprat childC leafC dp))
          , leaves                :: {-#UNPACK#-}!(UArray dp)
          }
  
  mkMutable [t| forall a b c d. CoverTree_ a b c d |]
  
  type instance Scalar (CoverTree_ exprat childC leafC dp) = Scalar dp
  type instance Logic (CoverTree_ exprat childC leafC dp) = Bool
  type instance Elem (CoverTree_ exprat childC leafC dp) = dp
  type instance SetElem (CoverTree_ exprat childC leafC dp) dp' = CoverTree_ exprat childC leafC dp'
  
  -- | This type alias simplifies all our type signatures.
  -- It ensures that a "CoverTree_"'s parameters are sufficient to carry out the necessary operations.
  --
  -- FIXME:
  -- Trim this set of constraints to be more manageable.
  --
  -- FIXME:
  -- There is a much smaller subset of these that is actually needed,
  -- but GHC's type system isn't strong enough to express this subset.
  type ValidCT exprat childC leafC dp =
      ( Foldable (childC (CoverTree_ exprat childC leafC dp))
      , Foldable (leafC dp)
      , Constructible (childC (CoverTree_ exprat childC leafC dp))
      , Constructible (leafC dp)
      , IxContainer (childC (CoverTree_ exprat childC leafC dp))
      , Sliceable (leafC dp)
      , Normed (childC (CoverTree_ exprat childC leafC dp))
      , Normed (leafC dp)
      , Elem (childC (CoverTree_ exprat childC leafC dp)) ~ CoverTree_ exprat childC leafC dp
      , Elem (leafC dp) ~ dp
      , Metric dp
      , QuotientField (Scalar dp) Int
      , Real (Scalar dp)
      , Bounded (Scalar dp)
  --     , CanError (Scalar dp)
      , Logic dp ~ Bool
      , Logic (CoverTree_ exprat childC leafC dp) ~ Bool
      , Logic (Scalar (leafC dp)) ~ Bool
      , NFData (CoverTree_ exprat childC leafC dp)
      , HasScalar dp
      , Eq_ (childC (CoverTree_ exprat childC leafC dp))
      , Index (leafC dp) ~ Int
      , Scalar (childC (CoverTree_ exprat childC leafC dp)) ~ Int
  
      , ClassicalLogic (leafC dp)
      , ClassicalLogic (leafC (CoverTree_ exprat childC leafC dp))
      , ClassicalLogic (childC (CoverTree_ exprat childC leafC dp))
      , Container (leafC dp)
      , Container (childC (CoverTree_ exprat childC leafC dp))
  
      -- ghc7.10
      , Elem (childC (CoverTree_ exprat childC leafC dp)) ~ (CoverTree_ exprat childC leafC dp)
      , Scalar (childC (CoverTree_ exprat childC leafC dp)) ~ Scalar (leafC dp)
      , Hilbert (Scalar (Elem (childC (Scalar dp))))
      , FiniteModule (Scalar (Elem (childC (Scalar dp))))
  
      -- unpack
      , dp ~ Labeled' (UVector "dyn" Float) Int
      , childC~BArray
      , leafC~UArray
  
      -- these constraints come from hlearn-allknn
      , Scalar (leafC dp) ~ Scalar (childC (CoverTree_ exprat childC leafC dp))
      , Elem (childC Bool) ~ Bool
      , Elem (childC (Scalar dp)) ~ Scalar dp
      , Elem (leafC dp) ~ dp
      , Foldable (childC Bool)
      , Foldable (childC (Scalar dp))
      , Integral (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , NFData (Scalar dp)
      , NFData dp
  
      -- debugging constraints
      , Show (Scalar dp)
      , Show dp
      , Show (leafC dp)
      , Show (childC (CoverTree_ exprat childC leafC dp))
      , Show (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , Show (Scalar (leafC dp))
      )
  
  -------------------------------------------------------------------------------
  -- type classes
  
  instance
      ( ValidCT exprat childC leafC dp
      ) => SpaceTree (CoverTree_ exprat childC leafC) dp
          where
  
      type ChildContainer (CoverTree_ exprat childC leafC ) = childC
      type LeafContainer (CoverTree_ exprat childC leafC ) = leafC
  
      stChildren  = children
      stLeaves    = leaves
      stNode      = nodedp
      stWeight    = nodeWeight
  
      stMaxDescendentDistance = maxDescendentDistance
  
  ----------------------------------------
  -- misc type classes
  
  deriving instance
      ( Show (childC (CoverTree_ exprat childC leafC dp))
      , Show (leafC dp)
      , Show dp
      , Show (Scalar dp)
      , ValidCT exprat childC leafC dp
      ) => Show (CoverTree_ exprat childC leafC dp)
  
  instance
      ( NFData (childC (CoverTree_ exprat childC leafC dp))
      , NFData (leafC dp)
      , NFData dp
      , NFData (Scalar dp)
      ) => NFData (CoverTree_ exprat childC leafC dp) where
      rnf ct = deepseq (nodedp ct)
             $ deepseq (nodeWeight ct)
             $ deepseq (level ct)
             $ deepseq (numdp ct)
             $ deepseq (maxDescendentDistance ct)
             $ deepseq (children ct)
             $ deepseq (leaves ct)
             $ rnf ()
  
  ----------------------------------------
  -- comparison
  
  instance ValidCT exprat childC leafC dp => Eq_ (CoverTree_ exprat childC leafC dp) where
      ct1==ct2 = stToList ct1==stToList ct2
  
  -- FIXME: need proper MultiSet type to implement
  --
  -- instance
  --     ( ValidCT exprat childC leafC dp
  --     ) => POrd_ (Maybe' (CoverTree_ exprat childC leafC dp))
  --         where
  --
  --     inf ct1 ct2 = trainInsert addChild_ancestor
  --         $ inf (convertContainer ct1) (convertContainer ct2 :: Set dp)
  --         where
  --             convertContainer = fromList . stToList
  --
  -- instance
  --     ( ValidCT exprat childC leafC dp
  --     ) => Lattice_ (Maybe' (CoverTree_ exprat childC leafC dp))
  --         where
  --
  --     sup ct1 ct2 = trainInsert addChild_ancestor
  --         $ sup (convertContainer ct1) (convertContainer ct2 :: Set dp)
  --         where
  --             convertContainer = fromList . stToList
  
  ----------------------------------------
  -- algebra
  
  instance ValidCT exprat childC leafC dp => Normed (CoverTree_ exprat childC leafC dp) where
      size = numdp
  
  ----------------------------------------
  -- container
  
  instance
      ( ValidCT exprat childC leafC dp
      ) => Constructible (CoverTree_ exprat childC leafC dp)
          where
  
      singleton = singletonCT
      fromList1 x xs = fromJust' $ trainInsert addChild_ancestor (x:xs)
  
  instance
      ( ValidCT exprat childC leafC dp
      ) => Container (CoverTree_ exprat childC leafC dp)
          where
  
      -- FIXME: use the covertree's structure!
      elem e ct = elem e $ stToList ct
  
  -- FIXME:
  -- We need to make subhask's hierarchy a bit more generic before we can make cover trees foldable.
  --
  -- instance
  --     ( ValidCT exprat childC leafC dp
  --     ) => Foldable (CoverTree_ exprat childC leafC dp)
  --         where
  --     toList = stToList
  
  -------------------------------------------------------------------------------
  -- construction
  
  {-# INLINABLE singletonCT #-}
  singletonCT :: ValidCT exprat childC leafC dp => dp -> CoverTree_  exprat childC leafC dp
  singletonCT dp = Node
      { nodedp                = dp
      , nodeWeight            = 1
      , level                 = minBound
      , numdp                 = 1
      , children              = empty
      , leaves                = empty
      , maxDescendentDistance = 0
      }
  
  ----------------------------------------
  
  -- | Construct a cover tree using the original algorithm.
  {-# INLINABLE trainInsertOrig #-}
  trainInsertOrig ::
      ( ValidCT exprat childC leafC (Elem xs)
      , Foldable xs
      ) => xs
        -> Maybe' (CoverTree_ exprat childC leafC (Elem xs))
  trainInsertOrig xs = {-# SCC trainInsertOrig #-}case uncons xs of
      Nothing -> Nothing'
      Just (dp,dps) -> Just' $ rmSingletons $ foldr' insertCTOrig (singletonCT dp) dps
  
      where
          -- Removes nodes that have only a single child that contains the same datapoint.
          -- These singleton nodes are not supposed to be included in the original cover tree's expicit representation,
          -- but the way our insertion method works it is easiest to add them then remove them at the end of insertion.
          -- The new insertion methods can't create singleton nodes.
          rmSingletons ::
              ( ValidCT exprat childC leafC dp
              ) => CoverTree_ exprat childC leafC dp
                -> CoverTree_ exprat childC leafC dp
          rmSingletons ct =  if isSingleton
              then  rmSingletons onlyChild
              else ct
                  { children = fromList $ map rmSingletons $ toList $ children ct
                  }
              where
                  isSingleton = size (children ct) == 1
                             && nodedp onlyChild == nodedp ct
  
                  onlyChild = P.head $ toList $ children ct
  
  -- | Insert a node into a cover tree using the original algorithm.
  {-# INLINABLE insertCTOrig #-}
  insertCTOrig ::
      ( ValidCT exprat childC leafC dp
      ) => dp
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  insertCTOrig dp ct = insertCTOrig_ dp ct (distance dp (nodedp ct))
  
  -- | Helper function required for GHC's optimizer to work properly.
  {-# INLINABLE insertCTOrig_ #-}
  insertCTOrig_ :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => dp
        -> CoverTree_ exprat childC leafC dp
        -> Scalar dp
        -> CoverTree_ exprat childC leafC dp
  insertCTOrig_ !dp !ct !dist = {-# SCC insertCTOrig_ #-}
      if dist > coverdist ct
  
          -- ct can't cover dp, so create a new node at dp that covers ct
          then Node
              { nodedp                = dp
              , nodeWeight            = 1
              , level                 = dist2level_up (Proxy::Proxy exprat) dist
              , numdp                 = numdp ct+1
              , maxDescendentDistance = dist+maxDescendentDistance ct
              , children              = singleton
                                      $ raiseRootLevel (dist2level_down (Proxy::Proxy exprat) dist)
                                      $ ct
              , leaves                = empty
              }
  
          -- insert dp underneath ct
          else ct
              { numdp                 = numdp ct+1
              , maxDescendentDistance = max dist (maxDescendentDistance ct)
              , children              = fromList $ go [] $ toList $ children ct
              }
  
          where
              go !acc (x:xs) = if isFartherThan (nodedp x) dp (sepdist ct)
                  then go (x:acc) xs
                  else acc+((insertCTOrig dp x):xs)
  
              go !acc [] = if dist >= sepdist ct
  
                  -- far from root, so just insert the node
                  then ((singletonCT dp) { level = level ct-1 }):acc
  
                  -- close to root, so add new lower root level
                  else insertCTOrig_ dp ct' dist:acc
                      where
                          ct' = (singletonCT (nodedp ct))
                              { level      = level ct-1
                              , numdp      = 0
                              , nodeWeight = 0
                              }
  
  ----------------------------------------
  
  -- | This corresponds to the simplified cover tree in the ICML paper.
  {-# INLINABLE trainInsertNoSort #-}
  trainInsertNoSort ::
      ( ValidCT exprat childC leafC (Elem xs)
      , Foldable xs
      ) => xs
        -> Maybe' (CoverTree_ exprat childC leafC (Elem xs))
  trainInsertNoSort xs = {-# SCC trainInsertNoSort #-}case uncons xs of
      Nothing -> Nothing'
      Just (dp,dps) -> Just' $ foldr' insertCTNoSort (singletonCT dp) dps
  
  -- | This corresponds to the simplified cover tree in the ICML paper.
  {-# INLINABLE insertCTNoSort #-}
  insertCTNoSort :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => dp
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  insertCTNoSort dp ct = {-# SCC insertCTNoSort #-} insertCTNoSort_ dp ct $ distance dp (nodedp ct)
  
  -- | Helper function required for GHC's optimizer to work properly.
  {-# INLINABLE insertCTNoSort_ #-}
  insertCTNoSort_ :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => dp
        -> CoverTree_ exprat childC leafC dp
        -> Scalar dp
        -> CoverTree_ exprat childC leafC dp
  insertCTNoSort_ dp ct dist = {-# SCC insertCTNoSort_ #-}
      if dist > coverdist ct
  
          -- ct can't cover dp, so create a new node at dp that covers ct
          then Node
              { nodedp                = dp
              , nodeWeight            = 1
              , level                 = dist2level_up (Proxy::Proxy exprat) dist
              , numdp                 = numdp ct+1
              , maxDescendentDistance = dist+maxDescendentDistance ct
              , children              = singleton
                                      $ raiseRootLevel (dist2level_down (Proxy::Proxy exprat) dist)
                                      $ ct
              , leaves                = empty
              }
  
          -- insert dp underneath ct
          else ct
              { numdp                 = numdp ct+1
              , maxDescendentDistance = max dist (maxDescendentDistance ct)
              , children              = {-# SCC conv #-} fromList $ go [] $ toList $ children ct
              }
  
          where
              go !acc []     = {-# SCC go #-} ((singletonCT dp) { level = level ct-1 }):acc
              go !acc (x:xs) = {-# SCC go #-} if isFartherThan (nodedp x) dp (sepdist ct)
                  then go (x:acc) xs
                  else acc+((insertCTNoSort dp x):xs)
  
  ----------------------------------------
  
  -- | Provides a generic insertion method that lets us enforce a whole suite of invariants related to the nearest ancestor invariant of the ICML paper.
  {-# INLINABLE trainInsert #-}
  trainInsert ::
      ( ValidCT exprat childC leafC (Elem xs)
      , Foldable xs
      ) => AddChildMethod exprat childC leafC (Elem xs)
        -> xs
        -> Maybe' (CoverTree_ exprat childC leafC (Elem xs))
  trainInsert addChild xs = {-# SCC trainInsert #-} case uncons xs of
      Nothing -> Nothing'
      Just (dp,dps) -> Just' $ foldr' (insertCT addChild) (singletonCT dp) $ toList dps
  
  -- | Insert a single data point into the cover tree.
  {-# INLINABLE insertCT #-}
  insertCT :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
        -> dp
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  insertCT addChild dp ct =
      insertCT_ addChild dp ct (distance dp $ nodedp ct)
  
  -- | This function is exactly the same as insertCT.
  -- We need to provide a different function, however, for performance reasons.
  -- There's many weird layers of recursion going on in these functions,
  -- and this was preventing GHC from inlining/specializing these functions.
  -- Now, insertCT is not recussive, so GHC can trivially inline it.
  {-# INLINABLE insertCT_internal #-}
  insertCT_internal :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
        -> dp
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  insertCT_internal addChild dp ct =
      insertCT_ addChild dp ct (distance dp $ nodedp ct)
  
  -- | Like "insertCT", but this function also takes the distance between the data point and root of the cover tree to avoid recomputation.
  {-# INLINABLE insertCT_ #-}
  insertCT_ :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
        -> dp
        -> CoverTree_ exprat childC leafC dp
        -> Scalar dp
        -> CoverTree_ exprat childC leafC dp
  insertCT_ addChild dp ct dist = {-# SCC insertCT_ #-}
      if dist > coverdist ct
          -- ct can't cover dp, so create a new node at dp that covers ct
          then Node
              { nodedp                = dp
              , nodeWeight            = 1
              , level                 = dist2level_up (Proxy::Proxy exprat) dist
              , numdp                 = numdp ct+1
              , maxDescendentDistance = dist+maxDescendentDistance ct
              , children              = singleton
                                      $ raiseRootLevel (dist2level_down (Proxy::Proxy exprat) dist)
                                      $ ct
              , leaves                = empty
              }
  
          -- insert dp underneath ct
          else ct
              { numdp                 = numdp ct+1
              , maxDescendentDistance = max dist (maxDescendentDistance ct)
              , children              = fromList $ go [] childrendists
              }
  
          where
              childrendists = map (\x -> (distance dp (nodedp x), x)) $ toList $ children ct
  
              mindist = minimum $ map fst childrendists
  
              go !acc [] = addChild dp ct
              go !acc ((dist,x):xs) = if dist == mindist && dist <= coverdist x
                  then insertCT_ addChild dp x dist:(acc+map snd xs)
                  else go (x:acc) xs
  
  -- | These functions control the invariants we maintain while performing insertions into the cover tree.
  -- The input data point will be directly inserted as one of the children of the root of the tree.
  -- Therefore, we require it satisfy the separating and covering conditions (and any other applicable conditions).
  -- The function may (possibly) move points from other nodes into this new child to enforce other invariants.
  -- The return value is the list of new children for the root node after the insertion has taken place.
  --
  -- NOTE:
  --
  -- We could make this type synonym have a much "prettier" interface like so:
  --
  -- > type AddChildMethod dp = forall exprat childC leafC.
  -- >     ValidCT exprat childC leafC dp
  -- >         => dp
  -- >         -> CoverTree_ exprat childC leafC dp
  -- >         -> [CoverTree_ exprat childC leafC dp]
  --
  -- But this has devastating effects on performance.
  -- It combines with the weird recursive calls to prevent inlining, which results in >10x slow downs.
  type AddChildMethod exprat childC leafC dp
          =  dp
          -> CoverTree_ exprat childC leafC dp
          -> [CoverTree_ exprat childC leafC dp]
  
  {-# INLINABLE addChild_nothing #-}
  addChild_nothing ::
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
  addChild_nothing dp ct = cons
      ( (singletonCT dp) { level = level ct-1} )
      (toList $ children ct)
  
  {-# INLINABLE addChild_parent #-}
  addChild_parent ::
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
  addChild_parent dp ct = {-# SCC addChild_parent #-} ret:acc'
      where
          (acc',dps) = rmCloseChildren addChild_parent dp  $ toList $ children ct
          ct'=(singletonCT dp) { level = level ct-1 }
          ret=foldr' (insertCT_internal addChild_parent) ct' $ concat $ map stToList dps
  
  {-# INLINABLE addChild_ancestor #-}
  addChild_ancestor :: forall exprat childC leafC dp k.
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
  addChild_ancestor dp ct = {-# SCC addChild_ancestor #-}
      toList $ children $ foldr' (insertCT addChild_ancestor) ct' (concat $ map stToList dps)
      where
          ( acc', dps ) = rmCloseChildren addChild_ancestor dp  $ toList $ children ct
  
          ct' :: CoverTree_ exprat childC leafC dp
          ct' = ct
              { children = fromList $ ((singletonCT dp) { level = level ct-1 }) : acc'
              }
  
  {-# INLINABLE rmCloseChildren #-}
  rmCloseChildren ::
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
        -> dp
        -> [CoverTree_ exprat childC leafC dp]
        -> ( [CoverTree_ exprat childC leafC dp]
           , [CoverTree_ exprat childC leafC dp]
           )
  rmCloseChildren addChild dp cts = {-# SCC rmCloseChildren #-}
      (map fst xs, P.concat $ map snd xs)
      where
          xs = map (extractCloseChildren addChild dp) cts
  
  {-# INLINABLE extractCloseChildren #-}
  extractCloseChildren :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => AddChildMethod exprat childC leafC dp
        -> dp
        -> CoverTree_ exprat childC leafC dp
        -> ( CoverTree_ exprat childC leafC dp
           , [CoverTree_ exprat childC leafC dp]
           )
  extractCloseChildren addChild dp root = {-# SCC extractCloseChildren #-}
      case go root of
          (Just' x,xs) -> (x,xs)
      where
          go ct = if dist_ct_root + maxDescendentDistance ct < dist_ct_dp
              then (Just' ct,[])
              else if dist_ct_root > dist_ct_dp
                  then (Nothing', [ct])
                  else
                      ( Just' $ ct
                          { children = fromList children'
                          , numdp    = nodeWeight ct + sum (map numdp children')
                          }
                      , concat $ map snd allbabies
                      )
                  where
                      allbabies = map go $ toList $ children ct
                      children' = justs' $ map fst allbabies
  
                      dist_ct_root = distance (nodedp ct) (nodedp root)
                      dist_ct_dp   = distance (nodedp ct) dp
  
  {-# INLINABLE moveLeafToRoot #-}
  moveLeafToRoot :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp
        -> Maybe' (CoverTree_ exprat childC leafC dp)
  moveLeafToRoot ct = if stHasNoChildren ct
      then Nothing'
      else Just' $ ct
          { nodedp   = nodedp leaf
          , numdp    = numdp ct - numdp leaf
          , children = children ct'
          , maxDescendentDistance = coverdist ct*2
          }
      where
          (leaf,ct') = rmleaf ct
  
  --------------------------------------------------------------------------------
  
  {-# INLINABLE trainMonoid #-}
  trainMonoid ::
      ( ValidCT exprat childC leafC (Elem xs)
      , Foldable xs
      ) => xs
        -> Maybe' (CoverTree_ exprat childC leafC (Elem xs))
  trainMonoid xs = {-# SCC trainMonoid #-} foldtree1 $ map (Just' . singletonCT) $ toList xs
  
  instance
      ( ValidCT exprat childC leafC dp
      ) => Semigroup (CoverTree_ exprat childC leafC dp)
          where
  
      {-# INLINABLE (+) #-}
      ct1 + ct2 = {-# SCC semigroup_CoverTree #-} case ctmerge_ ct1_ ct2_ dist of
          (ct, []) -> ct
          (ct, xs) -> {-# SCC sg_foldr #-} foldr' insertCTNoSort ct $ concat $ map stToList xs
  
          where
              dist = distance (nodedp ct1) (nodedp ct2)
  
              maxlevel = maximum
                  [ level ct1
                  , level ct2
                  , dist2level_down (Proxy::Proxy exprat) dist
                  ]
  
              ct1_ = if level ct1 < maxlevel then raiseRootLevel maxlevel ct1 else ct1
              ct2_ = if level ct2 < maxlevel then raiseRootLevel maxlevel ct2 else ct2
  
  -- | If the following prerequisites are met:
  --
  -- > level ct1==level ct2
  --
  -- > distance (nodedp ct1) (nodedp ct2) < coverdist ct1
  --
  -- then all output covertrees will be valid.
  -- The root of ct1 is guaranteed to not change.
  {-# INLINABLE ctmerge_ #-}
  ctmerge_ :: forall exprat childC leafC  dp.
      ( ValidCT exprat childC leafC  dp
      ) => CoverTree_ exprat childC leafC  dp
        -> CoverTree_ exprat childC leafC  dp
        -> Scalar dp
        -> ( CoverTree_ exprat childC leafC  dp
           , [CoverTree_ exprat childC leafC  dp]
           )
  ctmerge_ ct1 ct2 dist =
  
      {-# SCC ctmerge_ #-}
      ( ct' , notCoveredChildren+leftovers' )
      where
          -- remove the children of ct2 that can't be covered by ct1 ("notCoveredChildren");
          -- these will be handled separately in (+)
          (coveredChildren,notCoveredChildren) = {-# SCC isCovered #-}
              L.partition isCovered $ stChildrenList ct2
              where
                  isCovered x = not $ isFartherThan (nodedp ct1) (nodedp x) (coverdist ct1)
  
          -- sepcovChildren is not a part of children' because we loop through children' in go
          -- adding in sepcovChildren would result in extra iterations
          (children',sepcovChildren,leftovers)
              = {-# SCC sg_foldl #-} foldl' (go []) (stChildrenList ct1,[],[]) coveredChildren
              where
                  -- merge covChild with a child of ct1' within the separating distance
                  go tot (x:xs,ys,zs) covChild = if godist <= sepdist ct1
                      then let (x',zs') = ctmerge_ x covChild godist
                           in (x':tot++xs,ys,zs'++zs)
                      else go (x:tot) (xs,ys,zs) covChild
                      where
                          godist = distance (nodedp x) (nodedp covChild)
  
                  -- nothing within separating distance, so add covChild as new child
                  go tot ([],ys,zs) covChild = (tot,covChild:ys,zs)
  
          -- update children, insert root of ct2 into ct1
          ct_minusleftovers = {-# SCC minusleftover #-} insertCTNoSort_
              (nodedp ct2)
              ( ct1
                  { children = fromList $ children' + sepcovChildren
                  , numdp =  sum $ map numdp $ children' + sepcovChildren
                  , maxDescendentDistance = coverdist ct1*2
                  } )
              dist
  
          -- insert any leftovers into the tree if they fit
          (ct',leftovers') = {-# SCC part4 #-} foldl' go (ct_minusleftovers,[]) leftovers
              where
                  go (ct,xs) x = if level ct >= level x && godist <= coverdist ct
                      then (goct, goleftovers++xs)
                      else (ct,x:xs)
                      where
                          godist = distance (nodedp ct) (nodedp x)
                          (goct,goleftovers) = ctmerge_ ct (raiseRootLevel (level ct) x) godist
  
  -- | FIXME: does this work if there are leaves present?
  {-# INLINABLE raiseRootLevel #-}
  raiseRootLevel :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => Int
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  raiseRootLevel i ct
      | stHasNoChildren ct = {-# SCC raiseRootLevel #-}ct { level = i }
      | i <  level ct = error
          $ "\nraiseRootLevel: target level less than current tree level"
          + "; i="+show i
          + "; level ct="+show (level ct)
          + "; nodedp ct="+show (nodedp ct)
      | i == level ct = {-# SCC raiseRootLevel #-}ct
      | i >  level ct = {-# SCC raiseRootLevel #-} raiseRootLevel i $ leaf
          { level = level ct'+1
          , numdp = numdp ct'+nodeWeight leaf
          , maxDescendentDistance = distance (nodedp leaf) (nodedp ct) + maxDescendentDistance ct'
          , children = singleton ct'
          }
      where
          (leaf,ct') = rmleaf ct
  
  {-# INLINABLE rmleaf #-}
  rmleaf ::
      ( ValidCT exprat childC leafC  dp
      ) => CoverTree_ exprat childC leafC  dp
        -> ( CoverTree_ exprat childC leafC  dp
           , CoverTree_ exprat childC leafC  dp
           )
  rmleaf ct = {-# SCC rmleaf #-} if stHasNoChildren head
      then ( head
           , ct
              { numdp    = numdp ct-nodeWeight head
              , children = tail
              }
           )
      else ( itrleaf
           , ct
              { numdp    = numdp ct-nodeWeight head
              , children = itrtree `cons` tail
              }
           )
      where
          (itrleaf,itrtree) = rmleaf head
  
          childL = children ct
          (head,tail)  = case uncons childL of Just x -> x
  
  --------------------------------------------------------------------------------
  -- Performance measurements
  
  -- | returns a measure of how "spread out" descendent points are
  {-# INLINABLE ctMaxCoverRatio #-}
  ctMaxCoverRatio ::
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp -> Scalar dp
  ctMaxCoverRatio ct = if size (children ct) + size (leaves ct) > 0
      then maximum
          $ (stMaxDescendentDistance ct / coverdist ct)
          : map ctMaxCoverRatio (toList $ children ct)
      else 0
  
  -- | returns a measure of how "spread out" descendent points are
  {-# INLINABLE ctAveCoverRatio #-}
  ctAveCoverRatio ::
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp -> Normal (Scalar dp)
  ctAveCoverRatio ct = if size (children ct) + size (leaves ct) > 0
      then train1Normal (stMaxDescendentDistance ct / coverdist ct)
         + reduce (map ctAveCoverRatio $ toList $ children ct)
      else zero
  
  -- | counts the number of parents in the tree that have nephews that could be placed under them
  {-# INLINABLE ctMovableParents #-}
  ctMovableParents ::
      ( ValidCT exprat childC leafC dp
      , Integral (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , Integral (Scalar (leafC dp))
      ) => CoverTree_ exprat childC leafC dp -> Int
  ctMovableParents ct
      = sum (map movableChildren $ toList $ children ct)
      + sum (map ctMovableParents  $ toList $ children ct)
      where
          movableChildren c
              = sum (map totalParentsOfChildren (                  toList $ children c))
              + sum (map totalParentsOfChildren (map singletonCT $ toList $ leaves   c))
              - (fromIntegral $ toInteger $ size $ children c)
              - (fromIntegral $ toInteger $ size $ leaves c)
  
          totalParentsOfChildren c
              = sum
              $ map (\p -> indicator $ distance (nodedp c) (nodedp p) <= sepdist ct)
              $ toList (children ct)
             ++ toList (map singletonCT $ toList $ leaves ct)
  
  -- | counts the number of parents in the tree that have nephews that would be better placed under them
  {-# INLINABLE ctBetterMovableParents #-}
  ctBetterMovableParents ::
      ( ValidCT exprat childC leafC dp
      , Integral (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , Integral (Scalar (leafC dp))
      ) => CoverTree_ exprat childC leafC dp -> Int
  ctBetterMovableParents ct
      = sum (map betterMovableChildren  $ toList $ children ct)
      + sum (map ctBetterMovableParents $ toList $ children ct)
      where
          betterMovableChildren c
              = sum (map (totalBetterParentsOfChildren c) (                  toList $ children c))
              + sum (map (totalBetterParentsOfChildren c) (map singletonCT $ toList $ leaves   c))
              - (fromIntegral $ toInteger $ size $ children c)
              - (fromIntegral $ toInteger $ size $ leaves c)
  
          totalBetterParentsOfChildren realparent c
              = sum
              $ map (\p -> indicator $ distance (nodedp c) (nodedp p)
                                    <= distance (nodedp c) (nodedp realparent))
              $ toList (children ct)
             ++ toList (map singletonCT $ toList $ leaves ct)
  
  -- | counts the number of nodes in the tree with uncles they could be moved under
  {-# INLINABLE ctMovableNodes #-}
  ctMovableNodes ::
      ( ValidCT exprat childC leafC dp
      , Integral (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , Integral (Scalar (leafC dp))
      ) => CoverTree_ exprat childC leafC dp -> Int
  ctMovableNodes ct
      = sum (map movableChildren $ toList $ children ct)
      + sum (map ctMovableNodes  $ toList $ children ct)
      where
          movableChildren c
              = sum (map totalNodesOfChildren (                  toList $ children c))
              + sum (map totalNodesOfChildren (map singletonCT $ toList $ leaves   c))
  
          totalNodesOfChildren c
              = indicator
              $ (> (1::Int))
              $ sum
              $ map (\p -> indicator $ distance (nodedp c) (nodedp p) < sepdist ct)
              $ toList (children ct)
             ++ toList (map singletonCT $ toList $ leaves ct)
  
  -- | Counts the number of nodes in the tree with uncles they would be better placed under
  {-# INLINABLE ctBetterMovableNodes #-}
  ctBetterMovableNodes ::
      ( ValidCT exprat childC leafC dp
      , Integral (Scalar (childC (CoverTree_ exprat childC leafC dp)))
      , Integral (Scalar (leafC dp))
      ) => CoverTree_ exprat childC leafC dp -> Int
  ctBetterMovableNodes ct
      = sum (map betterMovableChildren  $ toList $ children ct)
      + sum (map ctBetterMovableNodes $ toList $ children ct)
      where
          betterMovableChildren c
              = sum (map (totalBetterNodesOfChildren c) (                  toList $ children c))
              + sum (map (totalBetterNodesOfChildren c) (map singletonCT $ toList $ leaves   c))
  
          totalBetterNodesOfChildren realparent c
              = indicator
              $ or
              $ map (\p -> distance (nodedp c) (nodedp p)
                         < distance (nodedp c) (nodedp realparent)
                    )
              $ toList (children ct)
             ++ toList (map singletonCT $ toList $ leaves ct)
  
  -------------------------------------------------------------------------------
  -- tests
  
  invariant_CoverTree_covering ::
      ( ValidCT exprat childC leafC dp
      , Elem (childC (Scalar dp)) ~ Scalar dp
      , Elem (childC Bool) ~ Bool
      , Foldable (childC Bool)
      , Foldable (childC (Scalar dp))
      ) => CoverTree_ exprat childC leafC dp -> Bool
  invariant_CoverTree_covering node
      = and (map invariant_CoverTree_covering $ stChildrenList node)
     && and (map (\child -> distance  (nodedp node) (nodedp child) <= coverdist node) $ stChildrenList node)
  
  invariant_CoverTree_tightCovering ::
      ( ValidCT exprat childC leafC dp
      , Elem (childC (Scalar dp)) ~ Scalar dp
      , Elem (childC Bool) ~ Bool
      , Foldable (childC Bool)
      , Foldable (childC (Scalar dp))
      ) => CoverTree_ exprat childC leafC dp -> Bool
  invariant_CoverTree_tightCovering node
      = and (map invariant_CoverTree_tightCovering $ stChildrenList node)
     && and (map (\dp -> distance dp (nodedp node) <= coverdist node) $ stDescendents node)
  
  invariant_CoverTree_maxDescendentDistance ::
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp -> Bool
  invariant_CoverTree_maxDescendentDistance node
      = and (map invariant_CoverTree_maxDescendentDistance $ stChildrenList node)
     && and (map (\dp -> distance dp (nodedp node) <= maxDescendentDistance node) $ stDescendents node)
  
  invariant_CoverTree_separating ::
      ( ValidCT exprat childC leafC dp
      , Elem (childC Bool) ~ Bool
      , Foldable (childC Bool)
      , Foldable (childC (Scalar dp))
      ) => CoverTree_ exprat childC leafC dp -> Bool
  invariant_CoverTree_separating node
      = minimum ( P.filter (>0)
                $ map (\(x,y) -> distance (nodedp x) (nodedp y))
                $ cartesianProduct (toList $ children node) (toList $ children node)
                )
        >= sepdist node
     && and (map invariant_CoverTree_separating $ toList $ children node)
      where
          cartesianProduct :: [a] -> [b] -> [(a,b)]
          cartesianProduct xs ys = P.concatMap (\y -> map (\x -> (x,y)) xs) ys
  
  {-
  -- | FIXME:
  -- This needs to be converted to use subhask notation.
  property_leveled ::
      ( ValidCT exprat childC leafC dp
      , VG.Vector childC Bool
      , VG.Vector childC Int
      , VG.Vector childC (CoverTree_ exprat childC leafC dp)
      ) => CoverTree_ exprat childC leafC dp -> Bool
  property_leveled node
      = VG.all (== VG.P.head xs) xs
     && VG.and (VG.map property_leveled $ children node)
      where
          xs = VG.map level $ children node
  -}
  
  -------------------------------------------------------------------------------
  -- optimization helpers
  
  -- | uncles adopt all children that are closer to them than their parents
  {-# INLINABLE ctAdoptNodes #-}
  ctAdoptNodes ::
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  ctAdoptNodes ct = ct { children = fromList $ map ctAdoptNodes $ go [] $ toList $ children ct }
      where
          go acc []     = acc
          go acc (x:xs) = go (x { children = (fromList accchildren+fromList xschildren+children x)}:acc') xs'
              where
                  betterMoveNode y c = distance (nodedp x) (nodedp c) < distance (nodedp y) (nodedp c)
  
                  extractChildren y = ( oldchildren, y { children = fromList newchildren } )
                      where
                          (oldchildren,newchildren) = L.partition (betterMoveNode y) $ toList $ children y
  
                  extractChildrenL ys = foldl' ecgo ([],[]) ys
                      where
                          ecgo (oldchildL, newchildL) y = (oldchildren++oldchildL,newparent:newchildL)
                              where
                                  (oldchildren, newparent) = extractChildren y
  
                  (accchildren, acc') = extractChildrenL acc
                  (xschildren, xs') = extractChildrenL xs
  
  -- | Sets the "maxDescendentDistance" parameter to the tightest bound possible.
  -- This makes future queries of the tree more efficient---we can prune off more traversals, resulting in fewer distance computations.
  --
  -- FIXME:
  -- This version uses a branch-and-bound recursion that is much faster than the previous naive implementation.
  -- But it would be cooler (and faster?) if we used a find farthest neighbor method in the SpaceTree framework.
  {-# INLINABLE setMaxDescendentDistance #-}
  setMaxDescendentDistance ::
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  setMaxDescendentDistance ct = {-# SCC setMaxDescendentDistance #-} ct
      { children = children'
      , maxDescendentDistance = max leavesMaxDist $ go 0 (toList $ children')
      }
      where
  
          children' = fromList $ map setMaxDescendentDistance $ toList $ children ct
  
          leavesMaxDist = maximum $ map (distance (nodedp ct)) $ toList $ leaves ct
  
          go curmax []     = curmax
          go curmax (x:xs) = go curmax' xs
              where
                  curmax' = if dist + maxDescendentDistance x <= curmax
                      then curmax
                      else go (maximum [dist,leavesMaxDist,curmax]) (toList $ children x)
  
                  leavesMaxDist = maximum $ map (distance (nodedp ct)) $ toList $ leaves x
  
                  dist = distance (nodedp x) (nodedp ct)
  
  ---------------------------------------
  
  {-# INLINABLE sortChildren #-}
  sortChildren ::
      ( ValidCT exprat childC leafC dp
      ) => ( CoverTree_ exprat childC leafC dp
          -> CoverTree_ exprat childC leafC dp
          -> CoverTree_ exprat childC leafC dp
          -> Ordering
           )
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  sortChildren cmp ct = ct
      { children = fromList $ L.sortBy (cmp ct) $ map (sortChildren cmp) $ toList $ children ct
      }
  
  cmp_numdp_distance ct a b
      = compare (numdp a) (numdp b)
      + compare (distance (nodedp ct) (nodedp a)) (distance (nodedp ct) (nodedp b))
  
  cmp_numdp_distance' ct b a
      = compare (numdp a) (numdp b)
      + compare (distance (nodedp ct) (nodedp a)) (distance (nodedp ct) (nodedp b))
  
  cmp_distance_numdp ct a b
      = compare (distance (nodedp ct) (nodedp a)) (distance (nodedp ct) (nodedp b))
      + compare (numdp a) (numdp b)
  
  cmp_distance_numdp' ct b a
      = compare (distance (nodedp ct) (nodedp a)) (distance (nodedp ct) (nodedp b))
      + compare (numdp a) (numdp b)
  
  ---------------------------------------
  
  -- | This function moves subtrees that have @n@ children or less from @childC@ to @leafC@.
  -- The @leafC@ container stores data points directly.
  -- This makes traversals faster and greatly improves runtimes.
  {-# INLINABLE setLeaves #-}
  setLeaves ::
      ( ValidCT exprat childC leafC dp
      ) => Int
        -> CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  setLeaves n ct = {-# SCC setLeaves #-} if stNumNodes ct > n
      then ct
          { children = fromList $ map (setLeaves n) $ L.filter (not . stHasNoChildren) $ toList $ children ct
          , leaves = fromList $ map nodedp $ L.filter stHasNoChildren $ toList $ children ct
          }
      else ct
          { children = zero
          , leaves = fromList $ stToList ct
          }
  
  -- | This function puts the data points into a van Embde Boas layout.
  -- This is a cache oblivious layout that causes queries to have fewer cache misses (and hence run faster).
  -- Any modifications to the cover tree after calling "PackCT" will result in a slow degradation of cache performance.
  {-# INLINABLE packCT #-}
  packCT :: forall exprat childC leafC dp.
      ( ValidCT exprat childC leafC dp
      ) => CoverTree_ exprat childC leafC dp
        -> CoverTree_ exprat childC leafC dp
  packCT ct = {-# SCC packCT #-} snd $ go 0 ct
      where
          dpvec :: leafC dp
          dpvec = fromList $ stToList ct
  
          go !i !t = {-# SCC packCT_go #-} ( i',t
              { nodedp = dpvec!i
              , leaves = slice (i+1) (length $ leaves t) dpvec
              , children = fromList children'
              } )
              where
                  (i',children') = {-# SCC mapAccumL #-} L.mapAccumL
                      go
                      (i+1+length (leaves t))
                      (toList $ children t)
  
  -------------------------------------------------------------------------------
  -- helper functions
  
  coverdist :: (QuotientField (Scalar dp) Int, Real (Scalar dp)) =>
      CoverTree_ exprat childC leafC  dp -> Scalar dp
  coverdist node = sepdist node*getExprat
  
  sepdist :: forall exprat childC leafC dp. (QuotientField (Scalar dp) Int, Real (Scalar dp)) =>
      CoverTree_ exprat childC leafC dp -> Scalar dp
  sepdist ct = getExprat**(fromIntegral $ level ct)
  
  level2sepdist :: (QuotientField f r, Real f) => r -> f
  level2sepdist i = getExprat**(fromIntegral i)
  
  level2coverdist :: (QuotientField f r, Real f) => r -> f
  level2coverdist i = level2sepdist (i+1)
  
  dist2level_down :: forall exprat num.
      ({-KnownFrac exprat, -}Real num, QuotientField num Int) => Proxy exprat -> num -> Int
  dist2level_down _ d = floor $ log d / log getExprat
  
  dist2level_up :: forall exprat num.
      ({-KnownFrac exprat,-} Real num, QuotientField num Int) => Proxy exprat -> num -> Int
  dist2level_up _ d = ceiling $ log d / log getExprat
  