Generating permutations in OCaml

Question

open Core.Std;;
let print aofa =
 let s1 = ( Array.length aofa ) - 1 in
 for i = 0 to s1 do
 for j = 0 to (Array.length aofa.(i)) - 1 do
 printf "%d " aofa.(i).(j);
 done;
 printf "\n";
 done;
;;
let rec fact i =
 if i <= 1 then 1 else i * fact (i - 1)
;;
let rec permutations ints =
 let length = Array.length ints in
 if length < 2 then
 [|ints|]
 else begin
 let total = fact length in
 let result = Array.create total (Array.create length 0) in
 for i = 0 to total - 1 do
 result.(i) <- Array.create length 0
 done;
 let block_size = total / length in
 for i = 1 to length do
 let rest = Array.append (Array.sub ints 0 (i - 1)) (Array.sub ints i (length - i)) in
 let rights = permutations rest in
 for r = 0 to (Array.length rights) - 1 do
 let n = Array.append [|Array.get ints (i - 1) |] rights.(r) in
 result.((i - 1) * block_size + r) <- n
 done;
 done;
 result
 end
;;
let () =
 let aofa = permutations [|1; 2; 3|] in
 print aofa;
;;

And result:

1 2 3 
1 3 2 
2 1 3 
2 3 1 
3 1 2 
3 2 1 

As the first step, I wrote this naive implementation in python and then translated it into OCaml:

def permutations(s):
 if len(s) > 1:
 for i, v in enumerate(s):
 for p in permutations(s[0: i] + s[i+1:]):
 yield [v] + p
 else:
 yield s
def main():
 for p in permutations([1, 2, 3]):
 print(p)
if __name__ == '__main__':
 main()

Answer 1

Your code is totally imperative. In some cases (probably in most) it's faster, but this not the best way to use OCaml :) Here is my solution in functional style:

Printing the list of lists can be done by iterating over list of lists:

let print lst =
 List.iter (fun l ->
 List.map string_of_int l
 |> String.concat " "
 |> print_endline
 ) lst

Next recursive function does:

• Selects head element of the list and makes it heading element of the resulting list
• Recursively calls itself on the list of all previous elements (minus resulting subset) + tail.

let rec permutations result other = function
 | [] -> [result]
 | hd :: tl ->
 let r = permutations (hd :: result) [] (other @ tl) in
 if tl <> [] then
 r @ permutations result (hd :: other) tl
 else
 r

All together. Initial result is empty and the stored list of previous elements is also empty:

let () =
 permutations [] [] [1; 2; 3]
 |> print

• grigoriytretyakov: My code is first try to write something longer than "hello world" in OCaml, so I was happy to see it works :) Thanks for your review!
• grigoriytretyakov: Btw, how works "@"?
• Evgenii Lepikhin: "@" concatenates two lists, see pervasives.mli in OCaml library. E.g.: [1; 2] @ [3; 4] → [1; 2; 3; 4] This is not tail-recursive and has complexity O(n) so actually you should use it carefully.
• grigoriytretyakov: May be Array more suitable in this case, than List?
• Chris: Suggestion: for your print function, look at Format.pp_print_list

Answer 2

Code style

An OCaml style suggestion: utilize the Format module. For instance, we can use it to implement your function to print an array of arrays.

let print aofa =
 Format.(
 let pp_print_one_space fmt () = fprintf fmt " " in
 let pp_print_int_array fmt arr = 
 fprintf fmt "%a" (pp_print_array ~pp_sep: pp_print_one_space pp_print_int) arr
 in
 printf "%a\n" (pp_print_array ~pp_sep: pp_print_newline pp_print_int_array) aofa
 )

Further, you have unnecessary ; and ;; tokens, and parentheses.

The ; token is an expression seperator and not a terminator as in languages like C, C++, Java, etc. E.g.

let print aofa =
 let s1 = ( Array.length aofa ) - 1 in
 for i = 0 to s1 do
 for j = 0 to (Array.length aofa.(i)) - 1 do
 printf "%d " aofa.(i).(j);
 done;
 printf "\n";
 done;

Can be written as follows, because only one ; is separating expressions.

let print aofa =
 let s1 = ( Array.length aofa ) - 1 in
 for i = 0 to s1 do
 for j = 0 to (Array.length aofa.(i)) - 1 do
 printf "%d " aofa.(i).(j)
 done;
 printf "\n"
 done

Parentheses are not needed in the above either as function application has higher precedence than binary -.

It actually has higher precedence than almost everything.

let print aofa =
 let s1 = Array.length aofa - 1 in
 for i = 0 to s1 do
 for j = 0 to Array.length aofa.(i) - 1 do
 printf "%d " aofa.(i).(j)
 done;
 printf "\n"
 done

Throughout your code you use ;; to separate/terminate top-level definitions, but you (correctly, kudos!) have only top-level definitions which makes your OCaml program well-formed, so all instances of ;; are extraneous.

Overall approach

Let's approach this from an immutability standpoint, so we'll substitute arrays for lists.

Fundamentally we can generate permutations by inserting each element of a list into each position of the list formed by the other elements of the list. For a list like [1; 2; 3; 4] the sets of data are:

1, [2; 3; 4]
2, [1; 3; 4]
3; [1; 2; 4]
4; [1; 2; 3] 

If we insert the first number into each position of the remaining list we get:

