#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
module Math.MetricSpace where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Lens
import Data.Function (on)
import Data.Functor.Contravariant.Divisible
import Data.Profunctor
import Data.Semigroup
import Data.Semigroupoid
import qualified Data.Vector as V
import Text.EditDistance
newtype MetricSpace a b = MetricSpace { dist :: a -> a -> b }
type ClosedMetricSpace a = MetricSpace a a
newtype FlippedMetricSpace b a = FlippedMetricSpace (MetricSpace a b)
type ClosedFlippedMetricSpace a = FlippedMetricSpace a a
infixl 8 <->
(<->) :: MetricSpace a b -> a -> a -> b
(<->) = dist
instance Functor (MetricSpace a) where
fmap = dimap id
instance Applicative (MetricSpace a) where
pure = MetricSpace . const . const
MetricSpace f <*> MetricSpace a = MetricSpace (\x y -> f x y (a x y))
instance Monad (MetricSpace a) where
return = pure
MetricSpace f >>= fn =
MetricSpace (\x y -> let MetricSpace s = fn (f x y) in s x y)
instance Semigroup b => Semigroup (MetricSpace a b) where
MetricSpace m1 <> MetricSpace m2 =
MetricSpace (\a1 a2 -> m1 a1 a2 <> m2 a1 a2)
instance Monoid b => Monoid (MetricSpace a b) where
mempty = MetricSpace . const . const $ mempty
mappend (MetricSpace m1) (MetricSpace m2) =
MetricSpace (\a1 a2 -> m1 a1 a2 `mappend` m2 a1 a2)
instance Profunctor MetricSpace where
lmap f (MetricSpace b) = MetricSpace (b `on` f)
rmap f (MetricSpace b) = MetricSpace (\x y -> f (b x y))
instance Semigroupoid MetricSpace where
MetricSpace m1 `o` MetricSpace m2 =
MetricSpace (\a1 a2 -> let b = m2 a1 a2 in m1 b b)
_FlippedMetricSpace
:: Iso
(MetricSpace a b)
(MetricSpace x y)
(FlippedMetricSpace b a)
(FlippedMetricSpace y x)
_FlippedMetricSpace = iso FlippedMetricSpace (\(FlippedMetricSpace m) -> m)
instance Contravariant (FlippedMetricSpace b) where
contramap f (FlippedMetricSpace m) = FlippedMetricSpace (dimap f id m)
instance Monoid b => Divisible (FlippedMetricSpace b) where
divide
f
(FlippedMetricSpace (MetricSpace m1))
(FlippedMetricSpace (MetricSpace m2)) =
FlippedMetricSpace (MetricSpace (\a1 a2 -> let (b1, c1) = f a1
(b2, c2) = f a2
in
m1 b1 b2 `mappend` m2 c1 c2))
conquer = FlippedMetricSpace . MetricSpace . const . const $ mempty
class SwappedMetricSpace m where
_SwappedMetricSpace :: Iso (m a b) (m x y) (m a b) (m x y)
instance SwappedMetricSpace MetricSpace where
_SwappedMetricSpace =
iso
(\(MetricSpace m) -> MetricSpace (flip m))
(\(MetricSpace m) -> MetricSpace (flip m))
instance SwappedMetricSpace FlippedMetricSpace where
_SwappedMetricSpace =
iso
(\(FlippedMetricSpace (MetricSpace m)) ->
FlippedMetricSpace (MetricSpace (flip m)))
(\(FlippedMetricSpace (MetricSpace m)) ->
FlippedMetricSpace (MetricSpace (flip m)))
levenshtein :: Integral b => MetricSpace String b
levenshtein =
MetricSpace (\a b -> fromIntegral $ levenshteinDistance defaultEditCosts a b)
discrete :: (Eq a, Integral b) => MetricSpace (V.Vector a) b
discrete = MetricSpace (\a b -> if a == b then 0 else 1)
euclidean :: RealFloat a => MetricSpace (V.Vector a) a
euclidean = MetricSpace (\a b -> f a b `seq` sqrt (f a b))
where
f a b = V.sum (V.zipWith (\x y -> (xy)^2) a b)
taxicab :: RealFloat a => MetricSpace (V.Vector a) a
taxicab = MetricSpace f
where
f a b = V.sum (V.zipWith (\x y -> abs (xy)) a b)
hamming :: (Eq a, Integral b) => MetricSpace (V.Vector a) b
hamming =
MetricSpace (\x y ->
fromIntegral .
V.length .
V.filter (uncurry (/=)) $ V.zip x y)