Hatena::Grouphaskell

wanparkの日記

2007-11-26

Haskellプログラミング(5) 記憶(memo)する関数

http://www.ipsj.or.jp/07editj/promenade/4608.pdf

http://www.sampou.org/cgi-bin/haskell.cgi?Memoise

後半理解できない・・。まずStateというのに慣れると良いと思う。

2007-11-25

Haskellプログラミング(3) 数当てゲームを解く

http://www.ipsj.or.jp/07editj/promenade/4606.pdf

うーん、難しい。予想と評価が一組与えられた状態なら、各欄に各数字が入る確率は出せる。けどその後もう一組与えられた時に確率表がどうなるのかてんでわからないな。いやそもそも欄ごとの確率に基づいて答えるのはいまいちだなたぶん。単純に履歴と矛盾しない回答をすればいいか。前の分では確率がどうとか混乱しているけど、矛盾しないものを答える以外の戦略はないんじゃないかな。うん、そんな気がしてきた。

まず出題者の部分

import Char
import List
import Time
import Random

-- MOO積
score :: [Int] -> [Int] -> (Int, Int)
score correct guess = (bull, cow)
    where bull = length $ filter id $ zipWith (==) correct guess
          cow  = (length $ filter (flip elem correct) guess) - bull

-- 対話的な出題者
host :: Int -> IO ()
host n = randomMoo n >>= ask
    where ask moo = do putStr "Guess: "
                       input <- getLine
                       s     <- score moo $ readMoo input
                       if fst s == n then putStrLn "Congratulations!"
                                     else do putStrLn $ show s
                                             ask moo

showMoo :: [Int] -> String
showMoo = map intToDigit

readMoo :: String -> [Int]
readMoo = map digitToInt

randomMoo :: Int -> IO [Int]
randomMoo n = randRs (0, 9) >>= return . take n . nub

randRs :: Random a => (a, a) -> IO [a]
randRs range = do seed <- timeSeed
                  setStdGen $ mkStdGen seed
                  g <- getStdGen
                  return $ randomRs range g

timeSeed :: IO Int
timeSeed = getClockTime >>= toCalendarTime >>= return . fromInteger . ctPicosec

Integer から Int への変換の挙動がわからないけど、とりあえず動いてるみたい。

回答者の部分

-- 重複を許さない順列
perm :: Eq a => [a] -> Int -> [[a]]
perm _ 0  = [[]]
perm xs n = concat [map (x:) $ perm (delete x xs) (n - 1) | x <- xs]

-- 履歴から次の一手を考える
guess :: Int -> [([Int], (Int, Int))] -> [Int]
guess n history = case find valid (perm [0..9] n) of
                    Just m  -> m
                    Nothing -> take n [0..9]
    where valid moo = all sameScore history
              where sameScore (guess, s) = score moo guess == s

-- 回答者
solver :: [Int] -> IO ()
solver correct = answer []
    where answer history = do putStrLn $ showMoo g ++ ": " ++ show s
                              if fst s == n then return ()
                                            else answer ((g, s) : history)
              where n = length correct
                    g = guess n history
                    s = score correct g
  • 出題/回答者のインターフェースをまともにしたい
  • permの効率が悪そう
  • permを毎回作り直して毎回0からチェックし直すのは無駄

くらいが思うところです。

重複なし順列の生成

Page not found · GitHub Pages では

perm :: [a] -> Int -> [[a]]
perm [] _ = []
perm xs 0 = [[]]
perm xs 1 = map (:[]) xs
perm xs n = concat $ map (pm n) $ divid xs
 where pm _ (_,[])      = []
       pm n (hs,(t:ts)) = map (t:) $ perm (hs ++ ts) (n-1)

divid :: [a] -> [([a],[a])]
divid xxs@(x:xs) = ([],xxs) : [(x:ys,zs) | (ys,zs) <- divid xs]
divid []         = [([],[])]

とやってる。Eq a じゃなくてもだいじょうぶ、だけどやってることはまあ同じだ。何度も同じpermを呼ぶのが非効率に思えるんだけどどうすればいいかわからない。

戦略

「矛盾しないものを答える以外の戦略はない」ことはないらしい。

http://www.tanaka.ecc.u-tokyo.ac.jp/~ktanaka/moo/moo.html

これは全部の正解と回答の組み合わせを試したってこと?

Haskellプログラミング(2) 木(tree)で遊ぶ

