From ef9d1a2ddb3cd1b237b82c7dda092527a2e7bb00 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 11 Feb 2014 00:01:05 -0800 Subject: * Makefile (OBJS): New object file, combi.o. * dep.mk: Updated. * eval.c: Removed combination and permutation functions; they now reside in combi.c. (generate): Changed from static to external linkage. * eval.h (generate): Declared. * combi.c: New file. * combi.h: New file. * txr.vim: Regenerated. --- ChangeLog | 18 ++ Makefile | 2 +- combi.c | 581 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ combi.h | 30 ++++ dep.mk | 3 +- eval.c | 547 +--------------------------------------------------------- eval.h | 1 + txr.vim | 135 +++++++-------- 8 files changed, 703 insertions(+), 614 deletions(-) create mode 100644 combi.c create mode 100644 combi.h diff --git a/ChangeLog b/ChangeLog index 48d91ce2..b5524435 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +2014-02-10 Kaz Kylheku + + * Makefile (OBJS): New object file, combi.o. + + * dep.mk: Updated. + + * eval.c: Removed combination and permutation functions; they + now reside in combi.c. + (generate): Changed from static to external linkage. + + * eval.h (generate): Declared. + + * combi.c: New file. + + * combi.h: New file. + + * txr.vim: Regenerated. + 2014-02-10 Kaz Kylheku * eval.c (rcomb_gen_fun_common): Streamlined implementation. diff --git a/Makefile b/Makefile index 99d0b66f..9fd20178 100644 --- a/Makefile +++ b/Makefile @@ -39,7 +39,7 @@ endif # TXR objects OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o -OBJS += arith.o hash.o utf8.o filter.o eval.o rand.o +OBJS += arith.o hash.o utf8.o filter.o eval.o rand.o combi.o OBJS-$(debug_support) += debug.o OBJS-$(have_syslog) += syslog.o OBJS-$(have_posix_sigs) += signal.o diff --git a/combi.c b/combi.c new file mode 100644 index 00000000..2af2a051 --- /dev/null +++ b/combi.c @@ -0,0 +1,581 @@ +/* Copyright 2010-2014 + * Kaz Kylheku + * Vancouver, Canada + * All rights reserved. + * + * BSD License: + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. The name of the author may not be used to endorse or promote + * products derived from this software without specific prior + * written permission. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + */ + +#include +#include +#include +#include +#include "config.h" +#include "lib.h" +#include "signal.h" +#include "unwind.h" +#include "eval.h" +#include "combi.h" + +static val perm_while_fun(val state) +{ + val p = vecref(state, zero); + cnum k = c_num(vecref(state, one)); + val c = vecref(state, two); + cnum n = c_num(length(p)); + cnum i, j; + + for (i = k - 1, j = n - k + 1; i >= 0; i--, j++) { + cnum ci = c_num(c->v.vec[i]) + 1; + + if (ci >= j) { + if (i == 0) + return nil; + c->v.vec[i] = zero; + } else { + c->v.vec[i] = num_fast(ci); + break; + } + } + + return t; +} + +static cnum perm_index(cnum n, val b) +{ + cnum i, j; + + for (i = 0, j = 0; i < n; i++, j++) { + while (b->v.vec[j]) + j++; + } + + while (b->v.vec[j]) + j++; + + return j; +} + +static void perm_gen_fun_common(val state, val out, + void (*fill)(val out, cnum i, val v)) +{ + val p = vecref(state, zero); + val kk = vecref(state, one); + val c = vecref(state, two); + val nn = length(p); + val b = vector(nn, nil); + cnum k = c_num(kk); + cnum i; + + for (i = 0; i < k; i++) { + cnum ci = c_num(c->v.vec[i]); + cnum j = perm_index(ci, b); + fill(out, i, p->v.vec[j]); + b->v.vec[j] = t; + } +} + +static val perm_init_common(val p, val k_null) +{ + uses_or2; + val n = length(p); + val k = or2(k_null, n); + + if (gt(k, n)) { + return nil; + } else { + val state = vector(three, nil); + val c = vector(k, zero); + *vecref_l(state, zero) = p; + *vecref_l(state, one) = k; + *vecref_l(state, two) = c; + *vecref_l(c, negone) = negone; + return state; + } +} + +static void perm_vec_gen_fill(val out, cnum i, val v) +{ + out->v.vec[i] = v; +} + +static val perm_vec_gen_fun(val state) +{ + val kk = vecref(state, one); + val out = vector(kk, nil); + perm_gen_fun_common(state, out, perm_vec_gen_fill); + return out; +} + +static val perm_vec(val p, val k) +{ + k = default_arg(k, length_vec(p)); + + if (k == zero) { + return cons(vector(zero, nil), nil); + } else { + val state = perm_init_common(p, k); + if (!state) + return nil; + return generate(func_f0(state, perm_while_fun), + func_f0(state, perm_vec_gen_fun)); + } +} + +static void perm_list_gen_fill(val out, cnum i, val v) +{ + val tail = cdr(out); + val nc = cons(v, nil); + if (tail) + rplacd(tail, nc); + else + rplaca(out, nc); + rplacd(out, nc); +} + +static val perm_list_gen_fun(val state) +{ + val out = cons(nil, nil); + perm_gen_fun_common(state, out, perm_list_gen_fill); + return car(out); +} + +static val perm_list(val p, val k) +{ + if (k == zero || (!k && !p)) { + return cons(nil, nil); + } else { + val state = perm_init_common(vector_list(p), k); + if (!state) + return nil; + return generate(func_f0(state, perm_while_fun), + func_f0(state, perm_list_gen_fun)); + } +} + +static void perm_str_gen_fill(val out, cnum i, val v) +{ + out->st.str[i] = c_chr(v); +} + +static val perm_str_gen_fun(val state) +{ + val kk = vecref(state, one); + val out = mkustring(kk); + perm_gen_fun_common(state, out, perm_str_gen_fill); + out->st.str[c_num(kk)] = 0; + return out; +} + +static val perm_str(val p, val k) +{ + k = default_arg(k, length_str(p)); + + if (k == zero) { + return cons(string(L""), nil); + } else { + val state = perm_init_common(vector_list(list_str(p)), k); + if (!state) + return nil; + return generate(func_f0(state, perm_while_fun), + func_f0(state, perm_str_gen_fun)); + } +} + +val perm(val seq, val k) +{ + if (null_or_missing_p(k)) { + k = nil; + } else { + if (!integerp(k)) + type_mismatch(lit("perm: ~s is not an integer"), k, nao); + + if (lt(k, zero)) + uw_throwf(numeric_error_s, lit("perm: ~s is not a positive integer"), + k, nao); + } + + switch (type(seq)) { + case CONS: + case LCONS: + case NIL: + return perm_list(seq, k); + case VEC: + return perm_vec(seq, k); + case STR: + case LSTR: + case LIT: + return perm_str(seq, k); + default: + type_mismatch(lit("perm: ~s is not a sequence"), seq, nao); + } +} + +static val rperm_while_fun(val env) +{ + val vec = cdr(env); + return consp(vecref(vec, zero)); +} + +static val rperm_gen_fun(val env) +{ + cons_bind (list, vec, env); + list_collect_decl(out, ptail); + cnum i; + cnum len = c_num(length_vec(vec)); + + for (i = 0; i < len; i++) + list_collect(ptail, car(vec->v.vec[i])); + + for (i = len-1; i >= 0; i--) { + pop(&vec->v.vec[i]); + if (atom(vec->v.vec[i]) && i > 0) + vec->v.vec[i] = list; + else + break; + } + + return out; +} + +static val rperm_list(val list, val k) +{ + val vec = vector(k, list); + val env = cons(list, vec); + return generate(func_f0(env, rperm_while_fun), + func_f0(env, rperm_gen_fun)); +} + +static val rperm_vec_gen_fun(val env) +{ + val list = rperm_gen_fun(env); + return vector_list(list); +} + +static val rperm_vec(val ve, val k) +{ + val list = list_vector(ve); + val vec = vector(k, list); + val env = cons(list, vec); + return generate(func_f0(env, rperm_while_fun), + func_f0(env, rperm_vec_gen_fun)); +} + +static val rperm_str_gen_fun(val env) +{ + val list = rperm_gen_fun(env); + return cat_str(list, nil); +} + +static val rperm_str(val str, val k) +{ + val list = list_str(str); + val vec = vector(k, list); + val env = cons(list, vec); + return generate(func_f0(env, rperm_while_fun), + func_f0(env, rperm_str_gen_fun)); +} + +val rperm(val seq, val k) +{ + if (!integerp(k)) + type_mismatch(lit("rperm: ~s is not an integer"), k, nao); + + if (lt(k, zero)) + uw_throwf(numeric_error_s, lit("rperm: ~s is not a positive integer"), + k, nao); + + switch (type(seq)) { + case NIL: + if (zerop(k)) + return cons(nil, nil); + return nil; + case CONS: + case LCONS: + if (zerop(k)) + return cons(nil, nil); + return rperm_list(seq, k); + case VEC: + if (zerop(k)) + return cons(vector(zero, nil), nil); + return rperm_vec(seq, k); + case STR: + case LSTR: + case LIT: + if (zerop(k)) + return cons(string(L""), nil); + return rperm_str(seq, k); + default: + type_mismatch(lit("rperm: ~s is not a sequence"), seq, nao); + } +} + + +static val k_conses(val list, val k) +{ + val iter = list, i = k; + list_collect_decl (out, ptail); + + for (; consp(iter) && gt(i, zero); iter = cdr(iter), i = minus(i, one)) + ptail = list_collect(ptail, iter); + + return (i != zero) ? nil : out; +} + +static val comb_while_fun(val state) +{ + return car(state); +} + +static void comb_gen_fun_common(val state) +{ + val iter; + val prev = nil; + + for (iter = state; consp(iter); iter = cdr(iter)) { + val curr = first(iter); + val curr_rest = rest(curr); + if (curr_rest != prev && consp(curr_rest)) { + *car_l(iter) = curr_rest; + return; + } else if (rest(iter)) { + val next = second(iter); + val next_rest = rest(next); + val next_rest_rest = rest(next_rest); + prev = curr; + if (next_rest != curr && consp(next_rest_rest)) + prev = *car_l(iter) = next_rest_rest; + } + } + + *car_l(state) = nil; +} + +static val comb_list_gen_fun(val state) +{ + val out = nreverse(mapcar(car_f, state)); + comb_gen_fun_common(state); + return out; +} + +static val comb_list(val list, val k) +{ + val state = nreverse(k_conses(list, k)); + return state ? generate(func_f0(state, comb_while_fun), + func_f0(state, comb_list_gen_fun)) + : nil; +} + +static val comb_vec_gen_fun(val state) +{ + val nn = length_list(state); + cnum i, n = c_num(nn); + val iter, out = vector(nn, nil); + + for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) + out->v.vec[i] = car(car(iter)); + + comb_gen_fun_common(state); + return out; +} + +static val comb_vec(val vec, val k) +{ + val state = nreverse(k_conses(list_vector(vec), k)); + return generate(func_f0(state, comb_while_fun), + func_f0(state, comb_vec_gen_fun)); +} + +static val comb_str_gen_fun(val state) +{ + val nn = length_list(state); + cnum i, n = c_num(nn); + val iter, out = mkustring(nn); + + out->st.str[n] = 0; + + for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) + out->st.str[i] = c_chr(car(car(iter))); + + comb_gen_fun_common(state); + return out; +} + +static val comb_str(val str, val k) +{ + val state = nreverse(k_conses(list_str(str), k)); + return generate(func_f0(state, comb_while_fun), + func_f0(state, comb_str_gen_fun)); +} + +val comb(val seq, val k) +{ + if (!integerp(k)) + type_mismatch(lit("comb: ~s is not an integer"), k, nao); + + if (lt(k, zero)) + uw_throwf(numeric_error_s, lit("comb: ~s is not a positive integer"), + k, nao); + + switch (type(seq)) { + case CONS: + case LCONS: + case NIL: + if (k == zero) + return cons(nil, nil); + return comb_list(seq, k); + case VEC: + if (k == zero) + return cons(vector(zero, nil), nil); + if (gt(k, length(seq))) + return nil; + return comb_vec(seq, k); + case STR: + case LSTR: + case LIT: + if (k == zero) + return cons(string(L""), nil); + if (gt(k, length(seq))) + return nil; + return comb_str(seq, k); + default: + type_mismatch(lit("comb: ~s is not a sequence"), seq, nao); + } +} + +static val rcomb_while_fun(val state) +{ + return car(state); +} + +static void rcomb_gen_fun_common(val state) +{ + val iter; + val next; + + for (iter = state, next = cdr(state); + consp(iter); + iter = next, next = cdr(iter)) + { + val curr = first(iter); + val curr_rest = rest(curr); + + if (consp(curr_rest)) { + val jter; + for (jter = state; jter != next; jter = cdr(jter)) + *car_l(jter) = curr_rest; + return; + } else if (next) { + val next = second(iter); + if (curr != next) + *car_l(iter) = rest(next); + } + } + + *car_l(state) = nil; +} + +static val rcomb_list_gen_fun(val state) +{ + val out = nreverse(mapcar(car_f, state)); + rcomb_gen_fun_common(state); + return out; +} + +static val rcomb_list(val list, val k) +{ + val state = nreverse(list_vector(vector(k, list))); + return generate(func_f0(state, rcomb_while_fun), + func_f0(state, rcomb_list_gen_fun)); +} + +static val rcomb_vec_gen_fun(val state) +{ + val nn = length_list(state); + cnum i, n = c_num(nn); + val iter, out = vector(nn, nil); + + for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) + out->v.vec[i] = car(car(iter)); + + rcomb_gen_fun_common(state); + return out; +} + +static val rcomb_vec(val vec, val k) +{ + val state = nreverse(list_vector(vector(k, list_vector(vec)))); + return generate(func_f0(state, rcomb_while_fun), + func_f0(state, rcomb_vec_gen_fun)); +} + +static val rcomb_str_gen_fun(val state) +{ + val nn = length_list(state); + cnum i, n = c_num(nn); + val iter, out = mkustring(nn); + + out->st.str[n] = 0; + + for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) + out->st.str[i] = c_chr(car(car(iter))); + + rcomb_gen_fun_common(state); + return out; +} + +static val rcomb_str(val str, val k) +{ + val state = nreverse(list_vector(vector(k, list_str(str)))); + return generate(func_f0(state, rcomb_while_fun), + func_f0(state, rcomb_str_gen_fun)); +} + +val rcomb(val seq, val k) +{ + if (!integerp(k)) + type_mismatch(lit("rcomb: ~s is not an integer"), k, nao); + + if (lt(k, zero)) + uw_throwf(numeric_error_s, lit("rcomb: ~s is not a positive integer"), + k, nao); + + switch (type(seq)) { + case CONS: + case LCONS: + case NIL: + if (k == zero) + return cons(nil, nil); + return rcomb_list(seq, k); + case VEC: + if (k == zero) + return cons(vector(zero, nil), nil); + return rcomb_vec(seq, k); + case STR: + case LSTR: + case LIT: + if (k == zero) + return cons(string(L""), nil); + return rcomb_str(seq, k); + default: + type_mismatch(lit("rcomb: ~s is not a sequence"), seq, nao); + } +} diff --git a/combi.h b/combi.h new file mode 100644 index 00000000..51c41f94 --- /dev/null +++ b/combi.h @@ -0,0 +1,30 @@ +/* Copyright 2012-2014 + * Kaz Kylheku + * Vancouver, Canada + * All rights reserved. + * + * BSD License: + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. The name of the author may not be used to endorse or promote + * products derived from this software without specific prior + * written permission. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + */ + +val perm(val seq, val k); +val rperm(val seq, val k); +val comb(val seq, val k); +val rcomb(val seq, val k); diff --git a/dep.mk b/dep.mk index 27bc8311..7fe347af 100644 --- a/dep.mk +++ b/dep.mk @@ -11,8 +11,9 @@ ./hash.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./gc.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./stream.h $(top_srcdir)/./hash.h ./utf8.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./utf8.h ./filter.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./hash.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./match.h $(top_srcdir)/./filter.h $(top_srcdir)/./gc.h $(top_srcdir)/./stream.h -./eval.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./gc.h $(top_srcdir)/./arith.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./regex.h $(top_srcdir)/./stream.h $(top_srcdir)/./parser.h $(top_srcdir)/./hash.h $(top_srcdir)/./debug.h $(top_srcdir)/./match.h $(top_srcdir)/./rand.h $(top_srcdir)/./filter.h $(top_srcdir)/./txr.h $(top_srcdir)/./syslog.h $(top_srcdir)/./eval.h +./eval.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./gc.h $(top_srcdir)/./arith.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./regex.h $(top_srcdir)/./stream.h $(top_srcdir)/./parser.h $(top_srcdir)/./hash.h $(top_srcdir)/./debug.h $(top_srcdir)/./match.h $(top_srcdir)/./rand.h $(top_srcdir)/./filter.h $(top_srcdir)/./txr.h $(top_srcdir)/./syslog.h $(top_srcdir)/./combi.h $(top_srcdir)/./eval.h ./rand.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./gc.h $(top_srcdir)/./arith.h $(top_srcdir)/./rand.h +./combi.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./eval.h $(top_srcdir)/./combi.h mpi-1.8.6/mpi.o: config.h $(top_srcdir)/mpi-1.8.6/mpi.h $(top_srcdir)/mpi-1.8.6/logtab.h mpi-1.8.6/mplogic.o: config.h $(top_srcdir)/mpi-1.8.6/mplogic.h ./debug.o: config.h $(top_srcdir)/./lib.h $(top_srcdir)/./debug.h $(top_srcdir)/./gc.h $(top_srcdir)/./signal.h $(top_srcdir)/./unwind.h $(top_srcdir)/./stream.h $(top_srcdir)/./parser.h $(top_srcdir)/./txr.h diff --git a/eval.c b/eval.c index 6d1d425f..13ec8e0c 100644 --- a/eval.c +++ b/eval.c @@ -61,6 +61,7 @@ #ifdef HAVE_SYSLOG #include "syslog.h" #endif +#include "combi.h" #include "eval.h" typedef val (*opfun_t)(val, val); @@ -2060,7 +2061,7 @@ static val generate_func(val env, val lcons) return nil; } -static val generate(val while_pred, val gen_fun) +val generate(val while_pred, val gen_fun) { if (!funcall(while_pred)) { return nil; @@ -2125,550 +2126,6 @@ static val force(val promise) return rplacd(promise, funcall(cdr(promise))); } -static val rperm_while_fun(val env) -{ - val vec = cdr(env); - return consp(vecref(vec, zero)); -} - -static val rperm_gen_fun(val env) -{ - cons_bind (list, vec, env); - list_collect_decl(out, ptail); - cnum i; - cnum len = c_num(length_vec(vec)); - - for (i = 0; i < len; i++) - list_collect(ptail, car(vec->v.vec[i])); - - for (i = len-1; i >= 0; i--) { - pop(&vec->v.vec[i]); - if (atom(vec->v.vec[i]) && i > 0) - vec->v.vec[i] = list; - else - break; - } - - return out; -} - -static val rperm_list(val list, val k) -{ - val vec = vector(k, list); - val env = cons(list, vec); - return generate(func_f0(env, rperm_while_fun), - func_f0(env, rperm_gen_fun)); -} - -static val rperm_vec_gen_fun(val env) -{ - val list = rperm_gen_fun(env); - return vector_list(list); -} - -static val rperm_vec(val ve, val k) -{ - val list = list_vector(ve); - val vec = vector(k, list); - val env = cons(list, vec); - return generate(func_f0(env, rperm_while_fun), - func_f0(env, rperm_vec_gen_fun)); -} - -static val rperm_str_gen_fun(val env) -{ - val list = rperm_gen_fun(env); - return cat_str(list, nil); -} - -static val rperm_str(val str, val k) -{ - val list = list_str(str); - val vec = vector(k, list); - val env = cons(list, vec); - return generate(func_f0(env, rperm_while_fun), - func_f0(env, rperm_str_gen_fun)); -} - -static val rperm(val seq, val k) -{ - if (!integerp(k)) - type_mismatch(lit("rperm: ~s is not an integer"), k, nao); - - if (lt(k, zero)) - uw_throwf(numeric_error_s, lit("rperm: ~s is not a positive integer"), - k, nao); - - switch (type(seq)) { - case NIL: - if (zerop(k)) - return cons(nil, nil); - return nil; - case CONS: - case LCONS: - if (zerop(k)) - return cons(nil, nil); - return rperm_list(seq, k); - case VEC: - if (zerop(k)) - return cons(vector(zero, nil), nil); - return rperm_vec(seq, k); - case STR: - case LSTR: - case LIT: - if (zerop(k)) - return cons(string(L""), nil); - return rperm_str(seq, k); - default: - type_mismatch(lit("rperm: ~s is not a sequence"), seq, nao); - } -} - -static val perm_while_fun(val state) -{ - val p = vecref(state, zero); - cnum k = c_num(vecref(state, one)); - val c = vecref(state, two); - cnum n = c_num(length(p)); - cnum i, j; - - for (i = k - 1, j = n - k + 1; i >= 0; i--, j++) { - cnum ci = c_num(c->v.vec[i]) + 1; - - if (ci >= j) { - if (i == 0) - return nil; - c->v.vec[i] = zero; - } else { - c->v.vec[i] = num_fast(ci); - break; - } - } - - return t; -} - -static cnum perm_index(cnum n, val b) -{ - cnum i, j; - - for (i = 0, j = 0; i < n; i++, j++) { - while (b->v.vec[j]) - j++; - } - - while (b->v.vec[j]) - j++; - - return j; -} - -static void perm_gen_fun_common(val state, val out, - void (*fill)(val out, cnum i, val v)) -{ - val p = vecref(state, zero); - val kk = vecref(state, one); - val c = vecref(state, two); - val nn = length(p); - val b = vector(nn, nil); - cnum k = c_num(kk); - cnum i; - - for (i = 0; i < k; i++) { - cnum ci = c_num(c->v.vec[i]); - cnum j = perm_index(ci, b); - fill(out, i, p->v.vec[j]); - b->v.vec[j] = t; - } -} - -static val perm_init_common(val p, val k_null) -{ - uses_or2; - val n = length(p); - val k = or2(k_null, n); - - if (gt(k, n)) { - return nil; - } else { - val state = vector(three, nil); - val c = vector(k, zero); - *vecref_l(state, zero) = p; - *vecref_l(state, one) = k; - *vecref_l(state, two) = c; - *vecref_l(c, negone) = negone; - return state; - } -} - -static void perm_vec_gen_fill(val out, cnum i, val v) -{ - out->v.vec[i] = v; -} - -static val perm_vec_gen_fun(val state) -{ - val kk = vecref(state, one); - val out = vector(kk, nil); - perm_gen_fun_common(state, out, perm_vec_gen_fill); - return out; -} - -static val perm_vec(val p, val k) -{ - k = default_arg(k, length_vec(p)); - - if (k == zero) { - return cons(vector(zero, nil), nil); - } else { - val state = perm_init_common(p, k); - if (!state) - return nil; - return generate(func_f0(state, perm_while_fun), - func_f0(state, perm_vec_gen_fun)); - } -} - -static void perm_list_gen_fill(val out, cnum i, val v) -{ - val tail = cdr(out); - val nc = cons(v, nil); - if (tail) - rplacd(tail, nc); - else - rplaca(out, nc); - rplacd(out, nc); -} - -static val perm_list_gen_fun(val state) -{ - val out = cons(nil, nil); - perm_gen_fun_common(state, out, perm_list_gen_fill); - return car(out); -} - -static val perm_list(val p, val k) -{ - if (k == zero || (!k && !p)) { - return cons(nil, nil); - } else { - val state = perm_init_common(vector_list(p), k); - if (!state) - return nil; - return generate(func_f0(state, perm_while_fun), - func_f0(state, perm_list_gen_fun)); - } -} - -static void perm_str_gen_fill(val out, cnum i, val v) -{ - out->st.str[i] = c_chr(v); -} - -static val perm_str_gen_fun(val state) -{ - val kk = vecref(state, one); - val out = mkustring(kk); - perm_gen_fun_common(state, out, perm_str_gen_fill); - out->st.str[c_num(kk)] = 0; - return out; -} - -static val perm_str(val p, val k) -{ - k = default_arg(k, length_str(p)); - - if (k == zero) { - return cons(string(L""), nil); - } else { - val state = perm_init_common(vector_list(list_str(p)), k); - if (!state) - return nil; - return generate(func_f0(state, perm_while_fun), - func_f0(state, perm_str_gen_fun)); - } -} - -static val perm(val seq, val k) -{ - if (null_or_missing_p(k)) { - k = nil; - } else { - if (!integerp(k)) - type_mismatch(lit("perm: ~s is not an integer"), k, nao); - - if (lt(k, zero)) - uw_throwf(numeric_error_s, lit("perm: ~s is not a positive integer"), - k, nao); - } - - switch (type(seq)) { - case CONS: - case LCONS: - case NIL: - return perm_list(seq, k); - case VEC: - return perm_vec(seq, k); - case STR: - case LSTR: - case LIT: - return perm_str(seq, k); - default: - type_mismatch(lit("perm: ~s is not a sequence"), seq, nao); - } -} - -static val k_conses(val list, val k) -{ - val iter = list, i = k; - list_collect_decl (out, ptail); - - for (; consp(iter) && gt(i, zero); iter = cdr(iter), i = minus(i, one)) - ptail = list_collect(ptail, iter); - - return (i != zero) ? nil : out; -} - -static val comb_while_fun(val state) -{ - return car(state); -} - -static void comb_gen_fun_common(val state) -{ - val iter; - val prev = nil; - - for (iter = state; consp(iter); iter = cdr(iter)) { - val curr = first(iter); - val curr_rest = rest(curr); - if (curr_rest != prev && consp(curr_rest)) { - *car_l(iter) = curr_rest; - return; - } else if (rest(iter)) { - val next = second(iter); - val next_rest = rest(next); - val next_rest_rest = rest(next_rest); - prev = curr; - if (next_rest != curr && consp(next_rest_rest)) - prev = *car_l(iter) = next_rest_rest; - } - } - - *car_l(state) = nil; -} - -static val comb_list_gen_fun(val state) -{ - val out = nreverse(mapcar(car_f, state)); - comb_gen_fun_common(state); - return out; -} - -static val comb_list(val list, val k) -{ - val state = nreverse(k_conses(list, k)); - return state ? generate(func_f0(state, comb_while_fun), - func_f0(state, comb_list_gen_fun)) - : nil; -} - -static val comb_vec_gen_fun(val state) -{ - val nn = length_list(state); - cnum i, n = c_num(nn); - val iter, out = vector(nn, nil); - - for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) - out->v.vec[i] = car(car(iter)); - - comb_gen_fun_common(state); - return out; -} - -static val comb_vec(val vec, val k) -{ - val state = nreverse(k_conses(list_vector(vec), k)); - return generate(func_f0(state, comb_while_fun), - func_f0(state, comb_vec_gen_fun)); -} - -static val comb_str_gen_fun(val state) -{ - val nn = length_list(state); - cnum i, n = c_num(nn); - val iter, out = mkustring(nn); - - out->st.str[n] = 0; - - for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) - out->st.str[i] = c_chr(car(car(iter))); - - comb_gen_fun_common(state); - return out; -} - -static val comb_str(val str, val k) -{ - val state = nreverse(k_conses(list_str(str), k)); - return generate(func_f0(state, comb_while_fun), - func_f0(state, comb_str_gen_fun)); -} - -static val comb(val seq, val k) -{ - if (!integerp(k)) - type_mismatch(lit("comb: ~s is not an integer"), k, nao); - - if (lt(k, zero)) - uw_throwf(numeric_error_s, lit("comb: ~s is not a positive integer"), - k, nao); - - switch (type(seq)) { - case CONS: - case LCONS: - case NIL: - if (k == zero) - return cons(nil, nil); - return comb_list(seq, k); - case VEC: - if (k == zero) - return cons(vector(zero, nil), nil); - if (gt(k, length(seq))) - return nil; - return comb_vec(seq, k); - case STR: - case LSTR: - case LIT: - if (k == zero) - return cons(string(L""), nil); - if (gt(k, length(seq))) - return nil; - return comb_str(seq, k); - default: - type_mismatch(lit("comb: ~s is not a sequence"), seq, nao); - } -} - -static val rcomb_while_fun(val state) -{ - return car(state); -} - -static void rcomb_gen_fun_common(val state) -{ - val iter; - val next; - - for (iter = state, next = cdr(state); - consp(iter); - iter = next, next = cdr(iter)) - { - val curr = first(iter); - val curr_rest = rest(curr); - - if (consp(curr_rest)) { - val jter; - for (jter = state; jter != next; jter = cdr(jter)) - *car_l(jter) = curr_rest; - return; - } else if (next) { - val next = second(iter); - if (curr != next) - *car_l(iter) = rest(next); - } - } - - *car_l(state) = nil; -} - -static val rcomb_list_gen_fun(val state) -{ - val out = nreverse(mapcar(car_f, state)); - rcomb_gen_fun_common(state); - return out; -} - -static val rcomb_list(val list, val k) -{ - val state = nreverse(list_vector(vector(k, list))); - return generate(func_f0(state, rcomb_while_fun), - func_f0(state, rcomb_list_gen_fun)); -} - -static val rcomb_vec_gen_fun(val state) -{ - val nn = length_list(state); - cnum i, n = c_num(nn); - val iter, out = vector(nn, nil); - - for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) - out->v.vec[i] = car(car(iter)); - - rcomb_gen_fun_common(state); - return out; -} - -static val rcomb_vec(val vec, val k) -{ - val state = nreverse(list_vector(vector(k, list_vector(vec)))); - return generate(func_f0(state, rcomb_while_fun), - func_f0(state, rcomb_vec_gen_fun)); -} - -static val rcomb_str_gen_fun(val state) -{ - val nn = length_list(state); - cnum i, n = c_num(nn); - val iter, out = mkustring(nn); - - out->st.str[n] = 0; - - for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--) - out->st.str[i] = c_chr(car(car(iter))); - - rcomb_gen_fun_common(state); - return out; -} - -static val rcomb_str(val str, val k) -{ - val state = nreverse(list_vector(vector(k, list_str(str)))); - return generate(func_f0(state, rcomb_while_fun), - func_f0(state, rcomb_str_gen_fun)); -} - -static val rcomb(val seq, val k) -{ - if (!integerp(k)) - type_mismatch(lit("rcomb: ~s is not an integer"), k, nao); - - if (lt(k, zero)) - uw_throwf(numeric_error_s, lit("rcomb: ~s is not a positive integer"), - k, nao); - - switch (type(seq)) { - case CONS: - case LCONS: - case NIL: - if (k == zero) - return cons(nil, nil); - return rcomb_list(seq, k); - case VEC: - if (k == zero) - return cons(vector(zero, nil), nil); - return rcomb_vec(seq, k); - case STR: - case LSTR: - case LIT: - if (k == zero) - return cons(string(L""), nil); - return rcomb_str(seq, k); - default: - type_mismatch(lit("rcomb: ~s is not a sequence"), seq, nao); - } -} - static val errno_wrap(val newval) { val oldval = num(errno); diff --git a/eval.h b/eval.h index 5389320d..03bfea23 100644 --- a/eval.h +++ b/eval.h @@ -42,5 +42,6 @@ val expand(val form); val expand_forms(val forms); val bindable(val obj); val mapcarv(val fun, val list_of_lists); +val generate(val while_pred, val gen_fun); void eval_init(void); diff --git a/txr.vim b/txr.vim index 37eedda5..cd49e35d 100644 --- a/txr.vim +++ b/txr.vim @@ -52,73 +52,74 @@ syn keyword txl_keyword contained chr-isgraph chr-islower chr-isprint chr-ispunc syn keyword txl_keyword contained chr-isspace chr-isupper chr-isxdigit chr-num syn keyword txl_keyword contained chr-str chr-str-set chr-tolower chr-toupper syn keyword txl_keyword contained chrp close-stream closelog collect-each -syn keyword txl_keyword contained collect-each* compl-span-str cond cons -syn keyword txl_keyword contained conses conses* consp copy-alist -syn keyword txl_keyword contained copy-cons copy-hash copy-list copy-str -syn keyword txl_keyword contained copy-vec cos count-if countq -syn keyword txl_keyword contained countql countqual cum-norm-dist daemon -syn keyword txl_keyword contained dec defun defvar del -syn keyword txl_keyword contained delete-package do dohash downcase-str -syn keyword txl_keyword contained dwim each each* eq -syn keyword txl_keyword contained eql equal errno error -syn keyword txl_keyword contained eval evenp exit exp -syn keyword txl_keyword contained expand expt exptmod fboundp -syn keyword txl_keyword contained fifth find find-if find-package -syn keyword txl_keyword contained first fixnump flatten flatten* -syn keyword txl_keyword contained flip flo-int flo-str floatp -syn keyword txl_keyword contained floor flush-stream for for* -syn keyword txl_keyword contained force format fourth fun -syn keyword txl_keyword contained func-get-env func-get-form func-set-env functionp -syn keyword txl_keyword contained gcd generate gensym get-byte -syn keyword txl_keyword contained get-char get-hash-userdata get-line get-list-from-stream -syn keyword txl_keyword contained get-sig-handler get-string-from-stream gethash group-by -syn keyword txl_keyword contained hash hash-alist hash-construct hash-count -syn keyword txl_keyword contained hash-diff hash-eql hash-equal hash-isec -syn keyword txl_keyword contained hash-keys hash-pairs hash-uni hash-update -syn keyword txl_keyword contained hash-values hashp identity if -syn keyword txl_keyword contained iff iffi inc int-flo -syn keyword txl_keyword contained int-str integerp intern interp-fun-p -syn keyword txl_keyword contained isqrt keep-if keep-if* keywordp -syn keyword txl_keyword contained lambda lazy-str lazy-str-force lazy-str-force-upto -syn keyword txl_keyword contained lazy-str-get-trailing-list lazy-stream-cons lazy-stringp lcons-fun -syn keyword txl_keyword contained ldiff length length-list length-str -syn keyword txl_keyword contained length-str-< length-str-<= length-str-> length-str->= -syn keyword txl_keyword contained length-vec let let* lisp-parse -syn keyword txl_keyword contained list list* list-str list-vector -syn keyword txl_keyword contained listp log log-alert log-auth -syn keyword txl_keyword contained log-authpriv log-cons log-crit log-daemon -syn keyword txl_keyword contained log-debug log-emerg log-err log-info -syn keyword txl_keyword contained log-ndelay log-notice log-nowait log-odelay -syn keyword txl_keyword contained log-perror log-pid log-user log-warning -syn keyword txl_keyword contained logand logior lognot logtest -syn keyword txl_keyword contained logtrunc logxor make-catenated-stream make-hash -syn keyword txl_keyword contained make-lazy-cons make-package make-random-state make-similar-hash -syn keyword txl_keyword contained make-string-byte-input-stream make-string-input-stream make-string-output-stream make-strlist-output-stream -syn keyword txl_keyword contained make-sym make-time make-time-utc mapcar -syn keyword txl_keyword contained mapcar* maphash mappend mappend* -syn keyword txl_keyword contained mask match-fun match-regex match-regex-right -syn keyword txl_keyword contained match-str match-str-tree max memq -syn keyword txl_keyword contained memql memqual merge min -syn keyword txl_keyword contained mkstring mod multi-sort n-choose-k -syn keyword txl_keyword contained n-perm-k none not nreverse -syn keyword txl_keyword contained null num-chr num-str numberp -syn keyword txl_keyword contained oddp op open-command open-directory -syn keyword txl_keyword contained open-file open-pipe open-process open-tail -syn keyword txl_keyword contained openlog or orf packagep -syn keyword txl_keyword contained pop pprint print prog1 -syn keyword txl_keyword contained progn prop proper-listp push -syn keyword txl_keyword contained pushhash put-byte put-char put-line -syn keyword txl_keyword contained put-string qquote quasi quote -syn keyword txl_keyword contained rand random random-fixnum random-state-p -syn keyword txl_keyword contained range range* read real-time-stream-p -syn keyword txl_keyword contained reduce-left reduce-right ref refset -syn keyword txl_keyword contained regex-compile regex-parse regexp regsub -syn keyword txl_keyword contained rehome-sym remhash remove-if remove-if* -syn keyword txl_keyword contained remove-path remq remq* remql -syn keyword txl_keyword contained remql* remqual remqual* rename-path -syn keyword txl_keyword contained repeat replace replace-list replace-str -syn keyword txl_keyword contained replace-vec rest return return-from -syn keyword txl_keyword contained reverse rplaca rplacd s-ifblk +syn keyword txl_keyword contained collect-each* comb compl-span-str cond +syn keyword txl_keyword contained cons conses conses* consp +syn keyword txl_keyword contained copy-alist copy-cons copy-hash copy-list +syn keyword txl_keyword contained copy-str copy-vec cos count-if +syn keyword txl_keyword contained countq countql countqual cum-norm-dist +syn keyword txl_keyword contained daemon dec defun defvar +syn keyword txl_keyword contained del delete-package do dohash +syn keyword txl_keyword contained downcase-str dwim each each* +syn keyword txl_keyword contained eq eql equal errno +syn keyword txl_keyword contained error eval evenp exit +syn keyword txl_keyword contained exp expand expt exptmod +syn keyword txl_keyword contained fboundp fifth find find-if +syn keyword txl_keyword contained find-package first fixnump flatten +syn keyword txl_keyword contained flatten* flip flo-int flo-str +syn keyword txl_keyword contained floatp floor flush-stream for +syn keyword txl_keyword contained for* force format fourth +syn keyword txl_keyword contained fun func-get-env func-get-form func-set-env +syn keyword txl_keyword contained functionp gcd generate gensym +syn keyword txl_keyword contained get-byte get-char get-hash-userdata get-line +syn keyword txl_keyword contained get-list-from-stream get-sig-handler get-string-from-stream gethash +syn keyword txl_keyword contained group-by hash hash-alist hash-construct +syn keyword txl_keyword contained hash-count hash-diff hash-eql hash-equal +syn keyword txl_keyword contained hash-isec hash-keys hash-pairs hash-uni +syn keyword txl_keyword contained hash-update hash-values hashp identity +syn keyword txl_keyword contained if iff iffi inc +syn keyword txl_keyword contained int-flo int-str integerp intern +syn keyword txl_keyword contained interp-fun-p isqrt keep-if keep-if* +syn keyword txl_keyword contained keywordp lambda lazy-str lazy-str-force +syn keyword txl_keyword contained lazy-str-force-upto lazy-str-get-trailing-list lazy-stream-cons lazy-stringp +syn keyword txl_keyword contained lcons-fun ldiff length length-list +syn keyword txl_keyword contained length-str length-str-< length-str-<= length-str-> +syn keyword txl_keyword contained length-str->= length-vec let let* +syn keyword txl_keyword contained lisp-parse list list* list-str +syn keyword txl_keyword contained list-vector listp log log-alert +syn keyword txl_keyword contained log-auth log-authpriv log-cons log-crit +syn keyword txl_keyword contained log-daemon log-debug log-emerg log-err +syn keyword txl_keyword contained log-info log-ndelay log-notice log-nowait +syn keyword txl_keyword contained log-odelay log-perror log-pid log-user +syn keyword txl_keyword contained log-warning logand logior lognot +syn keyword txl_keyword contained logtest logtrunc logxor make-catenated-stream +syn keyword txl_keyword contained make-hash make-lazy-cons make-package make-random-state +syn keyword txl_keyword contained make-similar-hash make-string-byte-input-stream make-string-input-stream make-string-output-stream +syn keyword txl_keyword contained make-strlist-output-stream make-sym make-time make-time-utc +syn keyword txl_keyword contained mapcar mapcar* maphash mappend +syn keyword txl_keyword contained mappend* mask match-fun match-regex +syn keyword txl_keyword contained match-regex-right match-str match-str-tree max +syn keyword txl_keyword contained memq memql memqual merge +syn keyword txl_keyword contained min mkstring mod multi-sort +syn keyword txl_keyword contained n-choose-k n-perm-k none not +syn keyword txl_keyword contained nreverse null num-chr num-str +syn keyword txl_keyword contained numberp oddp op open-command +syn keyword txl_keyword contained open-directory open-file open-pipe open-process +syn keyword txl_keyword contained open-tail openlog or orf +syn keyword txl_keyword contained packagep perm pop pprint +syn keyword txl_keyword contained print prog1 progn prop +syn keyword txl_keyword contained proper-listp push pushhash put-byte +syn keyword txl_keyword contained put-char put-line put-string qquote +syn keyword txl_keyword contained quasi quote rand random +syn keyword txl_keyword contained random-fixnum random-state-p range range* +syn keyword txl_keyword contained rcomb read real-time-stream-p reduce-left +syn keyword txl_keyword contained reduce-right ref refset regex-compile +syn keyword txl_keyword contained regex-parse regexp regsub rehome-sym +syn keyword txl_keyword contained remhash remove-if remove-if* remove-path +syn keyword txl_keyword contained remq remq* remql remql* +syn keyword txl_keyword contained remqual remqual* rename-path repeat +syn keyword txl_keyword contained replace replace-list replace-str replace-vec +syn keyword txl_keyword contained rest return return-from reverse +syn keyword txl_keyword contained rperm rplaca rplacd s-ifblk syn keyword txl_keyword contained s-ifchr s-ifdir s-ififo s-iflnk syn keyword txl_keyword contained s-ifmt s-ifreg s-irgrp s-iroth syn keyword txl_keyword contained s-irusr s-irwxg s-irwxo s-irwxu -- cgit v1.2.3