/*
 * m_proc.c: built-in procedures
 */

#include "m.h"

void mplot( void (*plotfn)( char *, double *, double *, int) )
{
    int narg = (int) *pc++;
    Symbolptr title = NULL, x = NULL, y;
    int n;
    npop( narg);

    if( narg < 1 || narg > 3)
	error("plot procedures take from one to three arguments","");

    m_check( y = sp[0], "plot");
    if( narg > 1 && sp[1])
	m_check( x = sp[1], "plot");
    if( narg > 2 && sp[2])
	s_check( title = sp[2], "plot");

    n = ROWS(y) * COLS(y);
    if( x && (n != ROWS(x) * COLS(x)) )
	error( "x & y arguments to plot must have same size", "");

    (*plotfn)( title ? STR(title) : NULL, x ? MAT(x)[0] : NULL, MAT(y)[0], n);
/*
 * this assumes that row pointers have not been interchanged
 */
}

void m_plot2d( void)
{
    mplot( plot2d);
}

void m_plot( void)
{
    mplot( plot);
}

void m_hplot( void)
{
    mplot( hplot);
}

void m_srand( void)
{
    int narg = (int) *pc++;
    npop( narg);

    if( narg > 1)
	error("srand() takes at most one argument","");

    if( narg == 0)
	randomize();
    else {
	n_check( sp[0], "srand()");
	srand( (unsigned) VAL(sp[0]) );
    }
}

void m_exit( void)
{
    npop( (int) *pc++);

    if( fin == stdin)
	(void) exit(SUCCESS);
    else {
	fclose(fin);
	fin = nextfile();
    }
}

void m_dump( void)
{
    int narg = (int) *pc++;
    npop(narg);

    dump();
}

#ifdef DEBUG
void m_debug( void)
{
    int narg = (int) *pc++;
    npop(narg);

    if( narg != 1)
	error("debug() takes 1 argument","");

    n_check( sp[0], "debug()");

    switch( (int) VAL(sp[0]) ) {
	case  0: stack_debug = prog_debug = stack_dump = trace = 0;
#ifdef YYDEBUG
		 yydebug = 0;
#endif
		 break;
#ifdef YYDEBUG
	case  1: yydebug = 1; break;
	case -1: yydebug = 0; break;
#else
	case  1:
	case -1: break;
#endif
	case  2: stack_debug = 1; break;
	case -2: stack_debug = 0; break;
	case  3: prog_debug = 1; break;
	case -3: prog_debug = 0; break;
	case  4: stack_dump = 1; break;
	case -4: stack_dump = 0; break;
	case  5: exe = 0; prog_debug = 1; break;
	case  6: trace = 1; break;
	case -6: trace = 0; break;
	default: error("debug() argument out of range",""); break;
    }
}
#endif

void m_printfn( void)
{
    int i;
    int narg = (int) *pc++;
    npop(narg);

    for( i = 0; i < narg; i++) {
	check(sp[i]);
	print(sp[i]);
    }
}

void m_printf( void)	/* C printf() interface */
{
    int i;
    int narg = (int) *pc++;
    npop(narg);

    if( narg < 1 || narg > 10)
	error( "printf() takes from 1 to 10 arguments","");

    s_check( sp[0], "printf()");

    for( i = 1; i < narg; i++)
	n_check( sp[i], "printf()");

    dprint( STR(sp[0]),
	narg > 1 ? VAL(sp[1]) : 0.0, 
	narg > 2 ? VAL(sp[2]) : 0.0, 
	narg > 3 ? VAL(sp[3]) : 0.0, 
	narg > 4 ? VAL(sp[4]) : 0.0, 
	narg > 5 ? VAL(sp[5]) : 0.0, 
	narg > 6 ? VAL(sp[6]) : 0.0, 
	narg > 7 ? VAL(sp[7]) : 0.0, 
	narg > 8 ? VAL(sp[8]) : 0.0, 
	narg > 9 ? VAL(sp[9]) : 0.0 );
}

void m_qr( void)	/* qr( a, q, r) */
{
    Symbolptr a, q, r;
    int m, n;
    int narg = (int) *pc++;
    npop(narg);

    if( narg < 2 || narg > 3)
	error("qr( a, q, r) takes two or three arguments","");

    m_check( a = sp[0], "qr()");

    m = ROWS(a);
    n = COLS(a);

    q = sp[1];
    if( q) {
	q = m_new( q, m, m);
	if( SCALAR(q))
	    VAL(q) = 1.0;
	else
	    eye( MAT(q), m, m);
    }

    if( narg > 2)
	r = sp[2];
    else
	r = NULL;

    r = copy( r, a);

    if( m > 1)
	qr( q ? MAT(q) : NULL, MAT(r), m, n);
}