[MLton] sequences of products

Vesa Karvonen vesa.karvonen@cs.helsinki.fi
Mon, 19 Sep 2005 19:17:35 +0300


Quoting Stephen Weeks <sweeks@sweeks.com>:
> The idea is to representat a product as its destructor function.  That
> is, represent the product of types t1, t2, ..., tn as the type
> 
>   (t1 -> t2 -> ... -> tn -> 'a) -> 'a

That's an interesting idea. I'll have to take a closer look when I have
more time.

[...]
> This representation of products has a couple of advantages over &.
> First, it supports products of length 1.

I'm not sure what you mean here. The ListProduct module that I have in my
utility library allows you to operate on one or more lists at a time. For
example,

  local
     open ListProduct
  in
     val [1,2,3] = map (fn x => x) L[1,2,3] $
  end

should work as expected (unless I made a typo). The implementation isn't
too complex either (see tha values noneMake and someMake below).

The simpler version I published earlier should also allow you to operate on
just one list at a time (unless I made a mistake).

> Second, there is a simple associative operator for appending two
> products. If f represents t1, t2, ..., tn and g represents u1, u2, ...,
> um, then g o f represents t1, t2, ..., tn, u1, u2, ..., um. Furthermore,
> append has a natural unit, namely, the identity function.

I agree that these properties are not as easily available using the
ListProduct approach, but I'm not sure how useful it is to be able to pass
products (of streams) around as first class entities. The point of the
ListProduct module is to make it convenient to perform ad hoc operations
on products of lists. The function that you pass to a ListProduct iterator
usually performs some ad hoc operation that considers all the elements of
the product.

Now that I think about, this reminds me of an experimental Loop module I
wrote after Anton van Straaten compared my Iter module to the Common Lisp
loop macro. The Loop module uses "iterators" (or sequences) of the type

  type ('a, 's) iter = {get: 's -> ('a * 's) option, state: 's}

The streams you are using might be a viable alternative, but I haven't yet
investigated the possiblity. The Loop module provides several operations
intended to simulate features of the Common Lisp loop macro (and others).
Here is a simple example from the unit tests

  ["a1", "b2", "c3"] =
  collect ((inList ["a", "b", "c"] && up 1)
              by (fn s & i =>
                     s ^ Int.toString i))

Here the && combinator creates a "parallel" product iterator (unlike the
cartesian product combinator of the Iter module). The up combinator
creates an iterator of increasing integers. I haven't yet considered ways
to avoid having to use infix declarations in the Loop module (I wrote it
before the Fold revolution).

> The currying is not so concise in SML.  One could use a function
> declaration instead of an anonymous function, but for many situations
> anonymous functions are handy.

Yes. Avoiding currying and the inconvenience of nested pairs was the idea
behind the product type.

> So, I think it's useful to have a family of curry functions C<n> so that
> one can do
>
>   p (Cn (fn (x1, x2, ..., xn) => e))

Using infix &, the above would be written as

    p (fn x1 & x2 & ... & xn => e)

which is slightly more concise and you are relieved from the task of
explictly counting the number of elements.

> The code below implements this idea, with the added bonus that it
> supports all kinds of sequences (arrays, lists, strings, vectors), not
> just lists.

That is a good idea. After reading about this, I added the same capability
to the ListProduct module of my utility lib. I should probably rename the
module (maybe SeqProduct).

Here is how you could translate the examples to use the ListProduct module
from my utility library:

> val () = foreach (P L l $, pi)
  val () = app pi L l $

> val () = foreach (P L l A a $, C2 (fn (i, r) => (pi i; pr r)))
  val () = app (fn i & r => (pi i; pr r)) L l A a $

> map (P A a L l S s V v $, C4 id)
  map p2t4 A a L l S s V v $

where

  val p2t4 = fn v1 & v2 & v3 & v4 => (v1, v2, v3, v4)

> val () = print (concat (rev ("\n" :: (fold (P S s V v $, [], C3 (fn (c, s, ac) => str c :: s :: ac))))))
  val () = print (concat (rev ("\n" :: (foldl (fn c & s & ac => str c :: s :: ac) [] S s V v $))))

Below is a copy-paste of just the signature and structure of the current
ListProduct module library without other modules from my utility lib. You
can't compile it directly, but I'll write a few clarifying comments below.
(Simple copy paste of all the required modules from my utility lib would
be about 3 times longer and it would take some time to trim it down to
just the relevant parts. I intend to publish parts of my utility library
in the future (hopefully within a month). I can prepare a snapshot earlier
if anyone wants it.)

(** Functions for manipulating products of list (as well as arrays,
 * strings, and vectors). This module can be seen as a generalization of
 * the Basis Library module {ListPair}.
 *
 * The functions {appEq}, {foldlEq}, {foldrEq}, {mapEq}, and {zipEq} raise
 * {UnequalLengths} if the lists are not all of equal length. The function
 * {allEq} returns {false} if the lists are not all the same length.
 * Except for {zipEq}, which has no side-effects, it is not specified
 * whether any side-effects are performed before the exception is raised,
 * and the equations illustrating the semantics are to be taken modulo
 * side-effects. If side-effects must not be performed before raising the
 * exception, then you should use {zipEq} and an appropriate function from
 * the {List} module.
 *)
signature LIST_PRODUCT =
   sig
      exception UnequalLengths

      type ('ep, 'sp, 'e, 's, 'epe, 'sps) list_product_st

      (* Below I make use of a couple of type abbreviations:
       *   'a predicate = 'a -> bool
       *   'a effect = 'a -> unit
       *   'a uop = 'a -> 'a
       *)

      val makeCombiner : {full: 'a -> 'b, hd: 'b -> 'c, null: 'b predicate, tl: 'b uop}
                         -> ('d, 'e, 'c, 'b, 'f, 'g) list_product_st * 'h -> 'a
                         -> (('f, 'g, 'i, 'j, ('f, 'i) product, ('g, 'j) product) list_product_st * 'h -> 'k) -> 'k
      (** Makes a new combiner. *)

      val A : ('a, 'b, 'c, 'c ArraySlice.slice, 'd, 'e) list_product_st * 'f -> 'c array
              -> (('d, 'e, 'g, 'h, ('d, 'g) product, ('e, 'h) product) list_product_st * 'f -> 'i) -> 'i
      (** Array combiner. *)

      val L : ('a, 'b, 'c, 'c list, 'd, 'e) list_product_st * 'f -> 'c list
              -> (('d, 'e, 'g, 'h, ('d, 'g) product, ('e, 'h) product) list_product_st * 'f -> 'i) -> 'i
      (** List combiner. *)

      val S : ('a, 'b, char, Substring.substring, 'c, 'd) list_product_st * 'e -> string
              -> (('c, 'd, 'f, 'g, ('c, 'f) product, ('d, 'g) product) list_product_st * 'e -> 'h) -> 'h
      (** String combiner. *)

      val V : ('a, 'b, 'c, 'c VectorSlice.slice, 'd, 'e) list_product_st * 'f -> 'c vector
              -> (('d, 'e, 'g, 'h, ('d, 'g) product, ('e, 'h) product) list_product_st * 'f -> 'i) -> 'i
      (** Vector combiner. *)

      val all : 'a predicate
                -> ((unit, unit, 'b, 'c, 'b, 'c) list_product_st
                    * ('a, 'd, 'e, 'f, 'g, 'h) list_product_st predicate -> 'i) -> 'i
      (** {all p L vs1 ... L vsN $ = List.all p (zip L vs1 ... L vsN $)} *)

      val allEq : 'a predicate
                  -> ((unit, unit, 'b, 'c, 'b, 'c) list_product_st
                      * ('a, 'd, 'e, 'f, 'g, 'h) list_product_st predicate -> 'i) -> 'i
      (** {allEq p L vs1 ... L vsN $ = try (fn () => zipEq L vs1 ... L vsN $, List.all p, const false)} *)

      val app : 'a effect
                -> ((unit, unit, 'b, 'c, 'b, 'c) list_product_st
                    * ('a, 'd, 'e, 'f, 'g, 'h) list_product_st effect -> 'i) -> 'i
      (** {app e L vs1 ... L vsN $ = List.app e (zip L vs1 ... L vsN $)} *)

      val appEq : 'a effect
                  -> ((unit, unit, 'b, 'c, 'b, 'c) list_product_st
                      * ('a, 'd, 'e, 'f, 'g, 'h) list_product_st effect -> 'i) -> 'i
      (** {appEq e L vs1 ... L vsN $ = List.app e (zipEq L vs1 ... L vsN $)} *)

      val exists : 'a predicate
                   -> ((unit, unit, 'b, 'c, 'b, 'c) list_product_st *
                       ('a, 'd, 'e, 'f, 'g, 'h) list_product_st predicate -> 'i) -> 'i
      (** {exists p L vs1 ... L vsN $ = List.exists p (zip L vs1 ... L vsN $)} *)

      val foldl : ('a * 'b -> 'b) -> 'b
                  -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st *
                      (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b) -> 'j) -> 'j
      (** {foldl f r L vs1 ... L vsN $ = List.foldl f r (zip L vs1 ... L vsN $)} *)

      val foldlEq : ('a * 'b -> 'b) -> 'b
                    -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st
                        * (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b) -> 'j) -> 'j
      (** {foldlEq f r L vs1 ... L vsN $ = List.foldl f r (zipEq L vs1 ... L vsN $)} *)

      val foldr : ('a * 'b -> 'b) -> 'b
                  -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st
                      * (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b) -> 'j) -> 'j
      (** {foldlr f r L vs1 ... L vsN $ = List.foldr f r (zip L vs1 ... L vsN $)} *)

      val foldrEq : ('a * 'b -> 'b) -> 'b
                    -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st
                        * (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b) -> 'j) -> 'j
      (** {foldlrEq f r L vs1 ... L vsN $ = List.foldr f r (zipEq L vs1 ... L vsN $)} *)

      val map : ('a -> 'b)
                -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st
                    * (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b list) -> 'j) -> 'j
      (** {map f L vs1 ... L vsN $ = List.map f (zip L vs1 ... L vsN $)} *)

      val mapEq : ('a -> 'b)
                  -> ((unit, unit, 'c, 'd, 'c, 'd) list_product_st
                      * (('a, 'e, 'f, 'g, 'h, 'i) list_product_st -> 'b list) -> 'j) -> 'j
      (** {mapEq f L vs1 ... L vsN $ = List.map f (zipEq L vs1 ... L vsN $)} *)

      val zip : ((unit, unit, 'a, 'b, 'a, 'b) list_product_st
                 * (('c, 'd, 'e, 'f, 'g, 'h) list_product_st -> 'c list) -> 'i) -> 'i
      (** Converts a product of lists into a list of products. Excess
       * elements are ignored. For example, {
       *   zip L[1, 2, 3] L[true, false] L["a", "b", "c"] $ =
       *     [1 & true & "a", 2 & false & "b"] } .
       *)

      val zipEq : ((unit, unit, 'a, 'b, 'a, 'b) list_product_st
                   * (('c, 'd, 'e, 'f, 'g, 'h) list_product_st -> 'c list) -> 'i) -> 'i
      (** Converts a product of equal length lists into a list of
       * products. Raises {UnequalLengths} if the lists are not all of
       * equal length.
       *)
   end

structure ListProduct :> LIST_PRODUCT =
   struct
      exception UnequalLengths = ListPair.UnequalLengths

      datatype ('ep, 'sp, 'e, 's, 'epe, 'sps) list_product_st =
               T of {allNull: 'sp predicate,
                     existsNull: 'sp predicate,
                     hd: 'sp -> 'ep,
                     ls: 'sp,
                     tl: 'sp uop} *
                    {allNull: ('sp predicate, 's predicate) product -> 'sps predicate,
                     existsNull: ('sp predicate, 's predicate) product -> 'sps predicate,
                     hd: ('sp -> 'ep, 's -> 'e) product -> 'sps -> 'epe,
                     ls: ('sp, 's) product -> 'sps,
                     tl: ('sp uop, 's uop) product -> 'sps uop}

      local
         local
            open Product
         in
            val noneMake = {allNull = snd, existsNull = snd, hd = snd, ls = snd, tl = snd}
            val someMake = {allNull = all, existsNull = exists, hd = map, ls = id, tl = map}

            (* The functions {snd} (projection), {all}, {exists}, and
             * {map} come from the {Product} module. {all}, {exists}, and
             * {map} are higher-order functions used to build functions on
             * products. I'm using one "make" function for each element of
             * the product, because is straightforward and avoids problems
             * with lack of first-class polymorphism.
             *)
         end

         fun listFn f =
             Fold.fold (T ({allNull = thunk true, (* thunk x = fn () => x *)
                            existsNull = thunk true,
                            hd = thunk (),
                            ls = (),
                            tl = thunk ()},
                           noneMake),
                        f)

         fun all' kf p (T ({allNull, existsNull, hd, ls, tl}, _)) =
             let
                fun lp ls =
                    if existsNull ls then
                       if allNull ls then
                          true
                       else
                          kf ()
                    else
                       p (hd ls) andalso lp (tl ls)
             in
                lp ls
             end

         fun foldl' kf f i (T ({allNull, existsNull, hd, ls, tl}, _)) =
             let
                fun lp (r, ls) =
                    if existsNull ls then
                       if allNull ls then
                          r
                       else
                          kf r
                    else
                       lp (f (hd ls, r), tl ls)
             in
                lp (i, ls)
             end

         fun rev' kf t =
             foldl' kf op:: [] t
      in
         fun makeCombiner {full, null, hd, tl} =
             Fold.step1 (fn (l, T (t, m)) =>
                            T ({allNull = #allNull m (#allNull t & null),
                                existsNull = #existsNull m (#existsNull t & null),
                                hd = #hd m (#hd t & hd),
                                ls = #ls m (#ls t & full l),
                                tl = #tl m (#tl t & tl)},
                               someMake))

         fun A $ = makeCombiner
                      let open ArraySlice in
                         {full = full,
                          null = isEmpty,
                          hd = #1 o valOf o getItem,
                          tl = #2 o valOf o getItem}
                      end $
         fun L $ = makeCombiner {full = id, null = null, hd = hd, tl = tl} $
         fun S $ = makeCombiner
                      let open Substring in
                         {full = full,
                          null = isEmpty,
                          hd = #1 o valOf o getc,
                          tl = #2 o valOf o getc}
                      end $
         fun V $ = makeCombiner
                      let open VectorSlice in
                         {full = full,
                          null = isEmpty,
                          hd = #1 o valOf o getItem,
                          tl = #2 o valOf o getItem}
                      end $

         fun all p = listFn (all' (const true) p)
         fun allEq p = listFn (all' (const false) p)

         fun app f = listFn (foldl' id (f o Pair.fst) ())
         fun appEq f = listFn (foldl' (fail UnequalLengths) (f o Pair.fst) ())

         fun exists p = listFn (not o all' (const true) (not o p))

         fun foldl f i = listFn (foldl' id f i)
         fun foldlEq f i = listFn (foldl' (fail UnequalLengths) f i)

         fun foldr f i = listFn (List.foldl f i o rev' id)
         fun foldrEq f i = listFn (List.foldl f i o rev' (fail UnequalLengths))

         fun map f = listFn (rev o foldl' id (op:: o Pair.map (f, id)) [])
         fun mapEq f = listFn (rev o foldl' (fail UnequalLengths) (op:: o Pair.map (f, id)) [])

         fun zip $ = map id $
         fun zipEq $ = mapEq id $
      end
   end