http://www.ipsj.or.jp/07editj/promenade/4605.pdf

例題1: 末端のノードがn個の二分木を列挙

data Tree = Node Tree Tree
          | Leaf

instance Show Tree where
    show (Node t1 t2) = "(" ++ show t1 ++ " " ++ show t2 ++ ")"
    show Leaf = "L"

nLeafTrees :: Int -> [Tree]
nLeafTrees 1 = [Leaf]
nLeafTrees n = concat [[Node t1 t2 | t1 <- nLeafTrees i, t2 <- nLeafTrees (n - i)] | i <- [1..(n - 1)]]

メモ化すると良いと思う

練習問題1: show を書き換える

[(L^(L^(L^R))),(L^((L^R)^R)),((L^R)^(L^R)),((L^(L^R))^R),(((L^R)^R)^R)]

になるように 。

instance Show Tree where
    show (Node Leaf Leaf) = pair "L" "R"
    show (Node Leaf t)    = pair "L" (show t)
    show (Node t Leaf)    = pair (show t) "R"
    show (Node t1 t2)     = pair (show t1) (show t2)
    show Leaf             = "0"

pair :: String -> String -> String
pair a b = "(" ++ a ++ "^" ++ b ++ ")"

冗長だ。3分木になったりしたら手に負えない

instance Show Tree where
    show (Node t1 t2) = "(" ++ showL t1 ++ "^" ++ showR t2 ++ ")"
    show Leaf         = "0"

showL, showR :: Tree -> String
showL Leaf = "L"
showL t = show t
showR Leaf = "R"
showR t = show t

こっちの方がいい

instance Show Tree where
    show (Node t1 t2) = "(" ++ showCustomLeaf "L" t1 ++ "^" ++ showCustomLeaf "R" t2 ++ ")"
    show Leaf         = "0"
        where showCustomLeaf s Leaf = s
              showCustomLeaf _ t    = show t

ちょっと変えた

例題2: 与えられた1桁の数すべてと四則演算を使って、指定した数の作り方を示せ

import Ratio

data Expression = Operator String (Rational -> Rational -> Rational) Expression Expression
                | Number Int

-- 内側のOperatorは括弧でくくる
instance Show Expression where
    show (Number n)                   = show n
    show (Operator label _ exp1 exp2) = (showP exp1) ++ label ++ (showP exp2)
        where showP op@(Operator _ _ _ _) = "(" ++ show op ++ ")"
              showP exp                       = show exp

-- 与えられた数値を使う全Expression
expressions :: [Int] -> [Expression]
expressions [] = []
expressions [n] = [Number n]
expressions (n:ns) = (operators "+" (+) True) ++ (operators "-" (-) False) ++
                     (operators "*" (*) True) ++ (operators "/" (/) False)
    where operators label op commute = [Operator label op (Number n) y | y <- expressions ns] ++
                                       if commute then [] else [Operator label op y (Number n) | y <- expressions ns]

eval :: Expression -> Rational
eval (Number x) = fromIntegral x
eval (Operator _ op exp1 exp2) = op (eval exp1) (eval exp2)

generator :: [Int] -> Int -> Expression
generator numbers answer = head $ filter ((== (fromIntegral answer)) . eval)  (expressions numbers)

ちょっと変える

import Ratio

data Expression = Term Operator Expression Expression
                | Number Int

-- Operator func commute label
data Operator = Operator (Rational -> Rational -> Rational) Bool String

instance Show Expression where
    show (Number n)                            = show n
    show (Term (Operator _ _ label) exp1 exp2) = "(" ++ (show exp1) ++ label ++ (show exp2) ++ ")"

operators :: [Operator]
operators = [Operator (+) True  "+",
             Operator (-) False "-",
             Operator (*) True  "*",
             Operator (/) False "/"]

expressions :: [Int] -> [Expression]
expressions []     = []
expressions [n]    = [Number n]
expressions (n:ns) = concatMap terms operators
    where terms op@(Operator _ commute _) = [Term op (Number n) y | y <- childExps] ++
                                            if commute then [] else [Term op y (Number n) | y <- childExps]
          childExps = expressions ns

eval :: Expression -> Rational
eval (Number x) = fromIntegral x
eval (Term (Operator func _ _) exp1 exp2) = func (eval exp1) (eval exp2)

generator :: [Int] -> Int -> Maybe Expression
generator numbers answer = let solutions = filter ((== (fromIntegral answer)) . eval)  (expressions numbers)
                           in if null solutions then Nothing else Just $ head solutions

