DouKaku?beta

Language detail: Haskell

Coverage: 99.32%
number of '+' ratings
 contribution for coverage

Unsolved challenges

codes

Feed

Used modules

next >>

島の数をカウントする (Nested Flatten) 
ナイーブに。

実行例
*Main> :main
□■■□
□□■□
□■□□
□■■□
白の島: 2個
黒の島: 2個
□□□□
■□■□
□■□□
□□□□
白の島: 1個
黒の島: 3個

 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
import Control.Arrow
import Data.List
import Data.Function
import qualified System.IO.UTF8 as U

main :: IO ()
main =  mapM_ displayIsland [sample1,sample2]

displayIsland = uncurry (>>) . (printMAP &&& (printAnswer . count . islands))
  where
    printMAP = U.putStr . unlines . map (concatMap show)
    printAnswer (w,b) = mapM_ U.putStrLn ["白の島: "++show w++"個"
                                         ,"黒の島: "++show b++"個"]

data BW = B | W deriving (Eq)

instance Show BW where
  show B = "■"
  show W = "□"

grouping :: [[(Int,BW)]] -> [[(Int,BW)]]
grouping = map (concatMap renumber . adjacent)
  where
    adjacent = groupBy ((==) `on` snd)
    renumber = uncurry replicate . (length &&& minimumBy (compare `on` fst))

count :: [[(Int,BW)]] -> (Int,Int)
count = (cnt *** cnt) . partition ((W ==) . snd) . concat
  where 
    cnt = length . groupBy ((==) `on` fst) . sortBy (compare `on` fst)

islands :: [[BW]] -> [[(Int,BW)]]
islands = fst . head
        . filter (uncurry ((==) . transpose))
        . uncurry zip 
        . (id &&& tail) 
        . iterate (transpose . grouping)
        . numbering 
  where
    numbering = snd . mapAccumL number [0..]  
    number (n:ns) (x:xs) = case number ns xs of (ns',ys) -> (ns',(n,x):ys)
    number ns     []     = (ns,[])

sample1 = [[W,B,B,W]
          ,[W,W,B,W]
          ,[W,B,W,W]
          ,[W,B,B,W]]

sample2 = [[W,W,W,W]
          ,[B,W,B,W]
          ,[W,B,W,W]
          ,[W,W,W,W]]
π (Nested Flatten) 
> 昔のメモにのこっていたコード。出典がわからないのだがなにかのpaperにあったコードだと思う。

コードの出典はわかりませんが計算方法は多分
「円周率の公式集（そのた・不明）」のページ
http://www.pluto.ai.kyutech.ac.jp/plt/matumoto/pi_small/node14.html
の下の方にある

t[n] = n(2n-1)((5n+3)+t[n+1])/((3n+1)(3n+2)3)
π[n] = 3 + t[1]
π = lim π[n]
というやつですね。

> 各桁の数のリストで出力

収束の関係上いつかは誤差で間違った数がでてくるんでしょうね
（後の桁で１０以上の数がでてきて全体としては正しい値に調整されると思いますが）
その桁にたどりつく前に計算機資源が足りなくなるか。
疑似並行処理 (Nested Flatten) 
1
2
3
4
5
6
import Data.Char
import Control.Concurrent

main = forkIO f >> g
    where f = mapM_ (\x -> threadDelay 100000 >> putStr (show x)) [1..10]
          g = mapM_ (\x -> threadDelay 100000 >> putChar x) ['A'..'J']
世界時計 (Nested Flatten) 
Time Zone の情報を取るのがすこしまわりくどいです

MacOS X 10.5、ghc-6.10.1 ではうまくいっているようにみえますが、
summer timeの扱いがうまくいくかどうかは未確認です。

実行例
*Main> :main
現在の時刻は、2008年11月07日 18時03分09秒です。
グリニッジ標準時刻は、2008年11月07日 09時03分09秒です。
アメリカ・ロサンジェルスの時刻は、2008年11月07日 01時03分09秒です。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
module Main where

import Data.Time
import System.Locale
import System.Posix.Env
import qualified System.IO.UTF8 as U

