00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include <basix/list.hpp>
00014 #include <basix/list_sort.hpp>
00015 #include <basix/tuple.hpp>
00016 #include <basix/glue.hpp>
00017 #include <basix/routine.hpp>
00018 namespace mmx {
00019
00020 template<typename T> vector<T>
00021 as_vector (const list<T>& l) {
00022 vector<T> a (fill<T> (N (l)));
00023 list<T> it= l;
00024 for (nat i= 0; !is_nil (it); it= cdr (it), i++)
00025 a[i]= car (it);
00026 return a;
00027 }
00028
00029 static generic
00030 rebuild (const list<generic>& l) {
00031 generic make_list= eval ("list");
00032 return as<routine> (make_list) -> apply (as_vector<generic> (l));
00033 }
00034
00035 list<generic>
00036 list_map_1 (const routine& fun, const list<generic>& l) {
00037 if (is_nil (l)) return l;
00038 generic r= fun->apply (car (l));
00039 return cons (r, list_map_1 (fun, cdr (l)));
00040 }
00041
00042 list<generic>
00043 list_map_2 (const routine& fun,
00044 const list<generic>& l1, const list<generic>& l2)
00045 {
00046 ASSERT (is_nil (l1) == is_nil (l2), "lists of unequal lengths");
00047 if (is_nil (l1)) return l1;
00048 generic r= fun->apply (car (l1), car (l2));
00049 return cons (r, list_map_2 (fun, cdr (l1), cdr (l2)));
00050 }
00051
00052 list<generic>
00053 list_map_n (const routine& fun, const vector<list<generic> >& a) {
00054 nat i, n= N(a);
00055 vector<generic> cara= fill<generic> (n);
00056 if (is_nil (a[0])) {
00057 for (i=0; i<n; i++)
00058 ASSERT (is_nil (a[i]), "lists of unequal lengths");
00059 return a[0];
00060 }
00061 for (i=0; i<n; i++) {
00062 ASSERT (!is_nil (a[i]), "lists of unequal lengths");
00063 cara[i]= car (a[i]);
00064 }
00065 vector<list<generic> > cdra= fill<list<generic> > (n);
00066 for (i=0; i<n; i++) cdra[i]= cdr (a[i]);
00067 generic r= fun->apply (cara);
00068 return cons (r, list_map_n (fun, cdra));
00069 }
00070
00071 generic
00072 list_map (const generic& f, const tuple<list<generic> >& t) {
00073 routine fun= is<routine> (f)? as<routine> (f): default_routine (f);
00074 switch (N(t)) {
00075 case 0: ASSERT (N(t)>0, "wrong number of arguments");
00076 case 1: return rebuild (list_map_1 (fun, t[0]));
00077 case 2: return rebuild (list_map_2 (fun, t[0], t[1]));
00078 default:
00079 {
00080 const vector<generic> a= cdr (compound_to_vector (*t));
00081 nat i, n= N(a);
00082 vector<list<generic> > b= fill<list<generic> > (n);
00083 for (i=0; i<n; i++) b[i]= as<list<generic> > (a[i]);
00084 return rebuild (list_map_n (fun, b));
00085 }
00086 }
00087 }
00088
00089 generic
00090 list_foreach (const generic& f, const tuple<list<generic> >& t) {
00091 generic r= list_map (f, t);
00092 return as<generic> (tuple<generic> (gen (GEN_TUPLE)));
00093 }
00094
00095 generic
00096 list_append_several (const tuple<list<generic> >& t) {
00097 list<generic> r;
00098 for (int i=N(t)-1; i>=0; i--)
00099 r= t[i] * r;
00100 return rebuild (r);
00101 }
00102
00103 generic
00104 list_apply (const generic& f, const list<generic>& l2) {
00105 routine fun= is<routine> (f)? as<routine> (f): default_routine (f);
00106 list<generic> l= l2;
00107 nat i, n= N(l);
00108 vector<generic> a= fill<generic> (n);
00109 for (i=0; !is_nil (l); i++, l= read_cdr(l))
00110 a[i]= read_car (l);
00111 return fun->apply (a);
00112 }
00113
00114 static routine current_comparison;
00115
00116 static int
00117 generic_compare (const generic& x, const generic& y) {
00118 bool b= as<bool> (current_comparison->apply (x, y));
00119 return b? -1: 1;
00120 }
00121
00122 list<generic>
00123 list_sort (const list<generic>& l, const generic& f) {
00124 routine old_comparison= current_comparison;
00125 current_comparison= is<routine> (f)? as<routine> (f): default_routine (f);
00126 list<generic> r= sort (l, generic_compare);
00127 current_comparison= old_comparison;
00128 return r;
00129 }
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159 void
00160 glue_list_map () {
00161 static bool done = false;
00162 if (done) return;
00163 done = true;
00164 register_glue ("glue_list_map", &glue_list_map);
00165 call_glue ("glue_list_generic");
00166 define ("map", list_map);
00167 define ("foreach", list_foreach);
00168 define ("append", list_append_several);
00169 define ("apply", list_apply);
00170 define ("sort", list_sort);
00171
00172
00173 }
00174
00175 }