askGenerator :: [Int] -> Int -> IO ()
askGenerator numbers answer = putStrLn $ case generator numbers answer of
                                Just exp -> show exp
                                Nothing  -> "Not found."

Haskellプログラミング」

息抜きに別のことをしよう。情報処理学会会誌の連載がPDFで読めるので読む。

http://www.ipsj.or.jp/07editj/promenade/

最初は「関数プログラミングの妙味」

http://www.ipsj.or.jp/07editj/promenade/4604.pdf

これに載っている車両のソート問題をやってみる。

電車の状態は [ [Int] ] 、動かす手は路線の番号 Int で表せる。全手筋を作っておいてそこから正解を選び出すのがそれっぽい気がします。

import System

main = getArgs >>= print . solve . map read

numLines = 3

-- 一車両動かして状態を更新
apply :: [[Int]] -> Int -> [[Int]]
apply lines from = if null (lines !! from)
                   then lines
                   else let fromLine = lines !! from
                            toLine   = lines !! (from + 1)
                        in take from lines ++ [tail fromLine, head fromLine : toLine] ++ drop (from + 2) lines

-- 重複ありの順列
perm :: [a] -> Int -> [[a]]
perm xs 0 = [[]]
perm xs 1 = [[x] | x <- xs]
perm xs n = [x : ys | x <- xs, ys <- perm xs (n - 1)]

-- 全移動手順
allTries :: [[Int]]
allTries = concatMap (perm [0..numLines]) [0..]

-- pos列がlineで残りは空の状態
createLines :: Int -> [Int] -> [[Int]]
createLines pos line = take pos (repeat []) ++ [line] ++ take (numLines - pos + 1) (repeat [])

-- 初期配置 -> 解
solve :: [Int] -> [Int]
solve trains = head $ filter isAnswer allTries
    where isAnswer try = goal == foldl apply begin try
          begin = createLines 0 trains
          goal  = createLines (numLines + 1) (reverse [0..(length trains - 1)])

(路線数)^(解の長さ)の手順を試していてちょう重い。電車3両が限界。無意味な手順を省くにしても総当りだと指数的でどうしようもない。

記事の解答を見てみると、結構大変そうだ。最初だからシンプルに解ける問題なのかと思ってたよ。えーと、半分ずつソートしてマージして、とやってる、らしい。マージソートというやつだね。字面からして。別に手順を答えろとは言ってないのか。そんな数学みたいな抽象化を求められてるとは知らなかったよ。そういえば情報処理だった。n番線まであれば2^n両をソートできることを証明せよって設問が付いてるとわかったかもしれない。まず手で解いて問題を把握しろってとこですね。次からはこころしてかかろう。つづく。

2007-11-24

Control.Monad.Error がないって

もうやだ。エラーの項はおいとこう。

解決、してないけど

ghc で怒られる。hugs -98 とやるとOKだった。

Write Yourself a Scheme in 48 Hours

http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours

3. Evaluation, Part 1 まで写経などしつつ読んだ。

import Parse
import Monad
import List


main = getContents >>= putStrLn . show . eval . readExpr


-- Data types

data LispVal = Atom String
             | List [LispVal]
             | Number Int
             | String String
             | Bool Bool

instance Show LispVal where
    show (Atom atom) = atom
    show (Number contents) = show contents
    show (String contents) = "\"" ++ contents ++ "\""
    show (Bool True) = "#t"
    show (Bool False) = "#f"
    show (List contents) = "(" ++ (unwords $ map show contents) ++ ")"


-- Parsing

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

parseString :: Parser LispVal
parseString = do char '"'
                 x <- many (noneOf "\"")
                 char '"'
                 return $ String x

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest  <- many (letter <|> digit <|> symbol)
               let atom = first:rest
               return $ case atom of
                          "#t" -> Bool True
                          "#f" -> Bool False
                          otherwise -> Atom atom

parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> do char '('
               x <- parseList
               char ')'
               return x

readExpr :: String -> LispVal
readExpr input = case parse parseExpr input of
                   Parsed x _ -> x
                   NoParse    -> String $ "No match"


-- Evaluation

eval :: LispVal -> LispVal
eval val@(String _) = val
eval val@(Number _) = val
eval val@(Bool   _) = val
eval (List (Atom func : args)) = apply func $ map eval args
eval _ = Atom "stub"


