Permutation group of endomorphisms on the set {1,2,3}

permutationGroup.hs

{-# LANGUAGE RecordWildCards #-}
module Main where

data Set = Set { first :: Int
               , second :: Int
               , third :: Int
               } deriving (Eq, Show)

data Permutation = Permutation { mapping :: Set -> Set
                               , name :: String }

instance Show Permutation where
  show (Permutation _ name) = name

-- Our normal, ordered set of values
s :: Set
s = Set { first = 1, second = 2, third = 3}

a :: Permutation
a = Permutation {..}
  where
    mapping = \ (Set first second third) -> Set second first third
    name = "a"

b :: Permutation
b = Permutation {..}
  where
    mapping = \ (Set first second third) -> Set first third second
    name = "b"

c :: Permutation
c = Permutation {..}
  where
    mapping = \ (Set first second third) -> Set third first second
    name = "c"

d :: Permutation
d = Permutation {..}
  where
    mapping = \ (Set first second third) -> Set second third first
    name = "d"

e :: Permutation
e = Permutation {..}
  where
    mapping = id
    name = "e"

f :: Permutation
f = Permutation {..}
  where
    mapping = \ (Set first second third) -> Set third second first
    name = "f"

times :: Permutation -> Permutation -> Permutation
times (Permutation mapping1 name1) (Permutation mapping2 name2) = Permutation {..}
  where
    mapping = mapping1 . mapping2
    name = name1 ++ name2

apply :: Permutation -> Set -> Set
apply (Permutation mapping _) = mapping

allTwoComps :: [Permutation]
allTwoComps = times <$> [a, b, c, d, e, f] <*> [a, b, c, d, e, f]

beforeAndAfter :: Permutation -> Set -> String
beforeAndAfter Permutation{..} s = name ++ ": " ++ before ++ " -> " ++ after
  where
    before = show s
    after = show $ mapping s

-- Outputs the following:
-- aa: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
-- ab: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- ac: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- ad: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- ae: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- af: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- ba: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- bb: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
-- bc: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- bd: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- be: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- bf: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- ca: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- cb: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- cc: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- cd: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
-- ce: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- cf: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- da: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- db: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- dc: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
-- dd: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- de: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- df: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- ea: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- eb: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- ec: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- ed: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- ee: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
-- ef: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- fa: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 1, third = 2}
-- fb: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 3, third = 1}
-- fc: Set {first = 1, second = 2, third = 3} -> Set {first = 2, second = 1, third = 3}
-- fd: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 3, third = 2}
-- fe: Set {first = 1, second = 2, third = 3} -> Set {first = 3, second = 2, third = 1}
-- ff: Set {first = 1, second = 2, third = 3} -> Set {first = 1, second = 2, third = 3}
main :: IO ()
main = mapM_ (putStrLn . flip beforeAndAfter s) allTwoComps