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 of for coset tables.
11 */
12
13 #include "costab.h"
14
15 #include "bool.h"
16 #include "error.h"
17 #include "integer.h"
18 #include "io.h"
19 #include "lists.h"
20 #include "modules.h"
21 #include "plist.h"
22
23
24 /****************************************************************************
25 **
26 *V declaration of static variables
27 */
28 static Obj objRel; /* handle of a relator */
29 static Obj objNums; /* handle of parallel numbers list */
30 static Obj objTable; /* handle of the coset table */
31 static Obj objTable2; /* handle of coset factor table */
32 static Obj objNext; /* */
33 static Obj objPrev; /* */
34 static Obj objFactor; /* */
35 static Obj objTree; /* handle of subgroup gens tree */
36
37 static Obj objTree1; /* first tree component */
38 static Obj objTree2; /* second tree component */
39
40 static Obj objExponent; /* handle of subgroup order */
41 static Obj objWordValue; /* handle of word value */
42
43 static Int treeType; /* tree type */
44 static Int treeWordLength; /* maximal tree word length */
45 static Int firstDef; /* */
46 static Int lastDef; /* */
47 static Int firstFree; /* */
48 static Int lastFree; /* */
49
50 static Int minGaps; /* switch for marking mingaps */
51 static Int nrdel; /* */
52
53 static Int dedfst; /* position of first deduction */
54 static Int dedlst; /* position of last deduction */
55 static Int dedgen [40960]; /* deduction list keeping gens */
56 static Int dedcos [40960]; /* deduction list keeping cosets */
57 static Int dedSize = 40960; /* size of deduction list buffers */
58 static Int dedprint; /* print flag for warning */
59
60 static Int wordList [1024]; /* coset rep word buffer */
61 static Int wordSize = 1023; /* maximal no. of coset rep words */
62
63 /* clean out global Obj-type variables to avoid hogging memory*/
CleanOut(void)64 static void CleanOut( void )
65 {
66 objRel = (Obj) 0;
67 objNums = (Obj) 0;
68 objTable = (Obj) 0;
69 objTable2 = (Obj) 0;
70 objNext = (Obj) 0;
71 objPrev = (Obj) 0;
72 objFactor = (Obj) 0;
73 objTree = (Obj) 0;
74 objTree1 = (Obj) 0;
75 objTree2 = (Obj) 0;
76 objExponent = (Obj) 0;
77 objWordValue = (Obj) 0;
78 }
79
80 /****************************************************************************
81 **
82 *F FuncApplyRel( <self>, <app>, <rel> ) apply a relator to a coset in a TC
83 **
84 ** 'FuncApplyRel' implements the internal function 'ApplyRel'.
85 **
86 ** 'ApplyRel( <app>, <rel> )'
87 **
88 ** 'ApplyRel' applies the relator <rel> to the application list <app>.
89 **
90 ** ... more about ApplyRel ...
91 */
FuncApplyRel(Obj self,Obj app,Obj rel)92 static Obj FuncApplyRel(Obj self,
93 Obj app, /* handle of the application list */
94 Obj rel) /* handle of the relator */
95 {
96
97 Int lp; /* left pointer into relator */
98 Int lc; /* left coset to apply to */
99 Int rp; /* right pointer into relator */
100 Int rc; /* right coset to apply to */
101 Int tc; /* temporary coset */
102
103 /* check the application list */
104 /*T 1996/12/03 fceller this should be replaced by 'PlistConv' */
105 RequirePlainList(0, app);
106 if ( LEN_PLIST(app) != 4 ) {
107 ErrorQuit( "<app> must be a list of length 4 not %d",
108 (Int) LEN_PLIST(app), 0L );
109 }
110
111 /* get the four entries */
112 lp = INT_INTOBJ( ELM_PLIST( app, 1 ) );
113 lc = INT_INTOBJ( ELM_PLIST( app, 2 ) );
114 rp = INT_INTOBJ( ELM_PLIST( app, 3 ) );
115 rc = INT_INTOBJ( ELM_PLIST( app, 4 ) );
116
117 /* get and check the relator (well, only a little bit) */
118 /*T 1996/12/03 fceller this should be replaced by 'PlistConv' */
119 RequirePlainList(0, rel);
120
121 /* fix right pointer if requested */
122 if ( rp == -1 )
123 rp = lp + INT_INTOBJ( ELM_PLIST( rel, 1 ) );
124
125 /* scan as long as possible from the right to the left */
126 while ( lp < rp
127 && 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,rp),rc))) )
128 {
129 rc = tc; rp = rp - 2;
130 }
131
132 /* scan as long as possible from the left to the right */
133 while ( lp < rp
134 && 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,lp),lc))) )
135 {
136 lc = tc; lp = lp + 2;
137 }
138
139 /* copy the information back into the application list */
140 SET_ELM_PLIST( app, 1, INTOBJ_INT( lp ) );
141 SET_ELM_PLIST( app, 2, INTOBJ_INT( lc ) );
142 SET_ELM_PLIST( app, 3, INTOBJ_INT( rp ) );
143 SET_ELM_PLIST( app, 4, INTOBJ_INT( rc ) );
144
145 /* return 'true' if a coincidence or deduction was found */
146 if ( lp == rp+1
147 && INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,lp),lc)) != rc )
148 {
149 return True;
150 }
151 else
152 return False;
153 }
154
155
156 /****************************************************************************
157 **
158 *F CompressDeductionList() . . . . removes unused items from deduction list
159 **
160 ** 'CompressDeductionList' tries to find and delete deduction list entries
161 ** which are not used any more.
162 **
163 ** 'dedgen', 'dedcos', 'dedfst', 'dedlst', 'dedSize' and 'objTable' are
164 ** assumed to be known as static variables.
165 */
CompressDeductionList(void)166 static void CompressDeductionList ( void )
167 {
168 Obj * ptTable; /* pointer to the coset table */
169 Int i;
170 Int j;
171
172 /* check if the situation is as assumed */
173 if ( dedlst != dedSize ) {
174 ErrorQuit( "invalid call of CompressDeductionList", 0L, 0L );
175 }
176
177 /* run through the lists and compress them */
178 ptTable = BASE_PTR_PLIST(objTable) - 1;
179 j = 0;
180 for ( i = dedfst; i < dedlst; i++ ) {
181 if ( INT_INTOBJ(ELM_PLIST(ptTable[dedgen[i]],dedcos[i])) > 0
182 && j < i )
183 {
184 dedgen[j] = dedgen[i];
185 dedcos[j] = dedcos[i];
186 j++;
187 }
188 }
189
190 /* update the pointers */
191 dedfst = 0;
192 dedlst = j;
193
194 /* check if we have at least one free position */
195 if ( dedlst == dedSize ) {
196 if ( dedprint == 0 ) {
197 Pr( "#I WARNING: deductions being discarded\n", 0L, 0L );
198 dedprint = 1;
199 }
200 dedlst--;
201 }
202 }
203
204
205 /****************************************************************************
206 **
207 *F HandleCoinc( <cos1>, <cos2> ) . . . . . . . . handle coincidences in a TC
208 **
209 ** 'HandleCoinc' is a subroutine of 'FuncMakeConsequences' and handles the
210 ** coincidence cos2 = cos1.
211 */
HandleCoinc(Int cos1,Int cos2)212 static void HandleCoinc (
213 Int cos1,
214 Int cos2 )
215 {
216 Obj * ptTable; /* pointer to the coset table */
217 Obj * ptNext;
218 Obj * ptPrev;
219 Int c1;
220 Int c2;
221 Int c3;
222 Int i;
223 Int firstCoinc;
224 Int lastCoinc;
225 Obj * gen;
226 Obj * inv;
227
228 /* is this test necessary? */
229 if ( cos1 == cos2 ) return;
230
231 /* get some pointers */
232 ptTable = BASE_PTR_PLIST(objTable) - 1;
233 ptNext = BASE_PTR_PLIST(objNext) - 1;
234 ptPrev = BASE_PTR_PLIST(objPrev) - 1;
235
236 /* take the smaller one as new representative */
237 if ( cos2 < cos1 ) { c3 = cos1; cos1 = cos2; cos2 = c3; }
238
239 /* if we are removing an important coset update it */
240 if ( cos2 == lastDef )
241 lastDef = INT_INTOBJ( ptPrev[lastDef ] );
242 if ( cos2 == firstDef )
243 firstDef = INT_INTOBJ( ptPrev[firstDef] );
244
245 /* remove <cos2> from the coset list */
246 ptNext[INT_INTOBJ(ptPrev[cos2])] = ptNext[cos2];
247 if ( ptNext[cos2] != INTOBJ_INT( 0 ) )
248 ptPrev[INT_INTOBJ(ptNext[cos2])] = ptPrev[cos2];
249
250 /* put the first coincidence into the list of coincidences */
251 firstCoinc = cos2;
252 lastCoinc = cos2;
253 ptNext[lastCoinc] = INTOBJ_INT( 0 );
254
255 /* <cos1> is the representative of <cos2> and its own representative */
256 ptPrev[cos2] = INTOBJ_INT( cos1 );
257
258 /* while there are coincidences to handle */
259 while ( firstCoinc != 0 ) {
260
261 /* replace <firstCoinc> by its representative in the table */
262 cos1 = INT_INTOBJ( ptPrev[firstCoinc] ); cos2 = firstCoinc;
263 for ( i = 1; i <= LEN_PLIST(objTable); i++ ) {
264 gen = BASE_PTR_PLIST(ptTable[i]) - 1;
265 /* inv = ADDR_OBJ(ptTable[ ((i-1)^1)+1 ] ); */
266 inv = BASE_PTR_PLIST(ptTable[i + 2 * (i % 2) - 1]) - 1;
267
268 /* replace <cos2> by <cos1> in the column of <gen>^-1 */
269 c2 = INT_INTOBJ( gen[cos2] );
270 if ( c2 > 0 ) {
271 c1 = INT_INTOBJ( gen[cos1] );
272
273 /* if the other entry is empty copy it */
274 if ( c1 <= 0 ) {
275 gen[cos1] = INTOBJ_INT( c2 );
276 gen[cos2] = INTOBJ_INT( 0 );
277 inv[c2] = INTOBJ_INT( cos1 );
278 if ( dedlst == dedSize )
279 CompressDeductionList( );
280 dedgen[dedlst] = i;
281 dedcos[dedlst] = cos1;
282 dedlst++;
283 }
284
285 /* otherwise check for a coincidence */
286 else {
287 inv[c2] = INTOBJ_INT( 0 );
288 gen[cos2] = INTOBJ_INT( 0 );
289 if ( gen[cos1] <= INTOBJ_INT( 0 ) ) {
290 gen[cos1] = INTOBJ_INT( cos1 );
291 if ( dedlst == dedSize )
292 CompressDeductionList( );
293 dedgen[dedlst] = i;
294 dedcos[dedlst] = cos1;
295 dedlst++;
296 }
297
298 /* find the representative of <c1> */
299 while ( c1 != 1
300 && INT_INTOBJ(ptNext[INT_INTOBJ(ptPrev[c1])]) != c1 )
301 {
302 c1 = INT_INTOBJ(ptPrev[c1]);
303 }
304
305 /* find the representative of <c2> */
306 while ( c2 != 1
307 && INT_INTOBJ(ptNext[INT_INTOBJ(ptPrev[c2])]) != c2 )
308 {
309 c2 = INT_INTOBJ(ptPrev[c2]);
310 }
311
312 /* if the representatives differ we got a coincindence */
313 if ( c1 != c2 ) {
314
315 /* take the smaller one as new representative */
316 if ( c2 < c1 ) { c3 = c1; c1 = c2; c2 = c3; }
317
318 /* if we are removing an important coset update it */
319 if ( c2 == lastDef )
320 lastDef = INT_INTOBJ(ptPrev[lastDef ]);
321 if ( c2 == firstDef )
322 firstDef = INT_INTOBJ(ptPrev[firstDef]);
323
324 /* remove <c2> from the coset list */
325 ptNext[INT_INTOBJ(ptPrev[c2])] = ptNext[c2];
326 if ( ptNext[c2] != INTOBJ_INT( 0 ) )
327 ptPrev[INT_INTOBJ(ptNext[c2])] = ptPrev[c2];
328
329 /* append <c2> to the coincidence list */
330 ptNext[lastCoinc] = INTOBJ_INT( c2 );
331 lastCoinc = c2;
332 ptNext[lastCoinc] = INTOBJ_INT( 0 );
333
334 /* <c1> is the rep of <c2> and its own rep. */
335 ptPrev[c2] = INTOBJ_INT( c1 );
336 }
337 }
338 }
339
340 /* save minimal gap flags */
341 else if ( minGaps != 0 && c2 == -1 ) {
342 if ( gen[cos1] <= INTOBJ_INT( 0 ) ) {
343 gen[cos1] = INTOBJ_INT( -1 );
344 }
345 gen[cos2] = INTOBJ_INT( 0 );
346 }
347 }
348
349 /* move the replaced coset to the free list */
350 if ( firstFree == 0 ) {
351 firstFree = firstCoinc;
352 lastFree = firstCoinc;
353 }
354 else {
355 ptNext[lastFree] = INTOBJ_INT( firstCoinc );
356 lastFree = firstCoinc;
357 }
358 firstCoinc = INT_INTOBJ( ptNext[firstCoinc] );
359 ptNext[lastFree] = INTOBJ_INT( 0 );
360
361 nrdel++;
362 }
363 }
364
365
366 /****************************************************************************
367 **
368 *F FuncMakeConsequences( <self>, <list> ) find consqs of a coset definition
369 */
FuncMakeConsequences(Obj self,Obj list)370 static Obj FuncMakeConsequences(Obj self, Obj list)
371 {
372 Obj hdSubs; /* */
373 Obj objRels; /* */
374 Obj * ptRel; /* pointer to the relator bag */
375 Obj * ptNums; /* pointer to this list */
376 Int lp; /* left pointer into relator */
377 Int lc; /* left coset to apply to */
378 Int rp; /* right pointer into relator */
379 Int rc; /* right coset to apply to */
380 Int tc; /* temporary coset */
381 Int i; /* loop variable */
382 Obj hdTmp; /* temporary variable */
383
384 /*T 1996/12/03 fceller this should be replaced by 'PlistConv' */
385 RequirePlainList(0, list);
386
387 objTable = ELM_PLIST( list, 1 );
388 objNext = ELM_PLIST( list, 2 );
389 objPrev = ELM_PLIST( list, 3 );
390
391 firstFree = INT_INTOBJ( ELM_PLIST( list, 6 ) );
392 lastFree = INT_INTOBJ( ELM_PLIST( list, 7 ) );
393 firstDef = INT_INTOBJ( ELM_PLIST( list, 8 ) );
394 lastDef = INT_INTOBJ( ELM_PLIST( list, 9 ) );
395 minGaps = INT_INTOBJ( ELM_PLIST( list, 12 ) );
396
397 nrdel = 0;
398
399 /* initialize the deduction queue */
400 dedprint = 0;
401 dedfst = 0;
402 dedlst = 1;
403 dedgen[ 0 ] = INT_INTOBJ( ELM_PLIST( list, 10 ) );
404 dedcos[ 0 ] = INT_INTOBJ( ELM_PLIST( list, 11 ) );
405
406 /* while the deduction queue is not empty */
407 while ( dedfst < dedlst ) {
408
409 /* skip the deduction, if it got irrelevant by a coincidence */
410 hdTmp = ELM_PLIST( objTable, dedgen[dedfst] );
411 hdTmp = ELM_PLIST( hdTmp, dedcos[dedfst] );
412 if ( INT_INTOBJ(hdTmp) <= 0 ) {
413 dedfst++;
414 continue;
415 }
416
417 /* while there are still subgroup generators apply them */
418 hdSubs = ELM_PLIST( list, 5 );
419 for ( i = LEN_LIST( hdSubs ); 1 <= i; i-- ) {
420 if ( ELM_PLIST( hdSubs, i ) != 0 ) {
421 objNums = ELM_PLIST( ELM_PLIST( hdSubs, i ), 1 );
422 ptNums = BASE_PTR_PLIST(objNums) - 1;
423 objRel = ELM_PLIST( ELM_PLIST( hdSubs, i ), 2 );
424 ptRel = BASE_PTR_PLIST(objRel) - 1;
425
426 lp = 2;
427 lc = 1;
428 rp = LEN_LIST( objRel ) - 1;
429 rc = 1;
430
431 /* scan as long as possible from the right to the left */
432 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {
433 rc = tc; rp = rp - 2;
434 }
435
436 /* scan as long as possible from the left to the right */
437 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {
438 lc = tc; lp = lp + 2;
439 }
440
441 /* if a coincidence or deduction has been found, handle it */
442 if ( lp == rp + 1 ) {
443 if ( INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc ) {
444 if ( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ) > 0 ) {
445 HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ), rc );
446 }
447 else if ( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ) > 0 ) {
448 HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ), lc );
449 }
450 else {
451 SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );
452 SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );
453 if ( dedlst == dedSize )
454 CompressDeductionList();
455 dedgen[ dedlst ] = INT_INTOBJ( ptNums[lp] );
456 dedcos[ dedlst ] = lc;
457 dedlst++;
458 }
459 }
460
461 /* remove the completed subgroup generator */
462 SET_ELM_PLIST( hdSubs, i, 0 );
463 if ( i == LEN_PLIST(hdSubs) ) {
464 while ( 0 < i && ELM_PLIST(hdSubs,i) == 0 )
465 --i;
466 SET_LEN_PLIST( hdSubs, i );
467 i++;
468 }
469 }
470
471 /* if a minimal gap has been found, set a flag */
472 else if ( minGaps != 0 && lp == rp - 1 ) {
473 SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( -1 ) );
474 SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( -1 ) );
475 }
476 }
477 }
478
479 /* apply all relators that start with this generator */
480 objRels = ELM_PLIST( ELM_PLIST( list, 4 ), dedgen[dedfst] );
481 for ( i = 1; i <= LEN_LIST( objRels ); i++ ) {
482 objNums = ELM_PLIST( ELM_PLIST(objRels,i), 1 );
483 ptNums = BASE_PTR_PLIST(objNums) - 1;
484 objRel = ELM_PLIST( ELM_PLIST(objRels,i), 2 );
485 ptRel = BASE_PTR_PLIST(objRel) - 1;
486
487 lp = INT_INTOBJ( ELM_PLIST( ELM_PLIST(objRels,i), 3 ) );
488 lc = dedcos[ dedfst ];
489 rp = lp + INT_INTOBJ( ptRel[1] );
490 rc = lc;
491
492 /* scan as long as possible from the right to the left */
493 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {
494 rc = tc; rp = rp - 2;
495 }
496
497 /* scan as long as possible from the left to the right */
498 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {
499 lc = tc; lp = lp + 2;
500 }
501
502 /* if a coincidence or deduction has been found, handle it */
503 if ( lp == rp+1 && INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc ) {
504 if ( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ) > 0 ) {
505 HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ), rc );
506 }
507 else if ( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ) > 0 ) {
508 HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ), lc );
509 }
510 else {
511 SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );
512 SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );
513 if ( dedlst == dedSize )
514 CompressDeductionList();
515 dedgen[ dedlst ] = INT_INTOBJ( ptNums[lp] );
516 dedcos[ dedlst ] = lc;
517 dedlst++;
518 }
519 }
520
521 /* if a minimal gap has been found, set a flag */
522 else if ( minGaps != 0 && lp == rp - 1 ) {
523 SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( -1 ) );
524 SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( -1 ) );
525 }
526 }
527
528 dedfst++;
529 }
530
531 SET_ELM_PLIST( list, 6, INTOBJ_INT( firstFree ) );
532 SET_ELM_PLIST( list, 7, INTOBJ_INT( lastFree ) );
533 SET_ELM_PLIST( list, 8, INTOBJ_INT( firstDef ) );
534 SET_ELM_PLIST( list, 9, INTOBJ_INT( lastDef ) );
535
536 /* clean out */
537 CleanOut();
538
539 return INTOBJ_INT( nrdel );
540 }
541
542
543 /****************************************************************************
544 **
545 *F FuncMakeConsequencesPres( <self>, <list> ) . . . . . . find consequences
546 **
547 ** This is a special version of `FuncMakeConsequences' for the subgroup
548 ** presentation routines.
549 */
FuncMakeConsequencesPres(Obj self,Obj list)550 static Obj FuncMakeConsequencesPres(Obj self, Obj list)
551 {
552 Obj objDefs1; /* handle of defs list part 1 */
553 Obj objDefs2; /* handle of defs list part 2 */
554 Obj objRels; /* */
555 Obj * ptRel; /* pointer to the relator bag */
556 Obj * ptNums; /* pointer to this list */
557 Int ndefs; /* number of defs done so far */
558 Int undefined; /* maximal of undefined entreis */
559 Int apply; /* num of next def to be applied */
560 Int ndefsMax; /* maximal number of definitons */
561 Int coset; /* coset involved in current def */
562 Int gen; /* gen involved in current def */
563 Int lp; /* left pointer into relator */
564 Int lc; /* left coset to apply to */
565 Int rp; /* right pointer into relator */
566 Int rc; /* right coset to apply to */
567 Int tc; /* temporary coset */
568 Int i; /* loop variable */
569
570 /*T 1996/12/03 fceller this should be replaced by 'PlistConv' */
571 RequirePlainList(0, list);
572
573 objTable = ELM_PLIST( list, 1 );
574 objDefs1 = ELM_PLIST( list, 2 );
575 objDefs2 = ELM_PLIST( list, 3 );
576
577 undefined = INT_INTOBJ( ELM_PLIST( list, 4 ) );
578 ndefs = INT_INTOBJ( ELM_PLIST( list, 5 ) );
579
580 /* check the definitions lists */
581 if ( ! ( IS_PLIST(objDefs1) && IS_PLIST(objDefs2) &&
582 LEN_PLIST(objDefs1) == LEN_PLIST(objDefs2) ) ) {
583 ErrorQuit( "inconsistent definitions lists", 0L, 0L );
584 }
585 ndefsMax = LEN_PLIST(objDefs1);
586 apply = 1;
587
588 /* while the deduction queue is not worked off */
589 while ( apply <= ndefs ) {
590
591 /* apply all relators that start with this generator */
592 coset = INT_INTOBJ( ELM_PLIST( objDefs1, apply ) );
593 gen = INT_INTOBJ( ELM_PLIST( objDefs2, apply ) );
594 objRels = ELM_PLIST( ELM_PLIST( list, 6 ), gen );
595 for ( i = 1; i <= LEN_LIST( objRels ); i++ ) {
596 objNums = ELM_PLIST( ELM_PLIST(objRels,i), 1 );
597 ptNums = BASE_PTR_PLIST(objNums) - 1;
598 objRel = ELM_PLIST( ELM_PLIST(objRels,i), 2 );
599 ptRel = BASE_PTR_PLIST(objRel) - 1;
600
601 lp = INT_INTOBJ( ELM_PLIST( ELM_PLIST(objRels,i), 3 ) );
602 lc = coset;
603 rp = lp + INT_INTOBJ( ptRel[1] );
604 rc = lc;
605
606 /* scan as long as possible from the right to the left */
607 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {
608 rc = tc; rp = rp - 2;
609 }
610
611 /* scan as long as possible from the left to the right */
612 while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {
613 lc = tc; lp = lp + 2;
614 }
615
616 /* if a deduction has been found, handle it */
617 if ( lp == rp+1 && INT_INTOBJ(ELM_PLIST(ptRel[rp],rc)) <= 0 ) {
618 SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );
619 undefined--;
620 if ( INT_INTOBJ(ELM_PLIST(ptRel[rp],rc)) <= 0 ) {
621 SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );
622 undefined--;
623 }
624 ndefs++;
625 if ( ndefs > ndefsMax ) {
626 ErrorQuit( "inconsistent definitions lists", 0L, 0L );
627 }
628 SET_ELM_PLIST( objDefs1, ndefs, INTOBJ_INT( lc ) );
629 SET_ELM_PLIST( objDefs2, ndefs, ptNums[lp] );
630 if ( undefined == 0 ) {
631 return INTOBJ_INT( 0 );
632 }
633 }
634 }
635
636 apply++;
637 }
638
639 /* clean out */
640 CleanOut();
641
642 return INTOBJ_INT( undefined );
643 }
644
645
646 /****************************************************************************
647 **
648 *F FuncStandardizeTableC(<self>,<table>,<stan>) . . . . . . standardize CT
649 **
650 ** This is the kernel routine for standardizing a coset table. It is called
651 ** by the GAP routine 'StandardizeTable'. The user should not call the
652 ** kernel routine but only the GAP routine.
653 **
654 ** If <stan> = 1 the table is standardized using the (old) semilenlex
655 ** standard.
656 ** If not <stan> = 1 the table is standardized using the (new) lenlex
657 ** standard (this is the default).
658 */
FuncStandardizeTableC(Obj self,Obj table,Obj stan)659 static Obj FuncStandardizeTableC(Obj self, Obj table, Obj stan)
660 {
661 Obj * ptTable; /* pointer to table */
662 UInt nrgen; /* number of rows of the table / 2 */
663 Obj * g; /* one generator list from table */
664 Obj * h; /* generator list */
665 Obj * i; /* and inverse */
666 UInt acos; /* actual coset */
667 UInt lcos; /* last seen coset */
668 UInt mcos; /* */
669 UInt c1, c2; /* coset temporaries */
670 Obj tmp; /* temporary for swap */
671 UInt j, k, nloop; /* loop variables */
672
673 RequirePlainList(0, table);
674
675 /* get the arguments */
676 objTable = table;
677 ptTable = BASE_PTR_PLIST(objTable) - 1;
678 nrgen = LEN_PLIST(objTable) / 2;
679 for ( j = 1; j <= nrgen*2; j++ ) {
680 if ( ! IS_PLIST(ptTable[j]) ) {
681 ErrorQuit(
682 "<table>[%d] must be a plain list (not a %s)",
683 (Int)j,
684 (Int)TNAM_OBJ(ptTable[j]) );
685 }
686 }
687 if ( IS_INTOBJ(stan) && INT_INTOBJ(stan) == 1 ) {
688 /* use semilenlex standard */
689 nloop = nrgen;
690 }
691 else {
692 /* use lenlex standard */
693 nloop = nrgen*2;
694 }
695
696 /* run over all cosets */
697 acos = 1;
698 lcos = 1;
699 while ( acos <= lcos ) {
700
701 /* scan through all columns of acos */
702 for ( j = 1; j <= nloop; j++ ) {
703 k = ( nloop == nrgen ) ? 2*j - 1 : j;
704 g = BASE_PTR_PLIST(ptTable[k]) - 1;
705
706 /* if we haven't seen this coset yet */
707 if ( lcos+1 < INT_INTOBJ( g[acos] ) ) {
708
709 /* swap rows lcos and g[acos] */
710 lcos = lcos + 1;
711 mcos = INT_INTOBJ( g[acos] );
712 for ( k = 1; k <= nrgen; k++ ) {
713 h = BASE_PTR_PLIST(ptTable[2 * k - 1]) - 1;
714 i = BASE_PTR_PLIST(ptTable[2 * k]) - 1;
715 c1 = INT_INTOBJ( h[lcos] );
716 c2 = INT_INTOBJ( h[mcos] );
717 if ( c1 != 0 ) i[c1] = INTOBJ_INT( mcos );
718 if ( c2 != 0 ) i[c2] = INTOBJ_INT( lcos );
719 tmp = h[lcos];
720 h[lcos] = h[mcos];
721 h[mcos] = tmp;
722 if ( i != h ) {
723 c1 = INT_INTOBJ( i[lcos] );
724 c2 = INT_INTOBJ( i[mcos] );
725 if ( c1 != 0 ) h[c1] = INTOBJ_INT( mcos );
726 if ( c2 != 0 ) h[c2] = INTOBJ_INT( lcos );
727 tmp = i[lcos];
728 i[lcos] = i[mcos];
729 i[mcos] = tmp;
730 }
731 }
732
733 }
734
735 /* if this is already the next only bump lcos */
736 else if ( lcos < INT_INTOBJ( g[acos] ) ) {
737 lcos = lcos + 1;
738 }
739
740 }
741
742 acos = acos + 1;
743 }
744
745 /* shrink the table */
746 for ( j = 1; j <= nrgen; j++ ) {
747 SET_LEN_PLIST( ptTable[2*j-1], lcos );
748 SET_LEN_PLIST( ptTable[2*j ], lcos );
749 }
750
751 /* clean out */
752 CleanOut();
753
754 /* return void */
755 return 0;
756 }
757
758
759 /****************************************************************************
760 **
761 *F InitializeCosetFactorWord() . . . . . . . initialize a coset factor word
762 **
763 ** 'InitializeCosetFactorWord' initializes a word in which a new coset
764 ** factor is to be built up.
765 **
766 ** 'wordList', 'treeType', 'objTree2', and 'treeWordLength' are assumed to
767 ** be known as static variables.
768 */
InitializeCosetFactorWord(void)769 static void InitializeCosetFactorWord ( void )
770 {
771 Obj * ptWord; /* pointer to the word */
772 Int i; /* integer variable */
773
774 /* handle the one generator MTC case */
775 if ( treeType == 1 ) {
776 objWordValue = INTOBJ_INT(0);
777 }
778
779 /* handle the abelianized case */
780 else if ( treeType == 0 ) {
781 ptWord = BASE_PTR_PLIST(objTree2) - 1;
782 for ( i = 1; i <= treeWordLength; i++ ) {
783 ptWord[i] = INTOBJ_INT(0);
784 }
785 }
786
787 /* handle the general case */
788 else {
789 wordList[0] = 0;
790 }
791 }
792
793
794 /****************************************************************************
795 **
796 *F TreeEntryC() . . . . . . . . . . . . returns a tree entry for a rep word
797 **
798 ** 'TreeEntryC' determines a tree entry which represents the word given in
799 ** 'wordList', if it finds any, or it defines a new proper tree entry, and
800 ** then returns it.
801 **
802 ** Warning: It is assumed, but not checked, that the given word is freely
803 ** reduced and that it does not contain zeros, and that the tree type is
804 ** either 0 or 2.
805 **
806 ** 'wordList' is assumed to be known as static variable.
807 **
808 */
TreeEntryC(void)809 static Int TreeEntryC ( void )
810 {
811 Obj * ptTree1; /* ptr to first tree component */
812 Obj * ptTree2; /* ptr to second tree component */
813 Obj * ptWord; /* ptr to given word */
814 Obj * ptFac; /* ptr to old word */
815 Obj * ptNew; /* ptr to new word */
816 Obj objNew; /* handle of new word */
817 Int treesize; /* tree size */
818 Int numgens; /* tree length */
819 Int leng; /* word length */
820 Int sign; /* sign flag */
821 Int i, k; /* integer variables */
822 Int gen; /* generator value */
823 Int u, u1, u2; /* generator values */
824 Int v, v1, v2; /* generator values */
825 Int t1, t2; /* generator values */
826 Int uabs, vabs; /* generator values */
827
828 /* Get the tree components */
829 ptTree1 = BASE_PTR_PLIST(objTree1) - 1;
830 ptTree2 = BASE_PTR_PLIST(objTree2) - 1;
831 treesize = LEN_PLIST(objTree1);
832 numgens = INT_INTOBJ( ELM_PLIST( objTree, 3 ) );
833
834 /* handle the abelianized case */
835 if ( treeType == 0 )
836 {
837 ptWord = BASE_PTR_PLIST(objTree2) - 1;
838 for ( leng = treeWordLength; leng >= 1; leng-- ) {
839 if ( ptWord[leng] != INTOBJ_INT(0) ) {
840 break;
841 }
842 }
843 if ( leng == 0 ) {
844 return 0;
845 }
846 for ( k = 1; k <= leng; k++ ) {
847 if ( ptWord[k] != INTOBJ_INT(0) ) {
848 break;
849 }
850 }
851 sign = 1;
852 if ( INT_INTOBJ( ptWord[k] ) < 0 ) {
853
854 /* invert the word */
855 sign = - 1;
856 for ( i = k; i <= leng; i++ ) {
857 ptWord[i] = INTOBJ_INT( - INT_INTOBJ( ptWord[i] ) );
858 }
859 }
860 for ( k = 1; k <= numgens; k++ ) {
861 ptFac = BASE_PTR_PLIST(ptTree1[k]) - 1;
862 if ( LEN_PLIST(ptTree1[k]) == leng ) {
863 for ( i = 1; i <= leng; i++ ) {
864 if ( ptFac[i] != ptWord[i] ) {
865 break;
866 }
867 }
868 if ( i > leng ) {
869 return sign * k;
870 }
871 }
872 }
873
874 /* extend the tree */
875 numgens++;
876 if ( treesize < numgens ) {
877 treesize = 2 * treesize;
878 GROW_PLIST( objTree1, treesize );
879 CHANGED_BAG(objTree);
880 }
881 objNew = NEW_PLIST( T_PLIST, leng );
882 SET_LEN_PLIST( objNew, leng );
883
884 SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );
885
886 SET_LEN_PLIST( objTree1, treesize );
887 SET_ELM_PLIST( objTree1, numgens, objNew );
888 CHANGED_BAG(objTree1);
889
890 /* copy the word to the new bag */
891 ptWord = BASE_PTR_PLIST(objTree2) - 1;
892 ptNew = BASE_PTR_PLIST(objNew) - 1;
893 while ( leng > 0 ) {
894 ptNew[leng] = ptWord[leng];
895 leng--;
896 }
897
898 return sign * numgens;
899 }
900
901 /* handle the general case */
902
903 /* Get the length of the word */
904 leng = wordList[0];
905
906 gen = ( leng == 0 ) ? 0 : wordList[1];
907 u2 = 0; /* just to shut up gcc */
908 for ( i = 2; i <= leng; i++ ) {
909 u = gen;
910 v = wordList[i];
911 while ( i ) {
912
913 /* First handle the trivial cases */
914 if ( u == 0 || v == 0 || ( u + v ) == 0 ) {
915 gen = u + v;
916 break;
917 }
918
919 /* Cancel out factors, if possible */
920 u1 = INT_INTOBJ( ptTree1[ (u > 0) ? u : -u ] );
921 if ( u1 != 0 ) {
922 if ( u > 0 ) {
923 u2 = INT_INTOBJ( ptTree2[u] );
924 }
925 else {
926 u2 = - u1;
927 u1 = - INT_INTOBJ( ptTree2[-u] );
928 }
929 if ( u2 == -v ) {
930 gen = u1;
931 break;
932 }
933 }
934 v1 = INT_INTOBJ( ptTree1[ (v > 0) ? v : -v ] );
935 if ( v1 != 0 ) {
936 if ( v > 0 ) {
937 v2 = INT_INTOBJ( ptTree2[v] );
938 }
939 else {
940 v2 = - v1;
941 v1 = - INT_INTOBJ( ptTree2[-v] );
942 }
943 if ( v1 == -u ) {
944 gen = v2;
945 break;
946 }
947 if ( u1 != 0 && v1 == - u2 ) {
948 u = u1;
949 v = v2;
950 continue;
951 }
952 }
953
954 /* Check if there is already a tree entry [u,v] or [-v,-u] */
955 if ( u < -v ) {
956 t1 = u;
957 t2 = v;
958 }
959 else {
960 t1 = -v;
961 t2 = -u;
962 }
963 uabs = ( u > 0 ) ? u : -u;
964 vabs = ( v > 0 ) ? v : -v;
965 k = ( uabs > vabs ) ? uabs : vabs;
966 for ( k++; k <= numgens; k++ ) {
967 if ( INT_INTOBJ(ptTree1[k]) == t1 &&
968 INT_INTOBJ(ptTree2[k]) == t2 )
969 {
970 break;
971 }
972 }
973
974 /* Extend the tree, if necessary */
975 if ( k > numgens ) {
976 numgens++;
977 if ( treesize < numgens ) {
978 treesize = 2 * treesize;
979 GROW_PLIST( objTree1, treesize );
980 GROW_PLIST( objTree2, treesize );
981 ptTree1 = BASE_PTR_PLIST(objTree1) - 1;
982 ptTree2 = BASE_PTR_PLIST(objTree2) - 1;
983 SET_LEN_PLIST( objTree1, treesize );
984 SET_LEN_PLIST( objTree2, treesize );
985 CHANGED_BAG(objTree);
986 }
987 ptTree1[numgens] = INTOBJ_INT( t1 );
988 ptTree2[numgens] = INTOBJ_INT( t2 );
989 SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );
990 }
991 gen = ( u > - v ) ? -k : k;
992 break;
993 }
994 }
995
996 return gen;
997 }
998
999
1000 /****************************************************************************
1001 **
1002 *F AddCosetFactor2( <factor> ) . add a factor to a coset representative word
1003 **
1004 ** 'AddCosetFactor2' adds a factor to a coset representative word and
1005 ** extends the tree appropriately, if necessary.
1006 **
1007 ** 'treeType', 'wordList', and 'wordSize' are assumed to be known as static
1008 ** variables, and 'treeType' is assumed to be either 0 or 2,
1009 **
1010 ** Warning: 'factor' is not checked for being zero.
1011 **
1012 ** it returns 0 if everything worked, and 1 if a problem arose.
1013 */
AddCosetFactor2(Int factor)1014 static Int AddCosetFactor2 (
1015 Int factor )
1016 {
1017 Obj * ptFac; /* pointer to the factor */
1018 Obj * ptWord; /* pointer to the word */
1019 Int leng; /* length of the factor */
1020 Obj sum; /* intermediate result */
1021 Int i; /* integer variable */
1022 Obj tmp;
1023
1024 /* handle the abelianized case */
1025 if ( treeType == 0 ) {
1026 ptWord = BASE_PTR_PLIST(objTree2) - 1;
1027 if ( factor > 0 ) {
1028 tmp = ELM_PLIST( objTree1, factor );
1029 ptFac = BASE_PTR_PLIST(tmp) - 1;
1030 leng = LEN_PLIST(tmp);
1031 for ( i = 1; i <= leng; i++ ) {
1032 if ( ! SUM_INTOBJS( sum, ptWord[i], ptFac[i] ) ) {
1033 return 1;
1034 /* used to be unrecoverable error message:
1035 ErrorQuit(
1036 "exponent too large, Modified Todd-Coxeter aborted",
1037 0L, 0L ); */
1038 }
1039 ptWord[i] = sum;
1040 }
1041 }
1042 else
1043 {
1044 tmp = ELM_PLIST( objTree1, -factor );
1045 ptFac = BASE_PTR_PLIST(tmp) - 1;
1046 leng = LEN_PLIST(tmp);
1047 for ( i = 1; i <= leng; i++ ) {
1048 if ( ! DIFF_INTOBJS( sum, ptWord[i], ptFac[i] ) ) {
1049 return 1;
1050 /* used to be unrecoverable error message:
1051 ErrorQuit(
1052 "exponent too large, Modified Todd-Coxeter aborted",
1053 0L, 0L ); */
1054 }
1055 ptWord[i] = sum;
1056 }
1057 }
1058 }
1059
1060 /* handle the general case */
1061 else if ( wordList[0] == 0 ) {
1062 wordList[++wordList[0]] = factor;
1063 }
1064 else if ( wordList[wordList[0]] == -factor ) {
1065 --wordList[0];
1066 }
1067 else if ( wordList[0] < wordSize ) {
1068 wordList[++wordList[0]] = factor;
1069 }
1070 else {
1071 wordList[0] = ( wordList[1] = TreeEntryC( ) == 0 ) ? 0 : 1;
1072 if (AddCosetFactor2(factor)==1) {
1073 return 1;
1074 }
1075 }
1076 return 0;
1077 }
1078
1079
1080 /****************************************************************************
1081 **
1082 *F FuncApplyRel2( <self>, <app>, <rel>, <nums> ) . . . . . . apply a relator
1083 **
1084 ** 'FuncApplyRel2' implements the internal function 'ApplyRel2'.
1085 **
1086 ** 'ApplyRel2( <app>, <rel>, <nums> )'
1087 **
1088 ** 'ApplyRel2' applies the relator <rel> to a coset representative and
1089 ** returns the corresponding factors in "word"
1090 **
1091 ** ...more about ApplyRel2...
1092 **
1093 ** function returns `true` if everything worked, and `false` if there was a
1094 ** problem (e.g. exponents).
1095 */
FuncApplyRel2(Obj self,Obj app,Obj rel,Obj nums)1096 static Obj FuncApplyRel2(Obj self, Obj app, Obj rel, Obj nums)
1097 {
1098 Obj * ptApp; /* pointer to that list */
1099 Obj word; /* handle of resulting word */
1100 Obj * ptWord; /* pointer to this word */
1101 Obj * ptTree; /* pointer to the tree */
1102 Obj * ptTree2; /* ptr to second tree component */
1103 Obj * ptRel; /* pointer to the relator bag */
1104 Obj * ptNums; /* pointer to this list */
1105 Obj * ptTabl2; /* pointer to coset factor table */
1106 Obj objRep; /* handle of temporary factor */
1107 Int lp; /* left pointer into relator */
1108 Int lc; /* left coset to apply to */
1109 Int rp; /* right pointer into relator */
1110 Int rc; /* right coset to apply to */
1111 Int rep; /* temporary factor */
1112 Int tc; /* temporary coset */
1113 Int bound; /* maximal number of steps */
1114 Int last; /* proper word length */
1115 Int size; /* size of the word bag */
1116 Int i; /* loop variables */
1117 Int tmp;
1118
1119 /* get and check the application list */
1120 RequirePlainList(0, app);
1121 if ( LEN_PLIST(app) != 9 ) {
1122 ErrorQuit( "<app> must be a list of length 9 not %d",
1123 (Int) LEN_PLIST(app), 0L );
1124 }
1125 ptApp = BASE_PTR_PLIST(app) - 1;
1126
1127 /* get the components of the proper application list */
1128 lp = INT_INTOBJ( ptApp[1] );
1129 lc = INT_INTOBJ( ptApp[2] );
1130 rp = INT_INTOBJ( ptApp[3] );
1131 rc = INT_INTOBJ( ptApp[4] );
1132
1133 /* get and check the relator (well, only a little bit) */
1134 objRel = rel;
1135 RequirePlainList(0, rel);
1136
1137 /* fix right pointer if requested */
1138 if ( rp == -1 )
1139 rp = lp + INT_INTOBJ( ELM_PLIST(objRel,1) );
1140
1141 /* get and check the numbers list parallel to the relator */
1142 objNums = nums;
1143 RequirePlainList(0, nums);
1144
1145 /* get and check the corresponding factors list */
1146 objTable2 = ptApp[6];
1147 RequirePlainList(0, objTable2);
1148
1149 /* get the tree type */
1150 treeType = INT_INTOBJ( ptApp[5] );
1151
1152 /* handle the one generator MTC case */
1153 if ( treeType == 1 ) {
1154
1155 /* initialize the resulting exponent by zero */
1156 objExponent = INTOBJ_INT( 0 );
1157
1158 /* scan as long as possible from the left to the right */
1159 while ( lp < rp + 2 &&
1160 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )
1161 {
1162 tmp = INT_INTOBJ( ELM_PLIST(objNums,lp) );
1163 objRep = ELM_PLIST( objTable2, tmp );
1164 objRep = ELM_PLIST( objRep, lc );
1165 objExponent = DiffInt( objExponent, objRep );
1166 lc = tc;
1167 lp = lp + 2;
1168 }
1169
1170 /* scan as long as possible from the right to the left */
1171 while ( lp < rp + 2 &&
1172 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )
1173 {
1174 tmp = INT_INTOBJ( ELM_PLIST(objNums,rp) );
1175 objRep = ELM_PLIST( objTable2, tmp );
1176 objRep = ELM_PLIST( objRep, rc );
1177 objExponent = SumInt( objExponent, objRep );
1178 rc = tc;
1179 rp = rp - 2;
1180 }
1181
1182 /* The functions DiffInt or SumInt may have caused a garbage */
1183 /* collections. So restore the pointer. */
1184
1185 /* save the resulting exponent */
1186 SET_ELM_PLIST( app, 9, objExponent );
1187 }
1188
1189 else {
1190
1191 /* get and check the corresponding word */
1192 word = ptApp[7];
1193 RequirePlainList(0, word);
1194
1195 /* handle the abelianized case */
1196 if ( treeType == 0 ) {
1197 objTree = ptApp[8];
1198 objTree1 = ELM_PLIST( objTree, 1 );
1199 objTree2 = ELM_PLIST( objTree, 2 );
1200 ptTree = BASE_PTR_PLIST(objTree) - 1;
1201 treeWordLength = INT_INTOBJ( ptTree[4] );
1202 if ( LEN_PLIST(objTree2) != treeWordLength ) {
1203 ErrorQuit( "ApplyRel2: illegal word length", 0L, 0L );
1204 }
1205
1206 /* initialize the coset representative word */
1207 InitializeCosetFactorWord();
1208
1209 /* scan as long as possible from the left to the right */
1210 while ( lp < rp + 2 &&
1211 0 < (tc=INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )
1212 {
1213 tmp = INT_INTOBJ( ELM_PLIST(objNums,lp) );
1214 objRep = ELM_PLIST(objTable2,tmp);
1215 objRep = ELM_PLIST(objRep,lc);
1216 rep = INT_INTOBJ(objRep);
1217 if ( rep != 0 ) {
1218 if (AddCosetFactor2(-rep)==1) {;
1219 return False;
1220 }
1221 }
1222 lc = tc;
1223 lp = lp + 2;
1224 }
1225
1226 /* scan as long as possible from the right to the left */
1227 while ( lp < rp + 2 &&
1228 0 < (tc=INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )
1229 {
1230 tmp = INT_INTOBJ( ELM_PLIST(objNums,rp) );
1231 objRep = ELM_PLIST(objTable2,tmp);
1232 objRep = ELM_PLIST(objRep,rc);
1233 rep = INT_INTOBJ(objRep);
1234 if ( rep != 0 ) {
1235 if (AddCosetFactor2(rep)==1) {
1236 return False;
1237 }
1238 }
1239 rc = tc;
1240 rp = rp - 2;
1241 }
1242
1243 /* initialize some local variables */
1244 ptWord = BASE_PTR_PLIST(word) - 1;
1245 ptTree2 = BASE_PTR_PLIST(objTree2) - 1;
1246
1247 /* copy the result to its destination, if necessary */
1248 if ( ptWord != ptTree2 ) {
1249 if ( LEN_PLIST(word) != treeWordLength ) {
1250 ErrorQuit( "illegal word length", 0L, 0L );
1251 }
1252 for ( i = 1; i <= treeWordLength; i++ ) {
1253 ptWord[i] = ptTree2[i];
1254 }
1255 SET_LEN_PLIST( word, LEN_PLIST(objTree2) );
1256 }
1257 }
1258
1259 /* handle the general case */
1260 else {
1261
1262 /* extend the word size, if necessary */
1263 bound = ( rp - lp + 3 ) / 2;
1264 size = SIZE_OBJ(word)/sizeof(Obj) - 1;
1265 if ( size < bound ) {
1266 size = ( bound > 2 * size ) ? bound : 2 * size;
1267 GROW_PLIST( word, size );
1268 CHANGED_BAG(app);
1269 }
1270
1271 /* initialize some local variables */
1272 ptRel = BASE_PTR_PLIST(objRel) - 1;
1273 ptNums = BASE_PTR_PLIST(objNums) - 1;
1274 ptTabl2 = BASE_PTR_PLIST(objTable2) - 1;
1275 ptWord = BASE_PTR_PLIST(word) - 1;
1276 last = 0;
1277
1278 /* scan as long as possible from the left to the right */
1279 while ( lp < rp + 2
1280 && 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) )
1281 {
1282 objRep = ELM_PLIST( ptTabl2[INT_INTOBJ(ptNums[lp])], lc );
1283 rep = INT_INTOBJ(objRep);
1284 if ( rep != 0 ) {
1285 if ( last > 0 && INT_INTOBJ(ptWord[last]) == rep ) {
1286 last--;
1287 }
1288 else {
1289 ptWord[++last] = INTOBJ_INT(-rep);
1290 }
1291 }
1292 lc = tc;
1293 lp = lp + 2;
1294 }
1295
1296 /* revert the ordering of the word constructed so far */
1297 if ( last > 0 ) {
1298 last++;
1299 for ( i = last / 2; i > 0; i-- ) {
1300 objRep = ptWord[i];
1301 ptWord[i] = ptWord[last-i];
1302 ptWord[last-i] = objRep;
1303 }
1304 last--;
1305 }
1306
1307 /* scan as long as possible from the right to the left */
1308 while ( lp < rp + 2
1309 && 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) )
1310 {
1311 objRep = ELM_PLIST( ptTabl2[INT_INTOBJ(ptNums[rp])], rc );
1312 rep = INT_INTOBJ(objRep);
1313 if ( rep != 0 ) {
1314 if ( last > 0 && INT_INTOBJ(ptWord[last]) == -rep ) {
1315 last--;
1316 }
1317 else {
1318 ptWord[++last] = INTOBJ_INT(rep);
1319 }
1320 }
1321 rc = tc;
1322 rp = rp - 2;
1323 }
1324
1325 /* save the word length */
1326 SET_LEN_PLIST( word, last );
1327 }
1328 }
1329
1330 /* copy the information back into the application list */
1331 SET_ELM_PLIST( app, 1, INTOBJ_INT( lp ) );
1332 SET_ELM_PLIST( app, 2, INTOBJ_INT( lc ) );
1333 SET_ELM_PLIST( app, 3, INTOBJ_INT( rp ) );
1334 SET_ELM_PLIST( app, 4, INTOBJ_INT( rc ) );
1335
1336 /* return true */
1337 return True;
1338 }
1339
1340
1341 /****************************************************************************
1342 **
1343 *F FuncCopyRel( <self>, <rel> ) . . . . . . . . . . . . copy of a relator
1344 **
1345 ** 'FuncCopyRel' returns a copy of the given RRS relator such that the bag
1346 ** of the copy does not exceed the minimal required size.
1347 */
FuncCopyRel(Obj self,Obj rel)1348 static Obj FuncCopyRel(Obj self, Obj rel) /* the given relator */
1349 {
1350 Obj * ptRel; /* pointer to the given relator */
1351 Obj copy; /* the copy */
1352 Obj * ptCopy; /* pointer to the copy */
1353 Int leng; /* length of the given word */
1354
1355 /* Get and check argument */
1356 RequirePlainList(0, rel);
1357 leng = LEN_PLIST(rel);
1358
1359 /* Allocate a bag for the copy */
1360 copy = NEW_PLIST( T_PLIST, leng );
1361 SET_LEN_PLIST( copy, leng );
1362 ptRel = BASE_PTR_PLIST(rel);
1363 ptCopy = BASE_PTR_PLIST(copy);
1364
1365 /* Copy the relator to the new bag */
1366 while ( leng > 0 ) {
1367 *ptCopy++ = *ptRel++;
1368 leng--;
1369 }
1370
1371 /* Return the copy */
1372 return copy;
1373 }
1374
1375
1376 /****************************************************************************
1377 **
1378 *F FuncMakeCanonical( <self>, <rel> ) . . . . . . . make a relator canonical
1379 **
1380 ** 'FuncMakeCanonical' is a subroutine of the Reduced Reidemeister-Schreier
1381 ** routines. It replaces the given relator by its canonical representative.
1382 ** It does not return anything.
1383 */
FuncMakeCanonical(Obj self,Obj rel)1384 static Obj FuncMakeCanonical(Obj self, Obj rel) /* the given relator */
1385 {
1386 Obj * ptRel; /* pointer to the relator */
1387 Obj obj1, obj2; /* handles 0f relator entries */
1388 Int leng, leng1; /* length of the relator */
1389 Int max, min, next; /* relator entries */
1390 Int i, j, k, l; /* integer variables */
1391 Int ii, jj, kk; /* integer variables */
1392
1393 /* Get and check the argument */
1394 RequirePlainList(0, rel);
1395 leng = LEN_PLIST(rel);
1396 if (leng == 0) {
1397 return 0;
1398 }
1399 ptRel = BASE_PTR_PLIST(rel);
1400 leng1 = leng - 1;
1401
1402 /* cyclically reduce the relator, if necessary */
1403 i = 0;
1404 while ( i<leng1 && INT_INTOBJ(ptRel[i]) == -INT_INTOBJ(ptRel[leng1]) ) {
1405 i++;
1406 leng1--;
1407 }
1408 if ( i > 0 ) {
1409 for ( j = i; j <= leng1; j++ ) {
1410 ptRel[j-i] = ptRel[j];
1411 }
1412 leng1 = leng1 - i;
1413 leng = leng1 + 1;
1414 SET_LEN_PLIST( rel, leng );
1415 }
1416
1417 /* Loop over the relator and find the maximal postitve and negative */
1418 /* entries */
1419 max = min = INT_INTOBJ(ptRel[0]);
1420 i = 0; j = 0;
1421 for ( k = 1; k < leng; k++ ) {
1422 next = INT_INTOBJ( ptRel[k] );
1423 if ( next > max ) {
1424 max = next;
1425 i = k;
1426 }
1427 else if ( next <= min ) {
1428 min = next;
1429 j = k;
1430 }
1431 }
1432
1433 /* Find the lexicographically last cyclic permutation of the relator */
1434 if ( max < -min ) {
1435 i = leng;
1436 }
1437 else {
1438 for ( k = i + 1; k < leng; k++ ) {
1439 for ( ii = i, kk = k, l = 0;
1440 l < leng;
1441 ii = (ii + 1) % leng, kk = (kk + 1) % leng, l++ )
1442 {
1443 if ( INT_INTOBJ(ptRel[kk]) < INT_INTOBJ(ptRel[ii]) ) {
1444 break;
1445 }
1446 else if ( INT_INTOBJ(ptRel[kk]) > INT_INTOBJ(ptRel[ii]) ) {
1447 i = k;
1448 break;
1449 }
1450 }
1451 if ( l == leng ) {
1452 break;
1453 }
1454 }
1455 }
1456
1457 /* Find the lexicographically last cyclic permutation of its inverse */
1458 if ( -max < min ) {
1459 j = leng;
1460 }
1461 else {
1462 for ( k = j - 1; k >= 0; k-- ) {
1463 for ( jj = j, kk = k, l = 0;
1464 l < leng;
1465 jj = (jj + leng1) % leng, kk = (kk + leng1) % leng, l++ )
1466 {
1467 if ( INT_INTOBJ(ptRel[kk]) > INT_INTOBJ(ptRel[jj]) ) {
1468 break;
1469 }
1470 else if ( INT_INTOBJ(ptRel[kk]) < INT_INTOBJ(ptRel[jj]) ) {
1471 j = k;
1472 break;
1473 }
1474 }
1475 if ( l == leng ) {
1476 break;
1477 }
1478 }
1479 }
1480
1481 /* Compare the two words and find the lexicographically last one */
1482 if ( -min == max ) {
1483 for ( ii = i, jj = j, l = 0;
1484 l < leng;
1485 ii = (ii + 1) % leng, jj = (jj + leng1) % leng, l++ )
1486 {
1487 if ( - INT_INTOBJ(ptRel[jj]) < INT_INTOBJ(ptRel[ii]) ) {
1488 break;
1489 }
1490 else if ( - INT_INTOBJ(ptRel[jj]) > INT_INTOBJ(ptRel[ii]) ) {
1491 i = leng;
1492 break;
1493 }
1494 }
1495 }
1496
1497 /* Invert the given relator, if necessary */
1498 if ( i == leng ) {
1499 for ( k = 0; k < leng / 2; k++ ) {
1500 next = INT_INTOBJ( ptRel[k] );
1501 ptRel[k] = INTOBJ_INT( - INT_INTOBJ( ptRel[leng1-k] ) );
1502 ptRel[leng1-k] = INTOBJ_INT( - next );
1503 }
1504 if ( leng % 2 ) {
1505 ptRel[leng1/2] = INTOBJ_INT( - INT_INTOBJ( ptRel[leng1/2] ) );
1506 }
1507 i = leng1 - j;
1508 }
1509
1510 /* Now replace the given relator by the resulting word */
1511 if ( i > 0 ) {
1512 k = INT_INTOBJ( GcdInt( INTOBJ_INT(i), INTOBJ_INT(leng) ) );
1513 l = leng / k;
1514 leng1 = leng - i;
1515 for ( j = 0; j < k; j++ ) {
1516 jj = (j + i) % leng;
1517 obj1 = ptRel[jj];
1518 for ( ii = 0; ii < l; ii++ ) {
1519 jj = (jj + leng1) % leng;
1520 obj2 = ptRel[jj]; ptRel[jj] = obj1; obj1 = obj2;
1521 }
1522 }
1523 }
1524
1525 /* return nothing */
1526 return 0;
1527 }
1528
1529
1530 /****************************************************************************
1531 **
1532 *F FuncTreeEntry( <self>, <tree>, <word> ) . tree entry for the given word
1533 **
1534 ** 'FuncTreeEntry' determines a tree entry which represents the given word
1535 ** in the current generators, if it finds any, or it defines a new proper
1536 ** tree entry, and then returns it.
1537 */
FuncTreeEntry(Obj self,Obj tree,Obj word)1538 static Obj FuncTreeEntry(Obj self, Obj tree, Obj word)
1539 {
1540 Obj * ptTree1; /* pointer to that component */
1541 Obj * ptTree2; /* pointer to that component */
1542 Obj * ptWord; /* pointer to that word */
1543 Obj new; /* handle of new word */
1544 Obj * ptNew; /* pointer to new word */
1545 Obj * ptFac; /* pointer to old word */
1546 Int treesize; /* tree size */
1547 Int numgens; /* tree length */
1548 Int leng; /* word length */
1549 Int sign; /* integer variable */
1550 Int i, j, k; /* integer variables */
1551 Int gen; /* generator value */
1552 Int u, u1, u2; /* generator values */
1553 Int v, v1, v2; /* generator values */
1554 Int t1, t2; /* generator values */
1555 Int uabs, vabs; /* generator values */
1556
1557 /* Get and check the first argument (tree) */
1558 objTree = tree;
1559 if ( ! IS_PLIST(tree) || LEN_PLIST(tree) < 5 ) {
1560 ErrorQuit( "invalid <tree>", 0L, 0L );
1561 }
1562
1563 /* Get and check the tree components */
1564 objTree1 = ELM_PLIST(objTree,1);
1565 if ( ! IS_PLIST(objTree1) ) {
1566 ErrorQuit( "invalid <tree>[1]", 0L, 0L );
1567 }
1568 objTree2 = ELM_PLIST(objTree,2);
1569 if ( ! IS_PLIST(objTree2) ) {
1570 ErrorQuit( "invalid <tree>[2]", 0L, 0L );
1571 }
1572 ptTree1 = BASE_PTR_PLIST(objTree1) - 1;
1573 ptTree2 = BASE_PTR_PLIST(objTree2) - 1;
1574 treesize = LEN_PLIST(objTree1);
1575 numgens = INT_INTOBJ( ELM_PLIST( objTree, 3 ) );
1576 treeWordLength = INT_INTOBJ( ELM_PLIST( objTree, 4 ) );
1577 treeType = INT_INTOBJ( ELM_PLIST( objTree, 5 ) );
1578
1579 /* Get the second argument (word) */
1580 if ( ! IS_PLIST(word) ) {
1581 ErrorQuit( "invalid <word>", 0L, 0L );
1582 }
1583
1584 /* handle the abelianized case */
1585 ptWord = BASE_PTR_PLIST(word) - 1;
1586 if ( treeType == 0 ) {
1587 if ( LEN_PLIST(word) != treeWordLength ) {
1588 ErrorQuit( "inconsistent <word> length", 0L, 0L );
1589 }
1590 ptWord = BASE_PTR_PLIST(objTree2) - 1;
1591 for ( leng = treeWordLength; leng >= 1; leng-- ) {
1592 if ( ptWord[leng] != INTOBJ_INT(0) ) {
1593 break;
1594 }
1595 }
1596 if ( leng == 0 ) {
1597 return INTOBJ_INT( 0 );
1598 }
1599
1600 for ( k = 1; k <= leng; k++ ) {
1601 if ( ptWord[k] != INTOBJ_INT(0) ) {
1602 break;
1603 }
1604 }
1605 sign = 1;
1606
1607 /* invert the word */
1608 if ( INT_INTOBJ(ptWord[k]) < 0 ) {
1609 sign = -1;
1610 for ( i = k; i <= leng; i++ ) {
1611 ptWord[i] = INTOBJ_INT( - INT_INTOBJ( ptWord[i] ) );
1612 }
1613 }
1614
1615 for ( k = 1; k <= numgens; k++ ) {
1616 ptFac = BASE_PTR_PLIST(ptTree1[k]) - 1;
1617 if ( LEN_PLIST(ptTree1[k]) == leng ) {
1618 for ( i = 1; i <= leng; i++ ) {
1619 if ( ptFac[i] != ptWord[i] ) {
1620 break;
1621 }
1622 }
1623 if ( i > leng ) {
1624 return INTOBJ_INT( sign * k );
1625 }
1626 }
1627 }
1628
1629 /* extend the tree */
1630 numgens++;
1631 if ( treesize < numgens ) {
1632 treesize = 2 * treesize;
1633 GROW_PLIST( objTree1, treesize );
1634 SET_LEN_PLIST( objTree1, treesize );
1635 CHANGED_BAG(objTree);
1636 }
1637 new = NEW_PLIST( T_PLIST, leng );
1638 SET_LEN_PLIST( new, leng );
1639
1640 SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );
1641 SET_ELM_PLIST( objTree1, numgens, new );
1642 CHANGED_BAG(objTree1);
1643
1644 /* copy the word to the new bag */
1645 ptWord = BASE_PTR_PLIST(objTree2) - 1;
1646 ptNew = BASE_PTR_PLIST(new) - 1;
1647 while ( leng > 0 ) {
1648 ptNew[leng] = ptWord[leng];
1649 leng--;
1650 }
1651
1652 return INTOBJ_INT( sign * numgens );
1653 }
1654
1655 /* handle the general case */
1656 if ( LEN_PLIST(objTree1) != LEN_PLIST(objTree2) ) {
1657 ErrorQuit( "inconsistent <tree> components", 0L, 0L );
1658 }
1659
1660 for ( i = 1; i <= numgens; i++ ) {
1661 if ( INT_INTOBJ(ptTree1[i]) <= -i || INT_INTOBJ(ptTree1[i]) >= i
1662 || INT_INTOBJ(ptTree2[i]) <= -i || INT_INTOBJ(ptTree2[i]) >= i )
1663 {
1664 ErrorQuit( "invalid <tree> components", 0L, 0L );
1665 }
1666 }
1667
1668 /* Freely reduce the given word */
1669 leng = LEN_PLIST(word);
1670 for ( j = 0, i = 1; i <= leng; i++ ) {
1671 gen = INT_INTOBJ(ptWord[i]);
1672 if ( gen == 0 ) {
1673 continue;
1674 }
1675 if ( gen > numgens || gen < -numgens ) {
1676 ErrorQuit( "invalid <word> entry [%d]", i, 0L );
1677 }
1678 if ( j > 0 && gen == - INT_INTOBJ(ptWord[j]) ) {
1679 j--;
1680 }
1681 else {
1682 ptWord[++j] = ptWord[i];
1683 }
1684 }
1685 for ( i = j + 1; i <= leng; i++ ) {
1686 ptWord[i] = INTOBJ_INT( 0 );
1687 }
1688 leng = j;
1689
1690 gen = ( leng == 0 ) ? 0 : INT_INTOBJ( ptWord[1] );
1691 u2 = 0; /* just to shut up gcc */
1692 for ( i = 2; i <= leng; i++ ) {
1693 u = gen;
1694 v = INT_INTOBJ( ELM_PLIST(word,i) );
1695 while ( i ) {
1696
1697 /* First handle the trivial cases */
1698 if ( u == 0 || v == 0 || ( u + v ) == 0 ) {
1699 gen = u + v;
1700 break;
1701 }
1702
1703 /* Cancel out factors, if possible */
1704 u1 = INT_INTOBJ( ptTree1[ (u > 0) ? u : -u ] );
1705 if ( u1 != 0 ) {
1706 if ( u > 0 ) {
1707 u2 = INT_INTOBJ( ptTree2[u] );
1708 }
1709 else {
1710 u2 = - u1;
1711 u1 = - INT_INTOBJ( ptTree2[-u] );
1712 }
1713 if ( u2 == -v ) {
1714 gen = u1;
1715 break;
1716 }
1717 }
1718 v1 = INT_INTOBJ( ptTree1[ (v > 0) ? v : -v ] );
1719 if ( v1 != 0 ) {
1720 if ( v > 0 ) {
1721 v2 = INT_INTOBJ( ptTree2[v] );
1722 }
1723 else {
1724 v2 = - v1;
1725 v1 = - INT_INTOBJ( ptTree2[-v] );
1726 }
1727 if ( v1 == -u ) {
1728 gen = v2;
1729 break;
1730 }
1731 if ( u1 != 0 && v1 == - u2 ) {
1732 u = u1;
1733 v = v2;
1734 continue;
1735 }
1736 }
1737
1738 /* Check if there is already a tree entry [u,v] or [-v,-u] */
1739 if ( u < -v ) {
1740 t1 = u;
1741 t2 = v;
1742 }
1743 else {
1744 t1 = -v;
1745 t2 = -u;
1746 }
1747 uabs = ( u > 0 ) ? u : -u;
1748 vabs = ( v > 0 ) ? v : -v;
1749 k = ( uabs > vabs ) ? uabs : vabs;
1750 for ( k++; k <= numgens; k++ ) {
1751 if ( INT_INTOBJ(ptTree1[k]) == t1 &&
1752 INT_INTOBJ(ptTree2[k]) == t2 )
1753 {
1754 break;
1755 }
1756 }
1757
1758 /* Extend the tree, if necessary */
1759 if ( k > numgens ) {
1760 numgens++;
1761 if ( treesize < numgens ) {
1762 treesize = 2 * treesize;
1763 GROW_PLIST( objTree1, treesize );
1764 GROW_PLIST( objTree2, treesize );
1765 SET_LEN_PLIST( objTree1, treesize );
1766 SET_LEN_PLIST( objTree2, treesize );
1767 ptTree1 = BASE_PTR_PLIST(objTree1) - 1;
1768 ptTree2 = BASE_PTR_PLIST(objTree2) - 1;
1769 CHANGED_BAG(objTree);
1770 }
1771 ptTree1[numgens] = INTOBJ_INT( t1 );
1772 ptTree2[numgens] = INTOBJ_INT( t2 );
1773 SET_ELM_PLIST( objTree, 3, INTOBJ_INT( numgens ) );
1774 }
1775 gen = ( u > - v ) ? -k : k;
1776 break;
1777 }
1778 }
1779
1780 return INTOBJ_INT( gen );
1781 }
1782
1783
1784 /****************************************************************************
1785 **
1786 *F FuncStandardizeTable2C(<self>,<table>,<table2>,<stan>) . standardize ACT
1787 **
1788 ** This is the kernel routine for standardizing an augmented coset table. It
1789 ** is called by the GAP routine 'StandardizeTable2'. The user should not
1790 ** call the kernel routine but only the GAP routine.
1791 **
1792 ** If <stan> = 1 the table is standardized using the (old) semilenlex
1793 ** standard.
1794 ** If not <stan> = 1 the table is standardized using the (new) lenlex
1795 ** standard (this is the default).
1796 */
FuncStandardizeTable2C(Obj self,Obj table,Obj table2,Obj stan)1797 static Obj FuncStandardizeTable2C(Obj self, Obj table, Obj table2, Obj stan)
1798 {
1799 Obj * ptTable; /* pointer to table */
1800 Obj * ptTabl2; /* pointer to coset factor table */
1801 UInt nrgen; /* number of rows of the table / 2 */
1802 Obj * g; /* one generator list from table */
1803 Obj * h; /* generator list */
1804 Obj * i; /* and inverse */
1805 Obj * h2; /* corresponding factor lists */
1806 Obj * i2; /* and inverse */
1807 UInt acos; /* actual coset */
1808 UInt lcos; /* last seen coset */
1809 UInt mcos; /* */
1810 UInt c1, c2; /* coset temporaries */
1811 Obj tmp; /* temporary for swap */
1812 UInt j, k, nloop; /* loop variables */
1813
1814 RequirePlainList(0, table);
1815 RequirePlainList(0, table2);
1816
1817 /* get the arguments */
1818 objTable = table;
1819 ptTable = BASE_PTR_PLIST(objTable) - 1;
1820 nrgen = LEN_PLIST(objTable) / 2;
1821 for ( j = 1; j <= nrgen*2; j++ ) {
1822 if ( ! IS_PLIST(ptTable[j]) ) {
1823 ErrorQuit(
1824 "<table>[%d] must be a plain list (not a %s)",
1825 (Int)j,
1826 (Int)TNAM_OBJ(ptTable[j]) );
1827 }
1828 }
1829 objTable2 = table2;
1830 ptTabl2 = BASE_PTR_PLIST(objTable2) - 1;
1831 if ( IS_INTOBJ(stan) && INT_INTOBJ(stan) == 1 ) {
1832 /* use semilenlex standard */
1833 nloop = nrgen;
1834 }
1835 else {
1836 /* use lenlex standard */
1837 nloop = nrgen*2;
1838 }
1839
1840 /* run over all cosets */
1841 acos = 1;
1842 lcos = 1;
1843 while ( acos <= lcos ) {
1844
1845 /* scan through all columns of acos */
1846 for ( j = 1; j <= nloop; j++ ) {
1847 k = ( nloop == nrgen ) ? 2*j - 1 : j;
1848 g = BASE_PTR_PLIST(ptTable[k]) - 1;
1849
1850 /* if we haven't seen this coset yet */
1851 if ( lcos+1 < INT_INTOBJ( g[acos] ) ) {
1852
1853 /* swap rows lcos and g[acos] */
1854 lcos = lcos + 1;
1855 mcos = INT_INTOBJ( g[acos] );
1856 for ( k = 1; k <= nrgen; k++ ) {
1857 h = BASE_PTR_PLIST(ptTable[2 * k - 1]) - 1;
1858 i = BASE_PTR_PLIST(ptTable[2 * k]) - 1;
1859 h2 = BASE_PTR_PLIST(ptTabl2[2 * k - 1]) - 1;
1860 i2 = BASE_PTR_PLIST(ptTabl2[2 * k]) - 1;
1861 c1 = INT_INTOBJ( h[lcos] );
1862 c2 = INT_INTOBJ( h[mcos] );
1863 if ( c1 != 0 ) i[c1] = INTOBJ_INT( mcos );
1864 if ( c2 != 0 ) i[c2] = INTOBJ_INT( lcos );
1865 tmp = h[lcos];
1866 h[lcos] = h[mcos];
1867 h[mcos] = tmp;
1868 tmp = h2[lcos];
1869 h2[lcos] = h2[mcos];
1870 h2[mcos] = tmp;
1871 if ( i != h ) {
1872 c1 = INT_INTOBJ( i[lcos] );
1873 c2 = INT_INTOBJ( i[mcos] );
1874 if ( c1 != 0 ) h[c1] = INTOBJ_INT( mcos );
1875 if ( c2 != 0 ) h[c2] = INTOBJ_INT( lcos );
1876 tmp = i[lcos];
1877 i[lcos] = i[mcos];
1878 i[mcos] = tmp;
1879 tmp = i2[lcos];
1880 i2[lcos] = i2[mcos];
1881 i2[mcos] = tmp;
1882 }
1883 }
1884
1885 }
1886
1887 /* if this is already the next only bump lcos */
1888 else if ( lcos < INT_INTOBJ( g[acos] ) ) {
1889 lcos = lcos + 1;
1890 }
1891
1892 }
1893
1894 acos = acos + 1;
1895 }
1896
1897 /* shrink the tables */
1898 for ( j = 1; j <= nrgen; j++ ) {
1899 SET_LEN_PLIST( ptTable[2*j-1], lcos );
1900 SET_LEN_PLIST( ptTable[2*j ], lcos );
1901 SET_LEN_PLIST( ptTabl2[2*j-1], lcos );
1902 SET_LEN_PLIST( ptTabl2[2*j ], lcos );
1903 }
1904
1905 /* return void */
1906 return 0;
1907 }
1908
1909
1910 /****************************************************************************
1911 **
1912 *F FuncAddAbelianRelator( <hdCall> ) . . . . . . internal 'AddAbelianRelator'
1913 **
1914 ** 'FuncAddAbelianRelator' implements 'AddAbelianRelator(<rels>,<number>)'
1915 */
FuncAddAbelianRelator(Obj self,Obj rels,Obj number)1916 static Obj FuncAddAbelianRelator(Obj self,
1917 Obj rels, /* relators list */
1918 Obj number)
1919 {
1920 Obj * ptRels; /* pointer to relators list */
1921 Obj * pt1; /* pointer to a relator */
1922 Obj * pt2; /* pointer to another relator */
1923 Obj tmp;
1924 Int numcols; /* list length of the rel vectors */
1925 Int numrows; /* number of relators */
1926 Int i, j; /* loop variables */
1927
1928 /* check the arguments */
1929 RequirePlainList(0, rels);
1930 ptRels = BASE_PTR_PLIST(rels) - 1;
1931 if ( !IS_INTOBJ(number) ) {
1932 ErrorQuit( "<number> must be a small integer (not a %s)",
1933 (Int)TNAM_OBJ(number), 0L );
1934 }
1935
1936 /* get the length of the given relators list */
1937 numrows = INT_INTOBJ(number);
1938 if ( numrows < 1 || LEN_PLIST(rels) < numrows ) {
1939 ErrorQuit( "inconsistent relator number", 0L, 0L );
1940 }
1941 tmp = ELM_PLIST( rels, numrows );
1942 if ( tmp == 0 ) {
1943 ErrorQuit( "inconsistent relator number", 0L, 0L );
1944 }
1945 pt2 = BASE_PTR_PLIST(tmp) - 1;
1946
1947 /* get the length of the exponent vectors (the number of generators) */
1948 numcols = LEN_PLIST(tmp);
1949
1950 /* remove the last relator if it has length zero */
1951 for ( i = 1; i <= numcols; i++ ) {
1952 if ( INT_INTOBJ(pt2[i]) ) {
1953 break;
1954 }
1955 }
1956 if ( i > numcols ) {
1957 return INTOBJ_INT(numrows-1);
1958 }
1959
1960 /* invert the relator if its first non-zero exponent is negative */
1961 if ( INT_INTOBJ(pt2[i]) < 0 ) {
1962 for ( j = i; j <= numcols; j++ ) {
1963 pt2[j] = INTOBJ_INT( -INT_INTOBJ( pt2[j] ) );
1964 }
1965 }
1966
1967 /* if the last relator occurs twice, remove one of its occurrences */
1968 for ( i = 1; i < numrows; i++ ) {
1969 pt1 = BASE_PTR_PLIST(ptRels[i]) - 1;
1970 for ( j = 1; j <= numcols; j++ ) {
1971 if ( pt1[j] != pt2[j] ) {
1972 break;
1973 }
1974 }
1975 if ( j > numcols ) {
1976 break;
1977 }
1978 }
1979 if ( i < numrows ) {
1980 for ( i = 1; i <= numcols; i++ ) {
1981 pt2[i] = INTOBJ_INT(0);
1982 }
1983 numrows = numrows - 1;
1984 }
1985
1986 return INTOBJ_INT( numrows );
1987 }
1988
1989 /* new type functions that use different data structures */
1990
1991 static UInt ret1, ret2;
1992
RelatorScan(Obj t,UInt di,Obj r)1993 static UInt RelatorScan(Obj t, UInt di, Obj r)
1994 {
1995 UInt m,i,p,a,j;
1996 UInt pa=0,pb=0;
1997 const UInt * rp;
1998 rp=(const UInt*)CONST_ADDR_OBJ(r);
1999 m=rp[1]; /* length is in position 1 */
2000 i=2;
2001 p=di;
2002 while ((p!=0) && (i<=(m+1))){
2003 a=rp[i];
2004 pa=p;
2005 p=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,a),p));
2006 if (p!=0) i++;
2007 }
2008
2009 if (i>(m+1)) {
2010 if (p==di)
2011 return 1;
2012 else
2013 return 0;
2014 }
2015
2016 /* backwards scan */
2017 j=m+1;
2018 p=di;
2019 while ((p!=0) && (j>=i)) {
2020 /* a=INT_INTOBJ(ELM_PLIST(invtab,INT_INTOBJ(ELM_PLIST(r,j))));*/
2021
2022 a=rp[j];
2023 if ((a%2)==1)
2024 a++;
2025 else
2026 a--;
2027 pb=p;
2028 p=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,a),p));
2029 if (p!=0) j--;
2030 }
2031
2032 if (j<i) {
2033 if (p==pa)
2034 return 1;
2035 else
2036 return 0;
2037 }
2038 else {
2039 if (j==i) {
2040 a=rp[i];
2041 if ((a%2)==0) {
2042 p=a-1;
2043 ret1=pb;
2044 ret2=p;
2045 }
2046 else {
2047 p=a+1;
2048 ret1=pa;
2049 ret2=a;
2050 }
2051 SET_ELM_PLIST(ELM_PLIST(t,a),pa,INTOBJ_INT(pb));
2052 SET_ELM_PLIST(ELM_PLIST(t,p),pb,INTOBJ_INT(pa));
2053
2054 return 2;
2055 }
2056 else
2057 return 1;
2058 }
2059
2060 }
2061
2062 /* data object type for the mangled relators */
2063 static Obj TYPE_LOWINDEX_DATA;
2064
2065 /****************************************************************************
2066 **
2067 *F FuncLOWINDEX_COSET_SCAN( <t>,<r>,<s1>,<s2>)
2068 **
2069 */
FuncLOWINDEX_COSET_SCAN(Obj self,Obj t,Obj r,Obj s1,Obj s2)2070 static Obj FuncLOWINDEX_COSET_SCAN(Obj self,
2071 Obj t, /* table */
2072 Obj r, /* relators */
2073 Obj s1, /* stack */
2074 Obj s2) /* stack */
2075 {
2076 UInt ok,i,j,d,e,x,y,l,sd;
2077 Obj rx;
2078 UInt * s1a;
2079 UInt * s2a;
2080
2081 ok=1;
2082 j=1;
2083 /* we convert stack entries to c-integers to avoid conversion */
2084 sd=LEN_PLIST(s1);
2085 s1a=(UInt*)ADDR_OBJ(s1);
2086 s2a=(UInt*)ADDR_OBJ(s2);
2087 s1a[1]=INT_INTOBJ((Obj)s1a[1]);
2088 s2a[1]=INT_INTOBJ((Obj)s2a[1]);
2089 while ((ok==1) && (j>0)) {
2090 d=s1a[j];
2091 x=s2a[j];
2092 j--;
2093 rx=ELM_PLIST(r,x);
2094 l=LEN_PLIST(rx);
2095 i=1;
2096 while ((ok==1)&&(i<=l)) {
2097 ok=RelatorScan(t,d,ELM_PLIST(rx,i));
2098 if (ok==2) {
2099 j++;
2100 if (j>sd) {
2101 sd=2*sd;
2102 GROW_PLIST(s1,sd);
2103 SET_LEN_PLIST(s1,sd);
2104 CHANGED_BAG(s1);
2105 GROW_PLIST(s2,sd);
2106 SET_LEN_PLIST(s2,sd);
2107 CHANGED_BAG(s2);
2108 s1a=(UInt*)ADDR_OBJ(s1);
2109 s2a=(UInt*)ADDR_OBJ(s2);
2110 }
2111 s1a[j]=ret1;
2112 s2a[j]=ret2;
2113 ok=1;
2114 }
2115 i++;
2116 }
2117
2118 e=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,x),d));
2119 y=x+1;
2120 rx=ELM_PLIST(r,y);
2121 i=1;
2122 while ((ok==1)&&(i<=l)) {
2123 ok=RelatorScan(t,e,ELM_PLIST(rx,i));
2124 if (ok==2) {
2125 j++;
2126 if (j>sd) {
2127 sd=2*sd;
2128 GROW_PLIST(s1,sd);
2129 GROW_PLIST(s2,sd);
2130 s1a=(UInt*)ADDR_OBJ(s1);
2131 s2a=(UInt*)ADDR_OBJ(s2);
2132 }
2133 s1a[j]=ret1;
2134 s2a[j]=ret2;
2135 ok=1;
2136 }
2137 i++;
2138 }
2139 }
2140 /* clean up the mess we made */
2141 for (i=1;i<=sd;i++) {
2142 s1a[i]=(Int)INTOBJ_INT(0);
2143 s2a[i]=(Int)INTOBJ_INT(0);
2144 }
2145 if (ok==1)
2146 return True;
2147 else
2148 return False;
2149 }
2150
2151 /****************************************************************************
2152 **
2153 *F FuncLOWINDEX_IS_FIRST( <t>,<n>,<mu>,<nu>)
2154 **
2155 */
FuncLOWINDEX_IS_FIRST(Obj self,Obj t,Obj nobj,Obj muo,Obj nuo)2156 static Obj FuncLOWINDEX_IS_FIRST(Obj self,
2157 Obj t, /* table */
2158 Obj nobj, /* relators */
2159 Obj muo, /* stack */
2160 Obj nuo) /* stack */
2161 {
2162 UInt l,ok,b,g,ga,de,a,n,mm;
2163 UInt * mu;
2164 UInt * nu;
2165
2166 mm=LEN_PLIST(t)-1;
2167 n=INT_INTOBJ(nobj);
2168 mu=(UInt*)ADDR_OBJ(muo);
2169 nu=(UInt*)ADDR_OBJ(nuo);
2170 for (b=1;b<=n;nu[b++]=0);
2171 l=0;
2172 for (a=2;a<=n;a++) {
2173 for (b=1;b<=l;nu[mu[b++]]=0);
2174 mu[1]=a;
2175 nu[a]=1;
2176 l=1;
2177 ok=1;
2178 b=1;
2179 while ((ok==1) && (b<=n)) {
2180 g=1;
2181 while ((ok==1)&&(g<=mm)) {
2182 ga=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,g),b));
2183 de=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,g),mu[b]));
2184 if ((ga==0)||(de==0))
2185 ok=0;
2186 else {
2187 if (nu[de]==0) {
2188 l++;
2189 mu[l]=de;
2190 nu[de]=l;
2191 }
2192 if (nu[de]<ga)
2193 return False;
2194 else {
2195 if (nu[de]>ga) {
2196 ok=0;
2197 }
2198 }
2199 }
2200 g=g+2;
2201 }
2202 b=b+1;
2203 }
2204 }
2205 return True;
2206 }
2207
2208 /****************************************************************************
2209 **
2210 *F FuncLOWINDEX_PREPARE_RELS( <rels> )
2211 **
2212 */
FuncLOWINDEX_PREPARE_RELS(Obj self,Obj r)2213 static Obj FuncLOWINDEX_PREPARE_RELS(Obj self, Obj r) /* rels */
2214 {
2215 UInt i,j,k,l;
2216 Obj ri, rel;
2217 UInt * rp;
2218
2219 for (i=1;i<=LEN_PLIST(r);i++) {
2220 ri=ELM_PLIST(r,i);
2221 for (j=1;j<=LEN_PLIST(ri);j++) {
2222 rel=ELM_PLIST(ri,j); /* single relator */
2223 l=LEN_PLIST(rel);
2224 rp=(UInt*)ADDR_OBJ(rel);
2225 for (k=1;k<=l;k++)
2226 rp[k]=INT_INTOBJ((Obj)rp[k]); /* convert relator entries to C-integers */
2227 /* change type */
2228 RetypeBag(rel,T_DATOBJ);
2229 SET_TYPE_DATOBJ(rel, TYPE_LOWINDEX_DATA);
2230 }
2231 }
2232 return (Obj) 0;
2233 }
2234
2235 /****************************************************************************
2236 **
2237 *F FuncTC_QUICK_SCAN( <c>,<o>,<alpha>,<w>)
2238 **
2239 */
FuncTC_QUICK_SCAN(Obj self,Obj c,Obj o,Obj a,Obj w,Obj result)2240 static Obj FuncTC_QUICK_SCAN(Obj self,
2241 Obj c, /* table */
2242 Obj o, /* offset */
2243 Obj a, /* alpha */
2244 Obj w, /* word */
2245 Obj result) /* result list */
2246 {
2247 Int f,b,ff,bb,r,i,j,alpha,offset;
2248
2249 alpha=INT_INTOBJ(a);
2250 offset=INT_INTOBJ(o);
2251
2252 f=alpha;i=1;
2253 r=LEN_PLIST(w);
2254
2255 /* # forward scan */
2256 /* while i<=r and c[w[i]+offset][f]<>0 do */
2257 while ((i<=r) &&
2258 ((ff=INT_INTOBJ(ELM_PLIST(ELM_PLIST(c,INT_INTOBJ(ELM_PLIST(w,i))+offset),f)))
2259 !=0) ) {
2260 /* f:=c[w[i]+offset][f]; Use extra variable so old f remains if
2261 * i-condition triggered */
2262 f=ff;
2263 i++;
2264 }
2265
2266 if (i>r) {
2267 if (f!=alpha) {
2268 SET_ELM_PLIST(result,1,INTOBJ_INT(i));
2269 SET_ELM_PLIST(result,2,INTOBJ_INT(f));
2270 return True;
2271 }
2272 return False;
2273 }
2274
2275 /* #backward scan */
2276 b=alpha; j=r;
2277 /* while j>=i and c[-w[j]+offset][b]<>0 do */
2278 while ((j>=i) &&
2279 ((bb=INT_INTOBJ(ELM_PLIST(ELM_PLIST(c,-INT_INTOBJ(ELM_PLIST(w,j))+offset),b)))
2280 !=0) ) {
2281
2282 /* b:=c[-w[j]+offset][b]; implicitly done*/
2283 b=bb;
2284 j--;
2285 }
2286 if (j<=i) {
2287 SET_ELM_PLIST(result,1,INTOBJ_INT(i));
2288 SET_ELM_PLIST(result,2,INTOBJ_INT(f));
2289 SET_ELM_PLIST(result,3,INTOBJ_INT(j));
2290 SET_ELM_PLIST(result,4,INTOBJ_INT(b));
2291 return True;
2292 }
2293 return False;
2294 }
2295
2296 /****************************************************************************
2297 **
2298 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
2299 */
2300
2301 /****************************************************************************
2302 **
2303 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
2304 */
2305 static StructGVarFunc GVarFuncs [] = {
2306
2307 GVAR_FUNC(ApplyRel, 2, "app, relator"),
2308 GVAR_FUNC(MakeConsequences, 1, "list"),
2309 GVAR_FUNC(MakeConsequencesPres, 1, "list"),
2310 GVAR_FUNC(StandardizeTableC, 2, "table, standard"),
2311 GVAR_FUNC(ApplyRel2, 3, "app, relators, nums"),
2312 GVAR_FUNC(CopyRel, 1, "relator"),
2313 GVAR_FUNC(MakeCanonical, 1, "relator"),
2314 GVAR_FUNC(TreeEntry, 2, "relator, word"),
2315 GVAR_FUNC(StandardizeTable2C, 3, "table, table, standard"),
2316 GVAR_FUNC(AddAbelianRelator, 2, "rels, number"),
2317 GVAR_FUNC(LOWINDEX_COSET_SCAN, 4, "table, relators, stack1,stack2"),
2318 GVAR_FUNC(LOWINDEX_IS_FIRST, 4, "table, n, mu, nu"),
2319 GVAR_FUNC(LOWINDEX_PREPARE_RELS, 1, "rels"),
2320 GVAR_FUNC(TC_QUICK_SCAN, 5, "table, offset, alpha, word, result"),
2321 { 0, 0, 0, 0, 0 }
2322
2323 };
2324
2325
2326 /****************************************************************************
2327 **
2328 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
2329 */
InitKernel(StructInitInfo * module)2330 static Int InitKernel (
2331 StructInitInfo * module )
2332 {
2333 /* init filters and functions */
2334 InitHdlrFuncsFromTable( GVarFuncs );
2335
2336 /* import kind (and unkind) functions */
2337 ImportGVarFromLibrary( "TYPE_LOWINDEX_DATA",&TYPE_LOWINDEX_DATA );
2338
2339 /* static variables */
2340 InitGlobalBag( &objRel , "src/costab.c:objRel" );
2341 InitGlobalBag( &objNums , "src/costab.c:objNums" );
2342 InitGlobalBag( &objFactor , "src/costab.c:objFactor" );
2343 InitGlobalBag( &objTable , "src/costab.c:objTable" );
2344 InitGlobalBag( &objTable2 , "src/costab.c:objTable2" );
2345 InitGlobalBag( &objNext , "src/costab.c:objNext" );
2346 InitGlobalBag( &objPrev , "src/costab.c:objPrev" );
2347 InitGlobalBag( &objTree , "src/costab.c:objTree" );
2348 InitGlobalBag( &objTree1 , "src/costab.c:objTree1" );
2349 InitGlobalBag( &objTree2 , "src/costab.c:objTree2" );
2350 InitGlobalBag( &objWordValue, "src/costab.c:objWordValue" );
2351 InitGlobalBag( &objExponent , "src/costab.c:objExponent" );
2352
2353 /* return success */
2354 return 0;
2355 }
2356
2357
2358 /****************************************************************************
2359 **
2360 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
2361 */
InitLibrary(StructInitInfo * module)2362 static Int InitLibrary (
2363 StructInitInfo * module )
2364 {
2365 /* init filters and functions */
2366 InitGVarFuncsFromTable( GVarFuncs );
2367
2368 /* return success */
2369 return 0;
2370 }
2371
2372
2373 /****************************************************************************
2374 **
2375 *F InitInfoCosetTable() . . . . . . . . . . . . . . table of init functions
2376 */
2377 static StructInitInfo module = {
2378 // init struct using C99 designated initializers; for a full list of
2379 // fields, please refer to the definition of StructInitInfo
2380 .type = MODULE_BUILTIN,
2381 .name = "costab",
2382 .initKernel = InitKernel,
2383 .initLibrary = InitLibrary,
2384 };
2385
InitInfoCosetTable(void)2386 StructInitInfo * InitInfoCosetTable ( void )
2387 {
2388 return &module;
2389 }
2390