[haskell] полугруппы нулей и единиц

data L = E | L1 | L2 deriving ( Eq, Show )
data R = R1 | R2 deriving ( Eq, Show )

ls :: [L]
ls = [E, L1, L2]

rs :: [R]
rs = [R1, R2]

(×) :: [a] -> [b] -> [(a, b)]
a × b = concat [[(x, y) | x <- a] | y <- b]

(∙) :: Eq a => (a, b') -> (a, b) -> (a, b)
x ∙ y = if fst x == fst y then y else (fst x, snd y)

-- > let prod = ls × rs
-- > prod
-- [(E,R1),(L1,R1),(L2,R1),(E,R2),(L1,R2),(L2,R2)]
-- > map (∙ head prod) prod
-- [(E,R1),(L1,R1),(L2,R1),(E,R1),(L1,R1),(L2,R1)]

-- |
-- Consider a term @a@ of a type (forall t. [t]) as a set, so that |a| = length(a).
-- 
import Prelude hiding ( (^) )
import Data.Maybe
import Data.List

-- | The cartesian power of a set @a@.
-- 
-- If |a| = n then |a ^ m| = n ^ m.
-- 
(^) :: [t] -> Int -> [[t]]
a ^ 0 = [[]]
a ^ n = [x:ys | x <- a, ys <- a ^ (n - 1)]

-- | All the different binary operations that can be defined on a set @a@.
-- 
-- If |a| = n then |magmas(n)| = n ^ (n ^ 2).
-- 
magmas :: Eq t => [t] -> [t -> t -> t]
magmas a = map (curry . op) $ a ^ length ops
  where
    op rs x = rs !! fromJust (elemIndex x ops) -- fromJust!
    ops = [(x, y) | x <- a, y <- a] -- length ops = length a ^ 2

-- | All the different associative binary operations that can be defined on a set @a@.
-- 
-- if |a| = n then |semigroups(n)| <= n ^ (n ^ 2).
-- 
semigroups :: Eq a => [a] -> [a -> a -> a]
semigroups a = filter assoc $ magmas a
  where
    assoc f = and [(x `f` y) `f` z == x `f` (y `f` z) | x <- a, y <- a, z <- a]

pPrint :: [t] -> [t -> t -> t] -> [[(t, t, t)]]
pPrint a fs = [[(x, y, f x y) | x <- a, y <- a] | f <- fs]

pPrintMagmas :: Eq t => [t] -> [[(t, t, t)]]
pPrintMagmas a = pPrint a $ magmas a

pPrintSemigroups :: Eq t => [t] -> [[(t, t, t)]]
pPrintSemigroups a = pPrint a $ semigroups a

-- > pPrintMagmas []
-- [[]]
-- > pPrintMagmas [1]
-- [[(1,1,1)]]
-- > pPrintMagmas [1,2]
-- [[(1,1,1),(1,2,1),(2,1,1),(2,2,1)],[(1,1,1),(1,2,1),(2,1,1),(2,2,2)],[(1,1,1),(1,2,1),(2,1,2),(2,2,1)],[(1,1,1),(1,2,1),(2,1,2),(2,2,2)],[(1,1,1),(1,2,2),(2,1,1),(2,2,1)],[(1,1,1),(1,2,2),(2,1,1),(2,2,2)],[(1,1,1),(1,2,2),(2,1,2),(2,2,1)],[(1,1,1),(1,2,2),(2,1,2),(2,2,2)],[(1,1,2),(1,2,1),(2,1,1),(2,2,1)],[(1,1,2),(1,2,1),(2,1,1),(2,2,2)],[(1,1,2),(1,2,1),(2,1,2),(2,2,1)],[(1,1,2),(1,2,1),(2,1,2),(2,2,2)],[(1,1,2),(1,2,2),(2,1,1),(2,2,1)],[(1,1,2),(1,2,2),(2,1,1),(2,2,2)],[(1,1,2),(1,2,2),(2,1,2),(2,2,1)],[(1,1,2),(1,2,2),(2,1,2),(2,2,2)]]
-- > length $ pPrintMagmas [1,2]
-- 16
-- > length $ pPrintMagmas [1,2,3]
-- 19683
-- > pPrintSemigroups []
-- [[]]
-- > pPrintSemigroups [1]
-- [[(1,1,1)]]
-- > pPrintSemigroups [1,2]
-- [[(1,1,1),(1,2,1),(2,1,1),(2,2,1)],[(1,1,1),(1,2,1),(2,1,1),(2,2,2)],[(1,1,1),(1,2,1),(2,1,2),(2,2,2)],[(1,1,1),(1,2,2),(2,1,1),(2,2,2)],[(1,1,1),(1,2,2),(2,1,2),(2,2,1)],[(1,1,1),(1,2,2),(2,1,2),(2,2,2)],[(1,1,2),(1,2,1),(2,1,1),(2,2,2)],[(1,1,2),(1,2,2),(2,1,2),(2,2,2)]]
-- > length $ pPrintSemigroups [1,2]
-- 8
-- > length $ pPrintSemigroups [1,2,3]
-- 113

(×) ∷ [a] → [b] → [(a, b)]
a × b = [ (x, y) | y ← b, x ← a ]

(load-file
 (let ((coding-system-for-read 'utf-8))
   (concat (file-name-directory
            (shell-command-to-string "~/.cabal/bin/agda-mode locate"))
           "agda-input.el")))

(setq haskell-font-lock-symbols 'unicode)