content: -- | This module defines the algebra over various types of balls in metric spaces
  module SubHask.Algebra.Metric
      where
  
  import SubHask.Category
  import SubHask.Algebra
  import SubHask.Internal.Prelude
  import Control.Monad
  import GHC.Classes (Ord)
  import qualified Data.List as L
  import System.IO
  
  --------------------------------------------------------------------------------
  
  -- | Useful for identifying tree metrics.
  printTriDistances :: (Show (Scalar m), Metric m) => m -> m -> m -> IO ()
  printTriDistances m1 m2 m3 = do
      putStrLn $ show (distance m1 m2) ++ " <= " + show (distance m2 m3 + distance m1 m3)
      putStrLn $ show (distance m1 m3) ++ " <= " + show (distance m2 m3 + distance m1 m2)
      putStrLn $ show (distance m2 m3) ++ " <= " + show (distance m1 m2 + distance m1 m3)
  
  -- | There are three distinct perfect matchings in every complete 4 node graph.
  -- A metric is a tree metric iff two of these perfect matchings have the same weight.
  -- This is called the 4 points condition.
  -- printQuadDistances :: (Ord (Scalar m), Show (Scalar m), Metric m) => m -> m -> m -> m -> IO ()
  printQuadDistances :: (GHC.Classes.Ord (Scalar t), Show (Scalar t), Metric t) =>
                        t -> t -> t -> t -> IO ()
  printQuadDistances m1 m2 m3 m4 = do
      forM_ xs $ \(match,dist) -> do
          putStrLn $ match ++ " = " ++ show dist
  
      where
          xs = L.nubBy (\(x,_) (y,_) -> x==y)
             $ L.sort
             $ map mkMatching
             $ L.permutations [('1',m1),('2',m2),('3',m3),('4',m4)]
  
          mkMatching [(i1,n1),(i2,n2),(i3,n3),(i4,n4)] =
              ( (\[x,y] -> x++":"++y) $ L.sort
                  [ L.sort (i1:i2:[])
                  , L.sort (i3:i4:[])
                  ]
              , distance n1 n2 + distance n3 n4
              )
          mkMatching _ = undefined
  
  --------------------------------------------------------------------------------
  
  -- | The closed balls in metric space.
  -- Note that since we are not assuming any special structure, addition is rather inefficient.
  --
  -- FIXME:
  -- There are several valid ways to perform the addition; which should we use?
  -- We could add Lattice instances in a similar way as we could with Box if we added an empty element; should we do this?
  
  data Ball v = Ball
      { radius :: !(Scalar v)
      , center :: !v
      }
  
  mkMutable [t| forall b. Ball b |]
  
  invar_Ball_radius :: (HasScalar v) => Ball v -> Logic (Scalar v)
  invar_Ball_radius b = radius b >= 0
  
  type instance Scalar (Ball v) = Scalar v
  type instance Logic (Ball v) = Logic v
  type instance Elem (Ball v) = v
  type instance SetElem (Ball v) v' = Ball v'
  
  -- misc classes
  
  deriving instance (Read v, Read (Scalar v)) => Read (Ball v)
  deriving instance (Show v, Show (Scalar v)) => Show (Ball v)
  
  instance (Arbitrary v, Arbitrary (Scalar v), HasScalar v) => Arbitrary (Ball v) where
      arbitrary = do
          r <- arbitrary
          c <- arbitrary
          return $ Ball (abs r) c
  
  instance (NFData v, NFData (Scalar v)) => NFData (Ball v) where
      rnf b = deepseq (center b)
            $ rnf (radius b)
  
  -- comparison
  
  instance (Eq v, HasScalar v) => Eq_ (Ball v) where
      b1 == b2 = radius b1 == radius b2
              && center b1 == center b2
  
  -- algebra
  
  instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where
      b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) }
  
  -- container
  
  instance (Metric v, HasScalar v, ClassicalLogic v) => Constructible (Ball v) where
      singleton v = Ball 0 v
  
  instance (Metric v, HasScalar v, ClassicalLogic v) => Container (Ball v) where
      elem v b = not $ isFartherThan v (center b) (radius b)
  
  --------------------------------------------------------------------------------
  
  -- | FIXME: In a Banach space we can make Ball addition more efficient by moving the center to an optimal location.
  newtype BanachBall v = BanachBall (Ball v)
  