{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Numeric.ProductOrd (ProductOrder (..), PartialOrdering (..), fromOrdering) where
import Data.Data
import Data.Kind (Type)
import Data.Monoid as Mon (Monoid (..))
import Data.Semigroup as Sem (Semigroup (..), stimesIdempotentMonoid)
import GHC.Generics
import Numeric.TypedList
class ProductOrder a where
cmp :: a -> a -> PartialOrdering
data PartialOrdering = PLT | PEQ | PGT | Incomparable
deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Enum, Bounded )
fromOrdering :: Ordering -> PartialOrdering
fromOrdering LT = PLT
fromOrdering EQ = PEQ
fromOrdering GT = PGT
{-# INLINE fromOrdering #-}
instance Sem.Semigroup PartialOrdering where
Incomparable <> _ = Incomparable
_ <> Incomparable = Incomparable
PLT <> PGT = Incomparable
PGT <> PLT = Incomparable
PLT <> _ = PLT
PGT <> _ = PGT
PEQ <> y = y
stimes = stimesIdempotentMonoid
instance Mon.Monoid PartialOrdering where
mempty = PEQ
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance All Ord (Map f xs)
=> ProductOrder (TypedList (f :: k -> Type) (xs :: [k])) where
cmp U U = PEQ
cmp (a :* as) (b :* bs) = fromOrdering (compare a b) <> cmp as bs
cmp' :: Ord a => a -> a -> PartialOrdering
cmp' a b = fromOrdering (compare a b)
{-# INLINE cmp' #-}
instance (Ord a1, Ord a2)
=> ProductOrder (a1, a2) where
cmp (a1, a2)
(b1, b2)
= cmp' a1 b1 <> cmp' a2 b2
instance (Ord a1, Ord a2, Ord a3)
=> ProductOrder (a1, a2, a3) where
cmp (a1, a2, a3)
(b1, b2, b3)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
instance (Ord a1, Ord a2, Ord a3, Ord a4)
=> ProductOrder (a1, a2, a3, a4) where
cmp (a1, a2, a3, a4)
(b1, b2, b3, b4)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4
instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5)
=> ProductOrder (a1, a2, a3, a4, a5) where
cmp (a1, a2, a3, a4, a5)
(b1, b2, b3, b4, b5)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4 <> cmp' a5 b5
instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6)
=> ProductOrder (a1, a2, a3, a4, a5, a6) where
cmp (a1, a2, a3, a4, a5, a6)
(b1, b2, b3, b4, b5, b6)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6
instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7)
=> ProductOrder (a1, a2, a3, a4, a5, a6, a7) where
cmp (a1, a2, a3, a4, a5, a6, a7)
(b1, b2, b3, b4, b5, b6, b7)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6
<> cmp' a7 b7
instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8)
=> ProductOrder (a1, a2, a3, a4, a5, a6, a7, a8) where
cmp (a1, a2, a3, a4, a5, a6, a7, a8)
(b1, b2, b3, b4, b5, b6, b7, b8)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6
<> cmp' a7 b7 <> cmp' a8 b8
instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8, Ord a9)
=> ProductOrder (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
cmp (a1, a2, a3, a4, a5, a6, a7, a8, a9)
(b1, b2, b3, b4, b5, b6, b7, b8, b9)
= cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3
<> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6
<> cmp' a7 b7 <> cmp' a8 b8 <> cmp' a9 b9