1 2% Ported to SEPIA by Joachim Schimpf, ECRC, 14.2.91 3% - checkbag/2 and mapbag/3 are tools 4 5:- module(bags). % SEPIA header 6:- export 7 bag_inter/3, 8 bag_to_list/2, 9 bag_to_set/2, 10 bag_union/3, 11 bagmax/2, 12 bagmin/2, 13 checkbag/2, 14 is_bag/1, 15 length/3, 16 list_to_bag/2, 17 make_sub_bag/2, 18 mapbag/3, 19 member/3, 20 portray_bag/1, 21 test_sub_bag/2. 22 23:- lib(apply). 24 25 26% File : BAGUTL.PL 27% Author : R.A.O'Keefe 28% Updated: 18 February 1984 29% Purpose: Bag Utilities 30/* 31 A bag B is a function from a set dom(B) to the non-negative integers. 32For the purposes of this module, a bag is constructed from two functions: 33 34 bag - creates an empty bag 35 bag(E, M, B) - extends the bag B with a new (NB!) element E 36 which occurs with multiplicity M, and which 37 precedes all elements of B in Prolog's order. 38 39For instance the bag with an a and two bs in it is represented by the 40term 41 bag(a,1,bag(b,2,bag)). 42 43A bag is represented by a Prolog term mirroring its construction. There 44is one snag with this: what are we to make of 45 bag(f(a,Y), 1, bag(f(X,b), 1, bag)) ? 46As a term it has two distinct elements, but f(a,b) will be reported as 47occurring in it twice. But according to the definition above, 48 bag(f(a,b), 1, bag(f(a,b), 1, bag)) 49is not the representation of any bag, that bag is represented by 50 bag(f(a,b), 2, bag) 51alone. We are apparently stuck with a scheme which is only guaranteed 52to work for "sufficiently instantiated" terms, but then, that's true of 53a lot of Prolog code. 54 55 The reason for insisting on the order is to make union and 56intersection linear in the sizes of their arguments. 57 58*/ 59 60% Defined in this file 61% bag_inter/3, 62% bag_to_list/2, 63% bag_to_set/2, 64% bag_union/3, 65% bagmax/2, 66% bagmin/2, 67% checkbag/2, 68% is_bag/1, 69% length/3, 70% list_to_bag/2, 71% make_sub_bag/2, 72% mapbag/3, 73% member/3, 74% member/3, 75% portray_bag/1, 76% test_sub_bag/2. 77% 78 79is_bag(bag). 80is_bag(bag(E,M,B)) :- 81 integer(M), M > 0, 82 is_bag(B, E). 83 84 is_bag(bag, _). 85 is_bag(bag(E,M,B), P) :- 86 E @> P, 87 integer(M), M > 0, 88 is_bag(B, E). 89 90 91 92portray_bag(bag(E,M,B)) :- 93 write('[% '), portray_bag(E, M, B), write(' %]'). 94portray_bag(bag) :- 95 write('[% '), write(' %]'). 96 97 portray_bag(E, M, B) :- 98 var(B), !, 99 portray_bag(E, M), write(' | '), write(B). 100 portray_bag(E, M, bag(F,N,B)) :- !, 101 portray_bag(E, M), write(', '), 102 portray_bag(F, N, B). 103 portray_bag(E, M, bag) :- !, 104 portray_bag(E, M). 105 portray_bag(E, M, B) :- 106 portray_bag(E, M), write(' | '), write(B). 107 108 portray_bag(E, M) :- 109 print(E), write(':'), write(M). 110 111 112% If bags are to be as useful as lists, we should provide mapping 113% predicates similar to those for lists. Hence 114% checkbag(Pred, Bag) - applies Pred(Element, Count) 115% mapbag(Pred, BagIn, BagOut) - applies Pred(Element, Answer) 116% Note that mapbag does NOT give the Count to Pred, but preserves it. 117% It wouldn't be hard to apply Pred to four arguments if it wants them. 118 119 120:- tool(checkbag/2, checkbag/3). 121 122checkbag(_, bag, _). 123checkbag(Pred, bag(E,M,B), Module) :- 124 apply(Pred, [E, M])@Module, 125 checkbag(Pred, B, Module). 126 127 128:- tool(mapbag/3, mapbag/4). 129 130mapbag(Pred, BagIn, BagOut, Module) :- 131 mapbaglist(Pred, BagIn, Listed, Module), 132 keysort(Listed, Sorted), 133 bagform(Sorted, BagOut). 134 135 mapbaglist(_, bag, [], _). 136 mapbaglist(Pred, bag(E,M,B), [R-M|L], Module) :- 137 apply(Pred, [E, R])@Module, 138 mapbaglist(Pred, B, L, Module). 139 140 141 142bag_to_list(bag, []). 143bag_to_list(bag(E,M,B), R) :- 144 bag_to_list(M, E, L, R), 145 bag_to_list(B, L). 146 147 bag_to_list(0, _, L, L) :- !. 148 bag_to_list(M, E, L, [E|R]) :- 149 N is M-1, 150 bag_to_list(N, E, L, R). 151 152 153 154list_to_bag(L, B) :- 155 addkeys(L, K), 156 keysort(K, S), 157 bagform(S, B). 158 159 addkeys([], []). 160 addkeys([Head|Tail], [Head-1|Rest]) :- 161 addkeys(Tail, Rest). 162 163 bagform([], bag) :- !. 164 bagform(List, bag(E,M,B)) :- 165 bagform(E, List, Rest, 0, M), !, 166 bagform(Rest, B). 167 168 bagform(Head, [Head-N|Tail], Rest, K, M) :-!, 169 L is K+N, 170 bagform(Head, Tail, Rest, L, M). 171 bagform(_, Rest, Rest, M, M). 172 173 174 175bag_to_set(bag, []). 176bag_to_set(bag(E,_,B), [E|S]) :- 177 bag_to_set(B, S). 178 179 180/* There are two versions of the routines member, bagmax, and bagmin. 181 The slow versions, which are commented out, try to allow for the 182 possibility that distinct elements in the bag might unify, while 183 the faster routines assume that all elements are ground terms. 184 185 186member(E, M, bag(E,K,B)) :- 187 member(B, E, K, M). 188member(E, M, bag(_,_,B)) :- 189 member(E, M, B). 190 191 member(bag(E,L,B), E, K, M) :- !, 192 N is K+L, 193 member(B, E, N, M). 194 member(bag(_,_,B), E, K, M) :- 195 member(B, E, K, M). 196 member(bag, E, M, M). 197 198% These routines are correct, but Oh, so costly! 199 200bagmax(B, E) :- 201 member(E, M, B), 202 \+ (member(F, N, B), N > M). 203 204bagmin(B, E) :- 205 member(E, M, B), 206 \+ (member(F, N, B), N < M). 207 208*//* The faster versions follow */ 209 210 211member(Element, Multiplicity, bag(Element,Multiplicity,_)). 212member(Element, Multiplicity, bag(_,_,Bag)) :- 213 member(Element, Multiplicity, Bag). 214 215 216memberchk(Element, Multiplicity, bag(Element,Multiplicity,_)) :- !. 217memberchk(Element, Multiplicity, bag(_,_,Bag)) :- 218 memberchk(Element, Multiplicity, Bag). 219 220 221 222bagmax(bag(E,M,B), Emax) :- 223 bag_scan(B, E, M, Emax, >). 224 225bagmin(bag(E,M,B), Emin) :- 226 bag_scan(B, E, M, Emin, <). 227 228 bag_scan(bag(Eb,Mb,B), _, Mi, Eo, C) :- 229 compare(C, Mb, Mi), !, 230 bag_scan(B, Eb, Mb, Eo, C). 231 bag_scan(bag(_,_,B), Ei, Mi, Eo, C) :- 232 bag_scan(B, Ei, Mi, Eo, C). 233/* bag_scan(bag(Eb,Mb,B), Ei, Mi, Eo, C) :- 234 bag_scan(B, Eb, Mb, Eo, C). % for all extrema 235*/ bag_scan(bag, Ei, _, Ei, _). 236 237 238 239 240length(B, BL, SL) :- 241 length(B, 0, BL, 0, SL). 242 243 length(bag, BL, BL, SL, SL). 244 length(bag(_,M,B), BA, BL, SA, SL) :- 245 BB is BA+M, SB is SA+1, 246 length(B, BB, BL, SB, SL). 247 248 249% sub_bag, if it existed, could be used two ways: to test whether one bag 250% is a sub_bag of another, or to generate all the sub_bags. The two uses 251% need different implementations. 252 253 254make_sub_bag(bag, bag). 255make_sub_bag(bag(E,M,B), bag(E,N,C)) :- 256 countdown(M, N), 257 make_sub_bag(B, C). 258make_sub_bag(bag(_,_,B), C) :- 259 make_sub_bag(B, C). 260 261 countdown(M, M). 262 countdown(M, N) :- 263 M > 1, K is M-1, 264 countdown(K, N). 265 266 267 268test_sub_bag(bag, _). 269test_sub_bag(bag(E1,M1,B1), bag(E2,M2,B2)) :- 270 compare(C, E1, E2), 271 test_sub_bag(C, E1, M1, B1, E2, M2, B2). 272 273 test_sub_bag(>, E1, M1, B1, _, _, B2) :- 274 test_sub_bag(bag(E1, M1, B1), B2). 275 test_sub_bag(=, E1, M1, B1, E1, M2, B2) :- 276 M1 =< M2, 277 test_sub_bag(B1, B2). 278 279 280bag_union(bag(E1,M1,B1), bag(E2,M2,B2), B3) :- 281 compare(C, E1, E2), !, 282 bag_union(C, E1, M1, B1, E2, M2, B2, B3). 283bag_union(bag, Bag, Bag) :- !. 284bag_union(Bag, bag, Bag). 285 286 bag_union(<, E1, M1, B1, E2, M2, B2, bag(E1,M1,B3)) :- 287 bag_union(B1, bag(E2, M2, B2), B3). 288 bag_union(>, E1, M1, B1, E2, M2, B2, bag(E2,M2,B3)) :- 289 bag_union(bag(E1, M1, B1), B2, B3). 290 bag_union(=, E1, M1, B1, E1, M2, B2, bag(E1,M3,B3)) :- 291 M3 is M1+M2, 292 bag_union(B1, B2, B3). 293 294 295 296bag_inter(bag(E1,M1,B1), bag(E2,M2,B2), B3) :- 297 compare(C, E1, E2), !, 298 bag_inter(C, E1, M1, B1, E2, M2, B2, B3). 299bag_inter(_, _, bag). 300 301 bag_inter(<, _, _, B1, E2, M2, B2, B3) :- 302 bag_inter(B1, bag(E2,M2,B2), B3). 303 bag_inter(>, E1, M1, B1, _, _, B2, B3) :- 304 bag_inter(bag(E1,M1,B1), B2, B3). 305 bag_inter(=, E1, M1, B1, E1, M2, B2, bag(E1, M3, B3)) :- 306 ( M1 < M2, M3 = M1 ; M3 = M2 ), !, 307 bag_inter(B1, B2, B3). 308 309 310