Finite.hs

-- | A datatype of finite sequences
module Test.Feat.Finite (Finite (..), Index, fromFinite, finFin) where

import Control.Applicative
import Data.Monoid

type Index = Integer
data Finite a = Finite {fCard :: Index, fIndex :: Index -> a}

finEmpty = Finite 0 (\i -> error "index: Empty")

finUnion :: Finite a -> Finite a -> Finite a
finUnion f1 f2
  | fCard f1 == 0  = f2
  | fCard f2 == 0  = f1
  | otherwise      = Finite car sel where
  car = fCard f1 + fCard f2
  sel i = if i < fCard f1
    then fIndex f1 i
    else fIndex f2 (i-fCard f1)

instance Functor Finite where
  fmap f fin = fin{fIndex = f . fIndex fin}

instance Applicative Finite where
  pure = finPure
  a <*> b = fmap (uncurry ($)) (finCart a b)

instance Alternative Finite where
  empty = finEmpty
  (<|>) = finUnion

instance Monoid (Finite a) where
  mempty = finEmpty
  mappend = finUnion
  mconcat xs = Finite
    (sum $ map fCard xs)
    (sumSel $ filter ((>0) . fCard) xs)

sumSel :: [Finite a] -> (Index -> a)
sumSel (f:rest) = \i -> if i < fCard f
  then fIndex f i
  else sumSel rest (i-fCard f)
sumSel _        = error "Index out of bounds"

finCart :: Finite a -> Finite b -> Finite (a,b)
finCart f1 f2 = Finite car sel where
  car = fCard f1 * fCard f2
  sel i = let (q, r) = (i `quotRem` fCard f2)
    in (fIndex f1 q, fIndex f2 r)

finPure :: a -> Finite a
finPure a = Finite 1 one where
  one 0 = a
  one _ = error "Index out of bounds"


fromFinite :: Finite a -> (Index,[a])
fromFinite (Finite c ix) = (c,map ix [0..c-1])


instance Show a => Show (Finite a) where
  show = show . fromFinite

finFin :: Integer -> Finite Integer
finFin k | k <= 0 = finEmpty
finFin k = Finite k (\i -> i)