Logo Search packages:      
Sourcecode: tcllib version File versions  Download package

walk.c

#include "tcl.h"
#include <graph.h>
#include <util.h>
#include <walk.h>

/* .................................................. */

static int walkdfspre  (Tcl_Interp* interp, GN* n, int dir,
                  Tcl_HashTable* v, int cc, Tcl_Obj** ev,
                  Tcl_Obj* action);
static int walkdfspost (Tcl_Interp* interp, GN* n, int dir,
                  Tcl_HashTable* v, int cc, Tcl_Obj** ev,
                  Tcl_Obj* action);
static int walkdfsboth (Tcl_Interp* interp, GN* n, int dir,
                  Tcl_HashTable* v, int cc, Tcl_Obj** ev,
                  Tcl_Obj* enter, Tcl_Obj* leave);
static int walkbfspre  (Tcl_Interp* interp, GN* n, int dir,
                  Tcl_HashTable* v, int cc, Tcl_Obj** ev,
                  Tcl_Obj* action);

static int walk_invoke (Tcl_Interp* interp, GN* n,
                  int cc, Tcl_Obj** ev, Tcl_Obj* action);

static int walk_neighbours (GN* n, Tcl_HashTable* v, int dir,
                      int* nc, GN*** nv);

/* .................................................. */

int
g_walkoptions (Tcl_Interp* interp,
             int objc, Tcl_Obj* const* objv,
             int* type, int* order, int* dir,
             int* cc, Tcl_Obj*** cv)
{
    int       xcc, xtype, xorder, xdir, i;
    Tcl_Obj** xcv;
    Tcl_Obj*  wtype  = NULL;
    Tcl_Obj*  worder = NULL;
    Tcl_Obj*  wdir   = NULL;
    Tcl_Obj*  wcmd   = NULL;

    static CONST char* wtypes [] = {
      "bfs", "dfs", NULL
    };
    static CONST char* worders [] = {
      "both", "pre", "post", NULL
    };
    static CONST char* wdirs [] = {
      "backward", "forward", NULL
    };

    for (i = 3; i < objc; ) {
      ASSERT_BOUNDS (i, objc);
      if (0 == strcmp ("-type", Tcl_GetString (objv [i]))) {
          if (objc == (i+1)) {
          wrongargs:
            Tcl_AppendResult (interp,
                          "value for \"", Tcl_GetString (objv[i]),
                          "\" missing, should be \"",
                          Tcl_GetString (objv [0]), " walk ",
                          W_USAGE, "\"", NULL);
            return TCL_ERROR;
          }

          ASSERT_BOUNDS (i+1, objc);
          wtype = objv [i+1];
          i += 2;

      } else if (0 == strcmp ("-order", Tcl_GetString (objv [i]))) {
          if (objc == (i+1)) goto wrongargs;

          ASSERT_BOUNDS (i+1, objc);
          worder = objv [i+1];
          i += 2;

      } else if (0 == strcmp ("-dir", Tcl_GetString (objv [i]))) {
          if (objc == (i+1)) goto wrongargs;

          ASSERT_BOUNDS (i+1, objc);
          wdir = objv [i+1];
          i += 2;

      } else if (0 == strcmp ("-command", Tcl_GetString (objv [i]))) {
          if (objc == (i+1)) goto wrongargs;

          ASSERT_BOUNDS (i+1, objc);
          wcmd = objv [i+1];
          i += 2;

      } else {
          Tcl_AppendResult (interp, "unknown option \"",
                        Tcl_GetString (objv [i]), "\": should be \"",
                        Tcl_GetString (objv [0]), " walk ",
                        W_USAGE, "\"", NULL);
          return TCL_ERROR;
          break;
      }
    }

    if (i < objc) {
      Tcl_WrongNumArgs (interp, 2, objv, W_USAGE);
      return TCL_ERROR;
    }

    if (!wcmd) {
    no_command:
      Tcl_AppendResult (interp,
                    "no command specified: should be \"",
                    Tcl_GetString (objv [0]), " walk ",
                    W_USAGE, "\"", NULL);
      return TCL_ERROR;
    } else if (Tcl_ListObjGetElements (interp, wcmd, &xcc, &xcv) != TCL_OK) {
      return TCL_ERROR;
    } else if (xcc == 0) {
      goto no_command;
    }

    xtype  = WG_DFS;
    xorder = WO_PRE;
    xdir   = WD_FORWARD;

    if (wtype &&
      (Tcl_GetIndexFromObj (interp, wtype, wtypes,
                        "search type", 0, &xtype) != TCL_OK)) {
      return TCL_ERROR;
    }

    if (worder &&
      (Tcl_GetIndexFromObj (interp, worder, worders,
                        "search order", 0, &xorder) != TCL_OK)) {
      return TCL_ERROR;
    }

    if (wdir &&
      (Tcl_GetIndexFromObj (interp, wdir, wdirs,
                        "search direction", 0, &xdir) != TCL_OK)) {
      return TCL_ERROR;
    }

    if (xtype == WG_BFS) {
      if (xorder == WO_BOTH) {
          Tcl_AppendResult (interp,
                        "unable to do a both-order breadth first walk",
                        NULL);
          return TCL_ERROR;
      }
      if (xorder == WO_POST) {
          Tcl_AppendResult (interp,
                        "unable to do a post-order breadth first walk",
                        NULL);
          return TCL_ERROR;
      }
    }

    *type  = xtype;
    *order = xorder;
    *dir   = xdir;
    *cc    = xcc;
    *cv    = xcv;

    return TCL_OK;
}

