(* --- Copyright University of Sussex 1990. All rights reserved. ----------
 * File:            C.all/pml/lib/ArrayImplementation.ml
 * Purpose:         Implementation of all Array and Vector functions
 * Author:          Robert John Duncan, Nov  9 1990
 * Documentation:   HELP * ARRAY, * VECTOR
 * Related Files:   C.all/pml/lib/Array.ml, C.all/pml/lib/Vector.ml
 *)


(*
 *	SIGNATURE
 *)

signature ArrayImplementation = sig

eqtype 'a vector
type 'a array

exception Size
exception Subscript

(* Vectors *)

val vector_create		: int * 'a -> 'a vector
val vector_fromlist		: 'a list -> 'a vector
val vector_tolist		: 'a vector -> 'a list
val vector_tabulate		: int * (int -> 'a) -> 'a vector
val vector_sub			: 'a vector * int -> 'a
val vector_length		: 'a vector -> int
val vector_map			: ('a -> 'b) -> 'a vector -> 'b vector
val vector_app			: ('a -> unit) -> 'a vector -> unit
val vector_iterate		: ('a * int -> 'b) -> 'a vector -> 'b vector

(* Arrays *)

val array_create		: int * '_a -> '_a array
val array_fromlist		: '_a list -> '_a array
val array_fromvector	: '_a vector -> '_a array
val array_tolist		: 'a array -> 'a list
val array_tovector		: 'a array -> 'a vector
val array_tabulate		: int * (int -> '_a) -> '_a array
val array_sub			: 'a array * int -> 'a
val array_update		: 'a array * int * 'a -> unit
val array_length		: 'a array -> int
val array_equal			: 'a array * 'a array -> bool
val array_map			: ('a -> '_b) -> 'a array -> '_b array
val array_app			: ('a -> unit) -> 'a array -> unit
val array_iterate		: ('a * int -> '_b) -> 'a array -> '_b array
val array_copy			: '_a array -> '_a array
val array_fill			: 'a array -> 'a -> unit
val array_nc_map		: ('a -> 'a) -> 'a array -> 'a array
val array_nc_iterate	: ('a * int -> 'a) -> 'a array -> 'a array

end;	(* signature ArrayImplementation *)


(*
 *	ABSTRACT IMPLEMENTATION
 *

structure ArrayImplementation : ArrayImplementation = struct

(* Vectors *)

datatype 'a vector =
	VECTOR of 'a list

exception Size
exception Subscript

fun vector_fromlist l =
		VECTOR l

fun vector_tolist(VECTOR l) =
		l

fun vector_tabulate(n, f) =
	let fun tabulate i =
			if i < n then
				f(i) :: tabulate(i+1)
			else
				[]
	in	if n < 0 then
			raise Size
		else
			VECTOR(tabulate 0)
	end

fun vector_create(n,x) =
		vector_tabulate(n, fn _ => x)

fun vector_length(VECTOR l) =
	let fun length [] = 0
		|	length (_::l) = length l + 1
	in	length l
	end

fun vector_sub(VECTOR l, i) =
	let	fun	vsub(x::_, 0) = x
		|	vsub(_::l, i) = vsub(l, i-1)
		|	vsub([], _)   = raise Subscript
	in	vsub(l, i)
	end

fun vector_map f (VECTOR l) =
		VECTOR(map f l)

fun vector_app f (VECTOR l) =
	let fun app f [] = ()
		|	app f (x::l) = (f x:unit; app f l)
	in	app f l
	end

fun vector_iterate f (VECTOR l) =
	let fun iterate f [] _ = []
		|	iterate f (x::l) i = f(x,i) :: iterate f l (i+1)
	in	VECTOR(iterate f l 0)
	end

(* Arrays *)

abstype 'a array =
	ARRAY of 'a ref vector
with

fun array_fromlist l =
		ARRAY(vector_fromlist(map ref l))

fun array_tolist(ARRAY v) =
		map ! (vector_tolist v)

fun array_fromvector v =
		ARRAY(vector_map ref v)

fun array_tovector(ARRAY v) =
		vector_map ! v

fun array_tabulate(n,f) =
		ARRAY(vector_tabulate(n, ref o f))

fun array_create(n,x) =
		ARRAY(vector_tabulate(n, fn _ => ref x))

fun array_length(ARRAY v) =
		vector_length v

fun array_equal(ARRAY v1, ARRAY v2) =
		v1 = v2

fun array_sub(ARRAY v, i) =
		!(vector_sub(v, i))

fun array_update(ARRAY v, i, x) =
		vector_sub(v, i) := x

fun array_map f (ARRAY v) =
		ARRAY(vector_map (ref o f o !) v)

fun array_app f (ARRAY v) =
		vector_app (f o !) v

fun array_iterate f (ARRAY v) =
		ARRAY(vector_iterate (fn(x,i)=> ref(f(!x,i))) v)

fun array_nc_map f (a as ARRAY v) =
		(vector_app op:= (vector_map (fn r => (r,f(!r))) v); a)

fun array_nc_iterate f (a as ARRAY v) =
		(vector_app op:= (vector_iterate (fn(r,i)=> (r,f(!r,i))) v); a)

fun array_copy a =
		array_map (fn x => x) a

fun array_fill (ARRAY v) x =
		vector_app (fn r => r := x) v

end;

end;

 *)


(*
 *	CONCRETE IMPLEMENTATION
 *)

external structure ArrayImplementation : ArrayImplementation = struct

ml_eqtype 'a vector;
ml_type 'a array;

ml_exception Size;
ml_exception Subscript;

/*
 *	POP-11 Utilities
 */

lconstant
	SizeExn = ml_valof("Size"),
	SubscriptExn = ml_valof("Subscript"),
;

;;; array0:
;;;		unique array of length 0

lconstant array0 = {};

;;; create(n, init):
;;;		create an array of size -n-, initialised to -init-

define lconstant create(n, init);
	lvars n, init;
	if isinteger(n) and n fi_> 0 then
		consvector(fast_repeat n times init endrepeat, n);
	elseif n == 0 then
		array0;
	else
		ml_raise(SizeExn);
	endif;
enddefine;

;;; fromlist(l):
;;;		create a vector (or array) from a list of items

define lconstant fromlist(items);
	lvars items;
	if items == [] then
		array0;
	else
		{% until items == [] do fast_destpair(items) -> items enduntil %};
	endif;
enddefine;

;;; tolist(a):
;;;		returns a list of all the items in an array

define lconstant tolist(a);
	lvars a;
	[% destvector(a) -> %];
enddefine;

;;; tabulate(n, f):
;;;		create an array of size n, with contents initialised by
;;;		the function f

define lconstant tabulate(n, f);
	lvars i, n, procedure f;
	if isinteger(n) and n fi_> 0 then
		consvector(fast_for i from 0 to n fi_- 1 do f(i) endfor, n);
	elseif n == 0 then
		array0;
	else
		ml_raise(SizeExn);
	endif;
enddefine;

;;; Arrays are indexed from 0: this is a hack to save explicit subtractions
lconstant macro fast_subscrv0 = "fast_prolog_arg";

;;; sub(a, i)
;;;		array access

define lconstant sub(a, i);
	lvars a, i;
	if i >= 0 and i < datalength(a) then
		fast_subscrv0(i, a);
	else
		ml_raise(SubscriptExn);
	endif;
enddefine;

;;; update(a, i, v)
;;;		array update

define lconstant update(a, i, v);
	lvars a, i, v;
	if i >= 0 and i < datalength(a) then
		v -> fast_subscrv0(i, a);
	else
		ml_raise(SubscriptExn);
	endif;
	ml_unit;
enddefine;

;;; map(f, a):
;;;		map a function -f- over an array -a-

define lconstant map(f, a);
	lvars f, a, n = datalength(a);
	returnif(n == 0)(array0);
	consvector(appdata(a, f), n);
enddefine;

;;; app(f, a):
;;;		apply -f- to each element of -a-

define lconstant app(f, a);
	lvars f, a;
	appdata(a, f);
	erasenum(datalength(a));
	ml_unit;
enddefine;

;;; iterate(f, a):
;;;		apply -f- to each element of -a- together with its index

define lconstant iterate(f, a);
	lvars i, procedure f, a, n = datalength(a);
	returnif(n == 0)(array0);
	consvector(
		fast_for i to n do
			f(conspair(fast_subscrv(i, a), i fi_- 1));
		endfor,
		n);
enddefine;

;;; copyarray(a):
;;;		copy the array -a-

define lconstant copyarray(a);
	lvars a;
	returnif(datalength(a) == 0)(array0);
	copy(a);
enddefine;

;;; fillarray(a,x):
;;;		fill the array -a- with value -x-

define lconstant fillarray(a, x);
	lvars a, x;
	fill(fast_repeat datalength(a) times x endrepeat, a) -> ;
	ml_unit;
enddefine;

;;; nc_map(f, a):
;;;		like -map-, but doesn't create a new array: results are copied
;;;		into the original array

define lconstant nc_map(f, a);
	lvars f, a;
	fill(appdata(a, f), a);
enddefine;

;;; nc_iterate(f, a):
;;;		like -iterate-, but doesn't create a new array: results are copied
;;;     into the original array

define lconstant nc_iterate(f, a);
	lvars i, procedure f, a, n = datalength(a);
	fill(
		fast_for i to n do
			f(conspair(fast_subscrv(i, a), i fi_- 1));
		endfor,
		a);
enddefine;

/*
 *	ML Bindings
 */

;;; Vectors

ml_val vector_create	: int * 'a -> 'a vector = create;
ml_val vector_fromlist	: 'a list -> 'a vector = fromlist;
ml_val vector_tolist	: 'a vector -> 'a list = tolist;
ml_val vector_tabulate	: int * (int -> 'a) -> 'a vector = tabulate;
ml_val vector_length	: 'a vector -> int = datalength;
ml_val vector_sub		: 'a vector * int -> 'a = sub;
ml_val vector_map		: ('a -> 'b) -> 'a vector -> 'b vector = map;
ml_val vector_app		: ('a -> unit) -> 'a vector -> unit = app;
ml_val vector_iterate	: ('a * int -> 'b) -> 'a vector -> 'b vector = iterate;

;;; Arrays

ml_val array_create		: int * '_a -> '_a array = create;
ml_val array_fromlist	: '_a list -> '_a array = fromlist;
ml_val array_fromvector	: '_a vector -> '_a array = copyarray;
ml_val array_tolist		: 'a array -> 'a list = tolist;
ml_val array_tovector	: 'a array -> 'a vector = copyarray;
ml_val array_tabulate	: int * (int -> '_a) -> '_a array = tabulate;
ml_val array_length		: 'a array -> int = datalength;
ml_val array_sub		: 'a array * int -> 'a = sub;
ml_val array_update		: 'a array * int * 'a -> unit = update;
ml_val array_equal		: 'a array * 'a array -> bool = nonop ==;
ml_val array_map		: ('a -> '_b) -> 'a array -> '_b array = map;
ml_val array_app		: ('a -> unit) -> 'a array -> unit = app;
ml_val array_iterate	: ('a * int -> '_b) -> 'a array -> '_b array = iterate;
ml_val array_copy		: '_a array -> '_a array = copyarray;
ml_val array_fill		: 'a array -> 'a -> unit = fillarray;
ml_val array_nc_map		: ('a -> 'a) -> 'a array -> 'a array = nc_map;
ml_val array_nc_iterate	: ('a * int -> 'a) -> 'a array -> 'a array = nc_iterate;

end;	(* structure ArrayImplementation *)
