[MLton] A Vector/Fold challenge

[Stephen Weeks]

> This has been itching me for a few weeks, and while I'm certain I
> would learn more by doing it myself, it will probably come pretty
> easy to the master Fold-ers.

My solution is at the end of this message.  I didn't use fold; more
important is the inductive construction of the sub and update
functions for products of vectors.  One could throw fold on top to
build the "numbers" more concisely, but I'm not sure it's necessary
here.

To make things effecient, I needed an improved version of
MLton.Vector.create with the following signature.

  val create: int -> {done: unit -> 'a vector,
                      sub: int -> 'a,
                      update: int * 'a -> unit}

The problem with the old version is that it controlled the stack,
which made it impossible to create several vectors simultaneously, and
was needed to do this well.  Here's the implementation (inside the
basis) for the new create.

------------------------------------------------------------
      fun create n =
         let
            val a = Primitive.Array.array n
            val subLim = ref 0
            fun sub i =
               if Primitive.safe andalso Primitive.Int.geu (i, !subLim) then
                  raise Subscript
               else
                  Primitive.Array.sub (a, i)
            val updateLim = ref 0
            fun update (i, x) =
               if Primitive.safe andalso Primitive.Int.geu (i, !updateLim) then
                  if i = !updateLim andalso Primitive.Int.< (i, n) then
                     (Primitive.Array.update (a, i, x);
                      subLim := i + 1;
                      updateLim := i + 1)
                  else
                     raise Subscript
               else
                  Primitive.Array.update (a, i, x)
            val gotIt = ref false
            fun done () =
               if !gotIt then
                  raise Fail "already got vector"
               else
                  if n = !updateLim then
                     (gotIt := true;
                      updateLim := 0;
                      fromArray a)
                  else
                     raise Fail "vector not full"
         in
            {done = done,
             sub = sub,
             update = update}
         end
------------------------------------------------------------

I propose to replace the current MLton.Vector.create with this one, as
it is strictly more powerful.

Here's the solution.  Let me know if it doesn't make sense.

--------------------------------------------------------------------------------
datatype ('a, 'b) prod = & of 'a * 'b
infix &
   
(* Uncomment the following to test in SML/NJ *)
(* structure MLton =
 *    struct
 *       structure Vector =
 *          struct
 *             val create: int -> {done: unit -> 'a vector,
 *                                 sub: int -> 'a,
 *                                 update: int * 'a -> unit} =
 *                fn _ => raise Fail "MLton.Vector.create"
 *          end
 *    end
 *)
structure Int =
   struct
      fun for (start, stop, f) =
         let
            fun loop i = if i = stop then () else (f i; loop (i + 1))
         in
            loop start
         end
   end

structure VectorMap =
   struct
      datatype ('a, 'b, 'c, 'd) t =
         T of {create: int -> {done: unit -> 'a,
                               update: int * 'b -> unit},
               size: 'c -> int,
               sub: 'c * int -> 'd}

      fun more (make: unit -> ('a, 'b, 'c, 'd) t) () =
         let
            val T {create, size, sub} = make ()
            val create =
               fn n =>
               let
                  val {done = d1, update = u1} = create n
                  val {done = d2, update = u2, ...} = MLton.Vector.create n
               in
                  {done = fn () => d1 () & d2 (),
                   update = fn (i, x1 & x2) => (u1 (i, x1); u2 (i, x2))}
               end
            val size = fn vs & v =>
               let
                  val n = Vector.length v
                  val n' = size vs
               in
                  if n = n' then
                     n
                  else
                     raise Fail "vectors of different sizes"
               end
            val sub = fn (vs & v, i) => sub (vs, i) & Vector.sub (v, i)
         in
            T {create = create,
               size = size,
               sub = sub}
         end

      fun one () =
         let
            fun create i =
               let
                  val {done, update, ...} = MLton.Vector.create i
               in
                  {done = done,
                   update = update}
               end
         in
            T {create = create,
               size = Vector.length,
               sub = Vector.sub}
         end

      fun two () = more one ()
      fun three () = more two ()

      fun mapNtoM (vs, n, m, f) =
         let
            val T {size, sub, ...} = n ()
            val T {create, ...} = m ()
            val n = size vs
            val {done, update} = create n
            val () = Int.for (0, n, fn i => update (i, f (sub (vs, i))))
         in
            done ()
         end
   end

val v1 = Vector.tabulate (10, fn i => i)
val v2 = Vector.tabulate (10, fn i => 2 * i)
 
val va & vb & vc =
   VectorMap.mapNtoM
   (v1 & v2, VectorMap.two, VectorMap.three,
    fn x & y => (x + y) & (x * y) & (chr x))