MuseMember.hs

import Data.Monoid

data Muse = HanayoKoizumi | RinHoshizora | MakiNishikino
          | UmiSonoda     | KotoriMinami | HonokaKosaka
          | EliAyase      | NicoYazawa   | NozomiTojo
          deriving (Eq, Ord, Enum, Show)

next :: Muse -> Muse
next HanayoKoizumi = RinHoshizora
next RinHoshizora  = MakiNishikino
next MakiNishikino = UmiSonoda
next UmiSonoda     = KotoriMinami
next KotoriMinami  = HonokaKosaka
next HonokaKosaka  = EliAyase
next EliAyase      = NicoYazawa
next NicoYazawa    = NozomiTojo
next NozomiTojo    = HanayoKoizumi

prev :: Muse -> Muse
prev HanayoKoizumi = NozomiTojo
prev RinHoshizora  = HanayoKoizumi
prev MakiNishikino = RinHoshizora
prev UmiSonoda     = MakiNishikino
prev KotoriMinami  = UmiSonoda
prev HonokaKosaka  = KotoriMinami
prev EliAyase      = HonokaKosaka
prev NicoYazawa    = EliAyase
prev NozomiTojo    = NicoYazawa

musePlus :: Muse -> Muse -> Muse
HanayoKoizumi `musePlus` HanayoKoizumi = HanayoKoizumi
HanayoKoizumi `musePlus` y = let y' = prev y
                             in next $ HanayoKoizumi `musePlus` y'
x `musePlus` y = let x' = prev x
                 in next $ x' `musePlus` y

instance Monoid Muse where
  mempty  = HanayoKoizumi
  mappend = musePlus

class (Monoid g) => MyGroup g where
  invert :: g -> g

museInvert :: Muse -> Muse
museInvert HanayoKoizumi = HanayoKoizumi
museInvert y = let y' = prev y
               in prev $ museInvert y'

instance MyGroup Muse where
  invert = museInvert

areSatisfyMonoidLaw :: Muse -> Muse -> Muse -> Bool
areSatisfyMonoidLaw x y z =
  let isAssociative = (x <> y) <> z == x <> (y <> z)
      unitExists    = mempty <> x == x && x == x <> mempty
  in isAssociative && unitExists

museIsMonoid :: Bool
museIsMonoid = foldr (&&) True $ do
  x <- [HanayoKoizumi .. NozomiTojo]
  y <- [HanayoKoizumi .. NozomiTojo]
  z <- [HanayoKoizumi .. NozomiTojo]
  return $ areSatisfyMonoidLaw x y z

satisfyGroupLaw :: Muse -> Bool
satisfyGroupLaw x =
  let inverseExists = x <> invert x == mempty && invert x <> x == mempty
  in inverseExists

museIsGroup :: Bool
museIsGroup = foldr (&&) True $ do
  x <- [HanayoKoizumi .. NozomiTojo]
  return $ satisfyGroupLaw x