[[1; 2; 3; 4]; [2; 1; 3; 4]; [2; 3; 1; 4]; [2; 3; 4; 1]]
[[2; 1; 3; 4]; [1; 2; 3; 4]; [1; 3; 2; 4]; [1; 3; 4; 2]]
[[3; 1; 2; 4]; [1; 3; 2; 4]; [1; 2; 3; 4]; [1; 2; 4; 3]]
[[4; 1; 2; 3]; [1; 4; 2; 3]; [1; 2; 4; 3]; [1; 2; 3; 4]]

If we flatten this list:

[[1; 2; 3; 4]; [2; 1; 3; 4]; [2; 3; 1; 4]; [2; 3; 4; 1];
 [2; 1; 3; 4]; [1; 2; 3; 4]; [1; 3; 2; 4]; [1; 3; 4; 2];
 [3; 1; 2; 4]; [1; 3; 2; 4]; [1; 2; 3; 4]; [1; 2; 4; 3];
 [4; 1; 2; 3]; [1; 4; 2; 3]; [1; 2; 4; 3]; [1; 2; 3; 4]]

And then we sort it:

[[1; 2; 3; 4]; [1; 2; 3; 4]; [1; 2; 3; 4]; [1; 2; 3; 4];
 [1; 2; 4; 3]; [1; 2; 4; 3]; [1; 3; 2; 4]; [1; 3; 2; 4];
 [1; 3; 4; 2]; [1; 4; 2; 3]; [2; 1; 3; 4]; [2; 1; 3; 4];
 [2; 3; 1; 4]; [2; 3; 4; 1]; [3; 1; 2; 4]; [4; 1; 2; 3]]

We can clearly see the repeats. Eliminating those:

[[1; 2; 3; 4]; 
 [1; 2; 4; 3]; [1; 3; 2; 4]; 
 [1; 3; 4; 2]; [1; 4; 2; 3]; [2; 1; 3; 4]; 
 [2; 3; 1; 4]; [2; 3; 4; 1]; [3; 1; 2; 4]; [4; 1; 2; 3]]

Zipper

A zipper data structure is useful for generating all of those initial sets of data, since it keeps track of the head and tail for any position within a list by means of a back and forward list, making bidirectional traversal of a singly linked list efficient.

module Zipper = struct
 type 'a t = 'a list * 'a list
 type end_t = Front | Back
 exception At_end of end_t
 
 let of_list lst = ([], lst)
 let to_list (b, f) = List.rev b @ f
 let advance = function
 | (_, []) -> raise (At_end Back)
 | (b, x::xs) -> (x::b, xs) 
 
 (* I won't really use this, but if you wanted 
 * bi-directional traversal... *) 
 let rewind = function
 | ([], _) -> raise (At_end Front)
 | (x::xs, f) -> (xs, x::f)
 let insert v (b, f) = (b, v::f)
end

We can now readily get a sequence of all zippers for a list.

let list_to_zipper_fwd_seq lst =
 let rec aux z () =
 match z with 
 | (_, []) -> Seq.Nil
 | (_, _) -> Seq.Cons (z, aux (Zipper.advance z))
 in
 lst |> Zipper.of_list |> aux

Testing this:

# [1; 2; 3; 4]
 |> list_to_zipper_fwd_seq
 |> List.of_seq;;
- : (int list * int list) list =
[([], [1; 2; 3; 4]); ([1], [2; 3; 4]); ([2; 1], [3; 4]);
 ([3; 2; 1], [4])]

And once we have this sequence we can get individual elements of the list and the remaining list (both ahead of and behind that element.

# [1; 2; 3; 4]
 |> list_to_zipper_fwd_seq
 |> Seq.map (fun (b, f) -> List.(hd f, rev_append b (tl f)))
 |> List.of_seq;;
- : (int * int list) list =
[(1, [2; 3; 4]); (2, [1; 3; 4]); (3, [1; 2; 4]); (4, [1; 2; 3])]

We can further use this zipper data structure to insert an element at each position in a list.

let insert_at_each_position_z v z =
 Zipper.(
 let rec aux z =
 let cur = z |> insert v |> advance in
 let rest = try aux (advance z) with At_end _ -> [] in
 cur :: rest
 in
 aux z
 )

This will yield a list of zippers. E.g.

# [2; 3; 4]
 |> Zipper.of_list
 |> insert_at_each_position_z 1;;
- : (int list * int list) list =
[([1], [2; 3; 4]); ([1; 2], [3; 4]); ([1; 3; 2], [4]);
 ([1; 4; 3; 2], [])]

We can get back to a list of lists:

# [2; 3; 4]
 |> Zipper.of_list
 |> insert_at_each_position_z 1
 |> List.map Zipper.to_list;;
- : int list list =
[[1; 2; 3; 4]; [2; 1; 3; 4]; [2; 3; 1; 4]; [2; 3; 4; 1]]

Putting this all together, List.sort_uniq removes the duplicates.

let permutations lst =
 lst 
 |> list_to_zipper_fwd_seq
 |> Seq.map (fun (b, f) -> List.(hd f, rev_append b (tl f)))
 |> Seq.map (fun (x, xs) -> 
 xs 
 |> Zipper.of_list 
 |> insert_at_each_position_z x 
 |> List.map Zipper.to_list)
 |> List.of_seq
 |> List.flatten
 |> List.sort_uniq compare

The key take away here is breaking the problem down into manageable chunks, which is reflected in the final function. The list is transformed step-by-step into a list of permutations, which is nicely illustrated by the OCaml |> operator.