カテゴリー: Haskell

データの整列（Haskell版）

同じことをHaskellで。Ordクラスのインスタンスにしたら sortByDic はただの sort ですんだ。

import List

data Point = Pt Float Float deriving (Show, Eq, Ord)

distance :: Point -> Float
distance (Pt x y) = sqrt (x * x + y * y)

sortByDic :: [Point] -> [Point]
sortByDic = sort

sortByDis :: [Point] -> [Point]
sortByDis = List.sortBy (\p1 p2 -> compare (distance p1) (distance p2))

実行結果，辞書順：

*Main> sortByDic [Pt 3.2 1.9, Pt 3.2 0.3, Pt 1.2 3.5]
[Pt 1.2 3.5,Pt 3.2 0.3,Pt 3.2 1.9]

距離の昇順：

*Main> sortByDis [Pt 3.2 1.9, Pt 3.2 0.3, Pt 1.2 3.5]
[Pt 3.2 0.3,Pt 1.2 3.5,Pt 3.2 1.9]

ダブル完全数

cf. どう書く？.org – ダブル完全数

HaskellのほうがRubyよりすっきりしてるな。

divisors n = filter ((==0).mod n) [1..(n `div` 2 + 1)]

isDoublePerfectNumber n = (sum.divisors) n == (n*2)

main = mapM_ (putStrLn.show) $ filter isDoublePerfectNumber [1..10000]
def divisors(n)
  (1..(n/2+1)).to_a.select{|x| n % x == 0 }
end

def double_complete_number?(n)
  divisors(n).inject(0){|a,b| a+b } == 2 * n
end

(1..10000).to_a.each do |n|
  puts n if double_complete_number?(n)
end

結果は同じ（あたりまえ）だけど，Rubyのほうが速かった。

^o^ >runhaskell dpn.hs
120
672
^o^ >ruby dpn.rb
120
672

アルファベットの繰り上がり

cf. どう書く？.org – アルファベットの繰り上がり

succ でいいじゃん，と思ったらダメだった。

Prelude> succ 'A'
'B'
Prelude> succ 'Z'
'['

Ruby の String#succ はうまくやってくれるのに。

なら，26進数だと考えて素直に繰り上がりを処理すればいいか……と思ったけどこれもダメ。’A’ は 0 じゃない。要するに 0 が無いんだな。結局繰り上がりのところで汚いコードになってしまった。

module Main ( main ) where

import Data.Char ( ord, chr )
import Data.List ( mapAccumR, intersperse )

succS :: [Char] -> Int -> [Char]
succS s n = map intToAlpha $ g $ mapAccumR f n $ map alphaToInt s
  where
    alphaToInt c = (ord c ) - 64
    intToAlpha i = chr (i + 64)
    f acc x = let (d,m) = (acc+x) `divMod` 26
    in if m == 0 then (d-1,26) else (d,m)
    g (0,b) = b
    g (a,b) = a:b

main :: IO ()
main = putStr $ concat $ intersperse "," $ take 100 $ iterate (flip succS 1) "A"

実行：

^o^ >runhaskell succS.hs
A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,AA,AB,AC,AD,AE,AF,AG,AH,AI,A
J,AK,AL,AM,AN,AO,AP,AQ,AR,AS,AT,AU,AV,AW,AX,AY,AZ,BA,BB,BC,BD,BE,BF,BG,BH,BI,BJ,
BK,BL,BM,BN,BO,BP,BQ,BR,BS,BT,BU,BV,BW,BX,BY,BZ,CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK
,CL,CM,CN,CO,CP,CQ,CR,CS,CT,CU,CV

倍数になる13進数

cf. どう書く？.org – 倍数になる13進数

module Main (main) where

fromDecimal :: (Integral a) => a -> a -> a
fromDecimal n x = f 0 x 1
  where
    f r 0 _ = r
    f r y z = f (r + (y `mod` 10) * z) (y `div` 10) (z * n)

main :: IO ()
main = putStr $ show $ head $ filter (\x -> fromDecimal 13 x `mod` x == 0) [10..]

実行。

^o^ >runhaskell multiple13.hs
1557

アレイのuniq

cf. どう書く？.org – アレイのuniq

再帰で

uniq [] = []
uniq (x:xs) = x:uniq (filter (/=x) xs)

と書いてから，こんな関数ありそうだなぁと思ったらやっぱりあった。

Data.List nub

高階関数版：

uniq2 :: (Eq a) => [a] -> [a]
uniq2 = foldl (\a e -> if (elem e a) then a else a ++ [e]) []

型を明示しないとダメ。

Prelude> :l uniq2.hs
[1 of 1] Compiling Main             ( uniq2.hs, interpreted )

uniq2.hs:2:27:
    Ambiguous type variable `b' in the constraint:
      `Eq b' arising from use of `elem' at uniq2.hs:2:27-34
    Possible cause: the monomorphism restriction applied to the following:
      uniq2 :: [b] -> [b] (bound at uniq2.hs:2:0)
    Probable fix: give these definition(s) an explicit type signature
                  or use -fno-monomorphism-restriction
Failed, modules loaded: none.

ピラミッドを作る

どう書く？org – ピラミッドを作る

与えられた高さのピラミッドを作る

module Main where

import System

cjust :: Int -> String -> String
cjust w s | w <= length s = s
          | otherwise = margin ++ s ++ margin
  where
    margin = replicate ((w - (length s)) `div` 2) ' '

pyramid :: [String]
pyramid = map (flip replicate '*') [1,3..]

main :: IO ()
main = do h <- getArgs >>= return.read.head
          putStr $ unlines $ map (cjust (h*2-1)) $ take h pyramid

実行。

^o^ >runhaskell pyramid.hs 4
   *
  ***
 *****
*******
^o^ >runhaskell pyramid.hs 5
    *
   ***
  *****
 *******
*********
^o^ >runhaskell pyramid.hs 6
     *
    ***
   *****
  *******
 *********
***********
^o^ >runhaskell pyramid.hs 1
*
^o^ >runhaskell pyramid.hs 0

お，高さ0でもちゃんと動く。

条件を満たす行を取り除く

条件を満たす行を取り除く
　via http://d.hatena.ne.jp/gan2/20070706/1183708048

‘#’で始まる行を取り除く問題。すげーひさしぶりに Haskell で書いてみる。

module Main where

import System

f :: String -> Bool
f (h:tl) | h == '#' = False
          | otherwise = True

main :: IO ()
main = do fileName <- getArgs
          contents <- readFile (head fileName)
          putStr $ unlines $ filter f $ lines contents

実行。

^o^ >type sample.txt
hello!
# remove this
 # don't remove this
bye!
^o^ >runhaskell filterline.hs sample.txt
hello!
 # don't remove this
bye!

ファイルを1行ずつ処理するやり方を忘れててあせった。

追記：id:jmkさんからもらったアドバイスを追記しておこう。ありがとうございます。

f ('#':_) = False
f _ = True
  • 元のコードでは空行に対応できてない。
  • パターンマッチにはリテラルを使える。

FizzBuzz問題

なんか昨日からあちこちで見かけるので書いてみた。久しぶりの Haslellで。
あと，増田で剰余は使うな，と言ってるから使わない。

fizz = cycle ["","","Fizz"]
buzz = cycle ["","","","","Buzz"]

f "" n = show n
f s _ = s

main = mapM_ putStrLn $ zipWith f (zipWith (++) fizz buzz) [1..100]

あなごるじゃないから短くするのはやらない。

文字列を空白で区切る

テキストファイルから入力を受け付ける時にはよく使う。あとはカンマ区切りなんかも。

import Data.Char

splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy p [] = []
splitBy p xs = a : (splitBy p $ dropWhile p $ b)
  where
    (a, b) = break p xs

splitBySpace :: String -> [String]
splitBySpace = splitBy isSpace
*Main> splitBySpace "a b c"
["a","b","c"]
*Main> splitBySpace " a b c "
["","a","b","c"]

正規表現（Text.Regex）を使えばもっとシンプルに書ける。

import Text.Regex

splitBySpace' :: String -> [String]
splitBySpace' = splitRegex (mkRegex " +")
*Main> splitBySpace' "a b c"
["a","b","c"]
*Main> splitBySpace' " a b c "
["","a","b","c",""]

……けど，ちょっと動作が違うな。
ちなみに Ruby の String#split は上の splitBySpace と同じ動作。

D:\>irb --simple-prompt
>> "a b c".split(/ +/)
=> ["a", "b", "c"]
>> " a b c ".split(/ +/)
=> ["", "a", "b", "c"]

パターンの回転

パソコン甲子園というのを見つけた。
プログラミング部門の問題が公開されてるので（↓）ちょっとやってみよう。

正方行列つながりってことで問題01。

8文字×8行のパターンを右回りに90度、180度、270度回転させて出力し終了するプログラムを作成してください。

rotateMatrixR で右に90度回転させる。左に回転させる rotateMatrixL があるのは，勘違いしてさきに書いちゃったから。でも考えると右回転はちょっと面倒そうだな。これで正解かも。
main は手抜き。美しくない。

module Main (main) where

main :: IO ()
main = do cs <- getContents >>= return . lines
          putStrLn "90"
          showMatrix $ rotateMatrixR cs
          putStrLn "180"
          showMatrix $ rotateMatrixR $ rotateMatrixR cs
          putStrLn "270"
          showMatrix $ rotateMatrixR $ rotateMatrixR $ rotateMatrixR cs

rotateMatrixL :: [[a]] -> [[a]]
rotateMatrixL [xs] = [[x]| x <- reverse xs]
rotateMatrixL (xs:xss) = zipWith (:) (reverse xs) (rotateMatrixL xss)

rotateMatrixR :: [[a]] -> [[a]]
rotateMatrixR = reverse . rotateMatrixL . reverse

showMatrix :: [String] -> IO ()
showMatrix = putStr . unlines

実行例。

D:\>type input01.txt
#*******
#*******
#*******
#*******
#*******
#*******
#*******
########
D:\>runhaskell problem01.hs < input01.txt
90
########
#*******
#*******
#*******
#*******
#*******
#*******
#*******
180
########
*******#
*******#
*******#
*******#
*******#
*******#
*******#
270
*******#
*******#
*******#
*******#
*******#
*******#
*******#
########

追記：
右回転の方が簡単だった……orz

rotateMatrixR' :: [[a]] -> [[a]]
rotateMatrixR' = transpose . reverse
*Main> showMatrix sampleMatrix
#*******
#*******
#*******
#*******
#*******
#*******
#*******
########
*Main> showMatrix $ rotateMatrixR' sampleMatrix
########
#*******
#*******
#*******
#*******
#*******
#*******
#*******
*Main> showMatrix $ rotateMatrixR' $ rotateMatrixR' sampleMatrix
########
*******#
*******#
*******#
*******#
*******#
*******#
*******#

さらに追記：
ちがう！左回転も同じくらい簡単だ。

rotateMatrixL' :: [[a]] -> [[a]]
rotateMatrixL' = reverse . transpose