That's totes my bag

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
module Data.Bag where

import Control.Comonad
import Control.Monad
import Data.Monoid

-- an implementation of the bag data type of http://lpaste.net/107881

{-- 

A bag is a collection of elements grouped and counted by isomorphism.
So if you had:

*Data.Bag> Bag.fromList [1,2,2,1,1,1,3] 

The bag would have something like the following representation:

~> Bag { (1, 4), (2, 2), (3, 1) }

 --}

data Bag a = Air | Stuffed Int (a, Int) (Bag a) (Bag a)

emptyBag :: Bag a
emptyBag = Air

-- size in constant-time

sizeB :: Bag a -> Int
sizeB Air = 0
sizeB (Stuffed x _ _ _) = x

addn :: Ord a => a -> Int -> Bag a -> Bag a
addn elt n Air = Stuffed n (elt, n) Air Air
addn elt n (Stuffed m (x, y) less more) = let o = n + m in
   case (compare elt x) of
      LT -> Stuffed o (x, y) (addn elt n less) more
      GT -> Stuffed o (x, y) less (addn elt n more)
      EQ -> Stuffed o (x, n + y) less more

add :: Ord a => a -> Bag a -> Bag a
add a bag = addn a 1 bag

-- the above is from my blog entry on the bag data type in Idris at
-- http://logicaltypes.blogspot.com/2014/06/thats-totes-my-bag.html

instance Show a => Show (Bag a) where
   show bag = "Bag.fromList " ++ show (toList bag)

fromList :: Ord a => [a] -> Bag a
fromList = foldr add emptyBag

toAssocList :: Bag a -> [(a, Int)]
toAssocList Air = []
toAssocList (Stuffed _ val less more) =
   toAssocList less ++ [val] ++ toAssocList more

toList :: Bag a -> [a]
toList bag = toAssocList bag >>= uncurry (flip replicate)

-- Bag is a Functor

instance Functor Bag where
   fmap f Air = Air
   fmap f (Stuffed n (elt, cnt) less more) =
      Stuffed n (f elt, cnt) (fmap f less) (fmap f more)

merge :: Ord a => Bag a -> Bag a -> Bag a
merge Air bag = bag
merge bag Air = bag
merge (Stuffed n (key, count) less more) bag =
   addn key count (merge more (merge less bag))

instance (Monoid a, Ord a) => Monoid (Bag a) where
   mempty = Air
   mappend = merge

-- equality check becomes easier with size inlined in the bag
instance Eq a => Eq (Bag a) where
   Air == Air = True
   Air == bag = False
   bag == Air = False
   (Stuffed n val less more) == (Stuffed m v1 l1 m1) =
      n == m && val == v1 && less == l1 && m1 == more
   bag1 /= bag2 = not (bag1 == bag2)

instance Ord a => Ord (Bag a) where
   compare Air Air = EQ
   compare Air bag = LT
   compare bag Air = GT
   compare (Stuffed n (key, cnt) less more) (Stuffed m (k1, cnt1) l1 mr1) =
      case compare key k1 of
         LT -> LT
         EQ -> let cmp = compare less l1
               in  if cmp == EQ then compare more mr1 else cmp
         GT -> GT

bjoin :: Ord a => Bag (Bag a) -> Bag a
bjoin Air = Air
bjoin (Stuffed n (bag, whatevs) less more) = 
   merge bag (merge (bjoin less) (bjoin more))

{--

So as I know Ord a => Bag a, but I do not know Ord b => Bag b, I am
having difficulty representing Bag as a Monad instance. Waah! :(

instance Monad Bag where
   return a = Stuffed (a, 1) Air Air
   -- (>>=) :: Ord b => Bag a -> (a -> Bag b) -> Bag b
   Air >>= f = Air
   (Stuffed (val, cnt) less more) >>= f = -- (bjoin . fmap f) bag

 --}

instance Copointed Bag where
   extract (Stuffed n (key, cnt) _ _) = key

instance Comonad Bag where
   duplicate Air = Air
   duplicate (Stuffed n (key, cnt) more less) =
      Stuffed n (Stuffed 1 (key, cnt) Air Air, 1) 
                (duplicate more) (duplicate less)
36:4: Warning: Redundant bracket
Found:
case (compare elt x) of
LT -> Stuffed o (x, y) (addn elt n less) more
GT -> Stuffed o (x, y) less (addn elt n more)
EQ -> Stuffed o (x, n + y) less more
Why not:
case compare elt x of
LT -> Stuffed o (x, y) (addn elt n less) more
GT -> Stuffed o (x, y) less (addn elt n more)
EQ -> Stuffed o (x, n + y) less more
42:1: Error: Eta reduce
Found:
add a bag = addn a 1 bag
Why not:
add a = addn a 1
85:19: Error: Use /=
Found:
not (bag1 == bag2)
Why not:
bag1 /= bag2
Note: incorrect if either value is NaN