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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
#include "HsVersions.h"
module Bag (
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
mapBag, -- UNUSED: elemBag,
filterBag, partitionBag, concatBag, foldBag,
isEmptyBag, consBag, snocBag,
listToBag, bagToList
) where
#ifdef COMPILING_GHC
IMP_Ubiq(){-uitous-}
IMPORT_1_3(List(partition))
import Outputable ( interpp'SP )
import Pretty
#endif
data Bag a
= EmptyBag
| UnitBag a
| TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
-- one branch is non-empty
| ListBag [a] -- The list is non-empty
| ListOfBags [Bag a] -- The list is non-empty
emptyBag = EmptyBag
unitBag = UnitBag
{- UNUSED:
elemBag :: Eq a => a -> Bag a -> Bool
elemBag x EmptyBag = False
elemBag x (UnitBag y) = x==y
elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
elemBag x (ListBag ys) = any (x ==) ys
elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-}
unionManyBags [] = EmptyBag
unionManyBags xs = ListOfBags xs
-- This one is a bit stricter! The bag will get completely evaluated.
unionBags EmptyBag b = b
unionBags b EmptyBag = b
unionBags b1 b2 = TwoBags b1 b2
consBag :: a -> Bag a -> Bag a
consBag elt bag = (unitBag elt) `unionBags` bag
snocBag :: Bag a -> a -> Bag a
snocBag bag elt = bag `unionBags` (unitBag elt)
isEmptyBag EmptyBag = True
isEmptyBag (UnitBag x) = False
isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe
isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe
isEmptyBag (ListOfBags bs) = all isEmptyBag bs
filterBag :: (a -> Bool) -> Bag a -> Bag a
filterBag pred EmptyBag = EmptyBag
filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
where
sat1 = filterBag pred b1
sat2 = filterBag pred b2
filterBag pred (ListBag vs) = listToBag (filter pred vs)
filterBag pred (ListOfBags bs) = ListOfBags sats
where
sats = [filterBag pred b | b <- bs]
concatBag :: Bag (Bag a) -> Bag a
concatBag EmptyBag = EmptyBag
concatBag (UnitBag b) = b
concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2
concatBag (ListBag bs) = ListOfBags bs
concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs)
partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
Bag a {- Don't -})
partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
where
(sat1,fail1) = partitionBag pred b1
(sat2,fail2) = partitionBag pred b2
partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
where
(sats,fails) = partition pred vs
partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
where
(sats, fails) = unzip [partitionBag pred b | b <- bs]
foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
-> (a -> r) -- Replace UnitBag with this
-> r -- Replace EmptyBag with this
-> Bag a
-> r
{- Standard definition
foldBag t u e EmptyBag = e
foldBag t u e (UnitBag x) = u x
foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
foldBag t u e (ListBag xs) = foldr (t.u) e xs
foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
-}
-- More tail-recursive definition, exploiting associativity of "t"
foldBag t u e EmptyBag = e
foldBag t u e (UnitBag x) = u x `t` e
foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
foldBag t u e (ListBag xs) = foldr (t.u) e xs
foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
mapBag :: (a -> b) -> Bag a -> Bag b
mapBag f EmptyBag = EmptyBag
mapBag f (UnitBag x) = UnitBag (f x)
mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
mapBag f (ListBag xs) = ListBag (map f xs)
mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
listToBag :: [a] -> Bag a
listToBag [] = EmptyBag
listToBag vs = ListBag vs
bagToList :: Bag a -> [a]
bagToList EmptyBag = []
bagToList (ListBag vs) = vs
bagToList b = bagToList_append b []
-- (bagToList_append b xs) flattens b and puts xs on the end.
-- (not exported)
bagToList_append EmptyBag xs = xs
bagToList_append (UnitBag x) xs = x:xs
bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
bagToList_append (ListBag xx) xs = xx++xs
bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
\end{code}
\begin{code}
#ifdef COMPILING_GHC
instance (Outputable a) => Outputable (Bag a) where
ppr sty EmptyBag = ppStr "emptyBag"
ppr sty (UnitBag a) = ppr sty a
ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
ppr sty (ListBag as) = interpp'SP sty as
ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
#endif {- COMPILING_GHC -}
\end{code}
|
