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

import Control.Applicative

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

finEmpty :: Finite a
finEmpty :: Finite a
finEmpty = Index -> (Index -> a) -> Finite a
forall a. Index -> (Index -> a) -> Finite a
Finite Index
0 (\Index
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"index: Empty")

finUnion :: Finite a -> Finite a -> Finite a
finUnion :: Finite a -> Finite a -> Finite a
finUnion Finite a
f1 Finite a
f2
  | Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f1 Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== Index
0  = Finite a
f2
  | Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f2 Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== Index
0  = Finite a
f1
  | Bool
otherwise      = Index -> (Index -> a) -> Finite a
forall a. Index -> (Index -> a) -> Finite a
Finite Index
car Index -> a
sel where
  car :: Index
car = Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f1 Index -> Index -> Index
forall a. Num a => a -> a -> a
+ Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f2
  sel :: Index -> a
sel Index
i = if Index
i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
< Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f1
    then Finite a -> Index -> a
forall a. Finite a -> Index -> a
fIndex Finite a
f1 Index
i
    else Finite a -> Index -> a
forall a. Finite a -> Index -> a
fIndex Finite a
f2 (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f1)

instance Functor Finite where
  fmap :: (a -> b) -> Finite a -> Finite b
fmap a -> b
f Finite a
fin = Finite a
fin{fIndex :: Index -> b
fIndex = a -> b
f (a -> b) -> (Index -> a) -> Index -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite a -> Index -> a
forall a. Finite a -> Index -> a
fIndex Finite a
fin}

instance Applicative Finite where
  pure :: a -> Finite a
pure = a -> Finite a
forall a. a -> Finite a
finPure
  Finite (a -> b)
a <*> :: Finite (a -> b) -> Finite a -> Finite b
<*> Finite a
b = ((a -> b, a) -> b) -> Finite (a -> b, a) -> Finite b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)) (Finite (a -> b) -> Finite a -> Finite (a -> b, a)
forall a b. Finite a -> Finite b -> Finite (a, b)
finCart Finite (a -> b)
a Finite a
b)

instance Alternative Finite where
  empty :: Finite a
empty = Finite a
forall a. Finite a
finEmpty
  <|> :: Finite a -> Finite a -> Finite a
(<|>) = Finite a -> Finite a -> Finite a
forall a. Finite a -> Finite a -> Finite a
finUnion

instance Semigroup (Finite a) where
  <> :: Finite a -> Finite a -> Finite a
(<>) = Finite a -> Finite a -> Finite a
forall a. Finite a -> Finite a -> Finite a
finUnion

instance Monoid (Finite a) where
  mempty :: Finite a
mempty = Finite a
forall a. Finite a
finEmpty
  mconcat :: [Finite a] -> Finite a
mconcat [Finite a]
xs = Index -> (Index -> a) -> Finite a
forall a. Index -> (Index -> a) -> Finite a
Finite
    ([Index] -> Index
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Index] -> Index) -> [Index] -> Index
forall a b. (a -> b) -> a -> b
$ (Finite a -> Index) -> [Finite a] -> [Index]
forall a b. (a -> b) -> [a] -> [b]
map Finite a -> Index
forall a. Finite a -> Index
fCard [Finite a]
xs)
    ([Finite a] -> Index -> a
forall a. [Finite a] -> Index -> a
sumSel ([Finite a] -> Index -> a) -> [Finite a] -> Index -> a
forall a b. (a -> b) -> a -> b
$ (Finite a -> Bool) -> [Finite a] -> [Finite a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
>Index
0) (Index -> Bool) -> (Finite a -> Index) -> Finite a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite a -> Index
forall a. Finite a -> Index
fCard) [Finite a]
xs)

sumSel :: [Finite a] -> (Index -> a)
sumSel :: [Finite a] -> Index -> a
sumSel (Finite a
f:[Finite a]
rest) = \Index
i -> if Index
i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
< Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f
  then Finite a -> Index -> a
forall a. Finite a -> Index -> a
fIndex Finite a
f Index
i
  else [Finite a] -> Index -> a
forall a. [Finite a] -> Index -> a
sumSel [Finite a]
rest (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Finite a -> Index
forall a. Finite a -> Index
fCard Finite a
f)
sumSel [Finite a]
_        = [Char] -> Index -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Index out of bounds"

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

finPure :: a -> Finite a
finPure :: a -> Finite a
finPure a
a = Index -> (Index -> a) -> Finite a
forall a. Index -> (Index -> a) -> Finite a
Finite Index
1 Index -> a
forall a. (Eq a, Num a) => a -> a
one where
  one :: a -> a
one a
0 = a
a
  one a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Index out of bounds"


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


instance Show a => Show (Finite a) where
  show :: Finite a -> [Char]
show = (Index, [a]) -> [Char]
forall a. Show a => a -> [Char]
show ((Index, [a]) -> [Char])
-> (Finite a -> (Index, [a])) -> Finite a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite a -> (Index, [a])
forall a. Finite a -> (Index, [a])
fromFinite

finFin :: Integer -> Finite Integer
finFin :: Index -> Finite Index
finFin Index
k | Index
k Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
<= Index
0 = Finite Index
forall a. Finite a
finEmpty
finFin Index
k = Index -> (Index -> Index) -> Finite Index
forall a. Index -> (Index -> a) -> Finite a
Finite Index
k (\Index
i -> Index
i)