main :: IO ()
main = do hereTZ <- getCurrentTimeZone
          tzenv  <- getEnv "TZ"
          setEnv "TZ" "America/Los_Angeles" True
          laTZ   <- getCurrentTimeZone
          case tzenv of { Nothing -> unsetEnv "TZ"; Just tz -> setEnv "TZ" tz True }
          ct     <- getCurrentTime
          mapM_ U.putStrLn 
            $ zipWith (formatTime defaultTimeLocale) [herefmt,utcfmt,lafmt] 
            $ flip map [hereTZ,utc,laTZ] 
            $ flip utcToLocalTime ct
          
herefmt = "現在の時刻は、%Y年%m月%d日 %H時%M分%S秒です。"
utcfmt  = "グリニッジ標準時刻は、%Y年%m月%d日 %H時%M分%S秒です。"
lafmt   = "アメリカ・ロサンジェルスの時刻は、%Y年%m月%d日 %H時%M分%S秒です。"
'('と')'の対応 (Nested Flatten)

$ と where があれば括弧要らない感じです． タプル使えないのがちょっと嫌ですが．

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
import qualified Data.Char
openP  = Data.Char.chr 40
closeP = Data.Char.chr 41

pNext = dropWhile $ \c -> c/=openP && c/=closeP
pHead = head . pNext
pTail = pNext . tail . pNext

parse :: String -> String
parse str = show result ++ "\n"
  where
    result = flip parse' 0 $ pNext str

    parse' "" n = n == 0
    parse' s  n | hd == openP = parse' tl $ succ n
                | n > 0       = parse' tl $ pred n
                | otherwise   = False
      where
        hd = pHead s
        tl = pTail s

main = interact parse
漢数字で九九の表 (Nested Flatten) 
基本的な数字を作ってから・・・なので、目新しさはありません。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
k = ["一","二","三","四","五","六","七","八","九"]
ku = "  ":k
kl = "〇":k

main = putStrLn $ concat [str (x*y) | x <- [one..nine] ,y <- [one-one..nine]]
    where
        one = ten - nine
        nine = length k
        ten = length ku
        str n
            | n < one   = "\n"
            | otherwise = "  " ++ ku!!u ++ kl!!l
            where
                (u,l) = divMod n ten
タブ区切りデータの処理 (Nested Flatten) 
あまり美しくないですが、基本に忠実に。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
import System.Environment
import Data.List

q1 (x:xs) = x:sortBy (\a b -> compare (toNum a) (toNum b)) xs
    where
        toNum n = read (head n)::Int
q2 = map (\[i,l,f,a] -> [i,f,l,a])
q3 (x:xs) = x:map (\[i,l,f,a] -> [i,l,f,show $ 1+read a]) xs

main = do
    args <- getArgs
    contents <- if (not.null) args
        then readFile $ head args
        else getContents
    let rec = map words $ lines contents
    putStrLn $ shows $ q1 rec
    putStrLn $ shows $ q2 rec
    putStrLn $ shows $ q3 rec
    where
        shows list = unlines $ map (concat.intersperse "\t") list
π (Nested Flatten)

単純に円周率の数字がほしいだけならHaskellには最初から用意されています。

1
main = print pi

すみません再投稿します

1
2
3
4
import System.Environment
main = print . flip take  (g (1,180,60,2)) . read . head =<< getArgs
g (q,r,t,i) = y : g (10*q*i*(2*i-1),10*u*(q*(5*i-2)+r-y*t),t*u,i+1)
  where (u,y) = (3*(3*i+1)*(3*i+2),div (q*(27*i-12)+5*r) (5*t))

言語指定しわすれた Haskell です

タブ区切りデータの処理 (Nested Flatten)

効率すこし改善版

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
import Control.Arrow
import Data.Function
import Data.List

main :: IO ()
main = mapM_ (putStrLn . concat . intersperse "\t") . uncurry (++) 
     . (map (swap23 . words) *** sortBy (compare `on` readInt . head) . map (swap23inccol4 . words)) 
     . splitAt 1 . filter (not . null) . lines =<< getContents
  where swap23 (x:y:z:ws) = x:z:y:ws
        swap23inccol4 (x:y:z:[w]) = x:z:y:[show (readInt w+1)]
        readInt :: String -> Int
        readInt = read

標準入力から標準出力へ

$ runghc tsv.hs < tsv.data
ID      Forename        Surname Age
0       Taro    Suzuki  19
1       Hanako  Sato    18

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
import Control.Arrow
import Data.Function
import Data.List

