## 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.pkgherein
# 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;