glue/glue_list_map.cpp

Go to the documentation of this file.

/******************************************************************************
* MODULE     : list_glue.cpp
* DESCRIPTION: Standard glue for lists
* COPYRIGHT  : (C) 2006  Joris van der Hoeven
*******************************************************************************
* This software falls under the GNU general public license and comes WITHOUT
* ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for more details.
* If you don't have this file, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************/

#include <basix/list.hpp>
#include <basix/list_sort.hpp>
#include <basix/tuple.hpp>
#include <basix/glue.hpp>
#include <basix/routine.hpp>
namespace mmx {

template<typename T> vector<T>
as_vector (const list<T>& l) {
  vector<T> a (fill<T> (N (l)));
  list<T> it= l;
  for (nat i= 0; !is_nil (it); it= cdr (it), i++)
    a[i]= car (it);
  return a;
}

static generic
rebuild (const list<generic>& l) {
  generic make_list= eval ("list");
  return as<routine> (make_list) -> apply (as_vector<generic> (l));
}

list<generic>
list_map_1 (const routine& fun, const list<generic>& l) {
  if (is_nil (l)) return l;
  generic r= fun->apply (car (l));
  return cons (r, list_map_1 (fun, cdr (l)));
}

list<generic>
list_map_2 (const routine& fun,
            const list<generic>& l1, const list<generic>& l2)
{
  ASSERT (is_nil (l1) == is_nil (l2), "lists of unequal lengths");
  if (is_nil (l1)) return l1;
  generic r= fun->apply (car (l1), car (l2));
  return cons (r, list_map_2 (fun, cdr (l1), cdr (l2)));
}

list<generic>
list_map_n (const routine& fun, const vector<list<generic> >& a) {
  nat i, n= N(a);
  vector<generic> cara= fill<generic> (n);
  if (is_nil (a[0])) {
    for (i=0; i<n; i++)
      ASSERT (is_nil (a[i]), "lists of unequal lengths");
    return a[0];
  }
  for (i=0; i<n; i++) {
    ASSERT (!is_nil (a[i]), "lists of unequal lengths");
    cara[i]= car (a[i]);
  }
  vector<list<generic> > cdra= fill<list<generic> > (n);
  for (i=0; i<n; i++) cdra[i]= cdr (a[i]);
  generic r= fun->apply (cara);
  return cons (r, list_map_n (fun, cdra));
}

generic
list_map (const generic& f, const tuple<list<generic> >& t) {
  routine fun= is<routine> (f)? as<routine> (f): default_routine (f);
  switch (N(t)) {
  case 0: ASSERT (N(t)>0, "wrong number of arguments");
  case 1: return rebuild (list_map_1 (fun, t[0]));
  case 2: return rebuild (list_map_2 (fun, t[0], t[1]));
  default:
    {
      const vector<generic> a= cdr (compound_to_vector (*t));
      nat i, n= N(a);
      vector<list<generic> > b= fill<list<generic> > (n);
      for (i=0; i<n; i++) b[i]= as<list<generic> > (a[i]);
      return rebuild (list_map_n (fun, b));
    }
  }
}

generic
list_foreach (const generic& f, const tuple<list<generic> >& t) {
  generic r= list_map (f, t);
  return as<generic> (tuple<generic> (gen (GEN_TUPLE)));
}

generic
list_append_several (const tuple<list<generic> >& t) {
  list<generic> r;
  for (int i=N(t)-1; i>=0; i--)
    r= t[i] * r;
  return rebuild (r);
}

generic
list_apply (const generic& f, const list<generic>& l2) {
  routine fun= is<routine> (f)? as<routine> (f): default_routine (f);
  list<generic> l= l2;
  nat i, n= N(l);
  vector<generic> a= fill<generic> (n);
  for (i=0; !is_nil (l); i++, l= read_cdr(l))
    a[i]= read_car (l);
  return fun->apply (a);
}

static routine current_comparison;

static int
generic_compare (const generic& x, const generic& y) {
  bool b= as<bool> (current_comparison->apply (x, y));
  return b? -1: 1;
}

list<generic>
list_sort (const list<generic>& l, const generic& f) {
  routine old_comparison= current_comparison;
  current_comparison= is<routine> (f)? as<routine> (f): default_routine (f);
  list<generic> r= sort (l, generic_compare);
  current_comparison= old_comparison;
  return r;
}

/*
list<generic>
list_filter_bis (const list<generic>& l, const routine& fun) {
  if (is_nil (l)) return l;
  generic cond= fun->apply (car (l));
  if (is<bool> (cond) && as<bool> (cond))
    return cons (car (l), list_filter_bis (cdr (l), fun));
  else return list_filter_bis (cdr (l), fun);
}

generic
list_filter (const list<generic>& l, const routine& fun) {
  return rebuild (list_filter_bis (l, fun));
}

generic
list_find_index (const list<generic>& l2, const routine& fun) {
  int i= 0;
  list<generic> l= l2;
  while (!is_nil (l)) {
    generic cond= fun->apply (car (l));
    if (is<bool> (cond) && as<bool> (cond)) return as<generic> (i);
    i++; l= cdr (l);
  }
  return as<generic> (false);
}
*/

void
glue_list_map () {
  static bool done = false;
  if (done) return;
  done = true;
  register_glue ("glue_list_map", &glue_list_map);
  call_glue ("glue_list_generic");
  define ("map", list_map);
  define ("foreach", list_foreach);
  define ("append", list_append_several);
  define ("apply", list_apply);
  define ("sort", list_sort);
  //define ("filter", list_filter);
  //define ("find_index", list_find_index);
}

} // namespace mmx

---