medit.src

没有说明

/*
**  _med_2r
**
**  Purpose: Calculate the number of matrix elements required for
**           x = x[i:j,.] | x[k:l,.];
**
**  Format:  size = _med1(row1_idx,row2_idx,no_rows,no_cols);
**
**  Inputs:   row1_idx    2x1 vector, indices of row selection
**                         OR missing value if x used instead of x[i:j,.].
**            row2_idx    2x1 vector, indices of row selection.
**                         OR missing value if x used instead of x[k:l,.].
**            no_rows     rows(x)  Do NOT use rows(x) or cols(x) as an argument.
**            no_cols     cols(x)  use temporary variables r=rows(x); c=cols(x);
**                              and then pass r and c to _med_2r().
**
**  Outputs:  size     scalar,  size in number of matrix elements needed for
**                     the operation.
**
*/

Proc(1) = _med_2r(row1_idx,row2_idx,no_rows,no_cols);
        local idx,matr1,matr2;
        idx = 0;
        if not(scalmiss(row1_idx));
           idx = idx + abs(row1_idx[2]-row1_idx[1]) + 1;
           matr1 = abs(row1_idx[2]-row1_idx[1]) + 1;  /* no rows in result 1 */
        else;
           matr1 = no_rows;
        endif;
        if not(scalmiss(row2_idx));
           idx = idx + abs(row2_idx[2]-row2_idx[1]) + 1;
           matr2 = abs(row2_idx[2]-row2_idx[1]) + 1;  /* no rows in result 2 */
        else;
           matr2 = no_rows;
        endif;
        /* add padding for matrix alignment and factor for safety */
        retp( (2*no_cols*(matr1+matr2) + idx*(_MED_ISZ/_MED_ESZ) + _MED_PAD));
endp;


/*
**  _med_2c
**
**  Purpose:  Calculate the number of matrix elements required for
**            x = x[.,i:j] ~ x[.,k:l];
**
**  Format:   size = _med1(col1_idx,col2_idx,no_rows,no_cols);
**
**  Inputs:   col1_idx  2x1 vector, indices of col selection
**                     OR missing value if x used instead of x[.,i:j].
**            col2_idx  2x1 vector, indices of col selection
**                     OR missing value if x used instead of x[.,k:l].
**            no_rows  rows(x)  Do NOT use rows(x) or cols(x) as an argument.
**            no_cols  cols(x)  use temporary variables r=rows(x); c=cols(x);
**                              and then pass r and c to _med_2c().
**
**  Outputs:  size     scalar,  size in number of matrix elements needed for
**                     the operation.
**
*/

Proc(1) = _med_2c(col1_idx,col2_idx,no_rows,no_cols);
         retp(_med_2r(col1_idx,col2_idx,no_cols,no_rows));
endp;



/*
**  medit
**
**  Purpose:  Full Screen Matrix Editor.
**
**  Format:   {y,yv,yfmt} = medit(x,v,fmt);
**
*/

proc (3) = medit(x,v,fmt);
    local _miss,     /* missing value */
        leavfree, TR, TC, BR, BC, CR, CC, bufr, bufc,
        rc_cut, /* 0 if nothing cut/copied, 1 for rows, 2 for columns */
        curs_pos, rc_blk, request, fill_val, ent_dir,
        m_col_v, m_n_fmt, m_c_fmt, scr_pos, old_ctrl, core,
        r, c, cga, izero, oldimtol, str, msg, max_vals,
        rc_buf, v_buf, fmt_buf, maxv_buf,  /* scrap buffers */
        med1; /* code buffer */

    cga = CGA;

    leavfree = 16384;


    _miss = miss(1,1);       /* missing value */

    if (type(x) NE 6);
        errorlog " ERROR : First argument must be a matrix";
        end;
    endif;
    if (type(v) NE 6);
        errorlog " ERROR : Second argument must be a scalar, vector or matrix";
        end;
    endif;

    if (type(fmt) NE 6) AND (type(fmt) NE 13);
        errorlog " ERROR : Third argument must be a scalar, vector, matrix"\
            " or string";
        end;
    endif;

    r = rows(x);
    c = cols(x);
    msg = "";       /* no errors */
    m_col_v = 5000;         /* must be > 4096 */
    curs_pos = ones(2,1);
    scr_pos = zeros(2,1);
    rc_blk = zeros(2,2);
    rc_buf = 0;
    request = 0;    /* initial startup */
    ent_dir = 0;    /* go right to start */
    rc_cut = 0;     /* scrap buffer empty */


    #ifcplx  /* COMPLEX version */
        core = floor((coreleft - leavfree) / _MED_ESZ); /* .a16 and .a32 */
        if (2*r*c + _MED_PAD) GT core;
            errorlog "Insufficient memory to run MEDIT.  Reduce matrix size.";
            end;
        endif;
        if (imag(x) $== 0);   /* complex part zero or missing */
            x = complex(x,0);
            izero = 1;  /* x not complex */
        else;
            izero = 0;  /* x complex */
        endif;
        if type(fmt) EQ 6;
            fmt = real(fmt);  /* strip off imaginary part */
        endif;
        if type(v) EQ 6;
            v = real(v);  /* strip off imaginary part */
        endif;
    #else
        izero = 1;
    #endif

    m_n_fmt = { "lg " 10 3 };
    m_c_fmt = { "s " 8 8 };
    if (type(fmt) EQ 13);
        /* string take first 8 characters */
        fmt = strsect(fmt,1,8);
        /* check for "s" if so add m_c_fmt[.,2:3] */
        /* alse add m_n_fmt[.,2:3] */
        if strindx(fmt,"s",1) == 0;  /* "s" not found */
            fmt = (0$+fmt)~m_n_fmt[.,2:3];
        else;
            fmt = (0$+fmt)~m_c_fmt[.,2:3];
        endif;
    else;           /* fmt a matrix */
        if (rows(fmt) == 1) and (cols(fmt) == 1);
        /* scalar use default values */
            fmt = fmt ~ m_n_fmt[.,2:3];
        elseif cols(fmt) /= 3;
            errorlog " ERROR : Wrong size format matrix";
            end;
        endif;
    endif;


    #ifcplx  /* complex data */
        /* missing value or blank to start with  */
        fill_val = MISS(1,1)~1;
        fill_val = complex(fill_val,0);
    #else
        /* missing value to start with  */
        fill_val = MISS(1,1)~1;
    #endif

    if (v $== 0);   /* all columns character */
        fill_val[2] = 0;  /* make default fill value character */
    endif;

    /* the values in v take precedence over fmt  */
    v = reshape(v,1,c);

    core = floor((coreleft - leavfree) / _MED_ESZ);       /* .a16 and .a32 */
    if (2*3*c + _MED_PAD) > core;
        errorlog "Insufficient memory to reshape format matrix.";
        end;
    endif;
    if (c*3) GT MAX_SIZE;
        msg = "Too many columns in matrix.";
        end;
    endif;
    fmt = reshape(fmt,c,3);         /* medit.gxe checks fmt and fixes if
                                    :: needs be
                                    */
    max_vals = reshape(m_col_v,1,c);        /* no max values to start with  */

    old_ctrl = ndpcntrl(0,0);       /* save current ndp setting */
    call ndpcntrl(0x1332,0xffff);           /* affine,near,64,denormal,
                                            :: underflow,inexact
                                            */

    if (2*(MED_SIZE+_MED_PAD)) > ((coreleft-leavfree)/8);  /* use real array */
        errorlog "Insufficient memory to load MEDIT";
        end;
    endif;
    med1 = zeros(MED_SIZE,1);

    #ifcplx
        loadexe med1 = mediti.rex;
    #else
        loadexe med1 = medit.rex;
    #endif

