DouKaku?

module NS = Set.Make(
struct
   type t = int
   let compare = Pervasives.compare
end)

module SS = Set.Make(
struct
   type t = NS.t
   let compare = NS.compare
end)

module LS = Set.Make(
struct
   type t = SS.t
   let compare = SS.compare
end)

let make_set_with_sum n =
   let rec loop set sum = function
      | 0  -> (set, sum)
      | n' -> loop (NS.add n' set) (sum + n') (n' - 1)
   in
   loop NS.empty 0 n

let ns_map f ns = NS.fold (fun s acc -> NS.add (f s) acc) ns NS.empty
let ss_map f ss = SS.fold (fun s acc -> SS.add (f s) acc) ss SS.empty
let ls_map f ls = LS.fold (fun s acc -> LS.add (f s) acc) ls LS.empty

let rec take_subsets set num limit =
   if NS.is_empty set || NS.cardinal set < num || NS.choose set > limit
   then SS.empty
   else begin
      match num with
      | 1 ->
           if NS.mem limit set
           then SS.singleton (NS.singleton limit)
           else SS.empty
      | n when n > 1 ->
           let result = ref SS.empty in
           NS.iter begin fun i ->
              let set' = NS.remove i set in
              let num' = num - 1 in
              let limit' = limit - i in
              begin match take_subsets set' num' limit' with
              | s when SS.is_empty s -> ()
              | ss -> result := SS.union !result (ss_map (NS.add i) ss)
              end
           end set;
           !result
      | _ -> invalid_arg "num is required positive number."
   end

let make_sets n =
   if n < 2 then invalid_arg "required greater than or equal to 2.";
   let full, max = make_set_with_sum (n * n) in
   let heads, _  = make_set_with_sum n in
   let diff  = NS.diff full heads in
   let limit = max / n in
   let subsets =
      NS.fold begin fun i acc ->
         LS.add
            (ss_map (NS.add i) (take_subsets diff (n - 1) (limit - i)))
            acc
      end heads LS.empty
   in
   let inters =
      let hd = LS.choose subsets in
      let tl = LS.remove hd subsets in
      LS.fold begin fun ss acc ->
         let result = ref LS.empty in
         LS.iter begin fun ss' ->
            SS.iter begin fun ns ->
               if SS.for_all (fun s -> NS.is_empty (NS.inter s ns)) ss'
               then result := LS.add (SS.add ns ss') !result
            end ss
         end acc;
         !result
      end tl (SS.fold (fun e acc -> LS.add (SS.singleton e) acc) hd LS.empty)
   in
   inters

let ns_print ns =
   print_string "{ ";
   NS.iter (Printf.printf "%d, ") ns;
   print_string "}"
let ss_print ss =
   SS.iter begin fun s ->
      ns_print s;
      print_string ", "
   end ss;
   print_newline ()
let ls_print ls = LS.iter ss_print ls

let exam n = LS.cardinal (make_sets n)

let main () =
   let num =
      match Sys.argv with
      | [|_; n |] -> int_of_string n
      | _ -> 3
   in
   Printf.printf "n = %d => %d patterns\n" num (exam num)
let () = if not !Sys.interactive then main ()