apply :: String -> [LispVal] -> LispVal
apply func args = maybe (Bool False) ($ args) (lookup func primitives)


primitives :: [(String, [LispVal] -> LispVal)]
primitives = [("+", numericBinop (+)),
              ("-", numericBinop (-)),
              ("*", numericBinop (*)),
              ("/", numericBinop div)]

numericBinop :: (Int -> Int -> Int) -> [LispVal] -> LispVal
numericBinop op = Number . foldl1 op . map unpackNum

unpackNum :: LispVal -> Int
unpackNum (Number n) = n
unpackNum (String n) = let parsed = reads n in
                          if null parsed
                            then 0
                            else fst $ head parsed
unpackNum (List [n]) = unpackNum n
unpackNum _ = 0

パーサ部分は昨日のを拡張。Parsecの抜粋って感じだけど。

module Parse where

import Char

-- Data types

data Result tok a = Parsed a [tok]
                  | NoParse

newtype GenParser tok a = Parser ([tok] -> Result tok a)

type Parser a = GenParser Char a


-- Basic Operations

instance Monad (GenParser tok) where
    return x          = Parser (\ts -> Parsed x ts)
    (Parser f1) >>= f = Parser (\ts -> case f1 ts of
                                         Parsed x ts' -> let Parser f2 = f x
                                                         in f2 ts'
                                         otherwise    -> NoParse)

infixr 1 <|>

(<|>) :: GenParser tok a -> GenParser tok a -> GenParser tok a
(Parser f1) <|> (Parser f2) = Parser (\ts -> case f1 ts of
                                               NoParse -> f2 ts
                                               r       -> r)

parse :: GenParser tok v -> [tok] -> Result tok v
parse (Parser f) = f


-- Combinator Parsers

fail :: GenParser tok a
fail = Parser (\ts -> NoParse)

satisfy :: GenParser tok a -> (a -> Bool) -> GenParser tok a
satisfy (Parser f) test = Parser (\ts -> case f ts of
                                           Parsed x ts' | test x -> Parsed x ts'
                                           otherwise             -> NoParse)

many :: GenParser tok a -> GenParser tok [a]
many p = do x  <- p
            xs <- many p
            return (x:xs)
     <|> return []

many1 :: GenParser tok a -> GenParser tok [a]
many1 p = do x  <- p
             xs <- many p
             return (x:xs)

skipMany :: GenParser tok a -> GenParser tok ()
skipMany p = do p
                skipMany p
                return ()
         <|> return ()

skipMany1 :: GenParser tok a -> GenParser tok ()
skipMany1 p = do p
                 skipMany p
                 return ()

sepBy :: GenParser tok a -> GenParser tok sep -> GenParser tok [a]
sepBy p sep = sepBy1 p sep <|> return []

sepBy1 :: GenParser tok a -> GenParser tok sep -> GenParser tok [a]
sepBy1 p sep = do x  <- p
                  xs <- many (sep >> p)
                  return (x:xs)


-- Character Parsers

type CharParser a = GenParser Char a

anyChar :: CharParser Char
anyChar = Parser parse
    where parse (x:xs) = Parsed x xs
          parse []     = NoParse

char :: Char -> CharParser Char
char c = satisfy anyChar (== c)

digit :: CharParser Char
digit = satisfy anyChar isDigit

letter :: CharParser Char
letter = satisfy anyChar isAlpha

space :: CharParser Char
space = satisfy anyChar isSpace

string :: String -> CharParser String
string s@(c:cs) = do char c
                     string cs
                     return s
string [] = do return []

oneOf :: [Char] -> CharParser Char
oneOf cs = satisfy anyChar (\c -> elem c cs)

noneOf :: [Char] -> CharParser Char
noneOf cs = satisfy anyChar (\c -> not(elem c cs))

2007-11-23

Packrat Parsing

Packrat Parsing を自分で書いてみよう。

序盤は普通な感じで書こうという流れ。文法

import Char

main = do cs <- getContents
          case run pAdditive cs of
            Parsed x _ -> print x
            otherwise  -> print "parse error"


run :: Parser v -> String -> Result v
run (Parser f) = f


data Result v = Parsed v String
              | NoParse

newtype Parser v = Parser (String -> Result v)

instance Monad Parser where
    return x = Parser (\input -> Parsed x input)
    p >>= f  = Parser (\input -> case run p input of
                                   Parsed x input' -> run (f x) input'
                                   otherwise       -> NoParse)

