6
\$\begingroup\$ 
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()
\$\endgroup\$

2 Answers 2

Reset to default
5
\$\begingroup\$

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
\$\endgroup\$
5
  • \$\begingroup\$ 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! \$\endgroup\$ Commented Apr 11, 2016 at 8:46
  • \$\begingroup\$ Btw, how works "@"? \$\endgroup\$ Commented Apr 11, 2016 at 8:49
  • \$\begingroup\$ "@" 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. \$\endgroup\$ Commented Apr 11, 2016 at 10:48
  • \$\begingroup\$ May be Array more suitable in this case, than List? \$\endgroup\$ Commented Apr 11, 2016 at 11:30
  • \$\begingroup\$ Suggestion: for your print function, look at Format.pp_print_list \$\endgroup\$ Commented Sep 29, 2024 at 6:14
3
\$\begingroup\$

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.

\$\endgroup\$

You must log in to answer this question.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.