some bipolygon finder

Elements.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Elements
  ( aElements, bElements, sElements
  ) where

import Control.Applicative (liftA2)

import Types

aElements :: [A]
aElements =
  [ E
  , LR L1 R1
  , LR L1 R2
  , LR L2 R1
  , LR L2 R2
  ]

bElements :: [B]
bElements = [ B1, B2 ]

sElements :: [S]
sElements = liftA2 S aElements bElements

Main.hs

$> cat Main.hs 
module Main where

import Properties
import Types

-- find right congruences not correct on A
ex1 :: [[[S]]]
ex1 = filter (not . onA) $ filter congruenceR distributions

Properties.hs

module Properties
  ( distributions
  , congruenceR, onA, equal, notCorrectOnA, mainCongruenceR
  ) where

import Control.Applicative ((<$>))
import Data.Function (on)
import Data.List (find)

import Elements
import Types

-- seems workable, not sure what going on inside these 2 functions
segmentation :: [a] -> [[[a]]]
segmentation [] = [[[]]]
segmentation [x] = [[[x]]]
segmentation (x:xs) =
    concatMap (\ys -> ([x]:ys):(superMap (\y h t -> h ++ [x:y] ++ t) ys)) $ segmentation xs

superMap :: (a -> [a] -> [a] -> b) -> [a] -> [b]
superMap f list = loop f list []
    where
      loop :: (a -> [a] -> [a] -> b) -> [a] -> [a] -> [b]
      loop _ [] _ = []
      loop f' (x:xs) ys =
        (f' x xs ys):(loop f' xs (x:ys))

distributions :: [[[S]]]
distributions = segmentation sElements

groupNumber :: (Eq a) => [[a]] -> a -> Maybe Int
groupNumber l = groupNumber' (zip l [0..])
  where groupNumber' ((list,index):lists) a | a `elem` list = Just index
                                            | otherwise = groupNumber' lists a
        groupNumber' [] _ = Nothing

equal :: [[S]] -> S -> S -> Bool
equal d = ((==) `on`) (groupNumber d)

congruenceR :: [[S]] -> Bool
congruenceR dis = and [ equal dis (a <> c) (b <> c)
  | a <- sElements
  , b <- sElements
  , a /= b
  , equal dis a b
  , c <- sElements
  ]

onA :: [[S]] -> Bool
onA dis = and [ equal dis (S (x <> s) y) (S (x' <> s) y')
  | S x y   <- sElements
  , S x' y' <- sElements
  , S x y /= S x' y'
  , equal dis (S x y) (S x' y')
  , s <- aElements
  ]

notCorrectOnA :: [[S]] -> Maybe (S, S, A)
notCorrectOnA dis = fst <$> find snd [ (els, not $ equal dis (S (x <> s) y) (S (x' <> s) y'))
  | S x  y  <- sElements
  , S x' y' <- sElements
  , S x y /= S x' y'
  , equal dis (S x y) (S x' y')
  , s <- aElements
  , let els = (S x y, S x' y', s)
  ]

mainCongruenceR :: [[S]] -> Bool
mainCongruenceR d = congruenceR d && mainCongruenceR' d
  where mainCongruenceR' dis = and [ not $ equal d (a <> c) (b <> c)
          | a <- sElements
          , b <- sElements
          , a /= b
          , not $ equal dis a b
          , c <- sElements
          ]

Types.hs

module Types
  ( L(..), R(..)
  , A(..), B(..), S(..)
  , Semigroup(..)
  ) where

import Data.Semigroup

data L = L1
       | L2
       deriving (Eq, Show)

data R = R1
       | R2
       deriving (Eq, Show)

data A = E
       | LR L R
       deriving (Eq, Show)

data B = B1
       | B2
       deriving (Eq, Show)

data S = S A B
       deriving (Eq, Show)

instance Semigroup A where
  E <> x = x
  x <> E = x
  LR l1 _ <> LR _ r2 = LR l1 r2

instance Semigroup B where
  _ <> x = x

instance Semigroup S where
  S a1 b1 <> S a2 b2 = S (a1 <> a2) (b1 <> b2)