DouKaku?beta

challenge 魔方分割数

1 .. N^2までの数をN個の数字の和が等しいN個のグループに分けたいと思います。

たとえば、N=3のときは、
(1) { 1, 5, 9 }, { 2, 6, 7 }, { 3, 4, 8 } 
(2) { 1, 6, 8 }, { 2, 4, 9 }, { 3, 5, 7 }
の2通りの方法があります。

ここで指定されたNに対して、何通りのグループ分けの方法があるかを数えるプログラムを作ってください。
(何通りかという値だけが出力されればよいのですが、予め計算してある結果を返すのはダメですよ。)
また、N=5を指定したときの実行時間もあわせて教えてください。

なお、数え上げるときの注意として、

・{ 1, 5, 9 } と { 1, 9, 5 }は同じもの

・{ 1, 5, 9 }, { 2, 6, 7 }, { 3, 4, 8 }と
　{ 1, 5, 9 }, { 3, 4, 8 }, { 2, 6, 7 }は同じもの
とすることに注意してください。
post comment

Posted feedbacks - OCaml

それなりの工夫はしたつもりだけど、それでも超遅い...orz
答が合ってるのかすら心配。

Mac OS X 10.5 / PPC G5/1.6GHz mem 1GB な環境で、

% time ./numbers.native 4
n = 4 => 151 patterns
./numbers.native 4  0.03s user 0.01s system 27% cpu 0.141 total

n = 5 は 5 分くらい待っても終わらなかったのであきらめた。
方針としては、

* 各セットの合計は 1 ~ n までの合計を n で割ったものになるので、そうなる組み合わせを生成
* 先頭が 1 ~ n のものが並ぶはずなので、そこまでしか計算しない
* OCaml の Set モジュールは整列済みなので、それを利用して多少枝刈りしているつもり

といった感じ。
n = 5 が終わらないのは、メモリ使用量の問題もありそうなので、完全なセットを作ってしまわずに逐次表示するようなアプローチにすれば、もう少し何とかなるかも。

でももう頭がパンクしそうなので、とりあえずこれで。 
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
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 ()

和が N*(N^2+1)/2 になる組み合わせを昇順に列挙して交わらないものを探す。nido さんの #4819 と同じ方針かな？

5 のときは 20 分かかって答えが出ました。 3245664 だそうです。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
(* list solutions of
     x1+...+xn=m
     1<=x1<...<xn<=l *)
let list_solutions m n k =
  let rec loop m n lbd tail =
    if m < n || m < lbd then []
    else if n = 1 then
      if lbd <= m && m <= k then [m::tail] else []
    else
      let acc = ref [] in
        for i = lbd to (min (m-n+1) k) do
          acc :=
            List.map (fun sols -> i::sols)
              (loop (m-i) (n-1) (i+1) tail) :: !acc
        done;
        List.concat !acc
  in loop m n 1

let rec disjoint xs ys =
  match xs, ys with
    | [], _ | _, [] -> true
    | x::xs', y::ys' ->
        if x > y then disjoint xs ys'
        else if x < y then disjoint xs' ys
        else false

let (@<) = List.merge compare

let rec count_choices n lists ex =
  if n = 1 then
    List.fold_left (fun i x -> if disjoint x ex then i+1 else i) 0 lists
  else
    match lists with
      | [] -> 0
      | x::rest ->
          let b = count_choices n rest ex in
            if disjoint x ex then
              b + count_choices (n-1) rest (x@<ex)
            else
              b

let count_partitions n =
  count_choices n (list_solutions (n * (n*n + 1) / 2) n (n*n) []) []

let _ = print_int (count_partitions 5); exit 0

出題者です。

私の用意した方法も#4835 minkeさんと同じ戦略で、ビットマスクを使うことを想定していました。
(ビットマスクを使っていない#4833 kozimaさんの方法が意外に速くて驚きました。)

それ以外は特に凝ったことはしていませんが、OCamlの再帰とmallocのコストが低いおかげで、2秒くらいで答えが出ました。

[xsd@celldev dk108]$ time ./dk108 5
3245664

real    0m2.056s
user    0m2.054s
sys     0m0.002s 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
let magic n =
    let m mask a = mask lor (1 lsl (a-1)) in
    let rec loop n r c mask acc =
        if c = 0 || r > (n*c-(n*(n-1)/2)) then acc else (
            if n = 1 then (
                if r <= c then (m mask r) :: acc else acc
            ) else (
                let x = r - c in
                let acc =
                    if x > 0 then
                        loop (n-1) x (min (c-1) x) (m mask c) acc
                    else
                        acc in
                loop n r (c-1) mask acc
            )
        ) in
    let rec filter mask acc = function
        | [] -> acc
        | hd :: tl -> filter mask (if (hd land mask) <> 0 then acc else hd :: acc) tl in

    let rec search n mask acc = function
        | []        -> acc
        | hd :: tl  ->
            if (mask land hd) <> 0 then
                let tl = if n > 1 then filter mask [] tl else tl in
                    search n mask acc tl
            else (
                if n = 1 then
                    acc + 1
                else (
                    let acc = search (n-1) (mask lor hd) acc tl in
                    search n mask acc tl
                )
            ) in
    search n 0 0 (loop n (n*(n*n+1)/2) (n*n) 0 [])

let _ = Printf.printf "%d\n" (magic (int_of_string Sys.argv.(1)))

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]