/* .................................................. */

int
g_walk (Tcl_Interp* interp, Tcl_Obj* go, GN* n,
      int type, int order, int dir,
      int cc, Tcl_Obj** cv)
{
    int       ec, res, i;
    Tcl_Obj** ev;
    Tcl_Obj*  la = NULL;
    Tcl_Obj*  lb = NULL;

    Tcl_HashTable v;

    /* Area to remember which nodes have been visited already */
    Tcl_InitHashTable (&v, TCL_ONE_WORD_KEYS);

    ec = cc + 3;
    ev = NALLOC (ec, Tcl_Obj*);

    for (i=0;i<cc;i++) {
      ev [i] = cv [i];
      Tcl_IncrRefCount (ev [i]);
    }

    /* cc+0 action
     * cc+1 graph  **
     * cc+2 node
     */

    ev [cc+1] = go;
    Tcl_IncrRefCount (ev [cc+1]);

    switch (type) {
    case WG_DFS:
      switch (order) {
      case WO_BOTH:
          la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
          lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb);

          res = walkdfsboth (interp, n, dir, &v, cc, ev, la, lb);

          Tcl_DecrRefCount (la);
          Tcl_DecrRefCount (lb);
          break;

      case WO_PRE:
          la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);

          res = walkdfspre (interp, n, dir, &v, cc, ev, la);

          Tcl_DecrRefCount (la);
          break;

      case WO_POST:
          la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la);

          res = walkdfspost (interp, n, dir, &v, cc, ev, la);

          Tcl_DecrRefCount (la);
          break;
      }
      break;

    case WG_BFS:
      switch (order) {
      case WO_BOTH:
      case WO_POST: Tcl_Panic ("impossible combination bfs/(both|post)"); break;
      case WO_PRE:
          la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);

          res = walkbfspre (interp, n, dir, &v, cc, ev, la);

          Tcl_DecrRefCount (la);
          break;
      }
      break;
    }

    for (i=0; i<cc; i++) {
      Tcl_DecrRefCount (ev [i]);
    }
    Tcl_DecrRefCount (ev [cc+1]);
    ckfree ((char*) ev);

    Tcl_DeleteHashTable (&v);

    /* Error and Return are passed unchanged. Everything else is ok */

    if (res == TCL_ERROR)  {return res;}
    if (res == TCL_RETURN) {return res;}
    return TCL_OK;
}


/* .................................................. */

int
walk_invoke (Tcl_Interp* interp, GN* n,
             int cc, Tcl_Obj** ev, Tcl_Obj* action)
{
    int res;

    /* cc+0 action **
     * cc+1 graph
     * cc+2 node   **
     */

    ev [cc+0] = action;        /* enter/leave */
    ev [cc+2] = n->base.name ; /* node */
    /* ec = cc+3 */

    Tcl_IncrRefCount (ev [cc+0]);
    Tcl_IncrRefCount (ev [cc+2]);

    res = Tcl_EvalObjv (interp, cc+3, ev, 0);

    Tcl_DecrRefCount (ev [cc+0]);
    Tcl_DecrRefCount (ev [cc+2]);

    return res;
}

/* .................................................. */

static int
walk_neighbours (GN* n, Tcl_HashTable* vn, int dir,
             int* nc, GN*** nv)
{
    GLA* neigh;
    GL*  il;
    int  c, i;
    GN** v;

    if (dir == WD_BACKWARD) {
      neigh = &n->in;
    } else {
      neigh = &n->out;
    }

    c = 0;
    v = NULL;

    if (neigh->n) {
      /* We make a copy of the neighbours. This emulates the behaviour of
       * the Tcl implementation, which will walk to a neighbour of this
       * node, even if the command moved it to a different node before it
       * was reached by the loop here. If the node the neighbours is moved
       * to was already visited nothing else will happen. Ortherwise the
       * neighbours will be visited multiple times.
       */

      c = neigh->n;
      v = NALLOC (c, GN*);

      if (dir == WD_BACKWARD) {
          for (i=0, il = neigh->first;
             il != NULL;
             il = il->next) {
            if (Tcl_FindHashEntry (vn, (char*) il->a->start->n)) continue;
            ASSERT_BOUNDS (i, c);
            v [i] = il->a->start->n;
            i++;
          }
      } else {
          for (i=0, il = neigh->first;
             il != NULL;
             il = il->next) {
            if (Tcl_FindHashEntry (vn, (char*) il->a->end->n)) continue;
            ASSERT_BOUNDS (i, c);
            v [i] = il->a->end->n;
            i++;
          }
      }

      c = i;
      if (!c) {
          ckfree ((char*) v);
          v = NULL;
      }
    }

    *nc = c;
    *nv = v;
}

