1 /****************************************************************************
2 **
3 ** This file is part of GAP, a system for computational discrete algebra.
4 **
5 ** Copyright of GAP belongs to its developers, whose names are too numerous
6 ** to list here. Please refer to the COPYRIGHT file for details.
7 **
8 ** SPDX-License-Identifier: GPL-2.0-or-later
9 **
10 ** This file contains the functions which mainly deal with proper sets.
11 **
12 ** A *proper set* is a list that has no holes, no duplicates, and is sorted.
13 ** For the full definition of sets see chapter "Sets" in the {\GAP} Manual.
14 ** Read also section "More about Sets" about the internal flag for sets.
15 **
16 ** The second part consists of the functions 'IsSet', 'SetList', 'SetList',
17 ** 'IsEqualSet', 'IsSubsetSet', 'AddSet', 'RemoveSet', 'UniteSet',
18 ** 'IntersectSet', and 'SubtractSet'. These functions make it possible to
19 ** make sets, either by converting a list to a set, or by computing the
20 ** union, intersection, or difference of two sets.
21 */
22
23 #include "set.h"
24
25 #include "ariths.h"
26 #include "bool.h"
27 #include "cyclotom.h"
28 #include "error.h"
29 #include "io.h"
30 #include "listfunc.h"
31 #include "lists.h"
32 #include "modules.h"
33 #include "plist.h"
34 #include "sysfiles.h"
35 #include "sysopt.h" // for SyInitializing
36
37
38 #define RequireMutableSet(funcname, op) \
39 RequireArgumentCondition(funcname, op, IS_MUTABLE_OBJ(op) && IsSet(op), \
40 "must be a mutable proper set")
41
42
43 /****************************************************************************
44 **
45 *F IsSet( <list> ) . . . . . . . . . . . . . . . . . test if a list is a set
46 **
47 ** 'IsSet' returns 1 if the list <list> is a proper set and 0
48 ** otherwise. A proper set is a list that has no holes,
49 ** no duplicates, and is sorted. As a side effect 'IsSet' changes the
50 ** type of proper sets as appropriate.
51 **
52 ** A typical call in the set functions looks like this:
53 **
54 ** | if ( ! IsSet(list) ) list = SetList(list); |
55 **
56 ** This tests if 'list' is a proper set and the type is changed
57 ** If it is not then 'SetList' is called to make a copy of 'list', remove
58 ** the holes, sort the copy, and remove the duplicates.
59 **
60 */
61
IsSet(Obj list)62 Int IsSet (
63 Obj list )
64 {
65 Int isSet; /* result */
66
67 /* if <list> is a plain list */
68 if ( IS_PLIST( list ) ) {
69
70 /* if <list> is the empty list, it is a set (:-) */
71 if ( LEN_PLIST(list) == 0 ) {
72 RetypeBagSMIfWritable(list, T_PLIST_EMPTY);
73 isSet = 1;
74 }
75
76 /* if <list> strictly sorted, it is a set */
77 else if ( IS_SSORT_LIST(list) ) {
78 isSet = 1;
79 }
80
81 /* otherwise it is not a set */
82 else {
83 isSet = 0;
84 }
85
86 }
87
88 /* if it is another small list */
89 else if ( IS_SMALL_LIST(list) ) {
90
91 /* if <list> is the empty list, it is a set (:-) */
92 if ( LEN_LIST(list) == 0 ) {
93 PLAIN_LIST( list );
94 RetypeBagSMIfWritable(list, T_PLIST_EMPTY);
95 isSet = 1;
96 }
97
98 /* if <list> strictly sorted, it is a set */
99 else if ( IS_SSORT_LIST(list) ) {
100 PLAIN_LIST( list );
101 /* SET_FILT_LIST( list, FN_IS_HOMOG ); */
102 SET_FILT_LIST( list, FN_IS_SSORT );
103 isSet = 1;
104 }
105
106 /* otherwise it is not a set */
107 else {
108 isSet = 0;
109 }
110
111 }
112
113 /* otherwise it is certainly not a set */
114 else {
115 isSet = 0;
116 }
117
118 /* return the result */
119 return isSet;
120 }
121
122
123 /****************************************************************************
124 **
125 *F SetList( <list> ) . . . . . . . . . . . . . . . . make a set from a list
126 **
127 ** 'SetList' returns a new set that contains the elements of <list>. Note
128 ** that 'SetList' returns a new plain list even if <list> was already a set.
129 **
130 ** 'SetList' makes a copy of the list <list>, removes the holes, sorts the
131 ** copy and finally removes duplicates, which must appear next to each other
132 ** now that the copy is sorted.
133 */
SetList(Obj list)134 Obj SetList (
135 Obj list )
136 {
137 Obj set; /* result set */
138 Int lenSet; /* length of <set> */
139 Int lenList; /* length of <list> */
140 Obj elm; /* one element of the list */
141 UInt status; /* the elements are mutable */
142 UInt i; /* loop variable */
143
144 /* make a dense copy */
145 lenList = LEN_LIST( list );
146 set = NEW_PLIST( T_PLIST, lenList );
147 lenSet = 0;
148 for ( i = 1; i <= lenList; i++ ) {
149 elm = ELMV0_LIST( list, i );
150 if ( elm != 0 ) {
151 lenSet += 1;
152 SET_ELM_PLIST( set, lenSet, elm );
153 CHANGED_BAG(set); /* in case elm had to be made, not just extracted */
154 }
155 }
156 SET_LEN_PLIST( set, lenSet );
157 SET_FILT_LIST( set, FN_IS_DENSE );
158
159 /* sort the set (which is a dense plain list) */
160 SortDensePlist( set );
161
162 /* remove duplicates */
163 status = RemoveDupsDensePlist( set );
164
165 /* adjust flags where possible */
166 switch(status)
167 {
168 case 0:
169 break;
170
171 case 1:
172 SET_FILT_LIST(set, FN_IS_NHOMOG);
173 SET_FILT_LIST(set, FN_IS_SSORT);
174 break;
175
176 case 2:
177 SET_FILT_LIST( set, FN_IS_HOMOG );
178 SET_FILT_LIST( set, FN_IS_SSORT );
179 break;
180 }
181
182 /* return set */
183 return set;
184 }
185
186
187 /****************************************************************************
188 **
189 *F FuncLIST_SORTED_LIST( <self>, <list> ) . . . . . make a set from a list
190 **
191 ** 'FuncLIST_SORTED_LIST' implements the internal function 'SetList'.
192 **
193 ** 'SetList( <list> )'
194 **
195 ** 'SetList' returns a new proper set, which is represented as a sorted list
196 ** without holes or duplicates, containing the elements of the list <list>.
197 **
198 ** 'SetList' returns a new list even if the list <list> is already a proper
199 ** set, in this case it is equivalent to 'ShallowCopy' (see "ShallowCopy").
200 */
FuncLIST_SORTED_LIST(Obj self,Obj list)201 static Obj FuncLIST_SORTED_LIST(Obj self, Obj list)
202 {
203 Obj set; /* result */
204
205 /* check the argument */
206 RequireSmallList("Set", list);
207
208 /* if the list is empty create a new empty list */
209 if ( LEN_LIST(list) == 0 ) {
210 set = NewEmptyPlist();
211 }
212
213 /* if <list> is a set just shallow copy it */
214 else if ( /* IS_HOMOG_LIST(list) && */ IS_SSORT_LIST(list) ) {
215 set = SHALLOW_COPY_OBJ( list );
216 }
217
218 /* otherwise let 'SetList' do the work */
219 else {
220 set = SetList( list );
221 }
222
223 /* return the set */
224 return set;
225 }
226
227
228 /****************************************************************************
229 **
230 *F FuncIS_EQUAL_SET(<self>,<l1>,<l2>) test if a two lists are equal as sets
231 **
232 ** 'FuncIS_EQUAL_SET' implements the internal function 'IsEqualSet'.
233 **
234 ** 'IsEqualSet( <list1>, <list2> )'
235 **
236 ** 'IsEqualSet' returns 'true' if the two lists <list1> and <list2> are
237 ** equal *when viewed as sets*, and 'false' otherwise. <list1> and <list2>
238 ** are equal if every element of <list1> is also an element of <list2> and
239 ** if every element of <list2> is also an element of <list1>.
240 */
EqSet(Obj listL,Obj listR)241 static Int EqSet(Obj listL, Obj listR)
242 {
243 Int lenL; /* length of the left operand */
244 Int lenR; /* length of the right operand */
245 Obj elmL; /* element of the left operand */
246 Obj elmR; /* element of the right operand */
247 UInt i; /* loop variable */
248
249 /* get the lengths of the lists and compare them */
250 lenL = LEN_PLIST( listL );
251 lenR = LEN_PLIST( listR );
252 if ( lenL != lenR ) {
253 return 0L;
254 }
255
256 /* loop over the elements and compare them */
257 for ( i = 1; i <= lenL; i++ ) {
258 elmL = ELM_PLIST( listL, i );
259 elmR = ELM_PLIST( listR, i );
260 if ( ! EQ( elmL, elmR ) ) {
261 return 0L;
262 }
263 }
264
265 /* no differences found, the lists are equal */
266 return 1L;
267 }
268
FuncIS_EQUAL_SET(Obj self,Obj list1,Obj list2)269 static Obj FuncIS_EQUAL_SET(Obj self, Obj list1, Obj list2)
270 {
271 /* check the arguments, convert to sets if necessary */
272 RequireSmallList("IsEqualSet", list1);
273 if ( ! IsSet( list1 ) ) list1 = SetList( list1 );
274 RequireSmallList("IsEqualSet", list2);
275 if ( ! IsSet( list2 ) ) list2 = SetList( list2 );
276
277 /* and now compare them */
278 return (EqSet( list1, list2 ) ? True : False );
279 }
280
281
282 /****************************************************************************
283 **
284 *F FuncIS_SUBSET_SET(<self>,<s1>,<s2>) test if a set is a subset of another
285 **
286 ** 'FuncIS_SUBSET_SET' implements the internal function 'IsSubsetSet'.
287 **
288 ** 'IsSubsetSet( <set1>, <set2> )'
289 **
290 ** 'IsSubsetSet' returns 'true' if the set <set2> is a subset of the set
291 ** <set1>, that is if every element of <set2> is also an element of <set1>.
292 ** Either argument may also be a list that is not a proper set, in which
293 ** case 'IsSubsetSet' silently applies 'Set' (see "Set") to it first.
294 */
FuncIS_SUBSET_SET(Obj self,Obj set1,Obj set2)295 static Obj FuncIS_SUBSET_SET(Obj self, Obj set1, Obj set2)
296 {
297 UInt len1; /* length of the left set */
298 UInt len2; /* length of the right set */
299 UInt i1; /* index into the left set */
300 UInt i2; /* index into the right set */
301 Obj e1; /* element of left set */
302 Obj e2; /* element of right set */
303 UInt pos; /* position */
304
305 /* check the arguments, convert to sets if necessary */
306 RequireSmallList("IsSubsetSet", set1);
307 RequireSmallList("IsSubsetSet", set2);
308 if ( ! IsSet( set1 ) ) set1 = SetList( set1 );
309 if ( ! IsSet( set2 ) ) set2 = SetList( set2 );
310
311 /* special case if the second argument is a set */
312 if ( IsSet( set2 ) ) {
313
314 /* get the logical lengths and get the pointer */
315 len1 = LEN_PLIST( set1 );
316 len2 = LEN_PLIST( set2 );
317 i1 = 1;
318 i2 = 1;
319
320 /* now compare the two sets */
321 while ( i1 <= len1 && i2 <= len2 && len2 - i2 <= len1 - i1 ) {
322 e1 = ELM_PLIST( set1, i1 );
323 e2 = ELM_PLIST( set2, i2 );
324 if ( EQ( e1, e2 ) ) {
325 i1++; i2++;
326 }
327 else if ( LT( e1, e2 ) ) {
328 i1++;
329 }
330 else {
331 break;
332 }
333 }
334
335 }
336
337 /* general case */
338 else {
339
340 /* first convert the other argument into a proper list */
341 PLAIN_LIST( set2 );
342
343 /* get the logical lengths */
344 len1 = LEN_PLIST( set1 );
345 len2 = LEN_PLIST( set2 );
346
347 /* loop over the second list and look for every element */
348 for ( i2 = 1; i2 <= len2; i2++ ) {
349
350 /* ignore holes */
351 if ( ELM_PLIST(set2,i2) == 0 )
352 continue;
353
354 /* perform the binary search to find the position */
355 pos = PositionSortedDensePlist( set1, ELM_PLIST(set2,i2) );
356
357 /* test if the element was found at position k */
358 if ( len1<pos || ! EQ(ELM_PLIST(set1,pos),ELM_PLIST(set2,i2)) ) {
359 break;
360 }
361
362 }
363
364 }
365
366 /* return 'true' if every element of <set2> appeared in <set1> */
367 return ((i2 == len2 + 1) ? True : False);
368 }
369
370
371 /****************************************************************************
372 **
373 *F * * * * * * * * * * * * * * GAP level functions * * * * * * * * * * * * *
374 */
375
376 /****************************************************************************
377 **
378 *F FuncADD_SET( <self>, <set>, <obj> ) . . . . . . . add an element to a set
379 **
380 ** 'FuncADD_SET' implements the internal function 'AddSet'.
381 **
382 ** 'AddSet( <set>, <obj> )'
383 **
384 ** 'AddSet' adds <obj>, which may be an object of an arbitrary type, to the
385 ** set <set>, which must be a proper set. If <obj> is already an element of
386 ** the set <set>, then <set> is not changed. Otherwise <obj> is inserted at
387 ** the correct position such that <set> is again a set afterwards.
388 **
389 ** 'AddSet' does not return anything, it is only called for the side effect
390 ** of changing <set>.
391 */
FuncADD_SET(Obj self,Obj set,Obj obj)392 static Obj FuncADD_SET(Obj self, Obj set, Obj obj)
393 {
394 UInt len; /* logical length of the list */
395 UInt pos; /* position */
396 UInt isCyc; /* True if the set being added to consists
397 of kernel cyclotomics */
398 UInt notpos; /* position of an original element
399 (not the new one) */
400 UInt wasHom;
401 UInt wasNHom;
402 UInt wasTab;
403
404 /* check the arguments */
405 RequireMutableSet("AddSet", set);
406 len = LEN_PLIST(set);
407
408 /* perform the binary search to find the position */
409 pos = PositionSortedDensePlist( set, obj );
410
411 /* add the element to the set if it is not already there */
412 if ( len < pos || ! EQ( ELM_PLIST(set,pos), obj ) ) {
413 GROW_PLIST( set, len+1 );
414 SET_LEN_PLIST( set, len+1 );
415 Obj * ptr = ADDR_OBJ(set) + pos;
416 SyMemmove(ptr + 1, ptr, sizeof(Obj) * (len - pos + 1));
417 SET_ELM_PLIST( set, pos, obj );
418 CHANGED_BAG( set );
419
420 /* fix up the type of the result */
421 if ( HAS_FILT_LIST( set, FN_IS_SSORT ) ) {
422 isCyc = (TNUM_OBJ(set) == T_PLIST_CYC_SSORT);
423 wasHom = HAS_FILT_LIST(set, FN_IS_HOMOG);
424 wasTab = HAS_FILT_LIST(set, FN_IS_TABLE);
425 wasNHom = HAS_FILT_LIST(set, FN_IS_NHOMOG);
426 CLEAR_FILTS_LIST(set);
427 /* the result of addset is always dense */
428 SET_FILT_LIST( set, FN_IS_DENSE );
429
430 /* if the object we added was not
431 mutable then we might be able to
432 conclude more */
433 if ( ! IS_MUTABLE_OBJ(obj) ) {
434 /* a one element list is automatically
435 homogenous and ssorted */
436 if (len == 0 )
437 {
438 if (IS_CYC(obj))
439 RetypeBagIfWritable( set, T_PLIST_CYC_SSORT);
440 else
441 {
442 SET_FILT_LIST( set, FN_IS_HOMOG );
443 SET_FILT_LIST( set, FN_IS_SSORT );
444 if (IS_HOMOG_LIST(obj)) /* it might be a table */
445 SET_FILT_LIST( set, FN_IS_TABLE );
446 }
447 }
448 else
449 {
450 /* Now determine homogeneity */
451 if (isCyc)
452 if (IS_CYC(obj))
453 RetypeBagIfWritable( set, T_PLIST_CYC_SSORT);
454 else
455 {
456 RESET_FILT_LIST(set, FN_IS_HOMOG);
457 SET_FILT_LIST(set, FN_IS_NHOMOG);
458 }
459 else if (wasHom)
460 {
461 if (!SyInitializing) {
462 notpos = (pos == 1) ? 2 : 1;
463 if (FAMILY_OBJ(ELM_PLIST(set,notpos)) == FAMILY_OBJ(obj))
464 {
465 SET_FILT_LIST(set, FN_IS_HOMOG);
466 if (wasTab) {
467 if (IS_HOMOG_LIST( obj ))
468 SET_FILT_LIST(set, FN_IS_TABLE);
469 }
470 }
471
472 else
473 SET_FILT_LIST(set, FN_IS_NHOMOG);
474 }
475 }
476 else if (wasNHom)
477 SET_FILT_LIST(set, FN_IS_NHOMOG);
478 }
479 }
480 SET_FILT_LIST( set, FN_IS_SSORT );
481 }
482 else {
483 CLEAR_FILTS_LIST(set);
484 SET_FILT_LIST( set, FN_IS_DENSE );
485 }
486 }
487
488 /* return void, this is a procedure */
489 return (Obj)0;
490 }
491
492
493 /****************************************************************************
494 **
495 *F FuncREM_SET( <self>, <set>, <obj> ) . . . . remove an element from a set
496 **
497 ** 'FuncREM_SET' implements the internal function 'RemoveSet'.
498 **
499 ** 'RemoveSet( <set>, <obj> )'
500 **
501 ** 'RemoveSet' removes <obj>, which may be an object of arbitrary type, from
502 ** the set <set>, which must be a proper set. If <obj> is in <set> it is
503 ** removed and all entries of <set> are shifted one position leftwards, so
504 ** that <set> has no holes. If <obj> is not in <set>, then <set> is not
505 ** changed. No error is signalled in this case.
506 **
507 ** 'RemoveSet' does not return anything, it is only called for the
508 ** side effect of changing <set>.
509 */
FuncREM_SET(Obj self,Obj set,Obj obj)510 static Obj FuncREM_SET(Obj self, Obj set, Obj obj)
511 {
512 UInt len; /* logical length of the list */
513 UInt pos; /* position */
514
515 /* check the arguments */
516 RequireMutableSet("RemoveSet", set);
517 len = LEN_PLIST(set);
518
519 /* perform the binary search to find the position */
520 pos = PositionSortedDensePlist( set, obj );
521
522 /* remove the element from the set if it is there */
523 if ( pos <= len && EQ( ELM_PLIST(set,pos), obj ) ) {
524
525 Obj * ptr = ADDR_OBJ(set) + pos;
526 SyMemmove(ptr, ptr + 1, sizeof(Obj) * (len - pos));
527 SET_ELM_PLIST( set, len, 0 );
528 SET_LEN_PLIST( set, len-1 );
529
530 /* fix up the type of the result */
531 if ( len-1 == 0 ) {
532 RetypeBag(set, T_PLIST_EMPTY);
533 }
534 }
535
536 /* return void, this is a procedure */
537 return (Obj)0;
538 }
539
540
541 /****************************************************************************
542 **
543 *F FuncUNITE_SET( <self>, <set1>, <set2> ) . . . unite one set with another
544 **
545 ** 'FuncUNITE_SET' implements the internal function 'UniteSet'.
546 **
547 ** 'UniteSet( <set1>, <set2> )'
548 **
549 ** 'UniteSet' changes the set <set1> so that it becomes the union of <set1>
550 ** and <set2>. The union is the set of those elements that are elements of
551 ** either set. So 'UniteSet' adds (see "AddSet") all elements to <set1>
552 ** that are in <set2>. <set2> may be a list that is not a proper set, in
553 ** which case 'Set' is silently applied to it.
554 **
555 ** 'FuncUNITE_SET' merges <set1> and <set2> into a buffer that is allocated
556 ** at initialization time.
557 **
558 */
559
FuncUNITE_SET(Obj self,Obj set1,Obj set2)560 static Obj FuncUNITE_SET(Obj self, Obj set1, Obj set2)
561 {
562 UInt lenr; /* length of result set */
563 UInt len1; /* length of left set */
564 UInt len2; /* length of right set */
565 UInt i1; /* index into left set */
566 UInt i2; /* index into right set */
567 Obj e1; /* element of left set */
568 Obj e2; /* element of right set */
569 Obj TmpUnion;
570
571 /* check the arguments */
572 RequireMutableSet("UniteSet", set1);
573 RequireSmallList("UniteSet", set2);
574 if ( ! IsSet(set2) ) set2 = SetList(set2);
575
576 /* get the logical lengths and the pointer */
577 len1 = LEN_PLIST( set1 );
578 len2 = LEN_PLIST( set2 );
579 TmpUnion = NEW_PLIST(T_PLIST,len1+len2);
580 lenr = 0;
581 i1 = 1;
582 i2 = 1;
583
584 /* now merge the two sets into the union */
585 while ( i1 <= len1 && i2 <= len2 ) {
586 e1 = ELM_PLIST( set1, i1 );
587 e2 = ELM_PLIST( set2, i2 );
588 if ( EQ( e1, e2 ) ) {
589 lenr++;
590 SET_ELM_PLIST( TmpUnion, lenr, e1 );
591 CHANGED_BAG( TmpUnion );
592 i1++; i2++;
593 }
594 else if ( LT( e1, e2 ) ) {
595 lenr++;
596 SET_ELM_PLIST( TmpUnion, lenr, e1 );
597 CHANGED_BAG( TmpUnion );
598 i1++;
599 }
600 else {
601 lenr++;
602 SET_ELM_PLIST( TmpUnion, lenr, e2 );
603 CHANGED_BAG( TmpUnion );
604 i2++;
605 }
606 }
607 while ( i1 <= len1 ) {
608 e1 = ELM_PLIST( set1, i1 );
609 lenr++;
610 SET_ELM_PLIST( TmpUnion, lenr, e1 );
611 CHANGED_BAG( TmpUnion );
612 i1++;
613 }
614 while ( i2 <= len2 ) {
615 e2 = ELM_PLIST( set2, i2 );
616 lenr++;
617 SET_ELM_PLIST( TmpUnion, lenr, e2 );
618 CHANGED_BAG( TmpUnion );
619 i2++;
620 }
621
622 /* fix up the type of the result */
623 if ( 0 == LEN_PLIST(set1) ) {
624 RetypeBag( set1, MUTABLE_TNUM(TNUM_OBJ(set2)) );
625 } else if ( 0 != LEN_PLIST(set2)) {
626 if (HAS_FILT_LIST(set1, FN_IS_HOMOG)) {
627 if( !HAS_FILT_LIST(set2, FN_IS_HOMOG))
628 RESET_FILT_LIST(set1, FN_IS_HOMOG);
629 else if (!SyInitializing &&
630 FAMILY_OBJ(ELM_PLIST(set1,1)) != FAMILY_OBJ(ELM_PLIST(set2,1)))
631 {
632 RetypeBag(set1, T_PLIST_DENSE_NHOM);
633 }
634 }
635 }
636
637 SET_FILT_LIST(set1, FN_IS_SSORT);
638
639 /* resize the result and copy back from the union */
640 GROW_PLIST( set1, lenr );
641 SET_LEN_PLIST( set1, lenr );
642 for ( i1 = 1; i1 <= lenr; i1++ ) {
643 SET_ELM_PLIST( set1, i1, ELM_PLIST( TmpUnion, i1 ) );
644 CHANGED_BAG( set1 );
645 SET_ELM_PLIST( TmpUnion, i1, (Obj)0 );
646 }
647
648 /* return void, this is a procedure */
649 return (Obj)0;
650 }
651
652
653 /****************************************************************************
654 **
655 *F FuncINTER_SET( <self>, <set1>, <set2> ) . intersect one set with another
656 **
657 ** 'FuncINTER_SET' implements the internal function 'IntersectSet'.
658 **
659 ** 'IntersectSet( <set1>, <set2> )'
660 **
661 ** 'IntersectSet' changes the set <set1> so that it becomes the intersection
662 ** of <set1> and <set2>. The intersection is the set of those elements that
663 ** are elements in both sets. So 'IntersectSet' removes (see "RemoveSet")
664 ** all elements from <set1> that are not in <set2>. <set2> may be a list
665 ** that is not a proper set, in which case 'Set' is silently applied to it.
666 */
667
InterSetInner1(Obj set1,Obj set2,UInt len1,UInt len2)668 static UInt InterSetInner1( Obj set1, Obj set2, UInt len1, UInt len2)
669 {
670 UInt lenr, i1,i2;
671 Obj e1,e2;
672 lenr = 0;
673 i1 = 1;
674 i2 = 1;
675
676 /* now merge the two sets into the intersection */
677 while ( i1 <= len1 && i2 <= len2 ) {
678 e1 = ELM_PLIST( set1, i1 );
679 e2 = ELM_PLIST( set2, i2 );
680 if ( EQ( e1, e2 ) ) {
681 lenr++;
682 SET_ELM_PLIST( set1, lenr, e1 );
683 i1++; i2++;
684 }
685 else if ( LT( e1, e2 ) ) {
686 i1++;
687 }
688 else {
689 i2++;
690 }
691 }
692 return lenr;
693 }
694
695 /* set1 should be the smaller set. setr should be the one
696 in which to put the results; */
InterSetInner2(Obj set1,Obj set2,Obj setr,UInt len1,UInt len2)697 static UInt InterSetInner2( Obj set1, Obj set2, Obj setr, UInt len1, UInt len2)
698 {
699 UInt i1,i2=1,bottom,top,middle,lenr=0,found;
700 Obj e1,e2;
701 for( i1 = 1; i1 <= len1; i1++)
702 {
703 e1 = ELM_PLIST( set1, i1 );
704 bottom = i2;
705 top = len2;
706 found = 0;
707 while (bottom <= top)
708 {
709 middle = (bottom + top)/2;
710 e2 = ELM_PLIST(set2,middle);
711 if (LT(e1,e2))
712 top = middle-1;
713 else if (EQ(e1,e2)) {
714 lenr++;
715 SET_ELM_PLIST(setr,lenr,e1);
716 i2 = middle+1;
717 found = 1;
718 break;
719 }
720 else
721 bottom = middle+1;
722 }
723 if (!found)
724 i2 = bottom;
725 }
726 return lenr;
727 }
728
729
FuncINTER_SET(Obj self,Obj set1,Obj set2)730 static Obj FuncINTER_SET(Obj self, Obj set1, Obj set2)
731 {
732 UInt len1; /* length of left set */
733 UInt len2; /* length of right set */
734 UInt lenr; /* length of result set */
735
736 /* check the arguments */
737 RequireMutableSet("IntersectSet", set1);
738 RequireSmallList("IntersectSet", set2);
739 if ( ! IsSet(set2) ) set2 = SetList(set2);
740
741 /* get the logical lengths and the pointer */
742 len1 = LEN_PLIST( set1 );
743 len2 = LEN_PLIST( set2 );
744
745 /* decide how to do the calculation and do it */
746 if (len1 < len2)
747 {
748 UInt x = len2;
749 UInt ll = 0;
750 while (x > 0)
751 {
752 ll++;
753 x >>= 1;
754 }
755 if (len1*ll < len2)
756 lenr = InterSetInner2(set1,set2,set1,len1,len2);
757 else
758 lenr = InterSetInner1(set1,set2,len1,len2);
759 }
760 else
761 {
762 UInt x = len1;
763 UInt ll = 0;
764 while (x > 0)
765 {
766 ll++;
767 x >>= 1;
768 }
769 if (len2*ll < len1)
770 lenr = InterSetInner2(set2,set1,set1,len2,len1);
771 else
772 lenr = InterSetInner1(set1,set2,len1,len2);
773 }
774
775 /* resize the result or clear the rest of the bag */
776 SET_LEN_PLIST( set1, lenr );
777 SHRINK_PLIST( set1, lenr );
778
779 /* fix up the type of the result */
780 if ( lenr == 0 ) {
781 RetypeBag(set1, T_PLIST_EMPTY);
782 }
783 else if ( lenr == 1) {
784 if (IS_CYC(ELM_PLIST(set1,1)))
785 RetypeBag(set1, T_PLIST_CYC_SSORT);
786 else
787 RetypeBag(set1, T_PLIST_HOM_SSORT);
788 }
789 else
790 {
791 if ( TNUM_OBJ(set2) >= T_PLIST_CYC )
792 RetypeBag(set1, MUTABLE_TNUM( TNUM_OBJ(set2)));
793 else
794 {
795 RESET_FILT_LIST(set1, FN_IS_NHOMOG);
796 if ( HAS_FILT_LIST( set2, FN_IS_HOMOG )) {
797 SET_FILT_LIST(set1, FN_IS_HOMOG );
798 SET_FILT_LIST(set1, FN_IS_SSORT );
799 }
800 }
801 }
802
803 /* return void, this is a procedure */
804 return (Obj)0;
805 }
806
807
808
809 /****************************************************************************
810 **
811 *F FuncSUBTR_SET( <self>, <set1>, <set2> ) . . subtract one set from another
812 **
813 ** 'FuncSUBTR_SET' implements the internal function 'SubstractSet'.
814 **
815 ** 'SubstractSet( <set1>, <set2> )'
816 **
817 ** 'SubstractSet' changes the set <set1> so that it becomes the difference
818 ** of <set1> and <set2>. The difference is the set of the elements that are
819 ** in <set1> but not in <set2>. So 'SubtractSet' removes (see "RemoveSet")
820 ** all elements from <set1> that are in <set2>. <set2> may be a list that
821 ** is not a proper set, in which case 'Set' is silently applied to it.
822 */
823
SubtrSetInner1(Obj set1,Obj set2,UInt len1,UInt len2)824 static UInt SubtrSetInner1( Obj set1, Obj set2, UInt len1, UInt len2)
825 {
826 UInt lenr, i1,i2;
827 Obj e1,e2;
828 lenr = 0;
829 i1 = 1;
830 i2 = 1;
831
832 /* now run through the two sets to find the difference */
833 while ( i1 <= len1 && i2 <= len2 ) {
834 e1 = ELM_PLIST( set1, i1 );
835 e2 = ELM_PLIST( set2, i2 );
836 if ( EQ( e1, e2 ) ) {
837 i1++; i2++;
838 }
839 else if ( LT( e1, e2 ) ) {
840 lenr++;
841 SET_ELM_PLIST( set1, lenr, e1 );
842 i1++;
843 }
844 else {
845 i2++;
846 }
847 }
848 while (i1 <= len1)
849 {
850 e1 = ELM_PLIST( set1, i1 );
851 lenr++;
852 SET_ELM_PLIST( set1, lenr, e1 );
853 i1++;
854 }
855 return lenr;
856 }
857
858 /* set1 should be smaller. */
SubtrSetInner2(Obj set1,Obj set2,UInt len1,UInt len2)859 static UInt SubtrSetInner2( Obj set1, Obj set2, UInt len1, UInt len2)
860 {
861 UInt i1,i2=1,bottom,top,middle,lenr=0, found;
862 Obj e1,e2;
863 for( i1 = 1; i1 <= len1; i1++)
864 {
865 e1 = ELM_PLIST( set1, i1 );
866 bottom = i2;
867 top = len2;
868 found = 0;
869 while (bottom <= top)
870 {
871 middle = (bottom + top)/2;
872 e2 = ELM_PLIST(set2,middle);
873 if (LT(e1,e2))
874 top = middle-1;
875 else if (EQ(e1,e2)) {
876 found = 1;
877 i2 = middle+1;
878 break;
879 }
880 else
881 bottom = middle+1;
882 }
883 if (!found)
884 {
885 lenr++;
886 SET_ELM_PLIST(set1,lenr,e1);
887 i2 = bottom;
888 }
889 }
890 return lenr;
891 }
892
FuncSUBTR_SET(Obj self,Obj set1,Obj set2)893 static Obj FuncSUBTR_SET(Obj self, Obj set1, Obj set2)
894 {
895 UInt len1; /* length of left set */
896 UInt len2; /* length of right set */
897 UInt lenr; /* length of result set */
898 UInt x;
899 UInt ll;
900
901 /* check the arguments */
902 RequireMutableSet("SubtractSet", set1);
903 RequireSmallList("SubtractSet", set2);
904 if ( ! IsSet(set2) ) set2 = SetList(set2);
905
906 /* get the logical lengths and the pointer */
907 len1 = LEN_PLIST( set1 );
908 len2 = LEN_PLIST( set2 );
909 /* decide how to do the calculation and do it */
910 x = len2;
911 ll = 0;
912 while (x > 0)
913 {
914 ll++;
915 x >>= 1;
916 }
917 if (len1*ll < len2)
918 lenr = SubtrSetInner2(set1,set2,len1,len2);
919 else
920 lenr = SubtrSetInner1(set1,set2,len1,len2);
921
922 /* resize the result or clear the rest of the bag */
923 SET_LEN_PLIST( set1, lenr );
924 SHRINK_PLIST( set1, lenr );
925
926 /* fix up the type of the result */
927 if ( lenr == 0 ) {
928 RetypeBag(set1, T_PLIST_EMPTY);
929 }
930 else if ( lenr == 1) {
931 if (IS_CYC(ELM_PLIST(set1,1)))
932 RetypeBag(set1, T_PLIST_CYC_SSORT);
933 else
934 RetypeBag(set1, T_PLIST_HOM_SSORT);
935 }
936 else
937 RESET_FILT_LIST(set1, FN_IS_NHOMOG);
938
939 /* return void, this is a procedure */
940 return (Obj)0;
941 }
942
943
944 /****************************************************************************
945 **
946 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
947 */
948
949 /****************************************************************************
950 **
951 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
952 */
953 static StructGVarFunc GVarFuncs [] = {
954
955 GVAR_FUNC(LIST_SORTED_LIST, 1, "list"),
956 GVAR_FUNC(IS_EQUAL_SET, 2, "list1, list2"),
957 GVAR_FUNC(IS_SUBSET_SET, 2, "set1, set2"),
958 GVAR_FUNC(ADD_SET, 2, "set, val"),
959 GVAR_FUNC(REM_SET, 2, "set, val"),
960 GVAR_FUNC(UNITE_SET, 2, "set1, set2"),
961 GVAR_FUNC(INTER_SET, 2, "set1, set2"),
962 GVAR_FUNC(SUBTR_SET, 2, "set1, set2"),
963 { 0, 0, 0, 0, 0 }
964
965 };
966
967
968 /****************************************************************************
969 **
970 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
971 */
InitKernel(StructInitInfo * module)972 static Int InitKernel (
973 StructInitInfo * module )
974 {
975 /* init filters and functions */
976 InitHdlrFuncsFromTable( GVarFuncs );
977
978 /* return success */
979 return 0;
980 }
981
982
983 /****************************************************************************
984 **
985 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
986 */
InitLibrary(StructInitInfo * module)987 static Int InitLibrary (
988 StructInitInfo * module )
989 {
990 /* init filters and functions */
991 InitGVarFuncsFromTable( GVarFuncs );
992
993 /* return success */
994 return 0;
995 }
996
997
998 /****************************************************************************
999 **
1000 *F InitInfoSet() . . . . . . . . . . . . . . . . . . table of init functions
1001 */
1002 static StructInitInfo module = {
1003 // init struct using C99 designated initializers; for a full list of
1004 // fields, please refer to the definition of StructInitInfo
1005 .type = MODULE_BUILTIN,
1006 .name = "set",
1007 .initKernel = InitKernel,
1008 .initLibrary = InitLibrary,
1009 };
1010
InitInfoSet(void)1011 StructInitInfo * InitInfoSet ( void )
1012 {
1013 return &module;
1014 }
1015