DouKaku?beta

challenge 正しい文(クイズ) 

「この文は0が□個，1が□個，...，9が□個あります」
が正しくなるように□を埋めてください．数値は10進数とします．
一般のn(<=16で可)進数でも解いてみてください．

たとえば2進数なら
「この文は0が11個，1が100個あります」
となります．
post comment

Posted feedbacks - Flatten

Nested Hidden

こんなんでも、一応題意は満たすかな・・・ （それとも、2を使うなら0,1も使わないとだめ？）

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
# coding: cp932

def solve(n):
    assert n >= 2
    if n == 2:
        print u"この文は0が11個，1が100個あります"
    else:
        print u"この文は2が2個あります"

def main():
    solve(2)
    solve(10)

if __name__ == '__main__':
    main()


うーん，
10進数のときは
「この文は
  0が□個，
  1が□個，
  2が□個，
  3が□個，
  4が□個，
  5が□個，
  6が□個，
  7が□個，
  8が□個，
  9が□個あります」
の省略形のつもりだったのですが，そうとれちゃいますかね．
もちろんn進数の場合は0からn-1までの数値は少なくとも一つ文中に登場します．


とりあえず乱暴な方法だけど2進から16進まで一つずつ答えを得た。

この文は0が11個,1が100個あります。
この文は0が1個,1が11個,2が2個あります。
この文は0が1個,1が11個,2が2個,3が1個あります。
...
この文は0が1個,1が11個,2が2個,3が1個,4が1個,5が1個,6が1個,7が1個,8が1個,9が1個あります。
...
この文は0が1個,1が11個,2が2個,3が1個,4が1個,5が1個,6が1個,7が1個,8が1個,9が1個,aが1個,bが1個,cが1個,dが1個,eが1個,fが1個あります。


 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
<?php
for($n=2;$n<=16;++$n)
{    $str="";
    do{
        $a=count_chars($str);
        $b=array();
        for($i=0;$i<$n;++$i)
        {    $c=base_convert($i,10,$n);
            $b[]="${c}が".base_convert($a[ord($c)],10,$n)."個";
        }
        $str0=$str;
        $str=implode(",",$b);
    }while($str!=$str0);
    echo "この文は${str}あります。\n";
}
?>

これでいいような気が。

1
2
3
4
5
6
def solve(n:int) = n match {
  case 2 => "0=11, 1=100"
  case n => "0=1, 1=11, 2=2, " + (List[String]() /: (3 until n)) {(s,i) => 
              Integer.toString(i,n)+"=1"::s
            }.reverse.mkString(", ")
}

すみません、日本語がこけるので文章を変えました。

n=10の時で

0=1, 1=11, 2=2, 3=1, 4=1, 5=1, 6=1, 7=1, 8=1, 9=1

という感じで出力します。


うう、すみません、題意を違えてました。あらためて、yuinさんの方法を拝借・・・

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
# coding: cp932

def solve(n):
    assert 2 <= n <= 16
    if n == 2:
        a = ["11", "100"]
    else:
        a = ["1"] * n; a[1] = "11"; a[2] = "2"
    print u"この文は%sあります" % \
        u"，".join(u"%sが%s個" % (hex(i)[-1], m) for (i, m) in enumerate(a))

def main():
    solve(2)
    solve(10)
    solve(16)

if __name__ == '__main__':
    main()


>一つずつ答えを得た。
別解もあるので探してみてください．
可能なら，全て列挙してみてください．
#「解いて下さい」というとそういうものだと思ってたけど，違うんですね．
# あいまいな書き方で申し訳ない．

ナイーブな総当たりを書いてみましたが、n進数のnが増えると計算量が爆発しますね。あと、解は常に有限個だと思うんですが (ある点以上になると数字の数を増やすには数値の「桁を増やす」しかなくなるが、一桁増やしても数字そのものは1つしか増えないのに、その数値分の数字を確保するにはさらにおよそn個の数字が増えなければならない)、具体的な上限を求めるまでには至りませんでした。コードは無限に順列を生成してチェックしつづけるので実行時に適当にinterruptしてます。どうも3進以上は「1が11個」の解がmaxっぽい?

2進
この文は0が11個, 1が100個あります。

3進
この文は0が10個, 1が10個, 2が2個あります。
この文は0が2個, 1が2個, 2が10個あります。
この文は0が1個, 1が11個, 2が2個あります。

