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