main :: IO ()
main = putStr . unlines . map (concat . intersperse "\t") . uncurry (++) 
     . second (map inccol4 . sortBy (compare `on` readInt . head)) 
     . splitAt 1 . map (swap23 . words) 
     . filter (not . null) . lines =<< getContents
  where swap23 (x:y:z:ws) = x:z:y:ws
        inccol4 (x:y:z:[w]) = x:y:z:[show (readInt w+1)]
        readInt :: String -> Int
        readInt = read
数値リストの圧縮 (Nested Flatten) 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
import List

compactNumberList xs = unfoldr f xs

f xs@(x:y:z:_) | x+z==2*y = Just (g (y-x) $ map fst as, map fst bs) where
  (as,bs) = span (uncurry (==)) $ zip xs [x,y..]
f (x:xs) = Just ([x], xs)
f [] = Nothing

g step xs = [head xs, last xs] ++ if step == 1 then [] else [step]

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
main = print $ f [1, 3, 4, 5, 6, 12, 13, 15, 20, 25, 26, 27] 

f s@(a:b:c:xs) = let step = b-a in
                 if b+step == c then fAux (a,c,step) xs
                 else [a] : f (b:c:xs)
f s = map (:[]) s
fAux (start,stop,step) s@(x:xs)
    | stop + step == x = fAux (start,x,step) xs
    | otherwise = (if step == 1 then [start,stop] else [start,stop,step]) : f s
fAux _ s = f s
LL Golf Hole 9 - トラックバックを打つ (Nested Flatten) 
 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
module Main where

import Data.Maybe
import Network.URI
import Network.HTTP

uriStr :: String
uriStr = "http://d.hatena.ne.jp/takano32/20080905"

bodyStr = urlEncodeVars
        [("title","LL Golf Hole 9")
        ,("blog_name", "LL Golf Hole 9")
        ,("url","http://ja.doukaku.org/207/")
        ,("excerpt","trackback from LL Golf Hole 9 with Haskell.")]

req :: Request
req = Request 
    { rqURI = fromJust $ parseURI uriStr
    , rqMethod = POST
    , rqHeaders = [Header HdrContentType "application/x-www-form-urlencoded"]
    , rqBody = bodyStr
    }