4進
この文は0が1個, 1が2個, 2が3個, 3が2個あります。
この文は0が1個, 1が3個, 2が1個, 3が3個あります。
この文は0が1個, 1が11個, 2が2個, 3が1個あります。

5進
この文は0が1個, 1が3個, 2が2個, 3が3個, 4が1個あります。
この文は0が1個, 1が11個, 2が2個, 3が1個, 4が1個あります。

6進
この文は0が1個, 1が11個, 2が2個, 3が1個, 4が1個, 5が1個あります。

7進
この文は0が1個, 1が4個, 2が3個, 3が2個, 4が2個, 5が1個, 6が1個あります。
この文は0が1個, 1が11個, 2が2個, 3が1個, 4が1個, 5が1個, 6が1個あります。

8進
この文は0が1個, 1が5個, 2が3個, 3が2個, 4が1個, 5が2個, 6が1個, 7が1個あります。
この文は0が1個, 1が11個, 2が2個, 3が1個, 4が1個, 5が1個, 6が1個, 7が1個あります。 
 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
module Main where
import Numeric
import Char
import System
import qualified System.IO.UTF8 as U

count pred [] = 0
count pred (x:xs) = (if pred x then 1 else 0) + count pred xs

countDigs radix k = let s = map digitToInt $ showIntAtBase radix intToDigit k $ ""
                    in map (\i -> count (==i) s) [0..(radix-1)]
countDigs' radix ks = foldl (\rs cs -> map (uncurry (+)) $ zip rs cs)
                            (replicate radix 0)
                            $ map (countDigs radix) ks

combListsM 1 lim     = [[lim]]
combListsM n lim = [x:xs | x <- [1..(lim-1)], xs <- combListsM (n-1) lim]
                   ++ [lim:xs | xs <- combListsS (n-1) lim]
                   ++ [lim:xs | xs <- combListsM (n-1) lim]
combListsS 1 lim     = [[x] | x <- [1..(lim-1)]]
combListsS n lim = [x:xs | x <- [1..(lim-1)], xs <- combListsS (n-1) lim]

combLists' n lim = combListsM n lim ++ combLists' n (lim+1)

combLists'' n = combLists' n 1

check radix (xs:xss) = let xs' = reverse xs
                           cs = map (+1) $ countDigs' radix xs'
                       in if and $ map (uncurry (==)) $ zip xs' cs
                          then xs':(check radix xss)
                          else check radix xss

solve radix = check radix $ combLists'' radix 

showResult radix xs = (foldl ct "この文は" [0..(radix-1)]) ++ "あります。"
  where ct cs i = cs ++ (if i == 0 then "" else ", ")
                     ++ show i ++ "が"
                     ++ showIntAtBase radix intToDigit (xs!!i) "個"

main = do args <- getArgs
          case args of
            [radix] -> case readDec radix of
                         (r,_):_  -> U.putStr
                                            $ unlines
                                            $ map (showResult r)
                                            $ solve r
            _       -> putStrLn "Usage: solve <radix>"


あ、いえいえ。
多分そうなんだろうと思ったのですが、
とりあえず漸近的な方法でも答えにたどり着く
(しかも総当たりよりかなり速い)ってことで
投稿してみました。

全探索バージョンは探索範囲の絞りこみ中…。

いい方法が思いつかなかったため多重ループ生成 & eval してしまいました。

入る数字は n=2 なら 8 未満、n>2 なら n^2 未満と評価できました。
というわけで理論上は停止性を保障できています。

;; format の部分はもっときれいにやる方法がないものでしょうか……
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
(defun bound (n) (if (= n 2) 8 (* n n)))

(defun solution-p (n &rest nums)
  (let ((s (format nil (format nil "~~{~~~DR~~}" n) nums)))
    (loop for i from 0 below n and a in nums
      unless (= (1- a) (count (digit-char i n) s)) return nil
      finally (return t))))

(defun gen-solver (n i bound chars vars)
  (if (= i n)
      `(if (solution-p ,n ,@vars)
           (format t "この文は~@?あります~%"
                   (format nil "~~@{~~Cが~~~DR個~~^，~~}" ,n)
                   ,@(apply #'nconc (mapcar #'list chars vars))))
    `(loop for ,(nth i vars) from 0 below ,bound do
       ,(gen-solver n (1+ i) bound chars vars))))

