1
2#include "tcl.h"
3#include <graph.h>
4#include <util.h>
5#include <walk.h>
6
7/* .................................................. */
8
9static int walkdfspre  (Tcl_Interp* interp, GN* n, int dir,
10			Tcl_HashTable* v, int cc, Tcl_Obj** ev,
11			Tcl_Obj* action);
12static int walkdfspost (Tcl_Interp* interp, GN* n, int dir,
13			Tcl_HashTable* v, int cc, Tcl_Obj** ev,
14			Tcl_Obj* action);
15static int walkdfsboth (Tcl_Interp* interp, GN* n, int dir,
16			Tcl_HashTable* v, int cc, Tcl_Obj** ev,
17			Tcl_Obj* enter, Tcl_Obj* leave);
18static int walkbfspre  (Tcl_Interp* interp, GN* n, int dir,
19			Tcl_HashTable* v, int cc, Tcl_Obj** ev,
20			Tcl_Obj* action);
21
22static int walk_invoke (Tcl_Interp* interp, GN* n,
23			int cc, Tcl_Obj** ev, Tcl_Obj* action);
24
25static int walk_neighbours (GN* n, Tcl_HashTable* v, int dir,
26			    int* nc, GN*** nv);
27
28/* .................................................. */
29
30int
31g_walkoptions (Tcl_Interp* interp,
32	       int objc, Tcl_Obj* const* objv,
33	       int* type, int* order, int* dir,
34	       int* cc, Tcl_Obj*** cv)
35{
36    int       xcc, xtype, xorder, xdir, i;
37    Tcl_Obj** xcv;
38    Tcl_Obj*  wtype  = NULL;
39    Tcl_Obj*  worder = NULL;
40    Tcl_Obj*  wdir   = NULL;
41    Tcl_Obj*  wcmd   = NULL;
42
43    static CONST char* wtypes [] = {
44	"bfs", "dfs", NULL
45    };
46    static CONST char* worders [] = {
47	"both", "pre", "post", NULL
48    };
49    static CONST char* wdirs [] = {
50	"backward", "forward", NULL
51    };
52
53    for (i = 3; i < objc; ) {
54	ASSERT_BOUNDS (i, objc);
55	if (0 == strcmp ("-type", Tcl_GetString (objv [i]))) {
56	    if (objc == (i+1)) {
57	    wrongargs:
58		Tcl_AppendResult (interp,
59				  "value for \"", Tcl_GetString (objv[i]),
60				  "\" missing, should be \"",
61				  Tcl_GetString (objv [0]), " walk ",
62				  W_USAGE, "\"", NULL);
63		return TCL_ERROR;
64	    }
65
66	    ASSERT_BOUNDS (i+1, objc);
67	    wtype = objv [i+1];
68	    i += 2;
69
70	} else if (0 == strcmp ("-order", Tcl_GetString (objv [i]))) {
71	    if (objc == (i+1)) goto wrongargs;
72
73	    ASSERT_BOUNDS (i+1, objc);
74	    worder = objv [i+1];
75	    i += 2;
76
77	} else if (0 == strcmp ("-dir", Tcl_GetString (objv [i]))) {
78	    if (objc == (i+1)) goto wrongargs;
79
80	    ASSERT_BOUNDS (i+1, objc);
81	    wdir = objv [i+1];
82	    i += 2;
83
84	} else if (0 == strcmp ("-command", Tcl_GetString (objv [i]))) {
85	    if (objc == (i+1)) goto wrongargs;
86
87	    ASSERT_BOUNDS (i+1, objc);
88	    wcmd = objv [i+1];
89	    i += 2;
90
91	} else {
92	    Tcl_AppendResult (interp, "unknown option \"",
93			      Tcl_GetString (objv [i]), "\": should be \"",
94			      Tcl_GetString (objv [0]), " walk ",
95			      W_USAGE, "\"", NULL);
96	    return TCL_ERROR;
97	    break;
98	}
99    }
100
101    if (i < objc) {
102	Tcl_WrongNumArgs (interp, 2, objv, W_USAGE);
103	return TCL_ERROR;
104    }
105
106    if (!wcmd) {
107    no_command:
108	Tcl_AppendResult (interp,
109			  "no command specified: should be \"",
110			  Tcl_GetString (objv [0]), " walk ",
111			  W_USAGE, "\"", NULL);
112	return TCL_ERROR;
113    } else if (Tcl_ListObjGetElements (interp, wcmd, &xcc, &xcv) != TCL_OK) {
114	return TCL_ERROR;
115    } else if (xcc == 0) {
116	goto no_command;
117    }
118
119    xtype  = WG_DFS;
120    xorder = WO_PRE;
121    xdir   = WD_FORWARD;
122
123    if (wtype &&
124	(Tcl_GetIndexFromObj (interp, wtype, wtypes,
125			      "search type", 0, &xtype) != TCL_OK)) {
126	return TCL_ERROR;
127    }
128
129    if (worder &&
130	(Tcl_GetIndexFromObj (interp, worder, worders,
131			      "search order", 0, &xorder) != TCL_OK)) {
132	return TCL_ERROR;
133    }
134
135    if (wdir &&
136	(Tcl_GetIndexFromObj (interp, wdir, wdirs,
137			      "search direction", 0, &xdir) != TCL_OK)) {
138	return TCL_ERROR;
139    }
140
141    if (xtype == WG_BFS) {
142	if (xorder == WO_BOTH) {
143	    Tcl_AppendResult (interp,
144			      "unable to do a both-order breadth first walk",
145			      NULL);
146	    return TCL_ERROR;
147	}
148	if (xorder == WO_POST) {
149	    Tcl_AppendResult (interp,
150			      "unable to do a post-order breadth first walk",
151			      NULL);
152	    return TCL_ERROR;
153	}
154    }
155
156    *type  = xtype;
157    *order = xorder;
158    *dir   = xdir;
159    *cc    = xcc;
160    *cv    = xcv;
161
162    return TCL_OK;
163}
164
165/* .................................................. */
166
167int
168g_walk (Tcl_Interp* interp, Tcl_Obj* go, GN* n,
169	int type, int order, int dir,
170	int cc, Tcl_Obj** cv)
171{
172    int       ec, res, i;
173    Tcl_Obj** ev;
174    Tcl_Obj*  la = NULL;
175    Tcl_Obj*  lb = NULL;
176
177    Tcl_HashTable v;
178
179    /* Area to remember which nodes have been visited already */
180    Tcl_InitHashTable (&v, TCL_ONE_WORD_KEYS);
181
182    ec = cc + 3;
183    ev = NALLOC (ec, Tcl_Obj*);
184
185    for (i=0;i<cc;i++) {
186	ev [i] = cv [i];
187	Tcl_IncrRefCount (ev [i]);
188    }
189
190    /* cc+0 action
191     * cc+1 graph  **
192     * cc+2 node
193     */
194
195    ev [cc+1] = go;
196    Tcl_IncrRefCount (ev [cc+1]);
197
198    switch (type) {
199    case WG_DFS:
200	switch (order) {
201	case WO_BOTH:
202	    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
203	    lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb);
204
205	    res = walkdfsboth (interp, n, dir, &v, cc, ev, la, lb);
206
207	    Tcl_DecrRefCount (la);
208	    Tcl_DecrRefCount (lb);
209	    break;
210
211	case WO_PRE:
212	    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
213
214	    res = walkdfspre (interp, n, dir, &v, cc, ev, la);
215
216	    Tcl_DecrRefCount (la);
217	    break;
218
219	case WO_POST:
220	    la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la);
221
222	    res = walkdfspost (interp, n, dir, &v, cc, ev, la);
223
224	    Tcl_DecrRefCount (la);
225	    break;
226	}
227	break;
228
229    case WG_BFS:
230	switch (order) {
231	case WO_BOTH:
232	case WO_POST: Tcl_Panic ("impossible combination bfs/(both|post)"); break;
233	case WO_PRE:
234	    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
235
236	    res = walkbfspre (interp, n, dir, &v, cc, ev, la);
237
238	    Tcl_DecrRefCount (la);
239	    break;
240	}
241	break;
242    }
243
244    for (i=0; i<cc; i++) {
245	Tcl_DecrRefCount (ev [i]);
246    }
247    Tcl_DecrRefCount (ev [cc+1]);
248    ckfree ((char*) ev);
249
250    Tcl_DeleteHashTable (&v);
251
252    /* Error and Return are passed unchanged. Everything else is ok */
253
254    if (res == TCL_ERROR)  {return res;}
255    if (res == TCL_RETURN) {return res;}
256    return TCL_OK;
257}
258
259
260/* .................................................. */
261
262int
263walk_invoke (Tcl_Interp* interp, GN* n,
264	       int cc, Tcl_Obj** ev, Tcl_Obj* action)
265{
266    int res;
267
268    /* cc+0 action **
269     * cc+1 graph
270     * cc+2 node   **
271     */
272
273    ev [cc+0] = action;        /* enter/leave */
274    ev [cc+2] = n->base.name ; /* node */
275    /* ec = cc+3 */
276
277    Tcl_IncrRefCount (ev [cc+0]);
278    Tcl_IncrRefCount (ev [cc+2]);
279
280    res = Tcl_EvalObjv (interp, cc+3, ev, 0);
281
282    Tcl_DecrRefCount (ev [cc+0]);
283    Tcl_DecrRefCount (ev [cc+2]);
284
285    return res;
286}
287
288/* .................................................. */
289
290static int
291walk_neighbours (GN* n, Tcl_HashTable* vn, int dir,
292		 int* nc, GN*** nv)
293{
294    GLA* neigh;
295    GL*  il;
296    int  c, i;
297    GN** v;
298
299    if (dir == WD_BACKWARD) {
300	neigh = &n->in;
301    } else {
302	neigh = &n->out;
303    }
304
305    c = 0;
306    v = NULL;
307
308    if (neigh->n) {
309	/* We make a copy of the neighbours. This emulates the behaviour of
310	 * the Tcl implementation, which will walk to a neighbour of this
311	 * node, even if the command moved it to a different node before it
312	 * was reached by the loop here. If the node the neighbours is moved
313	 * to was already visited nothing else will happen. Ortherwise the
314	 * neighbours will be visited multiple times.
315	 */
316
317	c = neigh->n;
318	v = NALLOC (c, GN*);
319
320	if (dir == WD_BACKWARD) {
321	    for (i=0, il = neigh->first;
322		 il != NULL;
323		 il = il->next) {
324		if (Tcl_FindHashEntry (vn, (char*) il->a->start->n)) continue;
325		ASSERT_BOUNDS (i, c);
326		v [i] = il->a->start->n;
327		i++;
328	    }
329	} else {
330	    for (i=0, il = neigh->first;
331		 il != NULL;
332		 il = il->next) {
333		if (Tcl_FindHashEntry (vn, (char*) il->a->end->n)) continue;
334		ASSERT_BOUNDS (i, c);
335		v [i] = il->a->end->n;
336		i++;
337	    }
338	}
339
340	c = i;
341	if (!c) {
342	    ckfree ((char*) v);
343	    v = NULL;
344	}
345    }
346
347    *nc = c;
348    *nv = v;
349}
350
351/* .................................................. */
352
353static int
354walkdfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
355	      int cc, Tcl_Obj** ev, Tcl_Obj* action)
356{
357    /* ok	- next node
358     * error	- abort walking
359     * break	- abort walking
360     * continue - next node
361     * return	- abort walking
362     */
363
364    int  nc, res, new;
365    GN** nv;
366
367    /* Current node before neighbours, action is 'enter'. */
368
369    res = walk_invoke (interp, n, cc, ev, action);
370
371    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
372	return res;
373    }
374
375    Tcl_CreateHashEntry (v, (char*) n, &new);
376    walk_neighbours  (n, v, dir, &nc, &nv);
377
378    if (nc) {
379	int i;
380	for (i = 0; i < nc; i++) {
381	    /* Skip nodes already visited deeper in the recursion */
382	    if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;
383
384	    res = walkdfspre (interp, nv [i], dir, v, cc, ev, action);
385
386	    /* continue cannot occur, were transformed into ok by the
387	     * neighbour.
388	     */
389
390	    if (res != TCL_OK) {
391		ckfree ((char*) nv);
392		return res;
393	    }
394	}
395
396	ckfree ((char*) nv);
397    }
398
399    return TCL_OK;
400}
401
402static int
403walkdfspost (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
404	      int cc, Tcl_Obj** ev, Tcl_Obj* action)
405{
406    int  nc, res, new;
407    GN** nv;
408
409    /* Current node after neighbours, action is 'leave'. */
410
411    Tcl_CreateHashEntry (v, (char*) n, &new);
412    walk_neighbours  (n, v, dir, &nc, &nv);
413
414    if (nc) {
415	int i;
416	for (i = 0; i < nc; i++) {
417	    /* Skip nodes already visited deeper in the recursion */
418	    if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;
419
420	    res = walkdfspost (interp, nv [i], dir, v, cc, ev, action);
421
422	    if ((res == TCL_ERROR) ||
423		(res == TCL_BREAK) ||
424		(res == TCL_RETURN)) {
425		ckfree ((char*) nv);
426		return res;
427	    }
428	}
429
430	ckfree ((char*) nv);
431    }
432
433    res = walk_invoke (interp, n, cc, ev, action);
434
435    if ((res == TCL_ERROR) ||
436	(res == TCL_BREAK) ||
437	(res == TCL_RETURN)) {
438	return res;
439    }
440
441    return TCL_OK;
442}
443
444static int
445walkdfsboth (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
446	       int cc, Tcl_Obj** ev, Tcl_Obj* enter, Tcl_Obj* leave)
447{
448    /* ok	- next node
449     * error	- abort walking
450     * break	- abort walking
451     * continue - next node
452     * return	- abort walking
453     */
454
455    int  nc, res, new;
456    GN** nv;
457
458    /* Current node before and after neighbours, action is 'enter' & 'leave'. */
459
460    res = walk_invoke (interp, n, cc, ev, enter);
461
462    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
463	return res;
464    }
465
466    Tcl_CreateHashEntry (v, (char*) n, &new);
467    walk_neighbours  (n, v, dir, &nc, &nv);
468
469    if (nc) {
470	int i;
471	for (i = 0; i < nc; i++) {
472	    /* Skip nodes already visited deeper in the recursion */
473	    if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;
474
475	    res = walkdfsboth (interp, nv [i], dir, v, cc, ev, enter, leave);
476
477	    /* continue cannot occur, were transformed into ok by the
478	     * neighbour.
479	     */
480
481	    if (res != TCL_OK) {
482		ckfree ((char*) nv);
483		return res;
484	    }
485	}
486
487	ckfree ((char*) nv);
488    }
489
490    res = walk_invoke (interp, n, cc, ev, leave);
491
492    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
493	return res;
494    }
495
496    return TCL_OK;
497}
498
499static int
500walkbfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
501	      int cc, Tcl_Obj** ev, Tcl_Obj* action)
502{
503    /* ok	- next node
504     * error	- abort walking
505     * break	- abort walking
506     * continue - next node
507     * return	- abort walking
508     */
509
510    int  nc, res, new;
511    GN** nv;
512    NLQ  q;
513
514    g_nlq_init   (&q);
515    g_nlq_append (&q, n);
516
517    while (1) {
518	n = g_nlq_pop (&q);
519	if (!n) break;
520
521	/* Skip nodes already visited deeper in the recursion */
522	if (Tcl_FindHashEntry (v, (char*) n)) continue;
523
524	res = walk_invoke (interp, n, cc, ev, action);
525
526	if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
527	    g_nlq_clear (&q);
528	    return res;
529	}
530
531	Tcl_CreateHashEntry (v, (char*) n, &new);
532	walk_neighbours  (n, v, dir, &nc, &nv);
533
534	if (nc) {
535	    int i;
536	    for (i = 0; i < nc; i++) {
537		g_nlq_append (&q, nv [i]);
538	    }
539
540	    ckfree ((char*) nv);
541	}
542    }
543
544    return TCL_OK;
545}
546
547/*
548 * Local Variables:
549 * mode: c
550 * c-basic-offset: 4
551 * fill-column: 78
552 * End:
553 */
554