1/* struct::graph - critcl - layer 1 definitions
2 * (c) Graph functions
3 */
4
5#include <nacommon.h>
6#include <util.h>
7#include <node.h>
8
9/* .................................................. */
10
11typedef enum NA_MODE {
12    NA_ADJ, NA_EMBEDDING, NA_IN, NA_INNER,
13    NA_OUT, NA_NONE
14} NA_MODE;
15
16typedef struct NA {
17    NA_MODE   mode;
18    int       nc;
19    Tcl_Obj** nv;
20    Tcl_Obj*  key;
21    Tcl_Obj*  value;
22    Tcl_Obj*  filter;
23} NA;
24
25typedef struct NARES {
26    int       c;
27    Tcl_Obj** v;
28} NARES;
29
30/* .................................................. */
31
32static int  filter_setup  (NA* na, Tcl_Interp* interp, int oc, Tcl_Obj* const* ov, G* g);
33static int  filter_run    (NA* na, Tcl_Interp* interp, int nodes, GCC* gx, GN_GET_GC* gf,
34			   Tcl_Obj* go, G* g);
35static void filter_none   (Tcl_Interp* interp, GCC* gx, NARES* l);
36static void filter_kv     (Tcl_Interp* interp, GCC* gx, NARES* l,
37			   GN_GET_GC* gf, G*g, Tcl_Obj* k, Tcl_Obj* v);
38static void filter_k      (Tcl_Interp* interp, GCC* gx, NARES* l,
39			   GN_GET_GC* gf, G* g, Tcl_Obj* k);
40static int  filter_cmd    (Tcl_Interp* interp, GCC* gx, NARES* l,
41			   Tcl_Obj* cmd, Tcl_Obj* g);
42
43static void filter_mode_n (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
44static void filter_mode_n_adj           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
45static void filter_mode_n_emb           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
46static void filter_mode_n_in            (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
47static void filter_mode_n_inn           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
48static void filter_mode_n_out           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
49static void filter_mode_a (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
50static void filter_mode_a_adj           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
51static void filter_mode_a_emb           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
52static void filter_mode_a_in            (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
53static void filter_mode_a_inn           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
54static void filter_mode_a_out           (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g);
55
56/* .................................................. */
57
58int
59gc_filter (int nodes, Tcl_Interp* interp,
60	   int oc, Tcl_Obj* const* ov,
61	   GCC* gx, GN_GET_GC* gf, G* g)
62{
63    NA na;
64
65    if (filter_setup (&na, interp, oc, ov, g) != TCL_OK) {
66	return TCL_ERROR;
67    }
68
69    return filter_run (&na, interp, nodes, gx, gf, ov [0], g);
70}
71
72/* .................................................. */
73
74static int
75filter_setup (NA* na, Tcl_Interp* interp, int oc, Tcl_Obj* const* ov, G* g)
76{
77    /* Syntax: graph arcs                       | all arcs
78     *         graph arcs -adj       NODE...    | arcs start|end in node in list
79     *         graph arcs -embedding NODE...    | arcs start^end in node in list
80     *         graph arcs -filter    CMDPREFIX  | arcs for which CMD returns True.
81     *         graph arcs -in        NODE...    | arcs end in node in list
82     *         graph arcs -inner     NODE...    | arcs start&end in node in list
83     *         graph arcs -key       KEY        | arcs have attribute KEY
84     *         graph arcs -out       NODE...    | arcs start in node in list
85     *         graph arcs -value     VALUE      | arcs have KEY and VALUE
86     *	       [0]   [1]  [2]        [3]
87     */
88
89    static const char* restr [] = {
90	"-adj",   "-embedding", "-filter", "-in",
91	"-inner", "-key",       "-out",    "-value",
92	NULL
93    };
94    enum restr {
95	R_ADJ,   R_EMB, R_CMD, R_IN,
96	R_INNER, R_KEY, R_OUT, R_VAL
97    };
98    static const int mode [] = {
99	NA_ADJ,   NA_EMBEDDING, -1,     NA_IN,
100	NA_INNER, -1,           NA_OUT, -1
101    };
102
103    int             ac = oc;
104    Tcl_Obj* const* av = ov;
105    int             r;
106
107    na->mode   = NA_NONE;
108    na->nc     = 0;
109    na->nv     = NALLOC (oc, Tcl_Obj*);
110    na->key    = NULL;
111    na->value  = NULL;
112    na->filter = NULL;
113
114    oc -= 2; /* Skip 'graph arcs' */
115    ov += 2;
116
117    while (oc) {
118	if ('-' == Tcl_GetString (ov[0])[0]) {
119	    if (Tcl_GetIndexFromObj (interp, ov [0], restr,
120				     "restriction", 0, &r) != TCL_OK) {
121		goto abort;
122	    }
123	    switch (r) {
124	    case R_ADJ:
125	    case R_EMB:
126	    case R_IN:
127	    case R_INNER:
128	    case R_OUT:
129		if (na->mode != NA_NONE) {
130		    Tcl_SetObjResult (interp,
131		      Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"", -1));
132		    goto abort;
133		}
134		na->mode = mode [r];
135		break;
136	    case R_CMD:
137		if (oc < 2) goto wrongargs;
138		if (na->filter) {
139		    Tcl_SetObjResult (interp,
140		      Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-filter\"", -1));
141		    goto abort;
142		}
143		na->filter = ov [1];
144		oc --;
145		ov ++;
146		break;
147	    case R_KEY:
148		if (oc < 2) goto wrongargs;
149		if (na->key) {
150		    Tcl_SetObjResult (interp,
151		      Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-key\"", -1));
152		    goto abort;
153		}
154		na->key = ov [1];
155		oc --;
156		ov ++;
157		break;
158	    case R_VAL:
159		if (oc < 2) goto wrongargs;
160		if (na->value) {
161		    Tcl_SetObjResult (interp,
162		      Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-value\"", -1));
163		    goto abort;
164		}
165		na->value = ov [1];
166		oc --;
167		ov ++;
168		break;
169	    }
170	    oc --;
171	    ov ++;
172	} else {
173	    /* Save non-options for the list of nodes */
174	    ASSERT_BOUNDS (na->nc, ac);
175	    na->nv [na->nc] = ov[0];
176	    na->nc ++;
177	    oc --;
178	    ov ++;
179	}
180    }
181
182    if (na->value && !na->key) {
183	Tcl_SetObjResult (interp,
184	  Tcl_NewStringObj ("invalid restriction: use of \"-value\" without \"-key\"", -1));
185	goto abort;
186    }
187
188    if ((na->mode != NA_NONE) && !na->nc) {
189    wrongargs:
190	Tcl_WrongNumArgs (interp, 2, av,
191	  "?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?");
192	goto abort;
193    }
194
195    if (!na->nc) {
196	ckfree((char*) na->nv);
197	na->nv = NULL;
198    } else {
199	/* Check that the nodes exist, and
200	 * remove duplicates in the same pass
201	 */
202
203	int i, j, new;
204	Tcl_HashTable cn;
205	GN* n;
206
207	Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS);
208
209	j=0;
210	for (i=0; i < na->nc; i++) {
211	    ASSERT_BOUNDS(i, na->nc);
212	    n = gn_get_node (g, na->nv[i], interp, av[0]);
213	    if (!n) {
214		Tcl_DeleteHashTable(&cn);
215		goto abort;
216	    }
217	    if (Tcl_FindHashEntry (&cn, (char*) n)) continue;
218	    ASSERT_BOUNDS(j, na->nc);
219	    Tcl_CreateHashEntry (&cn, (char*) n, &new);
220	    if (j < i) { na->nv[j] = na->nv[i]; }
221	    j ++;
222	}
223
224	Tcl_DeleteHashTable(&cn);
225	na->nc = j;
226    }
227    return TCL_OK;
228
229 abort:
230    ckfree((char*) na->nv);
231    return TCL_ERROR;
232}
233
234/* .................................................. */
235
236static int
237filter_run (NA* na, Tcl_Interp* interp, int nodes, GCC* gx, GN_GET_GC* gf, Tcl_Obj* go, G* g)
238{
239    NARES l;
240
241    if (!gx->n) {
242	/* Nothing to filter, ignore the filters */
243
244	Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
245	return TCL_OK;
246    }
247
248    l.c = -1;
249    l.v = NALLOC (gx->n, Tcl_Obj*);
250
251    if (!na->key &&
252	!na->filter &&
253	(na->mode == NA_NONE)) {
254	filter_none (interp, gx, &l);
255    } else {
256	if (na->mode != NA_NONE) {
257	    if (nodes) {
258		filter_mode_n (na->mode, gx, &l, na->nc, na->nv, g);
259	    } else {
260		filter_mode_a (na->mode, gx, &l, na->nc, na->nv, g);
261	    }
262	}
263	if (na->key && na->value) {
264	    filter_kv (interp, gx, &l, gf, g, na->key, na->value);
265	} else if (na->key) {
266	    filter_k  (interp, gx, &l, gf, g, na->key);
267	}
268	if (na->filter) {
269	    if (filter_cmd (interp, gx, &l, na->filter, go) != TCL_OK) {
270		ckfree ((char*) l.v);
271		return TCL_ERROR;
272	    }
273	}
274    }
275
276    ASSERT(l.c > -1, "No filters applied");
277    Tcl_SetObjResult (interp, Tcl_NewListObj (l.c, l.v));
278    ckfree ((char*) l.v);
279    return TCL_OK;
280}
281
282/* .................................................. */
283
284static void
285filter_none (Tcl_Interp* interp, GCC* gx, NARES* l)
286{
287    int i;
288    GC* iter;
289
290    for (i = 0, iter = gx->first;
291	 iter != NULL;
292	 iter = iter->next, i++) {
293	ASSERT_BOUNDS (i, gx->n);
294	l->v [i] = iter->name;
295    }
296
297    ASSERT (i == gx->n, "Bad list of nodes");
298    l->c = i;
299}
300
301/* .................................................. */
302
303static void
304filter_mode_a (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
305{
306    /*
307     * NS = {node ...}, a set of nodes
308     *
309     * ARC/in  (NS) := { a | target(a) in NS }     "Arcs going into the node set"
310     * ARC/out (NS) := { a | source(a) in NS }     "Arcs coming from the node set"
311     * ARC/adj (NS) := ARC/in  (NS) + ARC/out (NS) "Arcs touching the node set"
312     * ARC/inn (NS) := ARC/in  (NS) * ARC/out (NS) "Arcs connecting nodes in the set"
313     * ARC/emb (NS) := ARC/adj (NS) - ARC/inn (NS) "Arcs touching, yet not connecting"
314     *               = ARC/in  (NS) / ARc/out (NS) 'symmetric difference'
315     *
316     * Note: None of the iterations has to be concerned about space. It is
317     * bounded by the number of arcs in the graph, and the list has enough
318     * slots.
319     */
320
321    switch (mode) {
322    case NA_ADJ:       filter_mode_a_adj (gx, l, nc, nv, g); break;
323    case NA_EMBEDDING: filter_mode_a_emb (gx, l, nc, nv, g); break;
324    case NA_IN:        filter_mode_a_in  (gx, l, nc, nv, g); break;
325    case NA_INNER:     filter_mode_a_inn (gx, l, nc, nv, g); break;
326    case NA_OUT:       filter_mode_a_out (gx, l, nc, nv, g); break;
327    }
328}
329
330/* .................................................. */
331
332static void
333filter_mode_a_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
334{
335    /* ARC/adj (NS) := ARC/in  (NS) + ARC/out (NS)
336     * "Arcs touching the node set"
337     */
338
339    /* Iterate over the nodes and collect all incoming and outgoing arcs. We
340     * use a hash table to prevent us from entering arcs twice. If we find
341     * that all arcs are in the result we stop immediately.
342     */
343
344    int           i, j, new;
345    GL*           il;
346    Tcl_HashTable ht;
347    GN*           n;
348
349    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
350
351    j = 0;
352    for (i=0; i < nc; i++) {
353	ASSERT_BOUNDS(i, nc);
354	n = gn_get_node (g, nv[i], NULL, NULL);
355	for (il = n->in.first; il != NULL; il = il->next) {
356	    ASSERT_BOUNDS(j, gx->n);
357	    Tcl_CreateHashEntry (&ht, (char*) il->a, &new);
358	    l->v[j] = il->a->base.name;
359	    j ++;
360	}
361    }
362
363    ASSERT(j <= gx->n, "Overrun");
364
365    if (j < gx->n) {
366	for (i=0; i < nc; i++) {
367	    ASSERT_BOUNDS(i, nc);
368	    n = gn_get_node (g, nv[i], NULL, NULL);
369	    for (il = n->out.first; il != NULL; il = il->next) {
370		/* Skip if already present - union */
371		if (Tcl_FindHashEntry (&ht, (char*) il->a)) continue;
372		ASSERT_BOUNDS(j, gx->n);
373		Tcl_CreateHashEntry (&ht, (char*) il->a, &new);
374		l->v[j] = il->a->base.name;
375		j ++;
376	    }
377	    if (j == gx->n) break;
378	}
379    }
380
381    ASSERT(j <= gx->n, "Overrun");
382    l->c = j;
383
384    Tcl_DeleteHashTable(&ht);
385}
386
387/* .................................................. */
388
389static void
390filter_mode_a_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
391{
392    /* ARC/emb (NS) := ARC/adj (NS) - ARC/inn (NS)
393     *               = ARC/in  (NS) / ARc/out (NS)
394     * "Arcs touching, yet not connecting"
395     */
396
397    /* For the embedding we have to iterate several times. First to collect
398     * the relevant arcs in hashtables, then a last time using the hashtables
399     * to weed out the inner arcs, i.e the intersection, and collect the
400     * others.
401     */
402
403    int           i, j, new;
404    GL*           il;
405    Tcl_HashTable hti;
406    Tcl_HashTable hto;
407    GN*           n;
408
409    Tcl_InitHashTable (&hti, TCL_ONE_WORD_KEYS);
410    Tcl_InitHashTable (&hto, TCL_ONE_WORD_KEYS);
411
412    for (i=0; i < nc; i++) {
413	ASSERT_BOUNDS(i, nc);
414	n = gn_get_node (g, nv[i], NULL, NULL);
415	for (il = n->in.first; il != NULL; il = il->next) {
416	    Tcl_CreateHashEntry (&hti, (char*) il->a, &new);
417	}
418    }
419    for (i=0; i < nc; i++) {
420	ASSERT_BOUNDS(i, nc);
421	n = gn_get_node (g, nv[i], NULL, NULL);
422	for (il = n->out.first; il != NULL; il = il->next) {
423	    Tcl_CreateHashEntry (&hto, (char*) il->a, &new);
424	}
425    }
426
427    j = 0;
428    for (i=0; i < nc; i++) {
429	ASSERT_BOUNDS(i, nc);
430	n = gn_get_node (g, nv[i], NULL, NULL);
431	for (il = n->in.first; il != NULL; il = il->next) {
432	    /* Incoming arcs, skip if also outgoing */
433	    if (Tcl_FindHashEntry (&hto, (char*) il->a)) continue;
434	    ASSERT_BOUNDS(j, gx->n);
435	    l->v[j] = il->a->base.name;
436	    j ++;
437	}
438    }
439    for (i=0; i < nc; i++) {
440	ASSERT_BOUNDS(i, nc);
441	n = gn_get_node (g, nv[i], NULL, NULL);
442	for (il = n->out.first; il != NULL; il = il->next) {
443	    /* Outgoing arcs, skip if also incoming */
444	    if (Tcl_FindHashEntry (&hti, (char*) il->a)) continue;
445	    ASSERT_BOUNDS(j, gx->n);
446	    l->v[j] = il->a->base.name;
447	    j ++;
448	}
449    }
450
451    ASSERT(j <= gx->n,"Overrun");
452    l->c = j;
453
454    Tcl_DeleteHashTable(&hti);
455    Tcl_DeleteHashTable(&hto);
456}
457
458/* .................................................. */
459
460static void
461filter_mode_a_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
462{
463    /* ARC/in  (NS) := { a | target(a) in NS }
464     * "Arcs going into the node set"
465     */
466
467    /* Iterate over the nodes and collect all incoming arcs.  */
468
469    int i, j;
470    GL* il;
471    GN* n;
472
473    j = 0;
474    for (i=0; i < nc; i++) {
475	ASSERT_BOUNDS(i, nc);
476	n = gn_get_node (g, nv[i], NULL, NULL);
477	for (il = n->in.first; il != NULL; il = il->next) {
478	    ASSERT_BOUNDS(j, gx->n);
479	    l->v[j] = il->a->base.name;
480	    j ++;
481	}
482    }
483
484    ASSERT(j <= gx->n,"Overrun");
485    l->c = j;
486}
487
488/* .................................................. */
489
490static void
491filter_mode_a_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
492{
493    /* ARC/inn (NS) := ARC/in  (NS) * ARC/out (NS)
494     * "Arcs connecting nodes in the set"
495     */
496
497    /* Iterate over the nodes and collect all incoming arcs first, in a
498     * hashtable. Then iterate a second time to find all outgoing arcs which
499     * are also incoming. We skip the second iteration if the first one found all
500     * arcs, because then the intersection will remove nothing.
501     */
502
503    int           i, j, new;
504    GL*           il;
505    Tcl_HashTable ht;
506    GN*           n;
507
508    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
509
510    for (i=0; i < nc; i++) {
511	ASSERT_BOUNDS(i, nc);
512	n = gn_get_node (g, nv[i], NULL, NULL);
513	for (il = n->in.first; il != NULL; il = il->next) {
514	    Tcl_CreateHashEntry (&ht, (char*) il->a, &new);
515	}
516    }
517
518    j = 0;
519    for (i=0; i < nc; i++) {
520	ASSERT_BOUNDS(i, nc);
521	n = gn_get_node (g, nv[i], NULL, NULL);
522	for (il = n->out.first; il != NULL; il = il->next) {
523	    /* Note the !. This is the intersect */
524	    if (!Tcl_FindHashEntry (&ht, (char*) il->a)) continue;
525	    ASSERT_BOUNDS(j, gx->n);
526	    Tcl_CreateHashEntry (&ht, (char*) il->a, &new);
527	    l->v[j] = il->a->base.name;
528	    j ++;
529	}
530    }
531
532    ASSERT(j <= gx->n,"Overrun");
533    l->c = j;
534
535    Tcl_DeleteHashTable(&ht);
536}
537
538/* .................................................. */
539
540static void
541filter_mode_a_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
542{
543    /* ARC/out (NS) := { a | source(a) in NS }
544     * "Arcs coming from the node set"
545     */
546
547    /* Iterate over the nodes and collect all outcoming arcs.  */
548
549    int i, j;
550    GL* il;
551    GN* n;
552
553    j = 0;
554    for (i=0; i < nc; i++) {
555	ASSERT_BOUNDS(i, nc);
556	n = gn_get_node (g, nv[i], NULL, NULL);
557	for (il = n->out.first; il != NULL; il = il->next) {
558	    ASSERT_BOUNDS(j, gx->n);
559	    l->v[j] = il->a->base.name;
560	    j ++;
561	}
562    }
563
564    ASSERT(j <= gx->n,"Overrun");
565    l->c = j;
566}
567
568/* .................................................. */
569
570static void
571filter_mode_n (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
572{
573    /*
574     * NODES/in  (NS) = { source(a) | a in ARC/in  (NS) }
575     * NODES/out (NS) = { target(a) | a in ARC/out (NS) }
576     * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS)
577     * NODES/inn (NS) = NODES/adj (NS) * NS
578     * NODES/emb (NS) = NODES/adj (NS) - NS
579     */
580
581    switch (mode) {
582    case NA_ADJ:       filter_mode_n_adj (gx, l, nc, nv, g); break;
583    case NA_EMBEDDING: filter_mode_n_emb (gx, l, nc, nv, g); break;
584    case NA_IN:        filter_mode_n_in  (gx, l, nc, nv, g); break;
585    case NA_INNER:     filter_mode_n_inn (gx, l, nc, nv, g); break;
586    case NA_OUT:       filter_mode_n_out (gx, l, nc, nv, g); break;
587    }
588}
589
590/* .................................................. */
591
592static void
593filter_mode_n_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
594{
595    /*
596     * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS)
597     *
598     * using:
599     *		NODES/in  (NS) = { source(a) | a in ARC/in  (NS) }
600     *		NODES/out (NS) = { target(a) | a in ARC/out (NS) }
601     */
602
603    /* Iterate over the nodes and collect all incoming and outgoing nodes. We
604     * use a hash table to prevent us from entering nodes twice. Should we
605     * find that all nodes are in the result during the iteration we stop
606     * immediately, it cannot get better.
607     */
608
609    int           i, j, new;
610    GL*           il;
611    Tcl_HashTable ht;
612    GN*           n;
613
614    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
615
616    j = 0;
617    for (i=0; i < nc; i++) {
618	ASSERT_BOUNDS(i, nc);
619	n = gn_get_node (g, nv[i], NULL, NULL);
620	/* foreach n in cn */
621
622	for (il = n->in.first; il != NULL; il = il->next) {
623	    /* foreach a in ARC/in (n) */
624	    /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */
625
626	    if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue;
627	    ASSERT_BOUNDS(j, gx->n);
628	    Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new);
629	    l->v[j] = il->a->start->n->base.name;
630	    j ++;
631	}
632	if (j == gx->n) break;
633	for (il = n->out.first; il != NULL; il = il->next) {
634	    /* foreach a in ARC/out (n) */
635	    /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */
636
637	    if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue;
638	    ASSERT_BOUNDS(j, gx->n);
639	    Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new);
640	    l->v[j] = il->a->end->n->base.name;
641	    j ++;
642	}
643	if (j == gx->n) break;
644    }
645
646    ASSERT(j <= gx->n, "Overrun");
647    l->c = j;
648
649    Tcl_DeleteHashTable(&ht);
650}
651
652/* .................................................. */
653
654static void
655filter_mode_n_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
656{
657    /*
658     * NODES/emb (NS) = NODES/adj (NS) - NS
659     *
660     * using:
661     * 		NODES/adj (NS) = NODES/in (NS) + NODES/out (NS)
662     *
663     * using:
664     *		NODES/in  (NS) = { source(a) | a in ARC/in  (NS) }
665     *		NODES/out (NS) = { target(a) | a in ARC/out (NS) }
666     */
667
668    /* Iterate over the nodes and collect all incoming and outgoing nodes. We
669     * use a hash table to prevent us from entering nodes twice. A second hash
670     * table is used to skip over the nodes in the set itself.
671     */
672
673    int           i, j, new;
674    GL*           il;
675    Tcl_HashTable ht;
676    Tcl_HashTable cn;
677    GN*           n;
678
679    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
680    Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS);
681
682    for (i=0; i < nc; i++) {
683	ASSERT_BOUNDS(i, nc);
684	n = gn_get_node (g, nv[i], NULL, NULL);
685	/* foreach n in cn */
686	Tcl_CreateHashEntry (&cn, (char*) n, &new);
687    }
688
689    j = 0;
690    for (i=0; i < nc; i++) {
691	ASSERT_BOUNDS(i, nc);
692	n = gn_get_node (g, nv[i], NULL, NULL);
693	/* foreach n in cn */
694
695	for (il = n->in.first; il != NULL; il = il->next) {
696	    /* foreach a in ARC/in (n) */
697	    /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */
698	    /* - NS */
699
700	    if (Tcl_FindHashEntry (&cn, (char*) il->a->start->n)) continue;
701	    if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue;
702	    ASSERT_BOUNDS(j, gx->n);
703	    Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new);
704	    l->v[j] = il->a->start->n->base.name;
705	    j ++;
706	}
707	if (j == gx->n) break;
708	for (il = n->out.first; il != NULL; il = il->next) {
709	    /* foreach a in ARC/out (n) */
710	    /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */
711	    /* - NS */
712
713	    if (Tcl_FindHashEntry (&cn, (char*) il->a->end->n)) continue;
714	    if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue;
715	    ASSERT_BOUNDS(j, gx->n);
716	    Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new);
717	    l->v[j] = il->a->end->n->base.name;
718	    j ++;
719	}
720	if (j == gx->n) break;
721    }
722
723    ASSERT(j <= gx->n, "Overrun");
724    l->c = j;
725
726    Tcl_DeleteHashTable(&ht);
727    Tcl_DeleteHashTable(&cn);
728}
729
730/* .................................................. */
731
732static void
733filter_mode_n_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
734{
735    /*
736     * NODES/in (NS) = { source(a) | a in ARC/in (NS) }
737     */
738
739    int           i, j, new;
740    GL*           il;
741    GN*           n;
742    Tcl_HashTable ht;
743
744    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
745
746    j = 0;
747    for (i=0; i < nc; i++) {
748	ASSERT_BOUNDS(i, nc);
749	n = gn_get_node (g, nv[i], NULL, NULL);
750	for (il = n->in.first; il != NULL; il = il->next) {
751	    /* il->a in INa (NS) => il->a->start in INn (NS),
752	     * modulo already recorded
753	     */
754	    if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue;
755	    ASSERT_BOUNDS(j, gx->n);
756	    Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new);
757	    l->v[j] = il->a->start->n->base.name;
758	    j ++;
759	}
760    }
761
762    ASSERT(j <= gx->n,"Overrun");
763    l->c = j;
764
765    Tcl_DeleteHashTable(&ht);
766}
767
768/* .................................................. */
769
770static void
771filter_mode_n_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
772{
773    /*
774     * NODES/inn (NS) = NODES/adj (NS) * NS
775     *
776     * using:
777     * 		NODES/adj (NS) = NODES/in (NS) + NODES/out (NS)
778     *
779     * using:
780     *		NODES/in  (NS) = { source(a) | a in ARC/in  (NS) }
781     *		NODES/out (NS) = { target(a) | a in ARC/out (NS) }
782     */
783
784    /* Iterate over the nodes and collect all incoming and outgoing nodes. We
785     * use a hash table to prevent us from entering nodes twice. A second hash
786     * table is used to skip over the nodes _not_ in the set itself.
787     */
788
789    int           i, j, new;
790    GL*           il;
791    Tcl_HashTable ht;
792    Tcl_HashTable cn;
793    GN*           n;
794
795    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
796    Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS);
797
798    for (i=0; i < nc; i++) {
799	ASSERT_BOUNDS(i, nc);
800	n = gn_get_node (g, nv[i], NULL, NULL);
801	/* foreach n in cn */
802	Tcl_CreateHashEntry (&cn, (char*) n, &new);
803    }
804
805    j = 0;
806    for (i=0; i < nc; i++) {
807	ASSERT_BOUNDS(i, nc);
808	n = gn_get_node (g, nv[i], NULL, NULL);
809	/* foreach n in cn */
810
811	for (il = n->in.first; il != NULL; il = il->next) {
812	    /* foreach a in ARC/in (n) */
813	    /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */
814	    /* * NS */
815
816	    if (!Tcl_FindHashEntry (&cn, (char*) il->a->start->n)) continue;
817	    if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue;
818	    ASSERT_BOUNDS(j, gx->n);
819	    Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new);
820	    l->v[j] = il->a->start->n->base.name;
821	    j ++;
822	}
823	if (j == gx->n) break;
824	for (il = n->out.first; il != NULL; il = il->next) {
825	    /* foreach a in ARC/out (n) */
826	    /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */
827	    /* * NS */
828
829	    if (!Tcl_FindHashEntry (&cn, (char*) il->a->end->n)) continue;
830	    if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue;
831	    ASSERT_BOUNDS(j, gx->n);
832	    Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new);
833	    l->v[j] = il->a->end->n->base.name;
834	    j ++;
835	}
836	if (j == gx->n) break;
837    }
838
839    ASSERT(j <= gx->n, "Overrun");
840    l->c = j;
841
842    Tcl_DeleteHashTable(&ht);
843    Tcl_DeleteHashTable(&cn);
844}
845
846/* .................................................. */
847
848static void
849filter_mode_n_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g)
850{
851    /*
852     * NODES/out (NS) = { target(a) | a in ARC/out (NS) }
853     */
854
855    int           i, j, new;
856    GL*           il;
857    GN*           n;
858    Tcl_HashTable ht;
859
860    Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS);
861
862    j = 0;
863    for (i=0; i < nc; i++) {
864	ASSERT_BOUNDS(i, nc);
865	n = gn_get_node (g, nv[i], NULL, NULL);
866	for (il = n->out.first; il != NULL; il = il->next) {
867	    /* il->a in OUTa (NS) => il->a->end in OUTn (NS),
868	     * modulo already recorded
869	     */
870	    if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue;
871	    ASSERT_BOUNDS(j, gx->n);
872	    Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new);
873	    l->v[j] = il->a->end->n->base.name;
874	    j ++;
875	}
876    }
877
878    ASSERT(j <= gx->n,"Overrun");
879    l->c = j;
880
881    Tcl_DeleteHashTable (&ht);
882}
883
884/* .................................................. */
885
886static void
887filter_kv (Tcl_Interp* interp, GCC* gx, NARES* l, GN_GET_GC* gf, G* g, Tcl_Obj* k, Tcl_Obj* v)
888{
889    /* 2 modes:
890     * (a) l->c == -1 => Fill with matching entities
891     * (b) l->c == 0  => Nothing to do.
892     * (c) otherwise  => Filter found entities
893     */
894
895    Tcl_HashEntry* he;
896    const char*    key;
897    const char*    value;
898    int            vlen;
899    const char*    cmp;
900    int            clen;
901
902    /* Skip the step if there is nothing which can be filtered.  */
903    if (l->c == 0) return;
904
905    key   = Tcl_GetString (k);
906    value = Tcl_GetStringFromObj (v, &vlen);
907
908    if (l->c > 0) {
909	/* Filter an existing set of nodes/arcs down to the set of nodes/arcs
910	 * passing the filter.
911	 */
912
913	int src, dst;
914	GC* c;
915
916	for (src = 0, dst = 0; src < l->c; src++) {
917	    c = gf (g, l->v [src], NULL, NULL);
918
919	    if (!c->attr) continue;
920	    if (!c->attr->numEntries) continue;
921	    he = Tcl_FindHashEntry (c->attr, key);
922	    if (!he) continue;
923	    cmp = Tcl_GetStringFromObj ((Tcl_Obj*) Tcl_GetHashValue(he), &clen);
924	    if ((vlen != clen) ||
925		(strcmp(value, cmp) != 0)) continue;
926
927	    ASSERT_BOUNDS (dst, l->c);
928	    ASSERT_BOUNDS (src, l->c);
929
930	    l->v [dst] = l->v [src];
931	    dst++;
932	}
933
934	ASSERT (dst <= l->c, "Overrun");
935	l->c = dst;
936
937    } else {
938	/* There is no set, iterate over nodes/arcs and fill the result with
939	 * all nodes/arcs passing the filter.
940	 */
941
942	int i;
943	GC* iter;
944
945	for (i = 0, iter = gx->first;
946	     iter != NULL;
947	     iter = iter->next) {
948	    ASSERT_BOUNDS (i, gx->n);
949
950	    if (!iter->attr) continue;
951	    if (!iter->attr->numEntries) continue;
952	    he = Tcl_FindHashEntry (iter->attr, key);
953	    if (!he) continue;
954	    cmp = Tcl_GetStringFromObj ((Tcl_Obj*) Tcl_GetHashValue(he), &clen);
955	    if ((vlen != clen) ||
956		(strcmp(value, cmp) != 0)) continue;
957
958	    ASSERT_BOUNDS (i, gx->n);
959	    l->v [i] = iter->name;
960	    i++;
961	}
962
963	ASSERT (i <= gx->n, "Overrun");
964	l->c = i;
965    }
966}
967
968/* .................................................. */
969
970static void
971filter_k (Tcl_Interp* interp, GCC* gx, NARES* l, GN_GET_GC* gf, G* g, Tcl_Obj* k)
972{
973    /* 2 modes:
974     * (a) l->c == -1 => Fill with matching entities
975     * (b) l->c == 0  => Nothing to do.
976     * (c) otherwise  => Filter found entities
977     */
978
979    Tcl_HashEntry* he;
980    const char*    key;
981
982    /* Skip the step if there is nothing which can be filtered.  */
983    if (l->c == 0) return;
984
985    key = Tcl_GetString (k);
986
987    if (l->c > 0) {
988	/* Filter an existing set of nodes/arcs down to the set of nodes/arcs
989	 * passing the filter.
990	 */
991
992	int src, dst;
993	GC* c;
994
995	for (src = 0, dst = 0; src < l->c; src++) {
996	    c = gf (g, l->v [src], NULL, NULL);
997
998	    if (!c->attr) continue;
999	    if (!c->attr->numEntries) continue;
1000	    he = Tcl_FindHashEntry (c->attr, key);
1001	    if (!he) continue;
1002
1003	    ASSERT_BOUNDS (dst, l->c);
1004	    ASSERT_BOUNDS (src, l->c);
1005
1006	    l->v [dst] = l->v [src];
1007	    dst++;
1008	}
1009
1010	ASSERT (dst <= l->c, "Overrun");
1011	l->c = dst;
1012
1013    } else {
1014	/* There is no set, iterate over nodes/arcs and fill the result with
1015	 * all nodes/arcs passing the filter.
1016	 */
1017
1018	int i;
1019	GC* iter;
1020
1021	for (i = 0, iter = gx->first;
1022	     iter != NULL;
1023	     iter = iter->next) {
1024	    ASSERT_BOUNDS (i, gx->n);
1025
1026	    if (!iter->attr) continue;
1027	    if (!iter->attr->numEntries) continue;
1028	    he = Tcl_FindHashEntry (iter->attr, key);
1029	    if (!he) continue;
1030
1031	    ASSERT_BOUNDS (i, gx->n);
1032	    l->v [i] = iter->name;
1033	    i++;
1034	}
1035
1036	ASSERT (i <= gx->n, "Overrun");
1037	l->c = i;
1038    }
1039}
1040
1041/* .................................................. */
1042
1043static int
1044filter_cmd (Tcl_Interp* interp, GCC* gx, NARES* l, Tcl_Obj* cmd, Tcl_Obj* g)
1045{
1046    /* 2 modes:
1047     * (a) l->c == -1 => Fill with matching entities
1048     * (b) l->c == 0  => Nothing to do.
1049     * (c) otherwise  => Filter found entities
1050     */
1051
1052    int       cmdc;
1053    Tcl_Obj** cmdv;
1054    int       code = TCL_ERROR;
1055    int	      ec;
1056    Tcl_Obj** ev;
1057    int       flag;
1058    int       res;
1059    int       i;
1060
1061    if (Tcl_ListObjGetElements (interp, cmd, &cmdc, &cmdv) != TCL_OK) {
1062	return TCL_ERROR;
1063    }
1064
1065    /* Skip the step if there is nothing which can be filtered.  */
1066    if (l->c == 0) return;
1067
1068    /* -------------------- */
1069    /* Set up the command vector for the callback. Two placeholders for graph
1070     * and node/arc arguments.
1071     */
1072
1073    ec = cmdc + 2;
1074    ev = NALLOC (ec, Tcl_Obj*);
1075
1076    for (i = 0; i < cmdc; i++) {
1077	ASSERT_BOUNDS (i, ec);
1078	ev [i] = cmdv [i];
1079	Tcl_IncrRefCount (ev [i]);
1080    }
1081
1082    ASSERT_BOUNDS (cmdc, ec);
1083    ev [cmdc] = g; /* Graph */
1084    Tcl_IncrRefCount (ev [cmdc]);
1085
1086    /* -------------------- */
1087
1088    if (l->c > 0) {
1089	/* Filter an existing set of nodes/arcs down to the set of nodes/arcs
1090	 * passing the filter.
1091	 */
1092
1093	int src, dst;
1094
1095	for (src = 0, dst = 0; src < l->c; src++) {
1096	    /* Fill the placeholders */
1097
1098	    ASSERT_BOUNDS (cmdc+1, ec);
1099	    ASSERT_BOUNDS (src, l->c);
1100	    ev [cmdc+1] = l->v [src]; /* Node/Arc */
1101
1102	    /* Run the callback */
1103	    Tcl_IncrRefCount (ev [cmdc+1]);
1104	    res = Tcl_EvalObjv (interp, ec, ev, 0);
1105	    Tcl_DecrRefCount (ev [cmdc+1]);
1106
1107	    /* Process the result */
1108	    if (res != TCL_OK) {
1109		goto abort;
1110	    }
1111	    if (Tcl_GetBooleanFromObj (interp,
1112				       Tcl_GetObjResult (interp),
1113				       &flag) != TCL_OK) {
1114		goto abort;
1115	    }
1116
1117	    /* Result is valid, use this to decide retain/write over */
1118	    if (!flag) continue;
1119
1120	    ASSERT_BOUNDS (dst, l->c);
1121	    ASSERT_BOUNDS (src, l->c);
1122
1123	    l->v [dst] = l->v [src];
1124	    dst++;
1125	}
1126
1127	ASSERT (dst <= l->c, "Overrun");
1128	l->c = dst;
1129
1130    } else {
1131	/* There is no set, iterate over nodes/arcs and fill the result with
1132	 * all nodes/arcs passing the filter.
1133	 */
1134
1135	int i;
1136	GC* iter;
1137
1138	for (i = 0, iter = gx->first;
1139	     iter != NULL;
1140	     iter = iter->next) {
1141	    ASSERT_BOUNDS (i, gx->n);
1142
1143	    /* Fill the placeholders */
1144
1145	    ASSERT_BOUNDS (cmdc+1, ec);
1146	    ev [cmdc+1] = iter->name; /* Node/Arc */
1147
1148	    /* Run the callback */
1149	    Tcl_IncrRefCount (ev [cmdc+1]);
1150	    res = Tcl_EvalObjv (interp, ec, ev, 0);
1151	    Tcl_DecrRefCount (ev [cmdc+1]);
1152
1153	    /* Process the result */
1154	    if (res != TCL_OK) {
1155		goto abort;
1156	    }
1157	    if (Tcl_GetBooleanFromObj (interp,
1158				       Tcl_GetObjResult (interp),
1159				       &flag) != TCL_OK) {
1160		goto abort;
1161	    }
1162
1163	    /* Result is valid, use this to decide retain/write over */
1164	    if (!flag) continue;
1165
1166	    ASSERT_BOUNDS (i, gx->n);
1167	    l->v [i] = iter->name;
1168	    i++;
1169	}
1170
1171	ASSERT (i <= gx->n, "Overrun");
1172	l->c = i;
1173    }
1174
1175    /* -------------------- */
1176    /* Cleanup state */
1177
1178    Tcl_ResetResult (interp);
1179    code = TCL_OK;
1180
1181 abort:
1182    /* We do not reset the interp result. It either contains the non-boolean
1183     * result, or the error message.
1184     */
1185
1186    for (i = 0; i < cmdc; i++) {
1187	ASSERT_BOUNDS (i, ec);
1188	Tcl_DecrRefCount (ev [i]);
1189    }
1190
1191    ASSERT_BOUNDS (cmdc, ec);
1192    Tcl_DecrRefCount (ev [cmdc]); /* Graph */
1193    ckfree ((char*) ev);
1194
1195    /* -------------------- */
1196    return code;
1197}
1198
1199/* .................................................. */
1200
1201/*
1202 * Local Variables:
1203 * mode: c
1204 * c-basic-offset: 4
1205 * fill-column: 78
1206 * End:
1207 */
1208