(defun solve (n)
  (let ((code (gen-solver n 0 (bound n)
                          (loop for i from 0 below n collect (digit-char i n))
                          (loop repeat n collect (gensym)))))
    ;; (eval code)
    (funcall (compile nil (eval `(lambda () ,code))))
    ))

n>2 のときは n+2 未満しか入らないかな？ あと、文に表れる数字の個数を使って枝刈りできますね。 これで n=8 のときが1分で終わりました。 n<=8 での出力結果はすべて shiro さんの #4367 と同じです。

 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
(defun bound (n) (if (= n 2) 8 (+ n 2)))

(defun check (n &rest nums)
  (<= (reduce (lambda (s x) (+ s (- x (floor (log x n)) 1))) nums
              :initial-value 0)
      n))

(defun solution-p (n &rest nums)
  (let ((s (format nil (format nil "~~{~~~DR~~}" n) nums)))
    (loop for i from 0 below n and a in nums
      unless (= (1- a) (count (digit-char i n) s)) return nil
      finally (return t))))

(defun gen-solver (n i bound chars vars)
  (if (= i n)
      `(if (solution-p ,n ,@vars)
           (format t "この文は~@?あります~%"
                   (format nil "~~@{~~Cが~~~DR個~~^，~~}" ,n)
                   ,@(apply #'nconc (mapcar #'list chars vars))))
    `(loop for ,(nth i vars) from 1 below ,bound
       ,@(if (> n (1+ i)) `(while (check ,n ,@(subseq vars 0 i))) ()) do
       ,(gen-solver n (1+ i) bound chars vars))))

(defun solve (n)
  (let ((code (gen-solver n 0 (bound n)
                          (loop for i from 0 below n collect (digit-char i n))
                          (loop repeat n collect (gensym)))))
    ;; (eval code)
    (funcall (compile nil (eval `(lambda () ,code))))
    ))


「かな？」とか言ってますが、一応計算して出した評価なので
どうやって出てきたか書いておきます。

正しい文に現れる数字の個数は次の二通りに表せます。
1. Σ"k が現れる回数"
2. n + Σ("k が現れる回数" の n 進での桁数)
そこで k が現れる回数を a[k], その桁数を f[k] とすると
(*) Σ(a[k]-f[k]) = n

これと a[k] >= f[k] から各 k について a[k] - f[k] <= n
左辺は単調増加なことから適当に計算して
 n=2 なら a[k] <= 5
 n>2 なら a[k] <= n + 2
が出ます。

あと n>2 で n+2 が入らないことの確認も。
a[k] = n+2 = 12(n) だと a[k]-f[k] = n なので (*) から
i!=k のとき a[i]=f[i] が必要で、これを満たすのは a[i]=1 だけ。
つまりひとつの数字を除いて一回しか現れないということですが、
12 が出てくる以上これは不可能です。

全探索バージョン。
直前のお題"自然数の分割"のプログラムを応用して
「数字の数は2n～2n+2 (2進は例外)」という条件で探索範囲を限定。
2進から16進まで探索してCore2Duo 1.2GHzで 29秒

2進:
この文は0が11個,1が100個あります。
3進:
この文は0が10個,1が10個,2が2個あります。
この文は0が1個,1が11個,2が2個あります。
この文は0が2個,1が2個,2が10個あります。
...
10進:
この文は0が1個,1が11個,2が2個,3が1個,4が1個,5が1個,6が1個,7が1個,8が1個,9が1個あります。
この文は0が1個,1が7個,2が3個,3が2個,4が1個,5が1個,6が1個,7が2個,8が1個,9が1個あります。
...
16進:
この文は0が1個,1が11個,2が2個,3が1個,4が1個,5が1個,6が1個,7が1個,8が1個,9が1個,aが1個,bが1個,cが1個,dが1個,eが1個,fが1個あります。
この文は0が1個,1がd個,2が3個,3が2個,4が1個,5が1個,6が1個,7が1個,8が1個,9が1個,aが1個,bが1個,cが1個,dが2個,eが1個,fが1個あります。
28.799607992172sec

 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
<?php
function cmp(&$a1,&$a2)
{
    foreach($a2 as $k=>$v)
        if($a1[ord(base_convert($k,10,36))]!=$v)
            return false;
    return true;
}
function judge($a,$n)
{
    $b=array();
    for($i=0;$i<$n;++$i)
    {    $c=base_convert($i,10,$n);
        $b[]="${c}が".base_convert($a[$i],10,$n)."個";
    }
    $str=implode(",",$b);
    $a1=count_chars($str);
    if(cmp($a1,$a))
        echo "この文は${str}あります。\n";
}

function part($a,$n,$c,$s1,$s2,$m)
{
    if(!$c)
    {    $m1=min($m-$s1,$s2+1);
        for($i=$n*2-$s1;$i<=$m1;++$i)
        {    $a[$c]=$i;
            judge($a,$n);
        }
    }
    else
    {    $m1=min($m-$s1,$s2/$c+1);
        for($i=1;$i<=$m1;++$i)
        {    $a[$c]=$i;
            part($a,$n,$c-1,$s1+$i,$s2-$c*($i-1),$m);
        }
    }
}

$t=microtime(true);

for($n=2;$n<=16;++$n)
{    echo "${n}進:\n";
    $m=max($n*2+2,10);
    part(array(),$n,$n-1,0,$m,$m);
}

echo microtime(true)-$t,"sec\n";
?>


数字の出現回数の合計と(数字x(出現回数-1))の積分の関係で縛りを追加したら
#4376と同条件で4.1秒ほどになりました。

リストは変更していないcmp()とjudge()省略。
 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
<?php
function part($a,$n,$c,$s1,$s2,$m)
{
    if(!$c)
    {    for($i=$s2-$s1;$i<=min($m-$s1,$m-$s2+1);$i+=$n-1)
            if($i>=$n*2-$s1)
            {    $a[$c]=$i;
                judge($a,$n);
            }
    }
    else
    {    $m1=min($m-$s1,($m-$s2)/$c+1);
        for($i=1;$i<=$m1;++$i)
        {    $a[$c]=$i;
            part($a,$n,$c-1,$s1+$i,$s2+$c*($i-1),$m);
        }
    }
}

$t=microtime(true);

for($n=2;$n<=16;++$n)
{    echo "${n}進:\n";
    $m=max($n*2+2,10);
    part(array(),$n,$n-1,0,0,$m);
}

echo microtime(true)-$t,"sec\n";
?>

#4373 を参考にリミットを設定して、全てのパターンを並行処理するようにしたものです。
ただし、うちの環境 (Mac OS X 10.5 PPC64) ではリソースの問題で radix が 5 までしか計算できませんでした。

% time ./quiz 5
この文は0が1個, 1が3個, 2が2個, 3が3個, 4が1個あります。
./quiz 5  1.66s user 2.02s system 86% cpu 4.269 total

おそらくパターン数が爆発的に増える関係で、全てのシステムスレッドがブロックしてしまい、先に進まなくなるんじゃないかと思います。
この方式は Erlang じゃないと無理かもしれないです。 
  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
let limit radix =
   match radix with
   | 2 -> 8
   | n -> n + 2

let char_table =
   Array.map begin fun i ->
      Printf.sprintf "%x" i
   end (Array.init 16 (fun i -> i))

let lstring_of_radix_num radix num =
   let rec loop n acc =
      if n < radix then
         char_table.(n) :: acc
      else
         let rem = n mod radix in
         loop ((n - rem) / radix) (char_table.(rem) :: acc)
   in
   loop num []

let string_of_lstring str =
   List.fold_left begin fun acc ch ->
      acc ^ ch
   end "" str

let string_of_radix_num radix num =
   string_of_lstring (lstring_of_radix_num radix num)

let slist_of_alist radix alist =
   List.map begin fun i ->
      lstring_of_radix_num radix i
   end (List.flatten alist)

let count_digits radix str_list num =
   match lstring_of_radix_num radix num with
   | [ch] ->
        List.fold_left begin fun sum ch' ->
           sum + (if ch = ch' then 1 else 0)
        end 0 (List.flatten str_list)
   | _ -> failwith "unknown"

let validate radix alist =
   let str = List.flatten (slist_of_alist radix alist) in
   List.for_all begin fun pair ->
      match pair with
      | [i; num] -> begin
           match lstring_of_radix_num radix i with
           | [ch] ->
                num =
                   List.fold_left begin fun sum ch' ->
                      sum + (if ch = ch' then 1 else 0)
                   end 0 str
           | _ -> failwith "unknown"
        end
      | _ -> failwith "unknown"
   end alist

let search radix =
   let lim = limit radix in
   def search'(num, start, acc) =
      def result(alist) & wait() = reply alist to wait in
      def search''(n) =
         let acc' = [num; n] :: acc in
         match num - 1 with
         | next when next < 0 ->
              if validate radix acc'
              then result(acc')
              else 0
         | next ->
              let start' =
                 (count_digits radix (slist_of_alist radix acc') next) + 1
              in
              if start > lim then failwith "unknown";
              result(search'(next, start', acc'))
      in
      for i = start to lim do
         spawn search''(i)
      done;
      reply wait() to search'
   in
   search'(radix - 1, 1, [])

let print_result radix alist =
   let str =
      List.fold_left begin fun acc pair ->
         match List.map (string_of_radix_num radix) pair with
         | [i; n] ->
              acc ^ i ^ "が" ^ n ^ "個" ^ ", "
         | _ -> failwith "unknown"
      end "この文は" alist
   in
   let str' = (String.sub str 0 ((String.length str) - 2)) ^ "あります。" in
   print_endline str'

let main () =
   match Sys.argv with
   | [|_; radix |] ->
        let radix' = int_of_string radix in
        let result = search(radix') in
        print_result radix' result
   | _ -> print_endline "usage: command radix"

let () = if not !Sys.interactive then main ()

それなりに速く終わるやつを。手元で1秒切ります。たぶん正しい気がするんですが自信は無いような。 というかたぶんn=7以降は同じパターンで2種類しか解がない、と示せる気がします。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
def x(b,a,n,e,z)
  if b==n
    if a==e
      puts (0...b).map{|i|"#{i.to_s(b)}*#{a[i].to_s(b)}"}*','
    end
  else
    1.upto(b<5?5:[n>1?[4-n,0].max+e[n]:99,b+2-z+n].min){|i|a[n]=i
      f=e.dup
      i.to_s(b).scan(/./){f[$&.to_i(b)]+=1}
      next if (0..n).any?{|j|f[j]>a[j]}
      x(b,a,n+1,f,z+i)}
  end
end
2.upto(16){|b|p b
  x(b,[0]*b,0,[1]*b,0)}

#4381 を、ちゃんと動くように修正しました。
その分、おもしろみは減った気がしますが。
結局、この問題の場合、一つ一つの処理はあまり重くないので、プロセスをなるべく生成しない方が速いみたいですね。
jocamlopt でコンパイルしたもので、
 
% time ./quiz 16
この文は0が1個, 1が11個, 2が2個, 3が1個, 4が1個, 5が1個, 6が1個, 7が1個, 8が1個, 9が1個, aが1個, bが1個, cが1個, dが1個, eが1個, fが1個あります。
^C
./quiz 16  1.48s user 0.04s system 63% cpu 2.369 total

こんな感じでした。

答を全て表示しようとするように変更したので、止まらなくなりました。
上記の実行例もキーボード割り込みで止めています。
一応、第二引数に何か入れると、前回と同じように一つ目を見付けた時点で終了します。 
  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
105
106
107
108
109
110
let limit radix =
   match radix with
   | 2 -> 8
   | n -> n + 2

let char_table =
   Array.map begin fun i ->
      Printf.sprintf "%x" i
   end (Array.init 16 (fun i -> i))

let lstring_of_radix_num radix num =
   let rec loop n acc =
      if n < radix then
         char_table.(n) :: acc
      else
         let rem = n mod radix in
         loop ((n - rem) / radix) (char_table.(rem) :: acc)
   in
   loop num []

let string_of_lstring str =
   List.fold_left begin fun acc ch ->
      acc ^ ch
   end "" str

let string_of_radix_num radix num =
   string_of_lstring (lstring_of_radix_num radix num)

let slist_of_alist radix alist =
   List.map begin fun i ->
      lstring_of_radix_num radix i
   end (List.flatten alist)

let count_digits radix str_list num =
   match lstring_of_radix_num radix num with
   | [ch] ->
        List.fold_left begin fun sum ch' ->
           sum + (if ch = ch' then 1 else 0)
        end 0 (List.flatten str_list)
   | _ -> failwith "unknown"

let validate radix alist =
   let str = List.flatten (slist_of_alist radix alist) in
   List.for_all begin fun pair ->
      match pair with
      | [i; num] -> begin
           match lstring_of_radix_num radix i with
           | [ch] ->
                num =
                   List.fold_left begin fun sum ch' ->
                      sum + (if ch = ch' then 1 else 0)
                   end 0 str
           | _ -> failwith "unknown"
        end
      | _ -> failwith "unknown"
   end alist

def result_post(alist) & result_get() = reply alist to result_get

def search(radix) =
   let lim = limit radix in
   let rec search' label num acc =
      if label < 0 then
         (if validate radix acc then spawn result_post(acc))
      else
         let acc' = [label; num] :: acc in
         for i = 1 to lim do
            search' (label - 1) i acc'
         done
   in
   for i = 1 to lim do
      search' (radix - 1) i []
   done;
   0

let print_result radix alist =
   let str =
      List.fold_left begin fun acc pair ->
         match List.map (string_of_radix_num radix) pair with
         | [i; n] ->
              acc ^ i ^ "が" ^ n ^ "個" ^ ", "
         | _ -> failwith "unknown"
      end "この文は" alist
   in
   let str' = (String.sub str 0 ((String.length str) - 2)) ^ "あります。" in
   print_endline str'

let main () =
   match Sys.argv with
   | [|_; radix |] ->
        let radix' = int_of_string radix in
        spawn search(radix');
        let rec loop cache =
           let result = result_get() in
           if List.mem result cache then
              loop cache
           else
              begin
                 print_result radix' (result_get());
                 loop (result :: cache)
              end
        in
        loop []
   | [|_; radix; _|] ->
        let radix' = int_of_string radix in
        spawn search(radix');
        print_result radix' (result_get())
   | _ -> print_endline "usage: command radix"

let () = if not !Sys.interactive then main ()

まず問題ですが、

> が正しくなるように□を埋めてください．数値は10進数とします．

はn進数の間違いですよね。

以上を踏まえて、お代を忠実にコードしたらそのまま解けました。Regexpを使っているのがポイントかな。一秒といわず瞬殺です。

出力フォーマットは、#4382(http://ja.doukaku.org/comment/4382/)のものを採用していますが、日本語化は`sentenceed()`と`solve()`の該当箇所を変えるだけでOK.

Dan the Perl Monger

 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
#!/usr/local/bin/perl
use strict;
use warnings;

my @digits = ( '0' .. '9', 'a' .. 'z' );

sub n2s {
    use integer;
    my ( $n, $b ) = @_;
    my $s = $digits[ $n % $b ];
    $s = $digits[ $n % $b ] . $s while ( $n /= $b );
    $s;
}

sub sentenceed {
    my $b = shift;
    join( ",", map { "$_*1" } @digits[ 0 .. $b - 1 ] );
}

sub count {
    my ( $s, $d ) = @_;
    my $c = ( eval qq{\$s =~ y/$d/$d/} );
    $c;
}

sub solve {
    my $b    = shift;
    my $ans  = sentenceed($b);
    my $nans = '';
    while ( $ans ne $nans ) {
        $nans = $ans;
        $ans =~ s{([0-9a-z])\*[0-9a-z]+}{
            my $d = $1;
            my $c = n2s(count($ans, $d), $b);
            qq($d*$c)
        }egx;
    }
    $ans;
}

print "base($_):", solve($_), "\n" for ( 2 .. (shift||16) );

Squeak Smalltalk で。適度にはしょった総当たりですが、にもかかわらず 9 より上は実用に耐えられず。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
| nn results range digits digitChars max |
nn := 8.
range := 1 to: nn.
digits := range asArray - 1.
digitChars := digits collect: [:each | each asString asCharacter].
max := (Number readFrom: '11' base: nn) + (nn = 2 ifTrue: [1] ifFalse: [0]).
results := OrderedCollection new.
(0 to: 3) asDigitsToPower: nn - 1 do: [:ary |
    (0 to: max) do: [:mm |
        | bag array |
        bag := Bag withAll: digitChars.
        array := {ary first. mm}, ary allButFirst.
        array do: [:each | bag addAll: (each radix: nn)].
        (range allSatisfy: [:idx | 
                (bag occurrencesOf: (digitChars at: idx)) = (array at: idx)])
            ifTrue: [results add: array copy]]].
＾results

shinh さんの #4382 の爆速っぷりにいたく感動したので Squeak Smalltalk の直訳風に。 
 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
| x |
x := [:b :a :n :e :z |
    b = n ifTrue: [
        a = e ifTrue: [
            Transcript cr.
            (0 to: b - 1)
                do: [:i | Transcript show: (i radix: b), '*', ((a at: i + 1) radix: b)]
                separatedBy: [Transcript show: ', ']]
    ] ifFalse: [
        (1 to: (b < 5 ifTrue: [5] ifFalse: [
            n > 1 ifTrue: [(4 - n max: 0) + (e at: n + 1)] ifFalse: [99 min: b + 2 - z + n]]))
        do: [:i |
            | f |
            a at: n + 1 put: i.
            f := e copy.
            (i radix: b) do: [:char |
                f at: (Number readFrom: char asString base: b) + 1 incre