Playing around with ways of defining a group as a 2-category in Haskell

2cat.hs

{-# LANGUAGE MultiParamTypeClasses #-}

import Data.Maybe
import Data.List as List

-- Group stuff

class Group g where
    eye :: g
    (%) :: g -> g -> g
    inv :: g -> g

instance (Group g, Group h) => Group (g,h) where
    (a,b) % (c,d) = (a % c, b % d)
    inv (a,b)     = (inv a, inv b)
    eye           = (eye, eye)

cross xs ys = [(x,y) | x <- xs, y <- ys]

conj g = \h -> g % h % inv g

center gs = filter commutes gs where
    commutes g = all (\x -> g % x == x % g) gs

directProduct gs hs = [(g,h) | g <- gs, h <- hs]

-- Cyclic groups

data Cyclic = C { cn :: Int, k :: Int } deriving (Eq)

instance Show Cyclic where
    show (C n 0) = "1"
    show (C n k) = "c" ++ if k == 1 then "" else show k

instance Group Cyclic where
    (C n k) % (C n' k') = if n /= n'
        then error "Incompatible"
        else C n $ (k+k') `mod` n
    inv (C n k) = C n ((-k) `mod` n)
    eye = undefined

cyclic n = map (C n) [0..n-1]

-- Dihedral groups

data Dihedral = D { dn :: Int, r :: Int, m :: Int } deriving (Eq)

instance Show Dihedral where
    show (D n 0 m) = if m == 0 then "1" else "m"
    show (D n r 0) = "r" ++ (if r == 1 then "" else show r)
    show (D n r 1) = "mr" ++ (if r == 1 then "" else show r)

instance Group Dihedral where
    (D n r m) % (D n' r' m') = if n /= n'
        then error "Incompatible"
        else case (m, m') of
            (0, 0) -> D n ((r' + r) `mod` n) 0
            (0, 1) -> D n ((r' - r) `mod` n) 1
            (1, 0) -> D n ((r' + r) `mod` n) 1
            (1, 1) -> D n ((r' - r) `mod` n) 0
    inv (D n r m) = case m of
        0 -> D n (-r `mod` n) 0
        1 -> D n r 1
    eye = undefined

dihedral n = map (uncurry $ D n) (cross [0..(n-1)] [0,1])

-- Actions of one group on another (used to define semi-direct product)

class Acts g h where
    act :: g -> h -> h

instance Acts Cyclic Cyclic where
    (C n k) `act` c = if n /= 2
        then error "Only the action of C2 is defined"
        else case k of
            0 -> c
            1 -> inv c

newtype Semi g h = S { unS :: (g, h) } deriving (Eq)

instance (Show g, Show h) => Show (Semi g h) where
    show (S g) = show g

instance (Group g, Group h, Acts h g) => Group (Semi g h) where
    (S (a,b)) % (S (c,d)) = S (a % act b c, b % d)
    inv (S (a,b))         = S (inv b `act` inv a, inv b)
    eye                   = S (eye, eye)

semiDirect gs hs = [ S (g,h) | g <- gs, h <- hs ]

-- 

data Morphism2 g = T { from :: g, via :: g, to :: g } deriving (Eq)

instance (Show g) => Show (Morphism2 g) where
    show (T from via to) = "T[" ++ show via ++ "](" ++ show from ++ "->" ++ show to ++ ")"

make2morphism g h = T g h (h % g)
get2morphisms gs  = [ make2morphism g h | g <- gs, h <- center gs]

class TwoCell c where
    v :: c -> c -> Maybe c
    h :: c -> c -> Maybe c

instance (Group g, Eq g) => TwoCell (Morphism2 g) where
    (T a v b) `v` (T a' v' b') = if b' /= a
        then Nothing
        else Just $ T { from = a', via = v % v', to = b }
    (T a v b) `h` (T a' v' b') =
        Just $ T { from = a % a', via = v % v', to = b % b' }
--

justs = map fromJust . filter isJust

testComposition o gs = 
    let ms = get2morphisms gs
        cs = List.nub $ justs [ a `o` b | a <- ms, b <- ms]
    in and $ map (\m -> to m == via m % from m) cs

testVerticalComposition :: (Group g, Eq g) => [g] -> Bool
testVerticalComposition   = testComposition v

testHorizontalComposition :: (Group g, Eq g) => [g] -> Bool
testHorizontalComposition = testComposition h

testMorphismComposition gs =
    let ms = get2morphisms gs
        vs = List.nub $ justs [ a `v` b | a <- ms, b <- ms ]
        hs = List.nub $ justs [ a `h` b | a <- ms, b <- ms ]
    in length ms == length vs && length ms == length hs

testAlt a b c d = do 
    ab <- a `v` b
    cd <- c `v` d
    ac <- a `h` c
    bd <- b `h` d
    return $ (ab `h` cd) == (ac `v` bd)

testAlternatingLaw gs =
    let ms = get2morphisms gs
     in and $ justs [ testAlt a b c d | a <- ms, b <- ms, c <- ms, d <- ms ]

run = mapM_ (\n -> putStrLn $ "n = " ++ show n ++ ": " ++ 
        (show $ testAlternatingLaw $ dihedral n)) [1..10]