正しい文(クイズ) in Haskell DouKaku?

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

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

ナイーブな総当たりを書いてみましたが、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個あります。

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>"

高階関数を使って。
書き換えた部分のみ。

import List
import Maybe

count pred xs = length $ filter pred xs

countDigs' radix ks = map sum $ transpose $ map (countDigs radix) ks

combListsS n lim = sequence $ replicate n [1..lim-1]

combLists'' n = [1..] >>= combListsM n

check radix xss = mapMaybe f xss  where
  f xs = if xs' == cs then Just xs' else Nothing  where
    xs' = reverse xs
    cs = map (+1) $ countDigs' radix xs'

showResult radix xs = ("この文は" ++) $ (++ "あります。")
  $ concat $ intersperse ", "
  $ map ct [0..radix-1]
  where ct i = show i ++ "が" ++ showIntAtBase radix intToDigit (xs!!i) "個"

DouKaku?

正しい文(クイズ)

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq