月: 2016年1月

※この記事のMaybe編はこちら

idと名前のデータベースと、順位とidのデータベースからなる、下記のようなフレームワークを考えてみよう。

2位の名前を取り出すには、idFromRank で 2位のidを取り出し、その id を nameFromId に渡して名前を得るものとする。
idFromRank も nameFromId も要求された順位やidのデータがなければ Left に評価されるものとする。

type Err = String
type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Either Err ID
idFromRank db rk =
  case lookup rk db of
    Nothing -> Left $ "id of rank " ++ (show rk) ++ " was not found."
    Just id -> Right id

nameFromId :: NameDB -> ID -> Either Err Name
nameFromId db id =
  case lookup id db of
    Nothing   -> Left $ "name of id " ++ (show id) ++ " was not found."
    Just name -> Right name

このフレームワークを使って、上位3位の名前を取得する関数を作成してみよう。
ポイントは、idFromRank も nameFromId も Left に評価されることがあるため、この関数もEither型に評価されるものとし、1位から3位までのidがすべて存在し、それらの名前がすべて存在する場合のみRightに評価され、それ以外のときはLeftに評価されるようにすることだ。

下記のように呼び出されるようになればよいだろう。

main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

式を使ったプログラミングで素直に記述する場合、筆者の能力では下記の記述が限界である。
これはどう考えても地獄である。我々が関数プログラミングに求めていたものはこんなものではなかったはずだ。

topThree :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThree rdb ndb =
  let eitherId1 = idFromRank rdb 1
  in
   if isLeft eitherId1 then Left $ fromLeft eitherId1
   else
     let eitherName1 = nameFromId ndb $ fromRight eitherId1
     in
      if isLeft eitherName1 then Left $ fromLeft eitherName1
      else
        let eitherId2 = idFromRank rdb 2
        in
         if isLeft eitherId2 then Left $ fromLeft eitherId2
         else
           let eitherName2 = nameFromId ndb $ fromRight eitherId2
           in
            if isLeft eitherName2 then Left $ fromLeft eitherName2
            else
              let eitherId3 = idFromRank rdb 3
              in
               if isLeft eitherId3 then Left $ fromLeft eitherId3
               else
                 let eitherName3 = nameFromId ndb $ fromRight eitherId3
                 in
                  if isLeft eitherName3 then Left $ fromLeft eitherName3
                  else Right (
                    fromRight eitherName1,
                    fromRight eitherName2,
                    fromRight eitherName3
                    )
  where
    fromLeft (Left x) = x 
    fromRight (Right x) = x

Haskell には case 文があるので、効果的に使えば下記のように改善することができる。
しかし case 文の入れ子も本質的には地獄である。こんなことなら手続き型言語を使えばよいのではないか。

topThreeC :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Left e -> Left e
    Right id1 -> case nameFromId ndb id1 of
      Left e -> Left e
      Right n1 -> case idFromRank rdb 2 of
        Left e -> Left e
        Right id2 -> case nameFromId ndb id2 of
          Left e -> Left e
          Right n2 -> case idFromRank rdb 3 of
            Left e -> Left e
            Right id3 -> case nameFromId ndb id3 of
              Left e -> Left e
              Right n3 -> Right (n1,n2,n3)

そこで Eitherモナド登場。
Either型のモナドとしての性質を使うと、上記とまったく同じ意味の関数を下記の内容だけで記述することができる。
モナドとしてのEither型には、失敗するかもしれない計算どうしを組み合わせるときは、一部でも失敗したらすべてが失敗したことにする
という性質が最初から組み込まれているためである。

topThreeM :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)

全部のせておく。

import Data.Either (isLeft)

type Err = String
type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Either Err ID
idFromRank db rk =
  case lookup rk db of
    Nothing -> Left $ "id of rank " ++ (show rk) ++ " was not found."
    Just id -> Right id

nameFromId :: NameDB -> ID -> Either Err Name
nameFromId db id =
  case lookup id db of
    Nothing   -> Left $ "name of id " ++ (show id) ++ " was not found."
    Just name -> Right name




topThree :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThree rdb ndb =
  let eitherId1 = idFromRank rdb 1
  in
   if isLeft eitherId1 then Left $ fromLeft eitherId1
   else
     let eitherName1 = nameFromId ndb $ fromRight eitherId1
     in
      if isLeft eitherName1 then Left $ fromLeft eitherName1
      else
        let eitherId2 = idFromRank rdb 2
        in
         if isLeft eitherId2 then Left $ fromLeft eitherId2
         else
           let eitherName2 = nameFromId ndb $ fromRight eitherId2
           in
            if isLeft eitherName2 then Left $ fromLeft eitherName2
            else
              let eitherId3 = idFromRank rdb 3
              in
               if isLeft eitherId3 then Left $ fromLeft eitherId3
               else
                 let eitherName3 = nameFromId ndb $ fromRight eitherId3
                 in
                  if isLeft eitherName3 then Left $ fromLeft eitherName3
                  else Right (
                    fromRight eitherName1,
                    fromRight eitherName2,
                    fromRight eitherName3
                    )
  where
    fromLeft (Left x) = x 
    fromRight (Right x) = x



topThreeC :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Left e -> Left e
    Right id1 -> case nameFromId ndb id1 of
      Left e -> Left e
      Right n1 -> case idFromRank rdb 2 of
        Left e -> Left e
        Right id2 -> case nameFromId ndb id2 of
          Left e -> Left e
          Right n2 -> case idFromRank rdb 3 of
            Left e -> Left e
            Right id3 -> case nameFromId ndb id3 of
              Left e -> Left e
              Right n3 -> Right (n1,n2,n3)



topThreeM :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)




main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

※この記事のEither編はこちら

idと名前のデータベースと、順位とidのデータベースからなる、下記のようなフレームワークを考えてみよう。

2位の名前を取り出すには、idFromRank で 2位のidを取り出し、その id を nameFromId に渡して名前を得るものとする。
idFromRank も nameFromId も要求された順位やidのデータがなければ Nothing に評価されるものとする。

type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Maybe ID
idFromRank db rk = lookup rk db

nameFromId :: NameDB -> ID -> Maybe Name
nameFromId db id = lookup id db

このフレームワークを使って、上位3位の名前を取得する関数を作成してみよう。
ポイントは、idFromRank も nameFromId も Nothing に評価されることがあるため、この関数もMaybe型に評価されるものとし、1位から3位までのidがすべて存在し、それらの名前がすべて存在する場合のみJustに評価され、それ以外のときはNothingに評価されるようにすることだ。

下記のように呼び出されるようになればよいだろう。

main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

式を使ったプログラミングで素直に記述する場合、筆者の能力では下記の記述が限界である。
これはどう考えても地獄である。我々が関数プログラミングに求めていたものはこんなものではなかったはずだ。

topThree :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThree rdb ndb =
  let maybeId1 = idFromRank rdb 1
  in
   if isNothing maybeId1 then Nothing
   else
     let maybeName1 = nameFromId ndb $ fromJust maybeId1
     in
      if isNothing maybeName1 then Nothing
      else
        let maybeId2 = idFromRank rdb 2
        in
         if isNothing maybeId2 then Nothing
         else
           let maybeName2 = nameFromId ndb $ fromJust maybeId2
           in
            if isNothing maybeName2 then Nothing
            else
              let maybeId3 = idFromRank rdb 3
              in
               if isNothing maybeId3 then Nothing
               else
                 let maybeName3 = nameFromId ndb $ fromJust maybeId3
                 in
                  if isNothing maybeName3 then Nothing
                  else Just (
                    fromJust maybeName1,
                    fromJust maybeName2,
                    fromJust maybeName3
                    )

Haskell には case 文があるので、効果的に使えば下記のように改善することができる。
しかし case 文の入れ子も本質的には地獄である。こんなことなら手続き型言語を使えばよいのではないか。

topThreeC :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Nothing -> Nothing
    Just id1 -> case nameFromId ndb id1 of
      Nothing -> Nothing
      Just n1 -> case idFromRank rdb 2 of
        Nothing -> Nothing
        Just id2 -> case nameFromId ndb id2 of
          Nothing -> Nothing
          Just n2 -> case idFromRank rdb 3 of
            Nothing -> Nothing
            Just id3 -> case nameFromId ndb id3 of
              Nothing -> Nothing
              Just n3 -> Just (n1,n2,n3)

そこで Maybeモナド登場。
Maybe型のモナドとしての性質を使うと、上記とまったく同じ意味の関数を下記の内容だけで記述することができる。
モナドとしてのMaybe型には、失敗するかもしれない計算どうしを組み合わせるときは、一部でも失敗したらすべてが失敗したことにする
という性質が最初から組み込まれているためである。

topThreeM :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)

全部のせておく。

import Data.Maybe (isNothing,fromJust)

type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Maybe ID
idFromRank db rk = lookup rk db

nameFromId :: NameDB -> ID -> Maybe Name
nameFromId db id = lookup id db




topThree :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThree rdb ndb =
  let maybeId1 = idFromRank rdb 1
  in
   if isNothing maybeId1 then Nothing
   else
     let maybeName1 = nameFromId ndb $ fromJust maybeId1
     in
      if isNothing maybeName1 then Nothing
      else
        let maybeId2 = idFromRank rdb 2
        in
         if isNothing maybeId2 then Nothing
         else
           let maybeName2 = nameFromId ndb $ fromJust maybeId2
           in
            if isNothing maybeName2 then Nothing
            else
              let maybeId3 = idFromRank rdb 3
              in
               if isNothing maybeId3 then Nothing
               else
                 let maybeName3 = nameFromId ndb $ fromJust maybeId3
                 in
                  if isNothing maybeName3 then Nothing
                  else Just (
                    fromJust maybeName1,
                    fromJust maybeName2,
                    fromJust maybeName3
                    )
                                   


topThreeC :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Nothing -> Nothing
    Just id1 -> case nameFromId ndb id1 of
      Nothing -> Nothing
      Just n1 -> case idFromRank rdb 2 of
        Nothing -> Nothing
        Just id2 -> case nameFromId ndb id2 of
          Nothing -> Nothing
          Just n2 -> case idFromRank rdb 3 of
            Nothing -> Nothing
            Just id3 -> case nameFromId ndb id3 of
              Nothing -> Nothing
              Just n3 -> Just (n1,n2,n3)



topThreeM :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)




main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

現実的かどうかはさておき、税込み価格の商品と税抜き価格の商品が混在している店を考えてみよう。
会計の都合上、購入金額の合計を計算するときは、一旦すべての単価を税抜きに揃えてから集計し、まとめて税額を計算する必要があるものとする。

合計を計算するコードは下記のようになりそうだ。
このコードを眺めていると、toTaxIncluded と fromTaxIncluded の 引数 taxRate を消したくなってくるだろう。
ほぼ定数のようなものであり、合計の計算とは本質的に関係のない要素であるためだ。

main = do
  print $ total  0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]


toTaxIncluded :: Float -> Float -> Float
toTaxIncluded taxRate price = price * (1.00 + taxRate)

fromTaxIncluded :: Float -> Float -> Float
fromTaxIncluded taxRate tiPrice = tiPrice / (1.00 + taxRate)

total :: Float -> [(Float,Bool,Int)] -> Float
total taxRate xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncluded taxRate subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncluded taxRate
                      else id

そこでコードを下記のように改善してみよう。taxRate が引数から消えてすっきりした。
Haskell のコードをスクリプトとして使用している場合はこれで十分だろう。
ただ、一旦コンパイルされてしまうと、toTaxIncludedG と fromTaxIncludedG が使用する税率は固定されてしまう。

main = do
  print $ totalG      [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]


taxRateG :: Float
taxRateG = 0.08

toTaxIncludedG :: Float -> Float
toTaxIncludedG price = price * (1.00 + taxRateG)

fromTaxIncludedG :: Float -> Float
fromTaxIncludedG tiPrice = tiPrice / (1.00 + taxRateG)

totalG :: [(Float,Bool,Int)] -> Float
totalG xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncludedG subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncludedG
                      else id

そこでReaderモナド登場。Readerモナドを使用すると、手続き型プログラミングでグローバル変数として保持したいような要素を、自然に保持することができる。
runReader関数 の 第2引数で指定した値を、モナド内の任意の関数内で ask 関数を使用して取り出すことができる。

main = do
  print $ totalR 0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]



toTaxIncludedR :: Float -> Reader Float Float
toTaxIncludedR price = do
  taxRate <- ask
  return $ price * (1.00 + taxRate)

fromTaxIncludedR :: Float -> Reader Float Float
fromTaxIncludedR tiPrice = do
  taxRate <- ask
  return $ tiPrice / (1.00 + taxRate)
  
totalR :: Float -> [(Float,Bool,Int)] -> Float
totalR taxRate xs = (`runReader` taxRate) $ do
  subTotal <- foldM step 0.0 xs
  toTaxIncludedR subTotal
  where
    step :: Float -> (Float,Bool,Int) -> Reader Float Float
    step acc (price,taxin,quan) = do
      up <- unitPrice taxin price
      return $ acc + up * (fromIntegral quan)
  
    unitPrice taxin = if taxin
                      then fromTaxIncludedR
                      else return

全部のせておく。

import Data.List (foldl')
import Control.Monad.Reader (Reader,runReader,ask)
import Control.Monad (foldM)


main = do
  print $ total  0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]
  print $ totalG      [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]
  print $ totalR 0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]



toTaxIncluded :: Float -> Float -> Float
toTaxIncluded taxRate price = price * (1.00 + taxRate)

fromTaxIncluded :: Float -> Float -> Float
fromTaxIncluded taxRate tiPrice = tiPrice / (1.00 + taxRate)

total :: Float -> [(Float,Bool,Int)] -> Float
total taxRate xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncluded taxRate subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncluded taxRate
                      else id



taxRateG :: Float
taxRateG = 0.08

toTaxIncludedG :: Float -> Float
toTaxIncludedG price = price * (1.00 + taxRateG)

fromTaxIncludedG :: Float -> Float
fromTaxIncludedG tiPrice = tiPrice / (1.00 + taxRateG)

totalG :: [(Float,Bool,Int)] -> Float
totalG xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncludedG subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncludedG
                      else id



toTaxIncludedR :: Float -> Reader Float Float
toTaxIncludedR price = do
  taxRate <- ask
  return $ price * (1.00 + taxRate)

fromTaxIncludedR :: Float -> Reader Float Float
fromTaxIncludedR tiPrice = do
  taxRate <- ask
  return $ tiPrice / (1.00 + taxRate)
  
totalR :: Float -> [(Float,Bool,Int)] -> Float
totalR taxRate xs = (`runReader` taxRate) $ do
  subTotal <- foldM step 0.0 xs
  toTaxIncludedR subTotal
  where
    step :: Float -> (Float,Bool,Int) -> Reader Float Float
    step acc (price,taxin,quan) = do
      up <- unitPrice taxin price
      return $ acc + up * (fromIntegral quan)
  
    unitPrice taxin = if taxin
                      then fromTaxIncludedR
                      else return

System.Random について調べるコードを考えてみよう。
0から9までのランダムな整数を繰り返し生成するとき、最初に5が現れるのが何回目か知りたいとする。

System.Random には randomRs という関数があり、型と範囲と乱数生成器を指定すると、ランダムな値の無限リストに評価される。
この関数とリストを操作する関数を使えば、下記のようにすっきり記述できる。

場合によってはこれで十分だろう。ただ、処理効率や可読性の面で、より手続き型に近い記述にしたい場面がありそうだ。

count :: R.RandomGen g => g -> Int -> Int
count g n = length $ takeWhile (/=n) $ R.randomRs (0::Int,9) g

--
-- trace version
--
count' :: R.RandomGen g => g -> Int -> Int
count' g n = length $ takeWhile (\x -> trace ("x: " ++ show x) (x/=n)) $ R.randomRs (0::Int,9) g

方法1. Stateモナドを使う

System.Random には randomR という関数があり、型と範囲と乱数生成器を指定すると、ランダムな値と新しい乱数生成器の組に評価される。randomRs の単発版である。

execState は初期状態と Stateモナドを使用する関数を指定すると、終了状態に評価される関数だ。
Stateモナドは、副作用を扱うという点ではIOモナドと似ているが、純粋関数内に閉じ込められる点が異なる。
Stateモナド内で現在の状態を得るにはgetを、状態を更新するにはputを使用する。

countState :: R.RandomGen g => g -> Int -> Int
countState g n = snd $ execState loop (g,0)
  where
    loop :: R.RandomGen g => State (g,Int) ()
    loop = do
      (g,i) <- get
      let (x,g') = R.randomR (0::Int,9) g
      when (x/=n) $ put (g',i+1) >> loop -- n と同じ値が出るまで、状態を書き換えて繰り返す

--
-- trace version
--
countState' :: R.RandomGen g => g -> Int -> Int
countState' g n = snd $ execState loop (g,0)
  where
    loop :: R.RandomGen g => State (g,Int) ()
    loop = do
      (g,i) <- get
      let (x,g') = R.randomR (0::Int,9) g
      when (trace ("x: " ++ show x) (x/=n)) $ put (g',i+1) >> loop

方法2. STモナドを使う

また、IOモナドから入出力に関する機能を取り除き、純粋関数内で評価できるようにした、STモナドも使用できる。
IOモナド内で IORef を使用する感覚で STモナド内で使用できる STRefという型があり、状態を保持することができる。
STRef は 複数作成しても良いので状態の管理が複雑なときは便利かもしれない。

countST :: R.RandomGen g => g -> Int -> Int
countST g n = runST $ do
  ref <- newSTRef (g,0)
  loop ref
  (_,i) <- readSTRef ref -- 繰り返した回数を取り出して報告
  return i
    where
      loop :: R.RandomGen g => STRef s (g,Int) -> ST s ()
      loop ref = do
        (g,i) <- readSTRef ref
        let (x,g') = R.randomR (0::Int,9) g
        when (x/=n) $ writeSTRef ref (g',i+1) >> loop ref -- n と同じ値が出るまで、状態を書き換えて繰り返す

--
-- trace version
--
countST' :: R.RandomGen g => g -> Int -> Int
countST' g n = runST $ do
  ref <- newSTRef (g,0)
  loop ref
  (_,i) <- readSTRef ref
  return i
    where
      loop :: R.RandomGen g => STRef s (g,Int) -> ST s ()
      loop ref = do
        (g,i) <- readSTRef ref
        let (x,g') = R.randomR (0::Int,9) g
        when (trace ("x: " ++ show x) (x/=n)) $ writeSTRef ref (g',i+1) >> loop ref

全部のせておく。

import qualified System.Random as R
import Debug.Trace (trace)

import Control.Monad (when)
import Control.Monad.State(State,execState,get,put)
import Control.Monad.ST(ST,runST)
import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef)


main = do
  g <- R.newStdGen
  print $ count g 5
  print $ countState g 5
  print $ countST g 5
  print $ count' g 5
  print $ countState' g 5
  print $ countST' g 5



count :: R.RandomGen g => g -> Int -> Int
count g n = length $ takeWhile (/=n) $ R.randomRs (0::Int,9) g

--
-- trace version
--
count' :: R.RandomGen g => g -> Int -> Int
count' g n = length $ takeWhile (\x -> trace ("x: " ++ show x) (x/=n)) $ R.randomRs (0::Int,9) g



countState :: R.RandomGen g => g -> Int -> Int
countState g n = snd $ execState loop (g,0)
  where
    loop :: R.RandomGen g => State (g,Int) ()
    loop = do
      (g,i) <- get
      let (x,g') = R.randomR (0::Int,9) g
      when (x/=n) $ put (g',i+1) >> loop

--
-- trace version
--
countState' :: R.RandomGen g => g -> Int -> Int
countState' g n = snd $ execState loop (g,0)
  where
    loop :: R.RandomGen g => State (g,Int) ()
    loop = do
      (g,i) <- get
      let (x,g') = R.randomR (0::Int,9) g
      when (trace ("x: " ++ show x) (x/=n)) $ put (g',i+1) >> loop
      


countST :: R.RandomGen g => g -> Int -> Int
countST g n = runST $ do
  ref <- newSTRef (g,0)
  loop ref
  (_,i) <- readSTRef ref
  return i
    where
      loop :: R.RandomGen g => STRef s (g,Int) -> ST s ()
      loop ref = do
        (g,i) <- readSTRef ref
        let (x,g') = R.randomR (0::Int,9) g
        when (x/=n) $ writeSTRef ref (g',i+1) >> loop ref

--
-- trace version
--
countST' :: R.RandomGen g => g -> Int -> Int
countST' g n = runST $ do
  ref <- newSTRef (g,0)
  loop ref
  (_,i) <- readSTRef ref
  return i
    where
      loop :: R.RandomGen g => STRef s (g,Int) -> ST s ()
      loop ref = do
        (g,i) <- readSTRef ref
        let (x,g') = R.randomR (0::Int,9) g
        when (trace ("x: " ++ show x) (x/=n)) $ writeSTRef ref (g',i+1) >> loop ref