/* read a problem from a file; use %g for integers to avoid int conflicts */
problem *get_problem (FILE *f, double tol)
{
cs *T, *A, *C ;
int sym, m, n, mn, nz1, nz2 ;
problem *Prob ;
Prob = cs_calloc (1, sizeof (problem)) ;
if (!Prob) return (NULL) ;
T = cs_load (f) ; /* load triplet matrix T from a file */
Prob->A = A = cs_compress (T) ; /* A = compressed-column form of T */
cs_spfree (T) ; /* clear T */
if (!cs_dupl (A)) return (free_problem (Prob)) ; /* sum up duplicates */
Prob->sym = sym = is_sym (A) ; /* determine if A is symmetric */
m = A->m ; n = A->n ;
mn = CS_MAX (m,n) ;
nz1 = A->p [n] ;
cs_dropzeros (A) ; /* drop zero entries */
nz2 = A->p [n] ;
if (tol > 0) cs_droptol (A, tol) ; /* drop tiny entries (just to test) */
Prob->C = C = sym ? make_sym (A) : A ; /* C = A + triu(A,1)', or C=A */
if (!C) return (free_problem (Prob)) ;
printf ("\n--- Matrix: %g-by-%g, nnz: %g (sym: %g: nnz %g), norm: %8.2e\n",
(double) m, (double) n, (double) (A->p [n]), (double) sym,
(double) (sym ? C->p [n] : 0), cs_norm (C)) ;
if (nz1 != nz2) printf ("zero entries dropped: %g\n", (double) (nz1 - nz2));
if (nz2 != A->p [n]) printf ("tiny entries dropped: %g\n",
(double) (nz2 - A->p [n])) ;
Prob->b = cs_malloc (mn, sizeof (double)) ;
Prob->x = cs_malloc (mn, sizeof (double)) ;
Prob->resid = cs_malloc (mn, sizeof (double)) ;
return ((!Prob->b || !Prob->x || !Prob->resid) ? free_problem (Prob) : Prob) ;
}
/**
* Copy the contents of a to an appropriate CsparseMatrix object and,
* optionally, free a or free both a and the pointers to its contents.
*
* @param a matrix to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
*
* @return SEXP containing a copy of a
*/
SEXP Matrix_cs_to_SEXP(cs *a, char *cl, int dofree)
{
SEXP ans;
char *valid[] = {"dgCMatrix", "dsCMatrix", "dtCMatrix", ""};
int *dims, ctype = Matrix_check_class(cl, valid), nz;
if (ctype < 0)
error("invalid class of object to Matrix_cs_to_SEXP");
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = a->m; dims[1] = a->n;
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, a->n + 1)),
a->p, a->n + 1);
nz = a->p[a->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nz)), a->i, nz);
Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nz)), a->x, nz);
if (ctype > 0) {
int uplo = is_sym(a);
if (!uplo) error("cs matrix not compatible with class");
SET_SLOT(ans, Matrix_diagSym, mkString("N"));
SET_SLOT(ans, Matrix_uploSym, mkString(uplo < 0 ? "L" : "U"));
}
if (dofree > 0) cs_spfree(a);
if (dofree < 0) Free(a);
UNPROTECT(1);
return ans;
}
token get_token(source_loc& loc) {
auto& point = loc.point;
fox_assert(!is_space(point[0])); //Should've been skipped
if (!point[0]) {
token eof_tok;
zero(eof_tok);
eof_tok.kind = tk_eof;
return eof_tok;
}
//For returning errors
token ret_tok;
token err_tok;
zero(err_tok);
err_tok.kind = tk_err;
if (is_sym(point[0])) {
char const* one_past_end_sym_str = point;
do {
one_past_end_sym_str++;
} while (is_sym(one_past_end_sym_str[0]));
const_str sym_str;
sym_str.b = point;
sym_str.len = one_past_end_sym_str - point;
//Repeatedly try smaller symbol strings until we find one or error out
//@todo this is a shitty way to do this
bool found_special = false;
while (true) {
fox_for (ispecial, fox_array_len(lex_special_strings)) {
if (sym_str == lex_special_strings[ispecial]) {
token new_sym_tok;
zero(new_sym_tok);
new_sym_tok.kind = tk_special;
new_sym_tok.special_id = (lex_special_id)ispecial;
ret_tok = new_sym_tok;
found_special = true;
}
}
if (found_special) {
break;
} else {
if (!sym_str.len--) {
break;
}
}
}
point += sym_str.len;
if (!found_special) {
//@todo print at beginning of symbol string
print_at_loc("Syntax Error: Invalid symbol string.\n", loc);
return err_tok;
}
} else if (is_num(point[0])) {
bool is_name(char c) {
return !is_space(c) && !is_sym(c);
}
int main(int argc, char **argv)
{
if (argc > 1)
while (++argv, --argc) {
if (!strcmp("-c", argv[0]))
color_on = 1;
else if (!strcmp("-h", argv[0]))
printf("liblisp unit tests\n\tusage ./%s (-c)? (-h)?\n", argv[0]);
else
printf("unknown argument '%s'\n", argv[0]);
}
unit_test_start("liblisp");
{
print_note("util.c");
test(is_number("0xfAb"));
test(is_number("-01234567"));
test(is_number("+1000000000000000000000000000003"));
test(!is_number(""));
test(!is_number("+"));
test(!is_number("-"));
test(unbalanced("(((", '(', ')') > 0);
test(unbalanced("))", '(', ')') < 0);
test(unbalanced("", '(', ')') == 0);
test(unbalanced("\"(", '(', ')') == 0);
test(unbalanced("( \"))))(()()()(()\\\"())\")", '(', ')') == 0);
test(unbalanced("(a (b) c (d (e (f) \")\" g)))", '(', ')') == 0);
test(unbalanced("((a b) c", '(', ')') > 0);
test(!is_fnumber(""));
test(!is_fnumber("1e"));
test(!is_fnumber("-1e"));
test(!is_fnumber("1-e"));
test(is_fnumber("+0."));
test(is_fnumber("123")); /*this passes, see header */
test(is_fnumber("1e-3"));
test(is_fnumber("1.003e+34"));
test(is_fnumber("1e34"));
test(is_fnumber("93.04"));
test(match("", ""));
test(match("abc", "abc"));
test(!match("abC", "abc"));
test(match("aaa*", "aaaXX"));
test(!match("aaa*", "XXaaaXX"));
test(match(".bc", "abc"));
test(match("a.c", "aXc"));
test(!match("a\\.c", "aXc"));
test(match("a\\.c", "a.c"));
char *s = NULL;
state(s = vstrcatsep(",", "a", "b", "c", "", "foo", "bar", NULL));
test(!sstrcmp("a,b,c,,foo,bar", s));
free(s);
char *t = NULL, *s1 = "Hello,", *s2 = " World!";
state(t = calloc(16, 1));
state(strcpy(t, s1));
test(((size_t) (lstrcatend(t, s2) - t)) == (strlen(s1) + strlen(s2)));
free(t);
/*test tr, or translate, functionality */
size_t trinsz = 0;
uint8_t trout[128] = { 0 }, *trin = (uint8_t *) "aaabbbcdaacccdeeefxxxa";
tr_state_t *tr1;
state(tr1 = tr_new());
state(trinsz = strlen((char *)trin));
test(tr_init(tr1, "", (uint8_t *) "abc", (uint8_t *) "def") == TR_OK);
test(tr_block(tr1, trin, trout, trinsz) == trinsz);
test(!strcmp((char *)trout, "dddeeefdddfffdeeefxxxd"));
test(tr_init(tr1, "s", (uint8_t *) "abc", (uint8_t *) "def") == TR_OK);
state(memset(trout, 0, 128));
test(tr_block(tr1, trin, trout, trinsz) <= trinsz);
test(!strcmp((char *)trout, "defddfdeeefxxxd"));
state(tr_delete(tr1));
/*know collisions for the djb2 hash algorithm */
test(djb2("heliotropes", strlen("heliotropes")) ==
djb2("neurospora", strlen("neurospora")));
test(djb2("depravement", strlen("depravement")) ==
djb2("serafins", strlen("serafins")));
/*should not collide */
test(djb2("heliotropes", strlen("heliotropes")) !=
djb2("serafins", strlen("serafins")));
}
{ /*io.c test */
io_t *in, *out;
print_note("io.c");
/*string input */
static const char hello[] = "Hello\n";
/**@note io_sin currently duplicates "hello" internally*/
state(in = io_sin(hello, strlen(hello)));
test(io_is_in(in));
test(io_getc(in) == 'H');
test(io_getc(in) == 'e');
test(io_getc(in) == 'l');
test(io_getc(in) == 'l');
test(io_getc(in) == 'o');
test(io_getc(in) == '\n');
test(io_getc(in) == EOF);
test(io_getc(in) == EOF);
test(!io_error(in));
test(io_seek(in, 0, SEEK_SET) >= 0);
test(io_getc(in) == 'H');
test(io_seek(in, 3, SEEK_SET) >= 0);
test(io_getc(in) == 'l');
test(io_ungetc('x', in) == 'x');
test(io_getc(in) == 'x');
test(io_getc(in) == 'o');
state(io_close(in));
/*string output */
char *s = NULL;
static const char hello_world[] = "Hello,\n\tWorld!\n";
/**@note io_sin currently duplicates hello_world internally*/
state(in = io_sin(hello_world, strlen(hello_world)));
test(!strcmp(s = io_getline(in), "Hello,"));
s = (free(s), NULL);
test(!strcmp(s = io_getline(in), "\tWorld!"));
s = (free(s), NULL);
test(!io_getline(in));
test(io_seek(in, 0, SEEK_SET) >= 0);
test(!strcmp(s = io_getdelim(in, EOF), "Hello,\n\tWorld!\n"));
s = (free(s), NULL);
state(io_close(in));
state(out = io_sout(1));
test(io_puts("Hello, World", out) != EOF);
test(!strcmp("Hello, World", io_get_string(out)));
test(io_putc('\n', out) != EOF);
test(!strcmp("Hello, World\n", io_get_string(out)));
test(io_seek(out, -6, SEEK_CUR) >= 0);
test(io_puts("Mars\n", out) != EOF);
test(!strcmp("Hello, Mars\n\n", io_get_string(out)));
free(io_get_string(out));
state(io_close(out));
static const char block_in[16] = {1, 3, 4, 6};
static char block_out[16] = {0};
state((in = io_sin(block_in, 16)));
test(io_getc(in) == 1);
test(io_read(block_out, 15, in) == 15);
test(!memcmp(block_out, block_in+1, 15));
state(io_close(in));
}
{ /* hash.c hash table tests */
hash_table_t *h = NULL;
print_note("hash.c");
state(h = hash_create(1));
return_if(!h);
test(!hash_insert(h, "key1", "val1"));
test(!hash_insert(h, "key2", "val2"));
/* assuming the hash algorithm is djb2, then
* "heliotropes" collides with "neurospora"
* "depravement" collides with "serafins"
* "playwright" collides with "snush" (for djb2a)
* See:
* <https://programmers.stackexchange.com/questions/49550/which-hashing-algorithm-is-best-for-uniqueness-and-speed> */
test(!hash_insert(h, "heliotropes", "val3"));
test(!hash_insert(h, "neurospora", "val4"));
test(!hash_insert(h, "depravement", "val5"));
test(!hash_insert(h, "serafins", "val6"));
test(!hash_insert(h, "playwright", "val7"));
test(!hash_insert(h, "snush", "val8"));
test(!hash_insert(h, "", "val9"));
test(!hash_insert(h, "nil", ""));
test(!hash_insert(h, "a", "x"));
test(!hash_insert(h, "a", "y"));
test(!hash_insert(h, "a", "z"));
test(!sstrcmp("val1", hash_lookup(h, "key1")));
test(!sstrcmp("val2", hash_lookup(h, "key2")));
test(!sstrcmp("val3", hash_lookup(h, "heliotropes")));
test(!sstrcmp("val4", hash_lookup(h, "neurospora")));
test(!sstrcmp("val5", hash_lookup(h, "depravement")));
test(!sstrcmp("val6", hash_lookup(h, "serafins")));
test(!sstrcmp("val7", hash_lookup(h, "playwright")));
test(!sstrcmp("val8", hash_lookup(h, "snush")));
test(!sstrcmp("val9", hash_lookup(h, "")));
test(!sstrcmp("", hash_lookup(h, "nil")));
test(!sstrcmp("z", hash_lookup(h, "a")));
test(hash_get_load_factor(h) <= 0.75f);
state(hash_destroy(h));
}
{ /* lisp.c (and the lisp interpreter in general) */
lisp_t *l;
print_note("lisp.c");
/*while unit testing eschews state being held across tests it is makes
*little sense in this case*/
state(l = lisp_init());
state(io_close(lisp_get_logging(l)));
test(!lisp_set_logging(l, io_nout()));
return_if(!l);
test(!lisp_eval_string(l, ""));
test(is_int(lisp_eval_string(l, "2")));
test(get_int(lisp_eval_string(l, "(+ 2 2)")) == 4);
test(get_int(lisp_eval_string(l, "(* 3 2)")) == 6);
lisp_cell_t *x = NULL, *y = NULL, *z = NULL;
char *t = NULL;
state(x = lisp_intern(l, lstrdup_or_abort("foo")));
state(y = lisp_intern(l, t = lstrdup_or_abort("foo"))); /*this one needs freeing! */
state(z = lisp_intern(l, lstrdup_or_abort("bar")));
test(x == y && x != NULL);
test(x != z);
free(t); /*free the non-interned string */
test(is_proc(lisp_eval_string(l, "(define square (lambda (x) (* x x)))")));
test(get_int(lisp_eval_string(l, "(square 4)")) == 16);
test(!is_list(cons(l, gsym_tee(), gsym_tee())));
test(is_list(cons(l, gsym_tee(), gsym_nil())));
test(!is_list(cons(l, gsym_nil(), cons(l, gsym_tee(), gsym_tee()))));
test(is_list(mk_list(l, gsym_tee(), gsym_nil(), gsym_tee(), NULL)));
test(gsym_error() == lisp_eval_string(l, "(> 'a 1)"));
test(is_sym(x));
test(is_asciiz(x));
test(!is_str(x));
test(gsym_error() == lisp_eval_string(l, "(eval (cons quote 0))"));
char *serial = NULL;
test(!strcmp((serial = lisp_serialize(l, cons(l, gsym_tee(), gsym_error()))), "(t . error)"));
state(free(serial));
state(lisp_destroy(l));
}
return unit_test_end("liblisp"); /*should be zero! */
}
void
lien::calcul_sim(int numdc)
{
// on parcoure simultanément la ligne et la colonne numdc
// pl pointeur sur ligne
element *pl = mflux.tete_l[numdc] ;
// pc pointeur sur colonne
element *pc = mflux.tete_c[numdc] ;
// on parcoure tant que les 2 pointeurs ne sont pas nuls
while (pl != 0 || pc != 0) {
// si colonne finie ou à une valeur strictement inférieure
// le traitement se fait qu'avec pl
if ((pl != 0) && (pc == 0 || pl->numlc > pc->numlc)) {
int numdc_l=numdc ;
int numdc_c=pl->numlc ;
if (numdc_l != numdc_c && numdc_l && numdc_c) {
int numval=pl->numval ;
if ( mflux.tabval[numval].calc == 0 ) {
double lien = calcul_elem(numdc_l, numdc_c, mflux.tabval[numval].nb, 0) ;
mflux.tabval[numval].lien = lien ;
mflux.tabval[numval].calc = 1 ;
calcul_max(numdc_l,lien, numdc_c) ;
}
}
pl = pl->next;
// si ligne finie ou à une valeur strictement inférieure
// le traitement ne se fait qu'avec pc
} else if ((pc != 0) && (pl == 0 ||pc->numlc > pl->numlc)) {
int numdc_l=pc->numlc ;
int numdc_c=numdc ;
if (numdc_l != numdc_c && numdc_l && numdc_c) {
int numval=pc->numval ;
if ( mflux.tabval[numval].calc == 0 ) {
double lien = calcul_elem(numdc_l, numdc_c, 0,mflux.tabval[numval].nb) ;
mflux.tabval[numval].lien = lien ;
mflux.tabval[numval].calc = 1 ;
calcul_max(numdc_l,lien, numdc_c) ;
}
}
pc = pc->next;
} else {
int numdc_l=numdc ;
int numdc_c=pl->numlc ;
if (numdc_l != numdc_c && numdc_l && numdc_c) {
int numval=pl->numval ;
int numval_d=pc->numval ;
double lien = 0 ;
if ( mflux.tabval[numval].calc == 0 ) {
lien = calcul_elem(numdc_l, numdc_c,
mflux.tabval[numval].nb, mflux.tabval[numval_d].nb) ;
mflux.tabval[numval].lien = lien ;
mflux.tabval[numval].calc = 1 ;
calcul_max(numdc_l,lien, numdc_c) ;
}
if ( mflux.tabval[numval_d].calc == 0 ) {
if (! is_sym()) {
lien = calcul_elem(numdc_c, numdc_l,
mflux.tabval[numval_d].nb, mflux.tabval[numval].nb) ;
}
mflux.tabval[numval_d].lien = lien ;
mflux.tabval[numval_d].calc = 1 ;
calcul_max(numdc_c,lien, numdc_l) ;
}
}
pl = pl->next;
pc = pc->next;
}
}
}
