module SubHask.Algebra.Metric
where
import SubHask.Category
import SubHask.Algebra
import SubHask.Algebra.Ord
import SubHask.Internal.Prelude
import Control.Monad
import Data.List (nubBy,permutations,sort)
import System.IO
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)
printQuadDistances m1 m2 m3 m4 = do
forM_ xs $ \(match,dist) -> do
putStrLn $ match ++ " = " ++ show dist
where
xs = nubBy (\(x,_) (y,_) -> x==y)
$ sort
$ map mkMatching
$ permutations [('1',m1),('2',m2),('3',m3),('4',m4)]
mkMatching [(i1,n1),(i2,n2),(i3,n3),(i4,n4)] =
( (\[x,y] -> x++":"++y) $ sort
[ sort (i1:i2:[])
, sort (i3:i4:[])
]
, distance n1 n2 + distance n3 n4
)
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'
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)
instance (Eq v, HasScalar v) => Eq_ (Ball v) where
b1 == b2 = radius b1 == radius b2
&& center b1 == center b2
instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where
b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) }
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)
newtype BanachBall v = BanachBall (Ball v)