infixr 1 <|>
(<|>) :: Parser v -> Parser v -> Parser v
p1 <|> p2 = Parser nextState
    where nextState input = case run p1 input of
                              NoParse  -> run p2 input
                              r -> r


satisfy :: (Char -> Bool) -> Parser Char
satisfy test = Parser nextState
    where nextState (c:cs) | test c = Parsed c cs
          nextState _               = NoParse

char :: Char -> Parser Char
char ch = satisfy (\c -> c == ch)


-- Additive -> Multitive '+' Additive
--          |  Multitive
pAdditive :: Parser Int
pAdditive = do l <- pMultitive
               char '+'
               r <- pAdditive
               return $ l + r
        <|> do pMultitive

-- Multitive -> Primary '*' Multitive
--           |  Primary
pMultitive :: Parser Int
pMultitive = do l <- pPrimary
                char '*'
                r <- pAdditive
                return $ l * r
         <|> do pPrimary

-- Primary -> '(' Additive ')'
--         |  Decimal
pPrimary :: Parser Int
pPrimary = do char '('
              n <- pAdditive
              char ')'
              return n
       <|> do pDecimal

-- Decimal -> '0' | ... | '9'
pDecimal :: Parser Int
pDecimal = do c <- satisfy isDigit
              return $ digitToInt c

ふつうのHaskellプログラミングに載ってたのほぼそのままなんだけど、慣れないのでやたら時間がかかった。モナドとか。

で、これだとバックトレースで指数的な計算量で、それをmemorizeでなんとかしたのがPackrat Parsingだそうです。inputの線形時間になる、が使用メモリも線形になる。

読んでたらちょっとわかってきた。全データの構造をあらかじめ作っておいて遅延評価で一本釣りって感じか。

import Char

main = do cs <- getContents
          case dvAdditive $ parse cs of
            Parsed x _ -> print x
            otherwise  -> print "parse error"

parse :: String -> Derivs
parse s = d where
    d    = Derivs add mult prim dec chr
    chr  = case s of
              (c:s') -> Parsed c (parse s')
              []     -> NoParse
    add  = run pAdditive  d
    mult = run pMultitive d
    prim = run pPrimary   d
    dec  = run pDecimal   d

run :: Parser v -> Derivs -> Result v
run (Parser f) = f


data Result v = Parsed v Derivs
              | NoParse

newtype Parser v = Parser (Derivs -> Result v)

instance Monad Parser where
    return x = Parser (\derivs -> Parsed x derivs)
    p >>= f  = Parser (\derivs -> case run p derivs of
                                    Parsed x derivs' -> run (f x) derivs'
                                    otherwise        -> NoParse)

infixr 1 <|>
(<|>) :: Parser v -> Parser v -> Parser v
p1 <|> p2 = Parser nextState
    where nextState derivs = case run p1 derivs of
                               NoParse -> run p2 derivs
                               r       -> r

data Derivs = Derivs {
    dvAdditive  :: Result Int,
    dvMultitive :: Result Int,
    dvPrimary   :: Result Int,
    dvDecimal   :: Result Int,
    dvChar      :: Result Char}


satisfy :: (Char -> Bool) -> Parser Char
satisfy test = Parser (\derivs -> case run (Parser dvChar) derivs of
                                    Parsed c derivs' | test c -> Parsed c derivs'
                                    otherwise                 -> NoParse)

char :: Char -> Parser Char
char ch = satisfy (\c -> c == ch)


-- Additive -> Multitive '+' Additive
--          |  Multitive
pAdditive :: Parser Int
pAdditive = do l <- Parser dvMultitive
               char '+'
               r <- Parser dvAdditive
               return $ l + r
        <|> do Parser dvMultitive

-- Multitive -> Primary '*' Multitive
--           |  Primary
pMultitive :: Parser Int
pMultitive = do l <- Parser dvPrimary
                char '*'
                r <- Parser dvAdditive
                return $ l * r
         <|> do Parser dvPrimary

-- Primary -> '(' Additive ')'
--         |  Decimal
pPrimary :: Parser Int
pPrimary = do char '('
              n <- Parser dvAdditive
              char ')'
              return n
       <|> do Parser dvDecimal

-- Decimal -> '0' | ... | '9'
pDecimal :: Parser Int
pDecimal = do c <- satisfy isDigit
              return $ digitToInt c

一応動いてるっぽいけどメタ度合いに頭がついていってないなー。もうちょっと慣れないと。


