I ran into a problem recently where I had to decide whether a set of sum types was homogeneous (all the same). In itself, this is a pretty simple problem. However, there were a few complicating factors:
- There exists a type within the types (call it
Id) that is ignored in the comparisons.
- There exists a type (call it
Mix) that immediately makes the set non-homogeneous, even if all the types are
The extension of this problem was, given a list of types, is there a single type that can be removed that will make the rest of the types homogeneous (excepting, of course, the
For example, if we define our type as:
data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show)
[Bar, Bar, Bar] is homogeneous,
[Bar, Bar, Baz] would be homogeneous if
Baz were removed. Further,
[Bar, Bar, Id] is homogeneous, and
[Mix, Mix, Mix] is not. Finally,
[Bar, Bar, Mix] contains a
Mix type, and hence would not be homogeneous even if this type were removed.
import Data.List as List import Data.Map as Map data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show) -- Is a list of the above sum types homogeneous? -- Note that Id is ignored in the comparisons, and Mix immediately -- makes this False. homogeneous :: [Foo] -> Bool homogeneous  = True homogeneous [x] = if x == Mix then False else True homogeneous (x:xs) = all isEqNotMix xs where isEqNotMix y = ((y == x || y == Id) && y /= Mix) -- Find a type that would make the set homogeneous if it were removed. -- Note that if we have an already homogeneous set, then removing the -- single homoogeneous type from the list will leave it being homogenoeous. -- The final part of the tuple returns whether it was a homogeneous list or not. -- Note that in the case of no such type existing, the result is -- (Mixed, Mixed, False). homogeneousButOne :: [Foo] -> (Foo, Foo, Bool) homogeneousButOne xs = case xs of  -> (Id, Id, True) [x] -> (x, x, homogeneous [x]) xs@(x:_) -> if homogeneous xs then (x, x, True) else (fst mixed, snd mixed, False) where mixed = mixedCase $ List.filter (/= Id) xs -- Deal with the case where the list is not homogeneous in homogeneousButOne. mixedCase :: [Foo] -> (Foo, Foo) mixedCase xs | Mix `elem` keys = (Mix, Mix) | Map.size fooMap == 2 = decideTwo fooMap | otherwise = (Mix, Mix) where fooMap = List.foldl (acc x -> Map.insertWith (+) x 1 acc) Map.empty xs keys = Map.keys fooMap single = Map.filter (== 1) fooMap multiple = Map.filter (> 1) fooMap firstKey = head . Map.keys secondKey = head . tail . Map.keys -- Only case where we may not have (Mix, Mix) is if there were -- only two types found, and neither of them was `Mix`. decideTwo mp = case Map.size single of -- Both types exist > 1 times 0 -> (Mix, Mix) -- One type exists once, it is the type that can be removed 1 -> (firstKey multiple , firstKey single) -- Both types only exist once (e.g. [Bar, Baz]) 2 -> (firstKey single, secondKey single)
Any improvements to this code are welcome (excepting the names of the sum types: I realise
Quux aren’t great, but in the original problem, the names were no more descriptive).
In this line
homogeneous [x] = if x == Mix then False else True
you have something like
if expr then False else True which is the same as
not expr. That is:
homogeneous [x] = x /= Mix
In the fact the whole line could be just:
homogeneous [Mix] = False
because the line
homogeneous (x:xs) = ... would do the right thing for the cases that are not covered by
A Map is an overkill in this case, since the problem can be solved in linear time looping through the list of Foos. Here’s one possible implementation:
homogeneousButOne :: [Foo] -> (Foo, Foo, Bool) homogeneousButOne foos | sansId ==  = (Id, Id, True) | homogeneous sansId = (ref, ref, True) | elem Mix sansId = (Mix, Mix, False) | all (== other) others = (ref, other, False) | otherwise = (Mix, Mix, False) where sansId = filter (/= Id) foos (ref : remaining) = sansId (other : others) = filter (/= ref) remaining
Note however that in this implementation I valued clarity over efficiency.
homogeneous could also be defined using pattern matching, though that would not necessarily be an improvement.
homogeneousButOne can definitely be simplified using pattern matching, with no need for
data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show) homogeneous :: [Foo] -> Bool homogeneous  = True homogeneous (Mix : _) = False homogeneous (Id : xs) = homogeneous xs homogeneous (x : ) = True homogeneous (a:Id:rest) = homogeneous (a:rest) homogeneous (a:b:rest) = (a == b) && homogeneous (b:rest) homogeneousButOne :: [Foo] -> (Foo, Foo, Bool) homogeneousButOne xs | null nonId = (Id, Id, True) | x' == Mix = (Mix, Mix, False) | length nonId == 3 = majority2of3 nonId | homogeneous nonId = (x', x', True) | homogeneous xs' = (head xs', x', False) | x' == predominant = (predominant, alt, False) | otherwise = (Mix, Mix, False) where nonId = filter (/= Id) xs (x':xs') = nonId majority2of3 (a:b:c:) = if a == b then (a, c, a == c) else if a == c then (a, b, a == b) else if b == c then (b, a, b == a) else (Mix, Mix, False) (predominant, alt, _) = homogeneousButOne xs'