PreviousUpNext

15.4.1192  src/lib/std/src/rw-matrix.pkg

## rw-matrix.pkg
#
# Typeagnostic ("polymorphic") two-dimensional matrices.

# Compiled by:
#     src/lib/std/src/standard-core.sublib



###                  "Engineering is like acting,
###                   in that when it is well done,
###                   it goes unnoticed and unapplauded."



#  #DO set_control "compiler::trap_int_overflow" "TRUE";

stipulate
    package rwv =  rw_vector;                           # rw_vector             is from   src/lib/std/src/rw-vector.pkg
    package rws =  rw_vector_slice;                     # rw_vector_slice       is from   src/lib/std/src/rw-vector-slice.pkg
    package inl =  inline_t;                            # inline_t              is from   src/lib/core/init/built-in.pkg
herein

    # This package is used in:
    #
    #     src/lib/graph/floyd-warshalls-all-pairs-shortest-path-g.pkg
    #     src/lib/graph/johnsons-all-pairs-shortest-paths-g.pkg
    #
    package   rw_matrix
    : (weak)  Rw_Matrix                                 # Rw_Matrix             is from   src/lib/std/src/rw-matrix.api
    {
        ltu = inl::default_int::ltu;
        #
        unsafe_set = inl::poly_rw_vector::set;
        unsafe_get = inl::poly_rw_vector::get;

        Rw_Matrix(X)                                    # Duplicated as poly_rw_matrix::Rw_matrix(X)    in  src/lib/core/init/built-in.pkg
            =
            { rw_vector:        rwv::Rw_Vector(X),
              rows:             Int,
              cols:             Int
            };

        Region(X)
            =
            { rw_matrix:        Rw_Matrix(X),
              row:              Int,
              col:              Int,
              rows:             Null_Or( Int ),
              cols:             Null_Or( Int )
            };

        make_rw_vector'
            =
            inl::poly_rw_vector::make_nonempty_rw_vector;

        fun unsafe_index ( { rows, cols, ... }: Rw_Matrix(X), i, j)                             # Compute the index of a matrix element 
            =
            (i * cols + j);

        fun index (rw_matrix, i, j)
            =
            if ((ltu (i, rw_matrix.rows) and ltu (j, rw_matrix.cols)))
                #
                unsafe_index (rw_matrix, i, j);
            else
                raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;                                   # exceptions_guts       is from   src/lib/std/src/exceptions-guts.pkg
            fi;

        fun check_size (rows, cols)
            =
            if  (rows < 0
            or   cols < 0
            )
                raise exception exceptions_guts::SIZE;
            else
                n = rows * cols
                    except
                        OVERFLOW = raise exception exceptions_guts::SIZE;

                if (n > core::maximum_vector_length)    raise exception exceptions_guts::SIZE;  fi;

                n;
            fi;

        fun make_rw_matrix ((rows, cols), v)
            =
            case (check_size (rows, cols))
                #
                0 => { rows => 0, cols => 0, rw_vector => inl::poly_rw_vector::make_zero_length_vector() };
                n => { rows,      cols,      rw_vector => make_rw_vector' (n, v)                            };
            esac;

        fun from_list  (rows, cols)  data
            =
            {   if (rows * cols  !=  list::length data)   raise exception exceptions_guts::SIZE;   fi;
                #               
                { rows, cols,  rw_vector => rw_vector::from_list data };
            };

        fun from_lists rows
            =
            case (list::reverse rows)
                #         
                []  =>
                    { rw_vector  => inl::poly_rw_vector::make_zero_length_vector(),
                      rows => 0,
                      cols => 0
                    };

                last_row ! rest
                    =>
                    {   cols =  list::length  last_row;
                        #
                        fun check ([], rows, l)
                                =>
                                (rows, l);

                            check (row ! rest, rows, l)
                                =>
                                check (rest, rows+1, check_row (row, 0))
                                where
                                    fun check_row ([], n)
                                            =>
                                            {   if   (n != cols)   raise exception exceptions_guts::SIZE;   fi;
                                                l;
                                            };

                                        check_row (x ! r, n)
                                            =>
                                            x ! check_row (r, n+1);
                                    end;
                                end;
                        end;

                        (check (rest, 1, last_row))
                            ->
                            (rows, data);
                            

                        { rw_vector  => rw_vector::from_list data,
                          rows => rows,
                          cols => cols
                        };
                    };
            esac;



        fun from_fn ((rows, cols), f)
            =
            case (check_size (rows, cols))
                #
                0 =>    { rw_vector => inl::poly_rw_vector::make_zero_length_vector(), rows, cols };
                #
                n =>    {   rw_vector =  make_rw_vector' (n, f (0, 0));
                            #   
                            fun row_loop (i, j, k)
                                =
                                if (i < rows)
                                    #
                                    col_loop (i, 0, k);
                                fi

                            also
                            fun col_loop (i, j, k)
                                =
                                if (j < cols)
                                    #
                                    unsafe_set (rw_vector, k, f (i, j));
                                    col_loop (i, j+1, k+1);
                                else
                                    row_loop (i+1, 0, k);
                                fi;

                            col_loop (0, 1, 1);  #  we've already done (0, 0) 

                            { rw_vector, rows, cols };
                        };
            esac;



        fun get (a, (i, j))    =  unsafe_get (a.rw_vector, index (a, i, j));                    # This fn is duplicated in   poly_rw_matrix   in   src/lib/core/init/built-in.pkg
        fun set (a, (i, j), v) =  unsafe_set (a.rw_vector, index (a, i, j), v);                 # This fn is duplicated in   poly_rw_matrix   in   src/lib/core/init/built-in.pkg

        (_[])   = get;                                          # Synonym for 'get' -- supports   foo  = matrix[i,j];   syntax.
        (_[]:=) = set;                                          # Synonym for 'set' -- supports   matrix[i,j] := foo;   syntax.


        fun rowscols { rw_vector, rows, cols }
            =
            (rows, cols);


        fun cols (rw_matrix:  Rw_Matrix(X)) =  rw_matrix.cols;
        fun rows (rw_matrix:  Rw_Matrix(X)) =  rw_matrix.rows;


        fun row ( { rw_vector, rows, cols }, i)
            =
            {   stop = i*cols;
                #
                fun make_vec (j, l)
                    =
                    if (j < stop)
                         vector::from_list l;
                    else
                         make_vec (j - 1, rwv::get (rw_vector, j) ! l);
                    fi;

                if (not (ltu (rows, i)))
                    #
                    make_vec (stop+cols - 1, []);
                else 
                    raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;
                fi;
            };

        fun col ( { rw_vector, rows, cols }, j)
            =
            {   fun make_vec (i, l)
                    =
                    if (i < 0)
                        vector::from_list l;
                    else
                        make_vec (i-cols, rwv::get (rw_vector, i) ! l);
                    fi;

                if (ltu (cols, j))    raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;   fi;

                make_vec ((rwv::length rw_vector - cols) + j, []);                 
            };

        Index = DONE
              | INDEX  { i: Int, r: Int, c: Int }
              ;

        fun check_region { rw_matrix => { rw_vector, rows, cols }, row, col, rows=>nr, cols=>nc }
            =
            {   fun check (start, n, NULL)
                        =>
                        if  (start < 0
                        or   start > n
                        )
                             raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;
                        else
                             n-start;
                        fi;

                    check (start, n, THE len)
                        =>
                        if ((start < 0) or (len < 0) or (n < start+len))
                            #
                            raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;
                        else
                            len;
                        fi;
                end;

                nr = check (row, rows, nr);
                nc = check (col, cols, nc);

                { rw_vector, i => (row*cols + col), r=>row, c=>col, nr, nc };
            };

        fun copy_region
              { region:         Region(X),
                to:             Rw_Matrix(X),
                to_row:         Int,
                to_col:         Int
              }
            =
            {   check_region region;

                from = region.rw_matrix;

                rows_to_copy = the_else (region.rows, from.rows - region.row);
                cols_to_copy = the_else (region.cols, from.cols - region.col);

                fun copy_downward (rows_left_to_copy, d, s)                     # 'd' == start-of-row index into destination vector.
                    =                                                           # 's' == start-of-row index into source      vector.
                    if (rows_left_to_copy > 0)                                  # 'cols_to_copy' gives length of row.
                        #
                        # We might be better off doing this directly
                        # instead of calling the rw_vector_slice module:
                        #       
                        rws::copy { src => rws::make_slice (from.rw_vector, s, THE cols_to_copy),
                                    dst => to.rw_vector, di => d
                                  };

                        copy_downward (rows_left_to_copy - 1, d + to.cols, s + from.cols);
                    fi;


                fun copy_upward (rows_left_to_copy, d, s)                       # 'd' == start-of-row index into destination vector.
                    =                                                           # 's' == start-of-row index into source      vector.
                    if (rows_left_to_copy > 0)                                  # 'cols_to_copy' gives length of row.
                        #
                        rws::copy { src => rws::make_slice (from.rw_vector, s, THE cols_to_copy),
                                    dst => to.rw_vector, di => d
                                  };

                        copy_upward (rows_left_to_copy - 1, d - to.cols, s - from.cols);
                    fi;

                if  (rows_to_copy + to_row > to.rows                            # Sanity check that to-region fits entirely within to-matrix.
                or   cols_to_copy + to_col > to.cols                            # This check looks necessary but not sufficient to guarantee that.
                )
                    raise exception exceptions_guts::INDEX_OUT_OF_BOUNDS;
                fi;

                if (to_row <= region.row)                                       # Choose copy direction so that we're more likely to produce rational
                    #                                                           # results if source region overlaps destination region...?
                    copy_downward ( rows_to_copy,                               # To really do this right we'd need four cases (left-right + top-bottom).
                         to_row     *   to.cols + to_col,
                         region.row * from.cols + region.col
                       );
                else
                    copy_upward ( rows_to_copy,
                         (    to_row + rows_to_copy - 1) *   to.cols  +     to_col,
                         (region.row + rows_to_copy - 1) * from.cols  + region.col
                       );
                fi;
            };


        # This function generates a stream of indices
        # for the given region in row-major order.
        #
        fun iterate region
            =
            (rw_vector, iter)
            where  

                (check_region region)
                    ->
                    { rw_vector, i, r, c=>c_start, nr, nc };

                ii = REF i;
                ri = REF r;
                ci = REF c_start;

                r_end = r+nr;
                c_end = c_start+nc;

                row_delta = region.rw_matrix.cols - nc;

                fun make_index (r, c)
                    =
                    {   i = *ii;
                        #
                        ii := i+1;
                        INDEX { i, c, r };
                    };

                fun iter ()
                    =
                    {   r = *ri;
                        c = *ci;

                        if (c < c_end)
                            #
                            ci := c+1;
                            make_index (r, c);

                        elif (r+1 < r_end)

                            ii := *ii + row_delta;
                            ci := c_start;
                            ri := r+1;

                            iter ();
                        else
                            DONE;
                        fi;
                    };
                end;

        fun region_apply  f region
            =
            apply ()
            where
                (iterate region) ->    (rw_vector, iter);


                fun apply ()
                    =
                    case (iter ())
                        #
                        DONE => ();

                        INDEX { i, r, c }
                            =>
                            {   f (r, c, unsafe_get (rw_vector, i));

                                apply ();
                            };
                    esac;
            end;


        fun apply f { rw_vector, cols, rows }
            =
            rwv::apply f rw_vector;


        fun region_map_in_place f region
            =
            modify ()
            where
                (iterate  region) ->   (rw_vector, iter);

                fun modify ()
                    =
                    case (iter ())
                        #
                        DONE => ();

                        INDEX { i, r, c }
                            =>
                            {   unsafe_set (rw_vector, i, f (r, c, unsafe_get (rw_vector, i)));
                                modify();
                            };
                    esac;
            end;


        fun map_in_place f { rw_vector, cols, rows }
            =
            rwv::map_in_place  f  rw_vector;


        fun region_fold_forward f init region
            =
            fold init
            where

                (iterate  region) ->   (rw_vector, iter);

                fun fold accum
                    =
                    case (iter ())
                        #
                        DONE => accum;

                        INDEX { i, r, c }
                            =>
                            fold (f(r, c, unsafe_get (rw_vector, i), accum));
                    esac;
            end;


        fun fold_forward f init { rw_vector, cols, rows }
            =
            rwv::fold_forward f init rw_vector;


    };
end;



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext