-----------------------------------------------------------------------------
-- |
-- Module      :  Finite.Class
-- Maintainer  :  Felix Klein
--
-- 'Finite' main class decleration including generics support.
--
-----------------------------------------------------------------------------

{-# LANGUAGE

    MultiWayIf
  , TypeOperators
  , DefaultSignatures
  , MultiParamTypeClasses
  , FlexibleContexts
  , FlexibleInstances

  #-}

-----------------------------------------------------------------------------

module Finite.Class
  ( T
  , Finite(..)
  , GFinite(..)
  ) where

-----------------------------------------------------------------------------

import Control.Exception
  ( assert
  )

import Finite.Type
  ( T
  , FiniteBounds
  , (#<<)
  , (<<#)
  , v2t
  , (\#)
  , (#)
  )

import GHC.Generics
  ( Generic
  , Rep
  , (:*:)(..)
  , (:+:)(..)
  , U1(..)
  , M1(..)
  , K1(..)
  , from
  , to
  )

import qualified Data.IntSet as S
  ( toList
  , fromList
  , fromAscList
  , difference
  )

-----------------------------------------------------------------------------

-- | The 'Finite' class.

class Finite b a where

  -- | Returns the number of elements associated with the given type.
  elements
    :: FiniteBounds b
    => T a -> Int

  default elements
    :: (Generic a, GFinite b (Rep a), FiniteBounds b)
    => T a -> Int

  elements T a
t = T (Rep a Any) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements (T (Rep a Any) -> Int) -> Rep a Any -> Int
forall a b. (T a -> b) -> a -> b
#<< a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (a -> Rep a Any) -> T a -> Rep a Any
forall a b. (a -> b) -> T a -> b
<<# T a
t

  -- | Turns the value in the associated range into an Int uniquely
  -- identifiying the value.
  index
    :: FiniteBounds b
    => a -> Int

  default index
    :: (Generic a, GFinite b (Rep a), FiniteBounds b)
    => a -> Int

  index a
v = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ a -> T a
forall a. a -> T a
v2t a
v)) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rep a Any -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex (Rep a Any -> Int) -> Rep a Any -> Int
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v

  -- | Turns an Int back to the value that is associated with it.
  value
    :: FiniteBounds b => Int -> a

  default value
    :: (Generic a, GFinite b (Rep a), FiniteBounds b)
    => Int -> a

  value Int
v =
    let
      o :: Int
o = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ a -> T a
forall a. a -> T a
v2t a
r
      e :: Int
e = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ a -> T a
forall a. a -> T a
v2t a
r
      r :: a
r = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Rep a Any -> a
forall a b. (a -> b) -> a -> b
$ Int -> Rep a Any
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o)
    in
      Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
o Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e) a
r

  -- | Allows to put an offset to the integer mapping. Per default the
  -- offset is zero.
  offset
    :: FiniteBounds b
    => T a -> Int

  offset T a
_ = Int
0

  -- | Returns a finite list of all elements of that type.
  values
    :: FiniteBounds b
    => [a]

  values =
    let
      rs :: [a]
rs = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value [Int]
xs
      o :: Int
o = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> T a
forall a. [a] -> T a
f [a]
rs
      n :: Int
n = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> T a
forall a. [a] -> T a
f [a]
rs
      xs :: [Int]
xs = [Int
o, Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    in
      [a]
rs

    where
      f :: [a] -> T a
      f :: [a] -> T a
f [a]
_ = T a
forall a. T a
(#)

  -- | Complements a given list of elements of that type
  complement
    :: FiniteBounds b
    => [a] -> [a]

  complement [a]
xs =
    let
      o :: Int
o = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> T a
forall a. [a] -> T a
f [a]
rs
      n :: Int
n = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements (T a -> Int) -> T a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> T a
forall a. [a] -> T a
f [a]
rs
      s :: IntSet
s = [Int] -> IntSet
S.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index [a]
xs
      a :: IntSet
a = [Int] -> IntSet
S.fromAscList [Int
o, Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      rs :: [a]
rs = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value ([Int] -> [a]) -> [Int] -> [a]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
S.toList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
S.difference IntSet
a IntSet
s
    in
      [a]
rs

    where
      f :: [a] -> T a
      f :: [a] -> T a
f [a]
_ = T a
forall a. T a
(#)

  -- | Less than operator according to the implicit total index order.
  (|<|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|<|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |<|

  -- | Less or equal than operator according to the implicit total
  -- index order.
  (|<=|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|<=|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |<=|

  -- | Greater or equal than operator according to the implicit total
  -- index order.
  (|>=|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|>=|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |>=|

  -- | Greater than operator according to the implicit total index
  -- order.
  (|>|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|>|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |>|

  -- | Equal operator according to the implicit total index order.
  (|==|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|==|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |==|

  -- | Unequal operator according to the implicit total index order.
  (|/=|)
    :: FiniteBounds b
    => a -> a -> Bool

  (|/=|) a
x a
y =
    a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
y

  infixr |/=|


  -- | First element according to the total index order.
  initial
    :: FiniteBounds b
    => T a -> a

  initial T a
t =
    Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset T a
t

  -- | Last element according to the total index order.
  final
    :: FiniteBounds b
    => T a -> a

  final T a
t =
    Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset T a
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements T a
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

  -- | Next element according to the total index order (undefined for
  -- the last element).
  next
    :: FiniteBounds b
    => a -> a

  next a
x =
    let i :: Int
i = a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x
    in Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (a -> T a
forall a. a -> T a
v2t a
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements (a -> T a
forall a. a -> T a
v2t a
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
       (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  -- | Previous element according to the total index order (undefined
  -- for the first element).
  previous
    :: FiniteBounds b
    => a -> a

  previous a
x =
    let i :: Int
i = a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x
    in Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (a -> T a
forall a. a -> T a
v2t a
x))
       (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  -- | The upper and lower bounds of the instance.
  bounds
    :: FiniteBounds b
    => T a -> (a, a)

  bounds T a
t =
    (T a -> a
forall b a. (Finite b a, FiniteBounds b) => T a -> a
initial T a
t, T a -> a
forall b a. (Finite b a, FiniteBounds b) => T a -> a
final T a
t)

-----------------------------------------------------------------------------

-- | Generics implementation for the 'Finite' class. The
-- realization is closely related to the one presented at
-- https://wiki.haskell.org/GHC.Generics.

class GFinite b f where
  gelements :: FiniteBounds b => T (f a) -> Int
  gindex :: FiniteBounds b => f a -> Int
  gvalue :: FiniteBounds b => Int -> f a

-----------------------------------------------------------------------------

-- | :*: instance.

instance
  (GFinite b f, GFinite b g)
    => GFinite b (f :*: g) where

  gelements :: T ((:*:) f g a) -> Int
gelements T ((:*:) f g a)
x =
    T (f a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements ((forall b a. b -> T a
forall (f :: * -> *) (g :: * -> *) a. T ((:*:) f g a) -> T (f a)
(\#) :: T ((f :*: g) a) -> T (f a)) T ((:*:) f g a)
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
*
    T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements ((forall b a. b -> T a
forall (f :: * -> *) (g :: * -> *) a. T ((:*:) f g a) -> T (g a)
(\#) :: T ((f :*: g) a) -> T (g a)) T ((:*:) f g a)
x)

  gindex :: (:*:) f g a -> Int
gindex (f a
f :*: g a
g) =
    (f a -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex f a
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* (T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements (T (g a) -> Int) -> g a -> Int
forall a b. (T a -> b) -> a -> b
#<< g a
g)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ g a -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex g a
g

  gvalue :: Int -> (:*:) f g a
gvalue Int
n =
    let
      m :: Int
m = T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements (T (g a) -> Int) -> g a -> Int
forall a b. (T a -> b) -> a -> b
#<< g a
g
      f :: f a
f = Int -> f a
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
m)
      g :: g a
g = Int -> g a
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
m)
    in
     (f a
forall a. f a
f f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
forall a. g a
g)

-----------------------------------------------------------------------------

-- | :+: instance.

instance
  (GFinite b f, GFinite b g)
    => GFinite b (f :+: g) where

  gelements :: T ((:+:) f g a) -> Int
gelements T ((:+:) f g a)
x =
    T (f a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements ((forall b a. b -> T a
forall (f :: * -> *) (g :: * -> *) a. T ((:+:) f g a) -> T (f a)
(\#) :: T ((f :+: g) a) -> T (f a)) T ((:+:) f g a)
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+
    T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements ((forall b a. b -> T a
forall (f :: * -> *) (g :: * -> *) a. T ((:+:) f g a) -> T (g a)
(\#) :: T ((f :+: g) a) -> T (g a)) T ((:+:) f g a)
x)

  gindex :: (:+:) f g a -> Int
gindex (:+:) f g a
x = case (:+:) f g a
x of
    R1 g a
y -> g a -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex g a
y
    L1 f a
y -> f a -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex f a
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements ((forall b a. b -> T a
forall (f :: * -> *) (g :: * -> *) a. (:+:) f g a -> T (g a)
(\#) :: (f :+: g) a -> T (g a)) (:+:) f g a
x)

  gvalue :: Int -> (:+:) f g a
gvalue Int
n =
    let
      m :: Int
m = T (g a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements (T (g a) -> Int) -> g a -> Int
forall a b. (T a -> b) -> a -> b
#<< g a
g
      g :: g a
g = Int -> g a
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
m)
      f :: f a
f = Int -> f a
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
    in if
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m     -> g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g a
forall a. g a
g
      | Bool
otherwise -> f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f a
forall a. f a
f

-----------------------------------------------------------------------------

-- | U1 instance.

instance
  GFinite c U1 where

  gelements :: T (U1 a) -> Int
gelements T (U1 a)
_ = Int
1

  gindex :: U1 a -> Int
gindex U1 a
U1 = Int
0

  gvalue :: Int -> U1 a
gvalue Int
_ = U1 a
forall k (p :: k). U1 p
U1

-----------------------------------------------------------------------------

-- | M1 instance.

instance
  (GFinite c f)
    => GFinite c (M1 i v f) where

  gelements :: T (M1 i v f a) -> Int
gelements =
    T (f a) -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
T (f a) -> Int
gelements (T (f a) -> Int)
-> (T (M1 i v f a) -> T (f a)) -> T (M1 i v f a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b a. b -> T a
forall i (v :: Meta) (f :: * -> *) p. T (M1 i v f p) -> T (f p)
(\#) :: T ((M1 i v f) p) -> T (f p))

  gindex :: M1 i v f a -> Int
gindex (M1 f a
x) = f a -> Int
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
f a -> Int
gindex f a
x

  gvalue :: Int -> M1 i v f a
gvalue = f a -> M1 i v f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i v f a) -> (Int -> f a) -> Int -> M1 i v f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f a
forall b (f :: * -> *) a.
(GFinite b f, FiniteBounds b) =>
Int -> f a
gvalue

-----------------------------------------------------------------------------

-- | K1 instance.

instance
  (Finite b a)
    => GFinite b (K1 i a) where

  gelements :: T (K1 i a a) -> Int
gelements =
    T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements (T a -> Int) -> (T (K1 i a a) -> T a) -> T (K1 i a a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b a. b -> T a
forall i a c. T (K1 i a c) -> T a
(\#) :: T ((K1 i a) c) -> T a)

  gindex :: K1 i a a -> Int
gindex (K1 a
x) = a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index a
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- (T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> a -> Int
forall a b. (T a -> b) -> a -> b
#<< a
x)

  gvalue :: Int -> K1 i a a
gvalue Int
n =
    let
      m :: Int
m = T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset (T a -> Int) -> a -> Int
forall a b. (T a -> b) -> a -> b
#<< a
x
      x :: a
x = Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)
    in
      a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 a
x

-----------------------------------------------------------------------------