sameElements.hs

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}

import Data.Monoid

data Same a
  = Same a
  | NotSame
  | EmptySame
  deriving (Eq, Show)

same :: (Foldable t, Eq a) => t a -> Same a
same xs = foldr f id xs EmptySame
  where
    f b g x =
      case x of
        EmptySame -> g (Same b)
        Same x' ->
          if x' == b
            then g (Same b)
            else NotSame

same' :: (Foldable t, Eq a) => t a -> Same a
same' xs = appEndo (foldMap (Endo . f) xs) id EmptySame
  where
    f b g x =
      case x of
        EmptySame -> g (Same b)
        Same x' ->
          if x' == b
            then g (Same b)
            else NotSame

-- this terminates

listTest :: Same Integer
listTest = same (replicate 100 1 ++ [2] ++ repeat 1)

listTest' :: Same Integer
listTest' = same' (replicate 100 1 ++ [2] ++ repeat 1)

data Tree a
  = Nil
  | Tree a
         (Tree a)
         (Tree a)
  deriving (Functor, Foldable)

nats :: Tree Integer
nats = go 0
  where
    go x = Tree x (go (2 * x + 1)) (go (2 * x + 2))

weirdTree :: Tree Integer
weirdTree = go 1
  where
    go x = Tree x (go 2) (go 2)

-- These terminate

natsSame :: Same Integer
natsSame = same nats

natsSame' :: Same Integer
natsSame' = same' nats

weirdTreeSame :: Same Integer
weirdTreeSame = same weirdTree

weirdTreeSame' :: Same Integer
weirdTreeSame' = same' weirdTree