Haskell - 型によるプログラミング - 合成によるデザイン:SemigroupとMonoid - リファクタリング

開発環境

入門Haskellプログラミング (Will Kurt(著)、株式会社クイープ(監修、翻訳)、翔泳社)の UNIT3(型によるプログラミング)、LESSON 17(合成によるデザイン:SemigroupとMonoid)、17.5(練習問題)、Q17-2の解答を求めてみる。

コード

sample.hs

import Distribution.PackageDescription.Quirks (patchQuirks)

main :: IO ()
main = do
  print $ coinEvents <> coinEvents
  print $ coinProbs <> coinProbs
  print $ spinnerEvents <> spinnerEvents
  print $ spinnerProbs <> spinnerProbs
  print $ coinEvents <> spinnerEvents
  print $ coinProbs <> spinnerProbs
  print $ spinnerEvents <> coinEvents
  print $ spinnerProbs <> coinProbs

data Events = Events [String] deriving (Show)

data Probs = Probs [Double] deriving (Show)

cartCombine :: (a -> b -> c) -> [a] -> [b] -> [c]
cartCombine func l1 l2 = zipWith func newL1 cycleL2
  where
    nToAdd = length l2
    repeatedL1 = map (replicate nToAdd) l1
    newL1 = mconcat repeatedL1
    cycleL2 = cycle l2

instance Semigroup Events where
  (<>) :: Events -> Events -> Events
  (<>) (Events e1) (Events e2) = Events $ cartCombine combiner e1 e2
    where
      combiner x y = mconcat [x, "-", y]

instance Monoid Events where
  mempty :: Events
  mempty = Events []

instance Semigroup Probs where
  (<>) :: Probs -> Probs -> Probs
  (<>) (Probs p1) (Probs p2) = Probs $ cartCombine (*) p1 p2

instance Monoid Probs where
  mempty :: Probs
  mempty = Probs []

coinEvents :: Events
coinEvents = Events ["heads", "tails"]

coinProbs :: Probs
coinProbs = Probs [0.5, 0.5]

spinnerEvents :: Events
spinnerEvents = Events ["red", "blue", "green"]

spinnerProbs :: Probs
spinnerProbs = Probs [0.1, 0.2, 0.7]

入出力結果(Terminal, Zsh)

% runghc sample.hs
Events ["heads-heads","heads-tails","tails-heads","tails-tails"]
Probs [0.25,0.25,0.25,0.25]
Events ["red-red","red-blue","red-green","blue-red","blue-blue","blue-green","green-red","green-blue","green-green"]
Probs [1.0000000000000002e-2,2.0000000000000004e-2,6.999999999999999e-2,2.0000000000000004e-2,4.000000000000001e-2,0.13999999999999999,6.999999999999999e-2,0.13999999999999999,0.48999999999999994]
Events ["heads-red","heads-blue","heads-green","tails-red","tails-blue","tails-green"]
Probs [5.0e-2,0.1,0.35,5.0e-2,0.1,0.35]
Events ["red-heads","red-tails","blue-heads","blue-tails","green-heads","green-tails"]
Probs [5.0e-2,5.0e-2,0.1,0.1,0.35,0.35]
%