main :: IO ()
main = simpleHTTP req >>= print
lessの実装 (Nested Flatten) 
IOまみれですが、なんとか実装しました。
ライブラリを使えば楽勝と思いきや、必要な機能が無かったり、
画面サイズを超えるとエラーになったりと、意外と手間取り、
検索機能を入れる前に、力尽きてしまいました。

  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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
{-# LANGUAGE ForeignFunctionInterface #-}

--
--  ghc --make hless.hs -lncurses
--
--  need : hscurses-1.3

import System.IO
import Control.Exception
import System.Environment
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH

import Foreign
import Foreign.C.Types

--

foreign import ccall unsafe "ncurses.h winsdelln"
    winsdelln :: Curses.Window -> CInt -> IO CInt

deleteln :: Int -> IO CInt
deleteln n = winsdelln Curses.stdScr $ fromIntegral (-n)

insertln :: Int -> IO CInt
insertln n = winsdelln Curses.stdScr $ fromIntegral n

--
data File = File {
    fhandle ::  Handle,
    list    ::  [Integer]
} deriving (Show)

data Info = Info {
    file    ::  File,
    top     ::  Int
} deriving (Show)

--
scanFile :: Handle -> IO [Integer]
scanFile fp = do
    eof <- hIsEOF fp
    if eof
        then return []
        else do
            p <- hTell fp
            l <- hGetLine fp
            flist <- scanFile fp
            return (p : flist)

showLine :: File -> Int -> IO String
showLine f n
    | n >= (length $ list f)    = do return "~"
    | otherwise             = do
        hSeek (fhandle f) AbsoluteSeek $ (list f)!!n
        line <- hGetLine $ fhandle f
        return line
--

getW = do
    (_,w) <- Curses.scrSize
    return w

getH = do
    (h,_) <- Curses.scrSize
    return h

drawLine :: Info -> Int -> IO ()
drawLine info n = do
    str <- showLine (file info) (n + (top info))
    ss <- trim str
    Curses.mvWAddStr Curses.stdScr n 0 ss
    where
        trim s = do
            w <- getW
            if (length s) >= w
                then
                    return ((take (w-2) s) ++ "$")  -- (x_x)
                else
                    return s

redraw :: Info -> IO ()
redraw info = do
    h <- getH
    redraw' h
    Curses.refresh
    where
        redraw' 0 = return ()
        redraw' n = do
            m <- getH
            drawLine info (m-n)
            redraw' (n-1)

--

moveDown :: Info -> IO Info
moveDown info
    | (top info) >= len =   return info
    | otherwise         =   scrollUp
    where
        len = length $ list $ file info
        next = info { top = (top info) + 1 }
        scrollUp = do
            h <- getH
            CursesH.gotoTop
            deleteln 1
            Curses.move (h-1) 0
            drawLine next (h-1)
            Curses.refresh
            return next

moveUp :: Info -> IO Info
moveUp info
    | (top info) == 0   =   return info
    | otherwise         =   scrollDown
    where
        next = info { top = (top info) - 1 }
        scrollDown = do
            CursesH.gotoTop
            insertln 1
            drawLine next 0
            Curses.refresh
            return next

eventLoop :: Info -> IO Info
eventLoop info =
    do
        key <- Curses.getCh
        case key of
            Curses.KeyChar 'l' -> process $ return info
            Curses.KeyChar 'q' -> return info
            Curses.KeyChar 'n' -> process $ moveDown info
            Curses.KeyChar 'p' -> process $ moveUp info
            Curses.KeyUp       -> process $ moveUp info
            Curses.KeyDown     -> process $ moveDown info
            _ -> eventLoop info
        where
            process f = do
                r <- f
                eventLoop r

--

main = do
    (fileName:_) <- getArgs
    fp <- openFile fileName ReadMode
    flist <- scanFile fp
    let info = Info { file = File { fhandle = fp, list = flist}, top = 0}
    runMain info `finally` CursesH.end
    where
        runMain info = do
            CursesH.start
            redraw info
            eventLoop info
2^i * 3^j * 5^k なる整数 (Nested Flatten)

有名なエラトステネスのふるいを変形して。Haskellはあんまりやったことがないから勝手が分かりませんが。

1
2
3
4
5
sieve (x:xs) | divide235 x = x:sieve xs
             | otherwise = sieve [a | a <- xs, a `mod` x /= 0]
    where divide235 x = x `mod` 2 == 0 || x `mod` 3 == 0 || x `mod` 5 == 0

take 100 $ [1..6] ++ sieve [7..]

もりっとArrowで
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
module Main where

import Control.Arrow

f = Left >>> f' 2 >>> f' 3 >>> f' 5 >>> const False ||| const True                                                           
  where f' n = g n ||| Right

g n = loop ((snd &&& fst >>> app) &&& (snd >>> g'))
  where g' f m | n > m = Right ()
               | True  = case m `divMod` n of (x,0) -> f x; _ -> Left m

main = runKleisli func [1..]
  where func = arr (filter f) >>> arr (take 100) >>> Kleisli (mapM_ print)

Haskellらしく素直に無限リストで :)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
main :: IO ()
main = print $ take 100 hamming

hamming :: [Integer]
hamming = 1 : foldr1 (#) (zipWith map (map (*) [2,3,5]) (repeat hamming))

(#) :: Ord a => [a] -> [a] -> [a]
xxs@(x:xs) # yys@(y:ys) | x < y     = x : xs  # yys
                        | y < x     = y : xxs # ys
                        | otherwise = x : xs  # ys

ハミング数ですね。
anarchy golf の Hamming Numbers問題
http://golf.shinh.org/p.rb?Hamming+Numbers
のときに投稿した golf用の富豪コードです。

30のx乗 ≡ 0 (mod x) となる x がハミング数に
なることを使っています。（30 は 2,3,5 の最小公倍数）

富豪だから、け、計算量なんて気にしてないんだからね！

1
2
3
4
5
6
7
8
9
main = do
  n <- readLn
  mapM_ print $ take n [x| x <- [1..], mod (30^x) x == 0]

{- anarchy golf に投稿したコードはこちら

main=readLn>>=mapM print.(`take`[x|x<-[1..],mod(30^x)x<1])

-}
next >>

Index

Feed

Other

Link

Pathtraq

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