core = floor((coreleft - leavfree) / _MED_ESZ);       /* .a16 and .a32 */
if (r*c + 4*c + _MED_PAD) GT core;  /* not enough space to return results */
   errorlog "Insufficient memory to run MEDIT.  Reduce matrix size.";
   end;
endif;

RE_CALL:      /* start of main loop */

    callexe /r med1(x, r, c, v, fmt, msg, max_vals, curs_pos, scr_pos,
        rc_blk, request, izero, fill_val, ent_dir, cga);

    msg = "";  /* clear error messages */
    TR = rc_blk[1,1];
    TC = rc_blk[1,2];
    BR = rc_blk[2,1];
    BC = rc_blk[2,2];
    CR = curs_pos[1];
    CC = curs_pos[2];
    bufr = rows(rc_buf);
    bufc = cols(rc_buf);

    if (request $== -1);
        print "Editing Abandoned by user.  Results not saved.";
        call ndpcntrl(old_ctrl, 0xffff);
        end;
    endif;

    if (request $== 0);
        goto save_mat;
    endif;

    core = floor((coreleft - leavfree) / _MED_ESZ);       /* .a16 and .a32 */

    if (request $== 1);  /* delete rows memory used is reduced */
        /* delete all columns */
        if ((TR LE 1) AND (BR GE r));
            msg = "Cannot delete entire matrix";
            goto re_call;
        endif;
        gosub CUT_ROWS;       /* cut rows */
        if strlen(msg) /= 0;
           msg = "Not enough memory";
           goto re_call;
        endif;

    elseif (request $== 2);   /* cut rows memory used unchanged */
        /* cut all columns */
        if ((TR LE 1) AND (BR GE r));
            msg = "Cannot cut entire matrix";
            goto re_call;
        endif;
        clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */
        core = floor((coreleft - leavfree) / _MED_ESZ);  /* .a16 and .a32 */
        if _med_1(TR~BR,_miss,r,c,0) GT core;
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        rc_buf = x[TR:BR,.];
        rc_cut = 1;         /* have rows in buffer */
        core = floor((coreleft - leavfree) / _MED_ESZ);  /* .a16 and .a32 */
        gosub CUT_ROWS;       /* cut rows */
        if strlen(msg) /= 0;
           msg = "Not enough memory. Previous scrap buffer cleared.";
           clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */
           goto re_call;
        endif;

    elseif (request $== 3);  /* copy rows use more memory */
        /* copy all columns */
        clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */
        core = floor((coreleft - leavfree) / _MED_ESZ);    /* .a16 and .a32 */
        /* test if enough memory to store result */
        if ( (BR-TR+1) * c + GXE_SIZE + _MED_PAD) GT core;
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        if _med_1(TR~BR,_miss,r,c,0)  GT core;
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        rc_buf = x[TR:BR,.];
        rc_cut = 1;         /* have rows in buffer */

    elseif (request $== 4);  /* delete cols memory used reduced */
        /* delete all rows */
        if ((TC LE 1) AND (BC GE c));
            msg = "Cannot delete entire matrix";
            goto re_call;
        endif;
        gosub CUT_COLS;
        if strlen(msg) /= 0;
            msg = "Not enough memory";
            goto re_call;
        endif;

    elseif (request $== 5); /* cut cols memory used unchanged */
        /* cut all rows */
        if ((TC LE 1) AND (BC GE c));
            msg = "Cannot cut entire matrix";
            goto re_call;
        endif;
        clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */