Hatena::Grouphaskell

Haskell卒業!

　　Haskellの勉強 -> 演習 -> 卒業
　　Haskell＆プログラミング卒業しました。その他サイコなことは「route150の日記」に書いています。

2010年07月11日 日曜日

■ [メモ][QuickCheck]関数が同じか簡易チェック 10:42

import Test.QuickCheck

-- 唐突だが、sample1、sample2の関数が同じか調べたい...
sample1 :: (a -> b -> c) -> (c -> d) -> a -> b -> d
sample1 = (. (.)) . flip (.)

sample2 :: (a -> b -> c) -> (c -> d) -> a -> b -> d
sample2 = flip ((.) . (.))

-- めんどいのでQuickCheckで簡易チェックする...
type Sample a = (a -> a -> a) -> (a -> a) -> a -> a -> a

prop_IsEqual :: (CoArbitrary a, Arbitrary a, Eq a) => Sample a -> Property
prop_IsEqual t = (`forAll` id) $ do
  f1 <- arbitrary
  f2 <- arbitrary
  x1 <- arbitrary
  x2 <- arbitrary
  return $ (sample1 `asTypeOf` t) f1 f2 x1 x2 == sample2 f1 f2 x1 x2

check :: (CoArbitrary a, Arbitrary a, Eq a) => Sample a -> IO ()
check = quickCheckWith stdArgs {maxSuccess = 1000} . prop_IsEqual

checkInt :: IO ()
checkInt = check (undefined :: Sample Int)

checkList :: IO ()
checkList = check (undefined :: Sample [Int])

-- 同じっぽいが...
-- $> checkInt
-- +++ OK, passed 1000 tests.
-- $> checkList
-- +++ OK, passed 1000 tests.

結局イマイチ信用できないので展開(簡約？)の仕方がよくわからないけど、

手作業でやってみたら、やはり同じようだ...


sample3 = (. (.)) . flip (.)
        = \a -> (. (.)) ((flip (.)) a)
        = \a -> ((flip (.)) a) . (.)
        = \a -> \b -> ((flip (.)) a) ((.) b)
        = \a -> \b -> flip (.) a ((.) b)
        = \a -> \b -> (.) ((.) b) a
        = \a -> \b -> \c -> ((.) b) (a c)
        = \a -> \b -> \c -> (.) b (a c)
        = \a -> \b -> \c -> \d -> b ((a c) d)
      
sample4 = flip ((.) . (.))
        = \a -> \b -> ((.) . (.)) b a
        = \a -> \b -> ((.) ((.) b)) a
        = \a -> \b -> (.) ((.) b) a
        = \a -> \b -> \c -> ((.) b) (a c)
        = \a -> \b -> \c -> (.) b (a c)
        = \a -> \b -> \c -> \d -> b ((a c) d)

因みにpointfulで調べてみても同じっぽいのだが...

$> :! pointful f = (. (.)) . flip (.)
f m p j c = p (m j c)
$> :! pointful f = flip ((.) . (.))
f b c f i = c (b f i)

パッとわかんね...


冷静に考えたら、型が合ってるから渡す関数が同じなら同じだなぁ...


最近、型をしっかり書くようになった。MapとかContとか使い出すとまた書かなくなる...多分...


型書くと単相性制限とか気にしなくていいけど、せっかく型推論で楽々なのにとも思ってしまう...

■ [文法]応用文法 (関数モナド(いつかの続き)) 12:18

意外と使える...


import Control.Applicative
import Control.Monad
import Data.List

testA2, testA3, testA4, testA5, testM2, testM3, testM4, testM5
  :: Integer -> Integer

testA2 = (*) <*> id
testM2 = id >>= (*)

-- testA2' = flip ($) <*> (*)
-- testM2' = join (*)

-- Applicativeは括弧がめんどい...
testA3 = (*) <*> ((*) <*> id)
testM3 = id >>= (*) >>= (*)

testA4 = (*) <*> ((*) <*> ((*) <*> id))
testM4 = id >>= (*) >>= (*) >>= (*)

-- Monadはシンプル...
testA5 = (*) <*> ((*) <*> ((*) <*> ((*) <*> id)))
testM5 = id >>= (*) >>= (*) >>= (*) >>= (*)

-- ...

testAs, testMs :: [Integer -> Integer]

testAs = const 1 : iterate ((*) <*>) id
testMs = const 1 : iterate (>>= (*)) id

powA, powM :: Integer -> Integer -> Integer

powA = flip $ head . (`genericDrop` testAs)
powM = flip $ head . (`genericDrop` testMs)

-- $> powA 2 8
-- 256
-- $> powM 2 8
-- 256
-- $> powA 2 16
-- 65536
-- $> powM 2 16
-- 65536

■ [文法]基本文法 (mapAccumL) 13:02

import Control.Applicative
import Control.Monad
import Data.List
import Data.Char (digitToInt)

-- mapAccumLM(モナド版)とかないのかなぁ...

-- mapAccumLの型は...
-- $> :t mapAccumL
-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
-- ついでにmapAccumRは...
-- $> :t mapAccumR
-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])

-- アキュムレータがL、Rともに左にあるのが特徴。それが何を意味するのかと
-- 言うと、quotRemとかdivModと一緒に使ってくださいってことだとエスパーした...

plus :: Integer -> Integer -> [Int]
plus x y = dropWhile (== 0) . uncurry (:)
  . fmap reverse . mapAccumL (((`quotRem` 10) .) . (+)) 0
  $ merge (conv x) (conv y)
 where
  conv :: Integer -> [Int]
  conv = reverse . fmap digitToInt . show

  merge :: [Int] -> [Int] -> [Int]
  merge xs       []       = xs
  merge []       ys       = ys
  merge (x : xs) (y : ys) = (x + y) : merge xs ys

-- 結果は...
-- $> plus 987654321 987654321
-- [1,9,7,5,3,0,8,6,4,2]

-- つか、足してからshowしてdigitToIntすればいいじゃん...
-- どうも勘違いだったようだ...

■ [文法]基本文法 (unfoldr) 13:23

import Control.Applicative
import Data.List
import Data.Char (intToDigit)

-- quotRemとかdivModと相性がいいのは、やっぱunfoldrかな...

divide :: Integer -> Integer -> String
divide x y = case x `quotRem` y of
  (q, 0) -> show q
  (q, r) -> shows q "." ++ (intToDigit . fromEnum <$> unfoldr f (r * 10))
 where f 0 = Nothing
       f n = Just $ (* 10) <$> n `quotRem` y

-- これは正解かな...
-- $> divide 10 100
-- "0.1"
-- $> divide 10 25
-- "0.4"
-- $> divide 10 3
-- "3.3333333333333333333333333333333333333333333333333333333
-- ...

■ [文法][QuickCheck]応用文法 (IOモナド) 21:52

IOモナドっぽい奴を定義してみる。つか、モナド則が成り立つことを確認する演習...


import Control.Applicative
import Control.Monad
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
import Text.Printf
import Data.Maybe (listToMaybe)

type Input   = [String]
type Output  = [String]
type WorldLike = (Int, (Input, Output))

data IOLike a = IOLike {unIOLike :: WorldLike -> (WorldLike, a)}
  deriving Show

-- IOモナドの基本戦略(演算の要)は記述した順番で実行(評価)してくれることのはず。
-- 副作用とかはRealWorldに丸投げすることで理屈的にカバーできるけど、
-- 順番だけは遵守してくれないと困る。モナド則は演算の規則で、
-- 1 + (2 + 3)と(1 + 2) + 3が同じことを保障するような規則だから、あんま
-- 深く考えない。とりあえず、モナド則が成り立たないとdo記法が意味を
-- 持たないから頑張って成り立たせる...
instance Monad IOLike where
  -- returnはWorldLikeを変化させないはずだから、こんな定義になるはず...
  return x = IOLike $ \world -> (world, x)
  -- bindは前のWorldLikeが手に入らないと、次の値を取得できないような仕組みに
  -- するはずだが...
  m >>= k = IOLike $ \world -> 
              let (world', x') = unIOLike m world in
                unIOLike (k x') world'
  fail = error . ("<IOLike.fail> " ++)

-- Monadなら自動的にFunctorもおk...
instance Functor IOLike where
  fmap = (=<<) . (return .)

-- Monad(Functor)ならほぼ自動的にApplicativeもおk...
instance Applicative IOLike where
  pure = return
  (<*>) = ap

-- チェックに必要なその他の定義...
instance Arbitrary a => Arbitrary (IOLike a) where
  arbitrary = IOLike <$> promote (`coarbitrary` arbitrary)

instance EqProp a => EqProp (IOLike a) where
  a =-= b = property $ (=-=) <$> unIOLike a <*> unIOLike b

-- でけた...

とりあえず、モナド則とファンクタ則(制約？)が成り立つことを確認してみる。QuickCheck /w Checkersを使って適当なデータ型でMonad則に反する例がないかくらいで十分かと...


monadLaws :: [TestBatch]
monadLaws =
  [ monad (undefined :: IOLike (Int, Int, Int))
  , monad (undefined :: IOLike (Maybe String, String, (Int, Int, Int)))
  , monad (undefined :: IOLike (Maybe Bool, [Int], Char)) ]

-- MonadならFunctor則も満たせるのでテケトー...
functorLaws :: [TestBatch]
functorLaws =
  [ functor (undefined :: IOLike (Bool, String, Int)) ]

checkLaws :: IO ()
checkLaws = mapM_ quickBatch $ monadLaws ++ functorLaws

結果は...


$> checkLaws

monad laws:
  left  identity: +++ OK, passed 500 tests.
  right identity: +++ OK, passed 500 tests.
  associativity:  +++ OK, passed 500 tests.

monad laws:
  left  identity: +++ OK, passed 500 tests.
  right identity: +++ OK, passed 500 tests.
  associativity:  +++ OK, passed 500 tests.

monad laws:
  left  identity: +++ OK, passed 500 tests.
  right identity: +++ OK, passed 500 tests.
  associativity:  +++ OK, passed 500 tests.

functor:
  identity: +++ OK, passed 500 tests.
  compose:  +++ OK, passed 500 tests.
(1877.89 secs, 396505449760 bytes) ←　やっぱ、これくらいメモリつかわないとな...

一応成り立つけど、なんか遅かった...


で、実際に使ってみる...


-- それは混沌から始まった...らしい...
initialWorld :: Input -> WorldLike
initialWorld input = (0, (input, []))

runIOLike :: Show a => Input -> IOLike a -> IO ()
runIOLike input m = case flip ($) (initialWorld input) . unIOLike $ m of
  ((count, (input, output)), value) -> do
    printf ">> Initialized.\n%s" $ unlines (reverse output)
    printf ">> Done.\n"
    printf ">> WorldLike has changed %d times.\n" count
    printf ">> The last value yielded by IOLike is %s.\n\n" (show value)

runIOLike_ :: Show a => IOLike a -> IO ()
runIOLike_ m = runIOLike [] m

-- 段々飽きてきた...
putStrLn' :: String -> IOLike ()
putStrLn' s = IOLike $ \(count, (input, output)) ->
  ((succ count, (input, s : output)), ())

getLine' :: IOLike (Maybe String)
getLine' = IOLike $ \(count, (input, output)) ->
  ((succ count, (drop 1 input, output)), listToMaybe $ take 1 input)

-- 一応、テスト...
ioLike1 :: IOLike [Int]
ioLike1 = do
  x1 <- return 5 :: IOLike Int
  x2 <- fmap (+ x1) <$> return [1 .. 5] :: IOLike [Int]
  return x2

-- do記法とbindを直接使った場合に出力が同じことを確認...
-- モナド則が成り立ってないと結果が違ってしまうけど、チェックしたから
-- 大丈夫なはず...
ioLike2 :: IOLike ()
ioLike2 = do
  putStrLn' $ "Hello, "
  putStrLn' $ "World!"
  putStrLn' $ "2010"

ioLike3 :: IOLike ()
ioLike3 = putStrLn' "Hello, " >> putStrLn' "World!" >> putStrLn' "2010"

-- 入力っぽいこともやってみる...
ioLike4 :: IOLike ()
ioLike4 = do
  m1 <- getLine'
  let s1 = maybe "" id m1
  m2 <- getLine'
  let s2 = maybe "" id m2
  putStrLn' $ s1 ++ s2

-- 実行してみよう。  
main = do
  runIOLike_ ioLike1
  runIOLike_ ioLike2
  runIOLike_ ioLike3
  runIOLike ["Hello, ", "World!", "2010"] ioLike4

結果は...


>> Initialized.
>> Done.
>> WorldLike has changed 0 times.
>> The last value yielded by IOLike is [6,7,8,9,10].

>> Initialized.
Hello,
World!
2010
>> Done.
>> WorldLike has changed 3 times.
>> The last value yielded by IOLike is ().

>> Initialized.
Hello,
World!
2010
>> Done.
>> WorldLike has changed 3 times.
>> The last value yielded by IOLike is ().

>> Initialized.
Hello, World!
>> Done.
>> WorldLike has changed 3 times.
>> The last value yielded by IOLike is ().

本物のIOモナドは肝心な部分がGHCのコアライブラリとか、外部のC関数になっている感じ(つか、本当の核の部分は当然システムコールとか標準Cライブラリの関数になるはずなので仕方ない)で、Haskellの普通の文法の範囲では結局は実現できてないっぽい。


IOモナドはプラットフォーム依存らしいし、どうせ標準の範囲で実現できないなら、IOの定義自体全く見えなくていいから、Cとかアセンブラでゴリゴリに最適化して欲しいところ...


状態は普通のHaskellの文法で扱えると思うけど、IOは特別な気がする...

コメント
日記の検索
最新タイトル
カテゴリー
最近のコメント
最近のトラックバック