型によるプログラミング合成によるデザイン:SemigroupとMonoid 単位元、mempty、インスタンス

入門Haskellプログラミング
 楽天ブックス
Yahoo!ショッピング
au PAY マーケット

開発環境

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

コード

import Data.Semigroup

data Color
  = Red
  | Yellow
  | Blue
  | Green
  | Purple
  | Orange
  | Brown
  | Clear
  deriving (Show, Eq, Enum)

instance Semigroup Color where
  (<>) Clear c = c
  (<>) c Clear = c
  (<>) Red Blue = Purple
  (<>) Blue Red = Purple
  (<>) Yellow Blue = Green
  (<>) Blue Yellow = Green
  (<>) Yellow Red = Orange
  (<>) Red Yellow = Orange
  (<>) a b
    | a == b = a
    | all (`elem` [Red, Blue, Purple]) [a, b] = Purple
    | all (`elem` [Blue, Yellow, Green]) [a, b] = Green
    | all (`elem` [Red, Yellow, Orange]) [a, b] = Orange
    | otherwise = Brown

instance Monoid Color where
  mempty = Clear

cs :: [Color]
cs = [Red .. Clear]

cs1 :: [[String]]
cs1 =
  map
    ( \c1 ->
        map
          (\c2 -> show c1 ++ " " ++ show c2 ++ ": " ++ show (mappend c1 c2))
          cs
    )
    cs

main = do
  print (mempty :: Color)
  print $ mconcat cs
  mapM_ print cs1

入出力結果(Terminal, Zsh)

% runghc sample1.hs
Clear
Brown
["Red RedRed","Red YellowOrange","Red BluePurple","Red GreenBrown","Red PurplePurple","Red OrangeOrange","Red BrownBrown","Red ClearRed"]
["Yellow RedOrange","Yellow YellowYellow","Yellow BlueGreen","Yellow GreenGreen","Yellow PurpleBrown","Yellow OrangeOrange","Yellow BrownBrown","Yellow ClearYellow"]
["Blue RedPurple","Blue YellowGreen","Blue BlueBlue","Blue GreenGreen","Blue PurplePurple","Blue OrangeBrown","Blue BrownBrown","Blue ClearBlue"]
["Green RedBrown","Green YellowGreen","Green BlueGreen","Green GreenGreen","Green PurpleBrown","Green OrangeBrown","Green BrownBrown","Green ClearGreen"]
["Purple RedPurple","Purple YellowBrown","Purple BluePurple","Purple GreenBrown","Purple PurplePurple","Purple OrangeBrown","Purple BrownBrown","Purple ClearPurple"]
["Orange RedOrange","Orange YellowOrange","Orange BlueBrown","Orange GreenBrown","Orange PurpleBrown","Orange OrangeOrange","Orange BrownBrown","Orange ClearOrange"]
["Brown RedBrown","Brown YellowBrown","Brown BlueBrown","Brown GreenBrown","Brown PurpleBrown","Brown OrangeBrown","Brown BrownBrown","Brown ClearBrown"]
["Clear RedRed","Clear YellowYellow","Clear BlueBlue","Clear GreenGreen","Clear PurplePurple","Clear OrangeOrange","Clear BrownBrown","Clear ClearClear"]
kamimura@MacBook lesson17 % runghc sample1.hs
Clear
Brown
["Red Red: Red","Red Yellow: Orange","Red Blue: Purple","Red Green: Brown","Red Purple: Purple","Red Orange: Orange","Red Brown: Brown","Red Clear: Red"]
["Yellow Red: Orange","Yellow Yellow: Yellow","Yellow Blue: Green","Yellow Green: Green","Yellow Purple: Brown","Yellow Orange: Orange","Yellow Brown: Brown","Yellow Clear: Yellow"]
["Blue Red: Purple","Blue Yellow: Green","Blue Blue: Blue","Blue Green: Green","Blue Purple: Purple","Blue Orange: Brown","Blue Brown: Brown","Blue Clear: Blue"]
["Green Red: Brown","Green Yellow: Green","Green Blue: Green","Green Green: Green","Green Purple: Brown","Green Orange: Brown","Green Brown: Brown","Green Clear: Green"]
["Purple Red: Purple","Purple Yellow: Brown","Purple Blue: Purple","Purple Green: Brown","Purple Purple: Purple","Purple Orange: Brown","Purple Brown: Brown","Purple Clear: Purple"]
["Orange Red: Orange","Orange Yellow: Orange","Orange Blue: Brown","Orange Green: Brown","Orange Purple: Brown","Orange Orange: Orange","Orange Brown: Brown","Orange Clear: Orange"]
["Brown Red: Brown","Brown Yellow: Brown","Brown Blue: Brown","Brown Green: Brown","Brown Purple: Brown","Brown Orange: Brown","Brown Brown: Brown","Brown Clear: Brown"]
["Clear Red: Red","Clear Yellow: Yellow","Clear Blue: Blue","Clear Green: Green","Clear Purple: Purple","Clear Orange: Orange","Clear Brown: Brown","Clear Clear: Clear"]
%