{-# Language ConstraintKinds #-}
{-# Language Rank2Types #-}

module Data.Dioid.Signed where

import Data.Bifunctor (first)
import Data.Connection
import Data.Connection.Float
import Data.Float
import Data.Ord (Down(..))
import Data.Prd
import Data.Prd.Lattice
import Data.Semigroup.Quantale
import Data.Semiring
import Prelude

-- | 'Sign' is isomorphic to 'Maybe Ordering' and (Bool,Bool), but has a distinct poset ordering:
--
-- @ 'Indeterminate' >= 'Positive' >= 'Zero'@ and
-- @ 'Indeterminate' >= 'Negative' >= 'Zero'@ 
--
-- Note that 'Positive' and 'Negative' are not comparable. 
--
--   * 'Positive' can be regarded as representing (0, +∞], 
--   * 'Negative' as representing [−∞, 0), 
--   * 'Indeterminate' as representing [−∞, +∞] v NaN, and 
--   * 'Zero' as representing the set {0}.
--
data Sign = Zero | Negative | Positive | Indeterminate deriving (Show, Eq)

signOf :: (Eq a, Num a, Prd a) => a -> Sign
signOf x = case sign x of
    Nothing -> Indeterminate
    Just EQ -> Zero
    Just LT -> Negative
    Just GT -> Positive

instance Semigroup Sign where
    Positive <> Positive            = Positive
    Positive <> Negative            = Indeterminate
    Positive <> Zero                = Positive
    Positive <> Indeterminate       = Indeterminate

    Negative <> Positive            = Indeterminate
    Negative <> Negative            = Negative
    Negative <> Zero                = Negative
    Negative <> Indeterminate       = Indeterminate

    Zero <> a                       = a

    Indeterminate <> _              = Indeterminate

instance Monoid Sign where
    mempty = Zero

instance Semiring Sign where
    Positive >< a = a

    Negative >< Positive            = Negative
    Negative >< Negative            = Positive
    Negative >< Zero                = Zero
    Negative >< Indeterminate       = Indeterminate

    Zero >< _                       = Zero

    --NB: measure theoretic zero
    Indeterminate >< Zero           = Zero
    Indeterminate >< _              = Indeterminate

    fromBoolean = fromBooleanDef Positive

-- TODO if we dont use canonical ordering then we can define a
-- monotone map to floats
instance Prd Sign where
    Positive <~ Positive         = True
    Positive <~ Negative         = False
    Positive <~ Zero             = False
    Positive <~ Indeterminate    = True 

    Negative <~ Positive         = False
    Negative <~ Negative         = True
    Negative <~ Zero             = False
    Negative <~ Indeterminate    = True
    
    --Zero <~ Indeterminate        = False
    Zero <~ _                    = True

    Indeterminate <~ Indeterminate  = True
    Indeterminate <~ _              = False

instance Min Sign where
    minimal = Zero

instance Max Sign where
    maximal = Indeterminate

instance Bounded Sign where
    minBound = minimal
    maxBound = maximal

-- Signed

newtype Signed = Signed { unSigned :: Float }

instance Show Signed where
    show (Signed x) = show x

instance Eq Signed where
    (Signed x) == (Signed y) | isNan x && isNan y = True 
                             | isNan x || isNan y = False
                             | otherwise = split x == split y -- 0 /= -0

instance Prd Signed where
    Signed x <~ Signed y | isNan x && isNan y = True
                         | isNan x || isNan y = False
                         | otherwise = (first Down $ split x) <~ (first Down $ split y)

    pcompare (Signed x) (Signed y) | isNan x && isNan y = Just EQ 
                                   | isNan x || isNan y = Nothing 
                                   | otherwise = pcompare (first Down $ split x) (first Down $ split y)

f32sgn :: Conn Float Signed
f32sgn = Conn f g where
  f x | x == nInf = Signed $ -0
      | otherwise = Signed $ either (const 0) id $ split x

  g (Signed x) = either (const nInf) id $ split x

ugnsgn :: Conn Unsigned Signed
ugnsgn = Conn f g where
  f (Unsigned x) = Signed $ abs x
  g (Signed x) = Unsigned $ either (const 0) id $ split x

{-
ugnf32 :: Conn Unsigned (Down Float)
ugnf32 = Conn f g where
  g (Down x) = Unsigned . max 0 $ x
  f (Unsigned x) = Down x
-}

--TODO 
--dont export constructor, qquoters and/or rebindable syntax

newtype Unsigned = Unsigned Float

unsigned :: Signed -> Unsigned
unsigned (Signed x) = Unsigned (abs x)

instance Show Unsigned where
    show (Unsigned x) = show $ abs x

instance Eq Unsigned where
    (Unsigned x) == (Unsigned y) | finite x && finite y = (abs x) == (abs y) 
                                 | not (finite x) && not (finite y) = True
                                 | otherwise = False

-- Unsigned has a 2-Ulp interval semiorder containing all joins and meets.
instance Prd Unsigned where
    u <~ v = u `ltugn` v || u == v 

ltugn :: Unsigned -> Unsigned -> Bool
ltugn (Unsigned x) (Unsigned y) | finite x && finite y = (abs x) < shift (-2) (abs y) 
                                | finite x && not (finite y) = True
                                | otherwise = False

instance Min Unsigned where
    minimal = Unsigned 0

instance Max Unsigned where
    maximal = Unsigned pInf

instance Lattice Unsigned where
  (Unsigned x) \/ (Unsigned y) | finite x && finite y = Unsigned $ max (abs x) (abs y)
                               | otherwise = Unsigned x

  (Unsigned x) /\ (Unsigned y) | finite x && finite y = Unsigned $ min (abs x) (abs y)
                               | not (finite x)  && finite y = Unsigned y
                               | otherwise = Unsigned x

instance Semigroup Unsigned where
    Unsigned x <> Unsigned y = Unsigned $ abs x + abs y

instance Monoid Unsigned where
    mempty = Unsigned 0

instance Semiring Unsigned where
    Unsigned x >< Unsigned y | zero x || zero y = Unsigned 0
                             | otherwise = Unsigned $ abs x * abs y

    fromBoolean = fromBooleanDef (Unsigned 1)

instance Quantale Unsigned where
    x \\ y = y // x

    Unsigned y // Unsigned x = Unsigned . max 0 $ y // x