packages feed

ms (empty) → 0.1

raw patch · 6 files changed

+370/−0 lines, 6 filesdep +basedep +contravariantdep +doctestsetup-changed

Dependencies added: base, contravariant, doctest, edit-distance, lens, ms, profunctors, semigroups, tasty, tasty-quickcheck, vector

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Ricky Elrod+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ms.cabal view
@@ -0,0 +1,66 @@+name:                ms+version:             0.1+synopsis:            metric spaces+description:+  A 'MetricSpace' is a set together with a notion of distance between+  elements. Distance is computed by a function 'dist' which has the following+  four laws:+  .+    (1) __non-negative__: @forall x y. 'dist' x y >= 0@+    (2) __identity of indiscernibles__: @forall x y. 'dist' x y == 0 \<=\> x == y@+    (3) __symmetry__: @forall x y. dist x y == 'dist' y x@+    (4) __triangle inequality__: @forall x y z. 'dist' x z <= 'dist' x y + 'dist' y z@+  .+  See the Wikipedia <https://en.wikipedia.org/wiki/Metric_space article on+  metric spaces> for more details.++homepage:            https://github.com/relrod/ms+license:             BSD2+license-file:        LICENSE+author:              Ricky Elrod, Tony Morris+maintainer:          ricky@elrod.me+copyright:           (C) 2015 Ricky Elrod, Tony Morris+category:            Math+build-type:          Simple+cabal-version:       >= 1.10++source-repository head+  type:     git+  location: https://github.com/relrod/ms++library+  exposed-modules:+    Math.MetricSpace+  build-depends:       base >= 4 && < 5+                     , contravariant >= 1 && < 2+                     , edit-distance >= 0.2 && < 0.3+                     , lens >= 4 && < 5+                     , profunctors >= 5 && < 6+                     , semigroups >= 0.12 && < 0.17+                     , vector >= 0.10 && < 0.12+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             test.hs+  build-depends:       base >= 4 && < 5+                     , tasty >= 0.10+                     , tasty-quickcheck >= 0.8+                     , ms+                     , profunctors >= 5 && < 6+                     , vector >= 0.10 && < 0.12+  ghc-options:         -threaded+                       -O2+                       "-with-rtsopts=-N"++test-suite doctests+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  ghc-options:        -threaded+  hs-source-dirs:      tests+  main-is:             doctests.hs+  build-depends:       base >= 4 && < 5+                     , doctest >= 0.8
+ src/Math/MetricSpace.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Math.MetricSpace+-- Copyright   :  (C) 2015 Ricky Elrod, Tony Morris+-- License     :  BSD2 (see LICENSE file)+--+-- Maintainer  :  Ricky Elrod <ricky@elrod.me>+-- Stability   :  provisional+-- Portability :  lens+--+-- A 'MetricSpace' is a set together with a notion of distance between+-- elements. Distance is computed by a function 'dist' which has the following+-- four laws:+--+--   (1) __non-negative__: @forall x y. 'dist' x y >= 0@+--   (2) __identity of indiscernibles__: @forall x y. 'dist' x y == 0 \<=\> x == y@+--   (3) __symmetry__: @forall x y. dist x y == 'dist' y x@+--   (4) __triangle inequality__: @forall x y z. 'dist' x z <= 'dist' x y + 'dist' y z@+--+-- See the Wikipedia <https://en.wikipedia.org/wiki/Metric_space article on+-- metric spaces> for more details.+----------------------------------------------------------------------------+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 qualified Data.Vector as V+import Text.EditDistance++-- $setup+-- >>> import qualified Data.Vector as V++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++-- TODO: How to make this useful? Right now the precedence is all wrong.+infixl 8 <->+(<->) :: MetricSpace a b -> a -> a -> b+(<->) = dist+{-# INLINE (<->) #-}++instance Functor (MetricSpace a) where+  fmap = dimap id+  {-# INLINE fmap #-}++instance Applicative (MetricSpace a) where+  pure = MetricSpace . const . const+  {-# INLINE pure #-}+  MetricSpace f <*> MetricSpace a = MetricSpace (\x y -> f x y (a x y))+  {-# INLINE (<*>) #-}++instance Monad (MetricSpace a) where+  return = pure+  {-# INLINE return #-}+  MetricSpace f >>= fn =+    MetricSpace (\x y -> let MetricSpace s =  fn (f x y) in s x y)+  {-# INLINE (>>=) #-}++instance Semigroup b => Semigroup (MetricSpace a b) where+  MetricSpace m1 <> MetricSpace m2 =+    MetricSpace (\a1 a2 -> m1 a1 a2 <> m2 a1 a2)+  {-# INLINE (<>) #-}++instance Monoid b => Monoid (MetricSpace a b) where+  mempty = MetricSpace . const . const $ mempty+  {-# INLINE mempty #-}+  mappend (MetricSpace m1) (MetricSpace m2) =+    MetricSpace (\a1 a2 -> m1 a1 a2 `mappend` m2 a1 a2)+  {-# INLINE mappend #-}++instance Profunctor MetricSpace where+  lmap f (MetricSpace b) = MetricSpace (b `on` f)+  {-# INLINE lmap #-}++  rmap f (MetricSpace b) = MetricSpace (\x y -> f (b x y))+  {-# INLINE rmap #-}++_FlippedMetricSpace+  :: Iso+     (MetricSpace a b)+     (MetricSpace x y)+     (FlippedMetricSpace b a)+     (FlippedMetricSpace y x)+_FlippedMetricSpace = iso FlippedMetricSpace (\(FlippedMetricSpace m) -> m)+{-# INLINE _FlippedMetricSpace #-}++instance Contravariant (FlippedMetricSpace b) where+  contramap f (FlippedMetricSpace m) = FlippedMetricSpace (dimap f id m)+  {-# INLINE contramap #-}++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))+  {-# INLINE divide #-}+  conquer = FlippedMetricSpace . MetricSpace . const . const $ mempty+  {-# INLINE conquer #-}++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 (\a1 a2 -> m a2 a1))+      (\(MetricSpace m) -> MetricSpace (\a2 a1 -> m a1 a2))+  {-# INLINE _SwappedMetricSpace #-}++instance SwappedMetricSpace FlippedMetricSpace where+  _SwappedMetricSpace =+    iso+      (\(FlippedMetricSpace (MetricSpace m)) ->+         FlippedMetricSpace (MetricSpace (\a1 a2 -> m a2 a1)))+      (\(FlippedMetricSpace (MetricSpace m)) ->+         FlippedMetricSpace (MetricSpace (\a1 a2 -> m a2 a1)))+  {-# INLINE _SwappedMetricSpace #-}++-- | Levenshtein distance between 'String's.+--+-- >>> dist levenshtein "foo" "bar"+-- 3.0+--+-- >>> dist levenshtein "hi" "ha"+-- 1.0+--+-- >>> dist levenshtein "ff" "ff"+-- 0.0+levenshtein :: Floating b => MetricSpace String b+levenshtein =+  MetricSpace (\a b -> fromIntegral $ levenshteinDistance defaultEditCosts a b)+{-# INLINE levenshtein #-}++-- | Discrete distance over n-dimensional 'Vector's.+--+-- >>> dist discrete (V.fromList [3,4]) (V.fromList [3,4])+-- 0.0+--+-- >>> dist discrete (V.fromList [1,49]) (V.fromList [3,-94])+-- 1.0+discrete :: (Eq a, Floating b) => MetricSpace (V.Vector a) b+discrete = MetricSpace (\a b -> if a == b then 0 else 1)+{-# INLINE discrete #-}++-- | Euclidean distance over n-dimensional 'Vector's.+--+-- >>> dist euclidean (V.fromList [3,4]) (V.fromList [3,4])+-- 0.0+--+-- >>> dist euclidean (V.fromList [1,49]) (V.fromList [3,-94])+-- 143.01398533010678+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 -> (x-y)^2) a b)+{-# INLINE euclidean #-}++-- | Taxicab distance over n-dimensional 'Vector's.+--+-- >>> dist taxicab (V.fromList [3,4]) (V.fromList [3,4])+-- 0.0+--+-- >>> dist taxicab (V.fromList [1,49]) (V.fromList [3,-94])+-- 145.0+taxicab :: RealFloat a => MetricSpace (V.Vector a) a+taxicab = MetricSpace f+  where+    f a b = V.sum (V.zipWith (\x y -> abs (x-y)) a b)+{-# INLINE taxicab #-}
+ tests/doctests.hs view
@@ -0,0 +1,2 @@+import Test.DocTest+main = doctest ["-isrc", "src/Math/MetricSpace.hs"]
+ tests/test.hs view
@@ -0,0 +1,85 @@+import Data.Profunctor+import qualified Data.Vector as V+import Math.MetricSpace+import Test.Tasty+import Test.Tasty.QuickCheck as QC++data SameLengthVector3 a = SameLengthVector3 (V.Vector a) (V.Vector a) (V.Vector a) deriving Show++main = defaultMain $ opts tests+  where+    opts = localOption (QuickCheckTests 3000)++tests :: TestTree+tests = testGroup "Tests" [properties]++properties :: TestTree+properties = testGroup "Properties" [qcProps]++nonnegative :: (Num b, Ord b) => MetricSpace a b -> a -> a -> Bool+nonnegative m a b = dist m a b >= 0++indisc :: (Eq b, Num b) => MetricSpace a b -> a -> Bool+indisc m a = dist m a a == 0++symmetry :: Eq b => MetricSpace a b -> a -> a -> Bool+symmetry m a b = dist m a b == dist m b a++triangle :: (Num b, Ord b) => MetricSpace a b -> a -> a -> a -> Bool+triangle m a b c = dist m a c <= dist m a b + dist m b c++instance (Arbitrary a) => Arbitrary (V.Vector a) where+  arbitrary = fmap V.fromList arbitrary++triangleVect+  :: (Num b, Ord b, Show a, Arbitrary a) =>+     MetricSpace (V.Vector a) b -> V.Vector a -> Property+triangleVect m xs =+  forAll (vectorOf (V.length xs) arbitrary) $ \ys ->+  forAll (vectorOf (V.length xs) arbitrary) $ \zs -> triangle m xs (V.fromList ys) (V.fromList zs)++genTestGroup+  :: (Num b, Ord b, Show a, Arbitrary a, Eq a) =>+     TestName -> MetricSpace a b -> TestTree+genTestGroup name metric =+  testGroup name [+        QC.testProperty "nonnegative" $ \a b -> nonnegative metric a b+      , QC.testProperty "indisc" $ \a -> indisc metric a+      , QC.testProperty "symmetry" $ \a b -> symmetry metric a b+      , QC.testProperty "triangle" $ \a b -> triangle metric a b+      , QC.testProperty "profunctor lmap" $ \a b -> dist (lmap id metric) a b == dist metric a b+      , QC.testProperty "profunctor rmap" $ \a b -> dist (rmap id metric) a b == dist metric a b+    ]++genTestGroupV+  :: (Num b, Ord b, Show a, Arbitrary a, Eq a) =>+     TestName -> MetricSpace (V.Vector a) b -> TestTree+genTestGroupV name metric =+  testGroup name [+        QC.testProperty "nonnegative" $ \a b -> nonnegative metric a b+      , QC.testProperty "indisc" $ \a -> indisc metric a+      , QC.testProperty "symmetry" $ \a b -> symmetry metric a b+      -- TODO:+      --, QC.testProperty "triangle" $ triangleVect metric+      , QC.testProperty "profunctor lmap" $ \a b -> dist (lmap id metric) a b == dist metric a b+      , QC.testProperty "profunctor rmap" $ \a b -> dist (rmap id metric) a b == dist metric a b+    ]++qcProps = testGroup "(checked by QuickCheck)"+  [+    genTestGroup "levenshtein" levenshtein++    -- Double+  , testGroup "Double" [+        genTestGroupV "discrete" (discrete :: MetricSpace (V.Vector Double) Double)+      , genTestGroupV "euclidean" (euclidean :: MetricSpace (V.Vector Double) Double)+      , genTestGroupV "taxicab" (taxicab :: MetricSpace (V.Vector Double) Double)+    ]++    -- Float+  , testGroup "Float" [+        genTestGroupV "discrete" (discrete :: MetricSpace (V.Vector Float) Float)+      , genTestGroupV "euclidean" (euclidean :: MetricSpace (V.Vector Float) Float)+      , genTestGroupV "taxicab" (taxicab :: MetricSpace (V.Vector Float) Float)+    ]+  ]