More volatile sequence than "classical"

Question

For cartesian production there is a good enough function - sequence which defined like that:

let rec sequence = function 
  | []      -> Seq.singleton [] 
  | (l::ls) -> seq { for x in l do for xs in sequence ls do yield (x::xs) } 

but look at its result:

sequence [[1..2];[1..10000]] |> Seq.skip 1000 ;; val it : seq = seq [[1; 1001]; [1; 1002]; [1; 1003]; [1; 1004]; ...]

As we can see the first "coordinate" of the product alters very slowly and it will change the value when the second list is ended.

I wrote my own sequence as following (comments below):

/// Sum of all producted indeces = n
let rec hyper'plane'indices indexsum maxlengths =
    match maxlengths with 
    | [x]        -> if indexsum < x then [[indexsum]] else []
    | (i::is)   -> [for x in [0 .. min indexsum (i-1)] do for xs in hyper'plane'indices (indexsum-x) is do yield (x::xs)]
    | []        -> [[]]

let finite'sequence = function
    | [] -> Seq.singleton []
    | ns -> 
        let ars = [ for n in ns -> Seq.toArray n ]
        let length'list = List.map Array.length ars
        let nmax = List.max length'list
        seq { 
            for n in [0 .. nmax] do 
            for ixs in hyper'plane'indices n length'list do 
                yield (List.map2 (fun (a:'a[]) i -> a.[i]) ars ixs) 
        } 

The key idea is to look at (two) lists as at (two) orthogonal dimensions where every element marked by its index in the list. So we can enumerate all elements by enumerating every element in every section of cartesian product by hyper plane (in 2D case this is a line). In another words imagine excel's sheet where first column contains values from [1;1] to [1;10000] and second - from [2;1] to [2;10000]. And "hyper plane" with number 1 is the line that connects cell A2 and cell B1. For the our example

hyper'plane'indices 0 [2;10000];; val it : int list list = [[0; 0]]
hyper'plane'indices 1 [2;10000];; val it : int list list = [[0; 1]; [1; 0]]
hyper'plane'indices 2 [2;10000];; val it : int list list = [[0; 2]; [1; 1]]
hyper'plane'indices 3 [2;10000];; val it : int list list = [[0; 3]; [1; 2]]
hyper'plane'indices 4 [2;10000];; val it : int list list = [[0; 4]; [1; 3]]

Well if we have indeces and arrays that we are producing from the given lists than we can now define sequence as {all elements in plane 0; than all elements in plane 1 ... and so on } and get more volatile function than original sequence.

But finite'sequence turned out very gluttonous function. And now the question. How I can improve it?

With best wishes, Alexander. (and sorry for poor English)

Answer 1

Can you explain what exactly is the problem - time or space complexity or performance? Do you have a specific benchmark in mind? I am not sure how to improve on the time complexity here, but I edited your code a bit to remove the intermediate lists, which might help a bit with memory allocation behavior.

Do not do this:

for n in [0 .. nmax] do

Do this instead:

for n in 0 .. nmax do

Here is the code:

let rec hyper'plane'indices indexsum maxlengths =
    match maxlengths with
    | [] -> Seq.singleton []
    | [x] -> if indexsum < x then Seq.singleton [indexsum] else Seq.empty
    | i :: is ->
        seq {
            for x in 0 .. min indexsum (i - 1) do
                for xs in hyper'plane'indices (indexsum - x) is do
                    yield x :: xs
        }

let finite'sequence xs =
    match xs with
    | [] -> Seq.singleton []
    | ns -> 
        let ars = [ for n in ns -> Seq.toArray n ]
        let length'list = List.map Array.length ars
        let nmax = List.max length'list
        seq {
            for n in 0 .. nmax do
                for ixs in hyper'plane'indices n length'list do
                    yield List.map2 Array.get ars ixs
        }

Does this fare any better? Beautiful problem by the way.

UPDATE: Perhaps you are more interested to mix the sequences fairly than in maintaining the exact formula in your algorithm. Here is a Haskell code that mixes a finite number of possibly infinite sequences fairly, where fairness means that for every input element there is a finite prefix of the output sequence that contains it. You mention in the comment that you have a 2D incremental solution that is hard to generalize to N dimensions, and the Haskell code does exactly that:

merge :: [a] -> [a] -> [a]
merge [] y          = y
merge x []          = x
merge (x:xs) (y:ys) = x : y : merge xs ys

prod :: (a -> b -> c) -> [a] -> [b] -> [c]
prod _ [] _ = []
prod _ _ [] = []
prod f (x:xs) (y:ys) = f x y : a `merge` b `merge` prod f xs ys where
  a = [f x y | x <- xs] 
  b = [f x y | y <- ys]

prodN :: [[a]] -> [[a]]
prodN []     = [[]]
prodN (x:xs) = prod (:) x (prodN xs)

I have not ported this to F# yet - it requires some thought as sequences do not match to head/tail very well.

UPDATE 2:

A fairly mechanical translation to F# follows.

type Node<'T> =
    | Nil
    | Cons of 'T * Stream<'T>

and Stream<'T> = Lazy<Node<'T>>

let ( !! ) (x: Lazy<'T>) = x.Value
let ( !^ ) x = Lazy.CreateFromValue(x)

let rec merge (xs: Stream<'T>) (ys: Stream<'T>) : Stream<'T> =
    lazy
    match !!xs, !!ys with
    | Nil, r | r, Nil -> r
    | Cons (x, xs), Cons (y, ys) -> Cons (x, !^ (Cons (y, merge xs ys)))

let rec map (f: 'T1 -> 'T2) (xs: Stream<'T1>) : Stream<'T2> =
    lazy
    match !!xs with
    | Nil -> Nil
    | Cons (x, xs) -> Cons (f x, map f xs)

let ( ++ ) = merge

let rec prod f xs ys =
    lazy
    match !!xs, !!ys with
    | Nil, _ | _, Nil -> Nil
    | Cons (x, xs), Cons (y, ys) ->
        let a = map (fun x -> f x y) xs
        let b = map (fun y -> f x y) ys
        Cons (f x y, a ++ b ++ prod f xs ys)

let ofSeq (s: seq<'T>) =
    lazy
    let e = s.GetEnumerator()
    let rec loop () =
        lazy
        if e.MoveNext()
            then Cons (e.Current, loop ())
            else e.Dispose(); Nil
    !! (loop ())

let toSeq stream =
    stream
    |> Seq.unfold (fun stream ->
        match !!stream with
        | Nil -> None
        | Cons (x, xs) -> Some (x, xs))

let empty<'T> : Stream<'T> = !^ Nil
let cons x xs = !^ (Cons (x, xs))
let singleton x = cons x empty

let rec prodN (xs: Stream<Stream<'T>>) : Stream<Stream<'T>> =
    match !!xs with
    | Nil -> singleton empty
    | Cons (x, xs) -> prod cons x (prodN xs)

let test () =
    ofSeq [
        ofSeq [1; 2; 3]
        ofSeq [4; 5; 6]
        ofSeq [7; 8; 9]
    ]
    |> prodN
    |> toSeq
    |> Seq.iter (fun xs ->
        toSeq xs
        |> Seq.map string
        |> String.concat ", "
        |> stdout.WriteLine)