Define key for maps (#34)

* Define Product and Sum as CMonoids

* Define reduce for bags

* Rename reduce function for bags

* Define keys for finite map

* Define Maybe as a PointedSet

* Add some tests for () Key instance

* Fix index test case

* Add test cases for () key map unindex

* Comment reduceBag

* Add test for reduce

* Fix spellings

a-deeper-dive-into-relational-algebra-by-way-of-adjunctions.cabal

@@ -22,10 +22,10 @@ extra-source-files:
     README.md
 
 library
-    exposed-modules: Data.Bag, Data.PointedSet, Data.CMonoid
+    exposed-modules: Data.Bag, Data.PointedSet, Data.CMonoid, Data.Key
 
     -- Modules included in this library but not exported.
-    -- other-modules:
+    -- other-modules: 
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -54,6 +54,6 @@ test-suite spec
     type:               exitcode-stdio-1.0
     hs-source-dirs:     test
     main-is:            Spec.hs
-    other-modules:      Data.BagSpec
+    other-modules:      Data.BagSpec, Data.CMonoidSpec, Data.PointedSetSpec, Data.KeySpec
     build-depends:      base >=4.16.4.0, hspec ^>=2.10, a-deeper-dive-into-relational-algebra-by-way-of-adjunctions
     build-tool-depends: hspec-discover:hspec-discover == 2.*

src/Data/Bag.hs

@@ -48,3 +48,7 @@ empty = Bag []
 
 union :: Bag a -> Bag a -> Bag a
 b1 `union` b2 = Bag (elements b1 ++ elements b2)
+
+reduceBag :: CMonoid m => Bag m -> m
+-- Reduce a bag of ms into an m (e.g. a bag of bags into a bag)
+reduceBag = mconcat . elements

src/Data/CMonoid.hs

@@ -1,4 +1,9 @@
 module Data.CMonoid where
 
+import Data.Monoid
+
 class Monoid a => CMonoid a
--- (<>) is commutative
+-- (<>) is commutative
+
+instance Num k => CMonoid (Sum k)
+instance Num k => CMonoid (Product k)

src/Data/Key.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Data.Key where
+
+import Data.PointedSet
+import Data.Bag
+import Data.CMonoid
+
+class (Functor (Map k)) => Key k where
+  data Map k :: * -> *
+  empty :: (PointedSet v) => Map k v
+  isEmpty :: (PointedSet v) => Map k v -> Bool
+  single :: (PointedSet v) => (k, v) -> Map k v
+  merge :: (Map k v1, Map k v2) -> Map k (v1, v2)
+  unmerge :: Map k (v1, v2) -> (Map k v1, Map k v2)
+  unmerge x = (fmap fst x, fmap snd x)
+  dom :: (PointedSet v) => Map k v -> Bag k
+  cod :: (PointedSet v) => Map k v -> Bag v
+  cod t = reduce (fmap return t)
+  lookup :: Map k v -> (k -> v)
+  index :: Bag (k, v) -> Map k (Bag v)
+  unindex :: Map k (Bag v) -> Bag (k, v)
+  reduce :: (PointedSet v, CMonoid v) => Map k v -> v
+  reduce = reduceBag . cod
+
+instance Key () where
+  newtype Map () v = Lone v deriving (Show, Eq)
+
+  empty = Lone Data.PointedSet.null
+  isEmpty (Lone v) = isNull v
+  single ((), v) = Lone v
+  merge (Lone v1, Lone v2) = Lone (v1, v2)
+  dom map = if isEmpty map then Data.Bag.empty else pure ()
+  cod (Lone v) = if isEmpty (Lone v) then Data.Bag.empty else pure v 
+  lookup (Lone v) () = v
+  index kvps = Lone (fmap snd kvps)
+  unindex (Lone vs) = fmap (\v -> ((), v)) vs
+
+instance Functor (Map ()) where
+  fmap f (Lone v) = Lone (f v)

src/Data/PointedSet.hs

@@ -1,5 +1,11 @@
 module Data.PointedSet where
 
+import Data.Maybe
+
 class PointedSet a where
   null :: a
   isNull :: a -> Bool
+
+instance PointedSet (Maybe a) where
+  null = Nothing
+  isNull = isNothing

test/Data/BagSpec.hs

@@ -1,6 +1,7 @@
 module Data.BagSpec (spec) where
 
 import Test.Hspec
+import Data.Monoid
 import qualified Data.Bag as Bag
 import qualified Data.PointedSet as Pointed
 
@@ -76,6 +77,11 @@ spec = do
       Pointed.isNull (Bag.empty :: Bag.Bag Int) `shouldBe` True
     it "does not identify a non-empty Bag as null" $ do
       Pointed.isNull (Bag.Bag [1, 2, 4]) `shouldBe` False
+  describe "Data.Bag.reduceBag" $ do
+    it "correctly reduces a bag using sum" $ do
+      (getSum . Bag.reduceBag) (Bag.Bag [1, 2, 3, 4] :: Bag.Bag (Sum Int)) `shouldBe` 10
+    it "correctly reduces a bag using product" $ do
+      (getProduct . Bag.reduceBag) (Bag.Bag [1, 2, 3, 4] :: Bag.Bag (Product Int)) `shouldBe` 24
     where
       b1 = Bag.Bag ['a', 'b', 'c']
       b2 = Bag.Bag ['b', 'c', 'd']

test/Data/CMonoidSpec.hs

@@ -0,0 +1,14 @@
+module Data.CMonoidSpec (spec) where
+
+import Test.Hspec
+import Data.Monoid
+
+spec :: Spec
+spec = do
+  describe "CMonoid instance of Sum k" $ do
+    it "is commutative" $ do
+      (3 :: Sum Int) <> (5 :: Sum Int) `shouldBe` (5 :: Sum Int) <> (3 :: Sum Int)
+
+  describe "CMonoid instance of Product k" $ do
+    it "is commutative" $ do
+      (13 :: Product Int) <> (23 :: Product Int) `shouldBe` (23 :: Product Int) <> (13 :: Product Int)

test/Data/KeySpec.hs

@@ -0,0 +1,48 @@
+module Data.KeySpec (spec) where
+
+import Test.Hspec
+import Data.Key
+import qualified Data.Bag as Bag
+import qualified Data.PointedSet as Pointed
+
+spec :: Spec
+spec = do
+  describe "Data.Key ()" $ do
+    it "returns Lone null for empty" $ do
+      (empty :: Map () (Maybe Int)) `shouldBe` Lone Nothing
+    it "can detect empty" $ do
+      isEmpty (Lone Nothing :: Map () (Maybe Char)) `shouldBe` True
+    it "does not incorrectly detect empty" $ do
+      isEmpty (Lone (Just 'a') :: Map () (Maybe Char)) `shouldBe` False
+    it "returns the correct single element for not null" $ do
+      single ((), Just 3) `shouldBe` Lone (Just 3)
+    it "returns the correct single element for null" $ do
+      single ((), Nothing :: Maybe Int) `shouldBe` Lone (Nothing :: Maybe Int)
+    it "can correctly merge two maps" $ do
+      merge (Lone (Just 'b'), Lone (Just 'c')) `shouldBe` Lone (Just 'b', Just 'c')
+    it "can correctly unmerge two maps" $ do
+      unmerge (Lone (Just 3, Just 12)) `shouldBe` (Lone (Just 3), Lone (Just 12))
+    it "can correctly identify the domain of a non-empty map" $ do
+      dom (Lone (Just 'e')) `shouldBe` Bag.Bag [()]
+    it "can correctly identify the domain of an empty map" $ do
+      dom (Lone (Nothing :: Maybe Int)) `shouldBe` Bag.empty
+    it "can correctly identify the codomain of a non-empty map" $ do
+      cod (Lone (Just 'e')) `shouldBe` Bag.Bag [Just 'e']
+    it "can correctly identify the codomain of an empty map" $ do
+      cod (Lone (Nothing :: Maybe Bool)) `shouldBe` Bag.empty
+    it "can lookup elements" $ do
+      Data.Key.lookup (Lone (Just True)) () `shouldBe` Just True
+    it "can index a bag of pairs without multiplicity of keys" $ do
+      index (Bag.Bag [((), Just 'r')]) `shouldBe` Lone (Bag.Bag [Just 'r'])
+    it "can index an empty bag, with PointedSet null value as the null bag" $ do
+      index (Bag.empty :: Bag.Bag ((), Int)) `shouldBe` Lone (Pointed.null :: Bag.Bag Int)
+    it "can index a bag of pairs with multiplicity" $ do
+      index (Bag.Bag [((), 'a'), ((), 'b'), ((), 'c')]) `shouldBe` Lone (Bag.Bag ['a', 'b', 'c'])
+    it "can unindex a map with no multiplicities" $ do
+      unindex (Lone (Bag.Bag [1])) `shouldBe` Bag.Bag [((), 1)]
+    it "can unindex an empty map" $ do
+      unindex (Lone (Pointed.null :: Bag.Bag Char)) `shouldBe` (Bag.empty :: Bag.Bag ((), Char))
+    it "can unindex a map with multiplicities" $ do
+      unindex (Lone (Bag.Bag [True, True, False])) `shouldBe` Bag.Bag [((), True), ((), True), ((), False)]
+    it "can reduce a map correctly" $ do
+      reduce (Lone (Bag.Bag ['a'])) `shouldBe` Bag.Bag ['a']

test/Data/PointedSetSpec.hs

@@ -0,0 +1,14 @@
+module Data.PointedSetSpec (spec) where
+
+import Test.Hspec
+import qualified Data.PointedSet as Pointed
+
+spec :: Spec
+spec = do
+  describe "Maybe PointedSet" $ do
+    it "has Nothing as its null value" $ do
+      (Pointed.null :: Maybe Int) `shouldBe` Nothing
+    it "correctly detects Nothing as null" $ do
+      Pointed.isNull (Nothing :: Maybe Int) `shouldBe` True
+    it "does not interpret Just as Null" $ do
+      Pointed.isNull (Just 3) `shouldBe` False