/* .................................................. */

static int
walkdfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
            int cc, Tcl_Obj** ev, Tcl_Obj* action)
{
    /* ok   - next node
     * error      - abort walking
     * break      - abort walking
     * continue - next node
     * return     - abort walking
     */

    int  nc, res, new;
    GN** nv;

    /* Current node before neighbours, action is 'enter'. */

    res = walk_invoke (interp, n, cc, ev, action);

    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
      return res;
    }

    Tcl_CreateHashEntry (v, (char*) n, &new);
    walk_neighbours  (n, v, dir, &nc, &nv);

    if (nc) {
      int i;
      for (i = 0; i < nc; i++) {
          /* Skip nodes already visited deeper in the recursion */
          if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;

          res = walkdfspre (interp, nv [i], dir, v, cc, ev, action);

          /* continue cannot occur, were transformed into ok by the
           * neighbour.
           */

          if (res != TCL_OK) {
            ckfree ((char*) nv);
            return res;
          }
      }

      ckfree ((char*) nv);
    }

    return TCL_OK;
}

static int
walkdfspost (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
            int cc, Tcl_Obj** ev, Tcl_Obj* action)
{
    int  nc, res, new;
    GN** nv;

    /* Current node after neighbours, action is 'leave'. */

    Tcl_CreateHashEntry (v, (char*) n, &new);
    walk_neighbours  (n, v, dir, &nc, &nv);

    if (nc) {
      int i;
      for (i = 0; i < nc; i++) {
          /* Skip nodes already visited deeper in the recursion */
          if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;

          res = walkdfspost (interp, nv [i], dir, v, cc, ev, action);

          if ((res == TCL_ERROR) ||
            (res == TCL_BREAK) ||
            (res == TCL_RETURN)) {
            ckfree ((char*) nv);
            return res;
          }
      }

      ckfree ((char*) nv);
    }

    res = walk_invoke (interp, n, cc, ev, action);

    if ((res == TCL_ERROR) ||
      (res == TCL_BREAK) ||
      (res == TCL_RETURN)) {
      return res;
    }

    return TCL_OK;
}

static int
walkdfsboth (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
             int cc, Tcl_Obj** ev, Tcl_Obj* enter, Tcl_Obj* leave)
{
    /* ok   - next node
     * error      - abort walking
     * break      - abort walking
     * continue - next node
     * return     - abort walking
     */

    int  nc, res, new;
    GN** nv;

    /* Current node before and after neighbours, action is 'enter' & 'leave'. */

    res = walk_invoke (interp, n, cc, ev, enter);

    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
      return res;
    }

    Tcl_CreateHashEntry (v, (char*) n, &new);
    walk_neighbours  (n, v, dir, &nc, &nv);

    if (nc) {
      int i;
      for (i = 0; i < nc; i++) {
          /* Skip nodes already visited deeper in the recursion */
          if (Tcl_FindHashEntry (v, (char*) nv[i])) continue;

          res = walkdfsboth (interp, nv [i], dir, v, cc, ev, enter, leave);

          /* continue cannot occur, were transformed into ok by the
           * neighbour.
           */

          if (res != TCL_OK) {
            ckfree ((char*) nv);
            return res;
          }
      }

      ckfree ((char*) nv);
    }

    res = walk_invoke (interp, n, cc, ev, leave);

    if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
      return res;
    }

    return TCL_OK;
}

static int
walkbfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v,
            int cc, Tcl_Obj** ev, Tcl_Obj* action)
{
    /* ok   - next node
     * error      - abort walking
     * break      - abort walking
     * continue - next node
     * return     - abort walking
     */

    int  nc, res, new;
    GN** nv;
    NLQ  q;

    g_nlq_init   (&q);
    g_nlq_append (&q, n);

    while (1) {
      n = g_nlq_pop (&q);
      if (!n) break;

      /* Skip nodes already visited deeper in the recursion */
      if (Tcl_FindHashEntry (v, (char*) n)) continue;

      res = walk_invoke (interp, n, cc, ev, action);

      if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
          g_nlq_clear (&q);
          return res;
      }

      Tcl_CreateHashEntry (v, (char*) n, &new);
      walk_neighbours  (n, v, dir, &nc, &nv);

      if (nc) {
          int i;
          for (i = 0; i < nc; i++) {
            g_nlq_append (&q, nv [i]);
          }

          ckfree ((char*) nv);
      }
    }

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index