再開

Haskellってなんだっけ。

import System

main = getArgs >>= putStr . unlines . fizzbuzz . read . head

fizzbuzz :: Int -> [String]
fizzbuzz n = map conv [1..n]
             where conv i | i `mod` 15 == 0 = "fizzbuzz"
                          | i `mod` 3  == 0 = "fizz"
                          | i `mod` 5  == 0 = "buzz"
                          | otherwise       = show i

fizzbuzz。ながい。

2006-08-07

情報オリンピック2006 (1)

babieさんに倣って情報オリンピックの問題で演習することにします。あんまり難しいと大変だし。とりあえず 第5回日本情報オリンピック 本選をやってみる。面倒なので標準入出力でとかそこらへんは柔軟に。

問題1

01の表を数えてソートする。こりゃらくしょうだなー、と思ったもののかなり苦戦。splitは難しかったので青木日記 2005-12-04からコピペ。あとインプットを一旦全部読み込むのでとてもよくない。

import List

main = getContents >>= putStrLn . popularIndexes

popularIndexes :: String -> String
popularIndexes = join " " . map show . indexes . sortBy compareData .
                 indexing . map countBit . transpose . toBitMatrix

toBitMatrix :: String -> [[Bool]]
toBitMatrix = map (map (=="1") . split ' ') . drop 1 . filter (not . null) . lines

countBit :: [Bool] -> Int
countBit = length . filter id

indexing :: [a] -> [(Int, a)]
indexing = zip [1..]

compareData :: (Int, Int) -> (Int, Int) -> Ordering
compareData (i, m) (j, n) = case compare n m of
                              EQ -> compare i j
                              x  -> x

indexes :: [(a, b)] -> [a]
indexes = fst . unzip

split :: Char -> String -> [String]
split _ [] = []
split sep str = word : split sep cont
  where
    (word, cont') = break (==sep) str
    cont = case cont' of
             []     -> ""
             (c:cs) -> cs

join :: String -> [String] -> String
join sep = concat . intersperse sep

perlで書いてみる。

use strict;
my @counts;
<>;
while(<>) {
    chomp;
    my $index;
    $counts[++$index] += $_ for split ' ';
}
my @sorted_indexes = sort { $counts[$b] <=> $counts[$a] || $a <=> $b } (1 .. $#counts);
print join " ", @sorted_indexes, "\n";

haskellたいへんだ。

問題2

数列を簡単な規則で繰り返し変換する問題。これはHaskellと相性がよさそう。

main = getContents >>= putStrLn . calculate

calculate :: String -> String
calculate cs = let ls = lines cs in times convert (read $ ls !! 0) (ls !! 1)

times :: (a -> a) -> Int -> a -> a
times _ 0 x = x
times f n x = times f (n - 1) (f x)

convert :: String -> String
convert [] = []
convert (c:cs) = show len ++ [c] ++ convert remain
    where len = (length $ takeWhile (== c) cs) + 1
          remain = drop (len - 1) cs

わーい。

3問目

和が一定の単調減少数列を作る。数学っぽいものはやりやすい。

import List

main = getContents >>= putStr . format . decreaseLists . read

decreaseLists :: Int -> [[Int]]
decreaseLists 0 = []
decreaseLists n = withLimit n n
    where withLimit 0 _  = [[]]
          withLimit total limit = concatMap withHead $ reverse [1 .. min total limit]
              where withHead h = map (\xs -> [h] ++ xs) $ withLimit (total - h) h

format :: [[Int]] -> String
format = unlines . map (join " " . map show)

join :: String -> [String] -> String
join sep = concat . intersperse sep

効率悪そう。わかりやすいかというと、どうなんだろう。

はじめまして

よろしくお願いします。

AhmedAhmed2007/07/06 12:55http://2fa8216b7d824ab4428d571d77bac1a9-t.altzds.org <a href="http://2fa8216b7d824ab4428d571d77bac1a9-h.altzds.org">2fa8216b7d824ab4428d571d77bac1a9</a> [url]http://2fa8216b7d824ab4428d571d77bac1a9-b1.altzds.org[/url] [url=http://2fa8216b7d824ab4428d571d77bac1a9-b2.altzds.org]2fa8216b7d824ab4428d571d77bac1a9[/url] [u]http://2fa8216b7d824ab4428d571d77bac1a9-b3.altzds.org[/u] 380583722ce02cd0bced10e474462c70