{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Ord.Ordering where

import Control.Category (Category(..) )
import Control.Lens
    ( view,
      isn't,
      (#),
      iso,
      prism',
      Getting,
      Prism',
      _Just,
      Iso )
import Control.Monad.State
    ( StateT, evalStateT )
import Data.Bool(bool)
import Data.Functor.Identity ( Identity(..) )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Functor.Contravariant.Divisible
    ( Decidable(..), Divisible(..) )
import Data.Void ( absurd )
import Prelude hiding (id, (.) )

type OrderingKnownEq =
  Maybe Ordering

newtype Order b a =
  Order (a -> a -> b)

class IsOrdering a where
  _Ordering ::
    Prism' a Ordering
  _LT ::
    Prism' a ()
  _LT =
    forall a. IsOrdering a => Prism' a Ordering
_Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'
      (\() -> Ordering
LT)
      (\case  Ordering
LT ->
                forall a. a -> Maybe a
Just ()
              Ordering
_ ->
                forall a. Maybe a
Nothing
      )
  _EQ ::
    Prism' a ()
  _EQ =
    forall a. IsOrdering a => Prism' a Ordering
_Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'
      (\() -> Ordering
EQ)
      (\case  Ordering
EQ ->
                forall a. a -> Maybe a
Just ()
              Ordering
_ ->
                forall a. Maybe a
Nothing
      )
  _GT ::
    Prism' a ()
  _GT =
    forall a. IsOrdering a => Prism' a Ordering
_Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'
      (\() -> Ordering
GT)
      (\case  Ordering
GT ->
                forall a. a -> Maybe a
Just ()
              Ordering
_ ->
                forall a. Maybe a
Nothing
      )

instance IsOrdering Ordering where
  _Ordering :: Prism' Ordering Ordering
_Ordering =
    forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

instance IsOrdering (Maybe Bool) where
  _Ordering :: Prism' (Maybe Bool) Ordering
_Ordering =
    forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
      (\case  Maybe Bool
Nothing ->
                Ordering
LT
              Just Bool
False ->
                Ordering
EQ
              Just Bool
True ->
                Ordering
GT
      )
      (\case  Ordering
LT ->
                forall a. Maybe a
Nothing
              Ordering
EQ ->
                forall a. a -> Maybe a
Just Bool
False
              Ordering
GT ->
                forall a. a -> Maybe a
Just Bool
True
      )

class IsOrdering a => IsOrderingKnownEq a where
  _OrderingKnownEq ::
    Prism' a OrderingKnownEq
  _KnownEQ ::
    Prism' a ()
  _KnownEQ =
    forall a. IsOrderingKnownEq a => Prism' a OrderingKnownEq
_OrderingKnownEq forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'
      (\() -> forall a. Maybe a
Nothing)
      (\case  OrderingKnownEq
Nothing ->
                forall a. a -> Maybe a
Just ()
              OrderingKnownEq
_ ->
                forall a. Maybe a
Nothing
      )

instance IsOrdering OrderingKnownEq where
  _Ordering :: Prism' OrderingKnownEq Ordering
_Ordering =
    forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. IsOrdering a => Prism' a Ordering
_Ordering

instance IsOrderingKnownEq OrderingKnownEq where
  _OrderingKnownEq :: Prism' OrderingKnownEq OrderingKnownEq
_OrderingKnownEq =
    forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

order ::
  Iso
    (Order b a)
    (Order b' a')
    (a -> a -> b)
    (a' -> a' -> b')
order :: forall b a b' a'.
Iso (Order b a) (Order b' a') (a -> a -> b) (a' -> a' -> b')
order =
  forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (\(Order a -> a -> b
x) -> a -> a -> b
x)
    forall b a. (a -> a -> b) -> Order b a
Order

instance Semigroup b => Semigroup (Order b a) where
  Order a -> a -> b
f <> :: Order b a -> Order b a -> Order b a
<> Order a -> a -> b
g =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> a -> a -> b
f a
a1 a
a2 forall a. Semigroup a => a -> a -> a
<> a -> a -> b
g a
a1 a
a2)

instance Monoid b => Monoid (Order b a) where
  mempty :: Order b a
mempty =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. Monoid a => a
mempty)

instance Contravariant (Order b) where
  contramap :: forall a' a. (a' -> a) -> Order b a -> Order b a'
contramap a' -> a
f (Order a -> a -> b
g) =
    forall b a. (a -> a -> b) -> Order b a
Order (\a'
a1 a'
a2 -> a -> a -> b
g (a' -> a
f a'
a1) (a' -> a
f a'
a2))

instance Monoid b => Divisible (Order b) where
  divide :: forall a b c. (a -> (b, c)) -> Order b b -> Order b c -> Order b a
divide a -> (b, c)
f (Order b -> b -> b
g) (Order c -> c -> b
h) =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> let (b
b1, c
c1) = a -> (b, c)
f a
a1
                         (b
b2, c
c2) = a -> (b, c)
f a
a2
                     in  b -> b -> b
g b
b1 b
b2 forall a. Semigroup a => a -> a -> a
<> c -> c -> b
h c
c1 c
c2)
  conquer :: forall a. Order b a
conquer =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. Monoid a => a
mempty)

instance Monoid b =>  Decidable (Order b) where
  choose :: forall a b c.
(a -> Either b c) -> Order b b -> Order b c -> Order b a
choose a -> Either b c
f (Order b -> b -> b
g) (Order c -> c -> b
h) =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> let e1 :: Either b c
e1 = a -> Either b c
f a
a1
                         e2 :: Either b c
e2 = a -> Either b c
f a
a2
                     in  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> b -> b
g (\c
_ b
_ -> forall a. Monoid a => a
mempty) Either b c
e2) (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\b
_ c
_ -> forall a. Monoid a => a
mempty) c -> c -> b
h Either b c
e2) Either b c
e1)
  lose :: forall a. (a -> Void) -> Order b a
lose a -> Void
f =
    forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> forall a. Void -> a
absurd (a -> Void
f a
a1 forall a. Semigroup a => a -> a -> a
<> a -> Void
f a
a2))

lt ::
  IsOrdering b =>
  Order b a
lt :: forall b a. IsOrdering b => Order b a
lt =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. IsOrdering a => Prism' a ()
_LT forall t b. AReview t b -> b -> t
# ())

isLT ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isLT :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool
isLT (Order a -> a -> b
f) a
a1 a
a2 =
  Bool -> Bool
not (forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_LT (a -> a -> b
f a
a1 a
a2))

ifLT ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifLT :: forall x a. IsOrdering x => a -> a -> x -> a
ifLT a
a1 a
a2 =
  forall a. a -> a -> Bool -> a
bool a
a2 a
a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_LT

eq ::
  IsOrdering b =>
  Order b a
eq :: forall b a. IsOrdering b => Order b a
eq =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. IsOrdering a => Prism' a ()
_EQ forall t b. AReview t b -> b -> t
# ())

isEQ ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isEQ :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool
isEQ (Order a -> a -> b
f) a
a1 a
a2 =
  Bool -> Bool
not (forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_EQ (a -> a -> b
f a
a1 a
a2))

ifEQ ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifEQ :: forall x a. IsOrdering x => a -> a -> x -> a
ifEQ a
a1 a
a2 =
  forall a. a -> a -> Bool -> a
bool a
a2 a
a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_EQ

gt ::
  IsOrdering b =>
  Order b a
gt :: forall b a. IsOrdering b => Order b a
gt =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. IsOrdering a => Prism' a ()
_GT forall t b. AReview t b -> b -> t
# ())

isGT ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isGT :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool
isGT (Order a -> a -> b
f) a
a1 a
a2 =
  Bool -> Bool
not (forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_GT (a -> a -> b
f a
a1 a
a2))

ifGT ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifGT :: forall x a. IsOrdering x => a -> a -> x -> a
ifGT a
a1 a
a2 =
  forall a. a -> a -> Bool -> a
bool a
a2 a
a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrdering a => Prism' a ()
_GT

knownEq ::
  IsOrderingKnownEq b =>
  Order b a
knownEq :: forall b a. IsOrderingKnownEq b => Order b a
knownEq =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
_ a
_ -> forall a. IsOrderingKnownEq a => Prism' a ()
_KnownEQ forall t b. AReview t b -> b -> t
# ())

isKnownEq ::
  IsOrderingKnownEq b =>
  Order b a
  -> a
  -> a
  -> Bool
isKnownEq :: forall b a. IsOrderingKnownEq b => Order b a -> a -> a -> Bool
isKnownEq (Order a -> a -> b
f) a
a1 a
a2 =
  Bool -> Bool
not (forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrderingKnownEq a => Prism' a ()
_KnownEQ (a -> a -> b
f a
a1 a
a2))

ifKnownEq ::
  IsOrderingKnownEq x =>
  a
  -> a
  -> x
  -> a
ifKnownEq :: forall x a. IsOrderingKnownEq x => a -> a -> x -> a
ifKnownEq a
a1 a
a2 =
  forall a. a -> a -> Bool -> a
bool a
a2 a
a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s t a b. APrism s t a b -> s -> Bool
isn't forall a. IsOrderingKnownEq a => Prism' a ()
_KnownEQ

ordOrder ::
  (Ord a, IsOrdering b) =>
  Order b a
ordOrder :: forall a b. (Ord a, IsOrdering b) => Order b a
ordOrder =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> case forall a. Ord a => a -> a -> Ordering
compare a
a1 a
a2 of
                      Ordering
LT ->
                        forall a. IsOrdering a => Prism' a ()
_LT forall t b. AReview t b -> b -> t
# ()
                      Ordering
GT ->
                        forall a. IsOrdering a => Prism' a ()
_GT forall t b. AReview t b -> b -> t
# ()
                      Ordering
EQ ->
                        forall a. IsOrdering a => Prism' a ()
_EQ forall t b. AReview t b -> b -> t
# ())

knownUnknownOrdering ::
  (IsOrderingKnownEq t, IsOrderingKnownEq a) =>
  t
  -> a
knownUnknownOrdering :: forall t a. (IsOrderingKnownEq t, IsOrderingKnownEq a) => t -> a
knownUnknownOrdering t
x =
  forall x a. IsOrdering x => a -> a -> x -> a
ifEQ
    (forall a. IsOrderingKnownEq a => Prism' a ()
_KnownEQ forall t b. AReview t b -> b -> t
# ())
    (
      forall x a. IsOrderingKnownEq x => a -> a -> x -> a
ifKnownEq
        (forall a. IsOrdering a => Prism' a ()
_EQ forall t b. AReview t b -> b -> t
# ())
        (
          forall x a. IsOrdering x => a -> a -> x -> a
ifLT
            (forall a. IsOrdering a => Prism' a ()
_LT forall t b. AReview t b -> b -> t
# ())
            (forall a. IsOrdering a => Prism' a ()
_GT forall t b. AReview t b -> b -> t
# ())
            t
x
        )
        t
x
    )
    t
x

mapOrdering ::
  (b -> b')
  -> Order b a
  -> Order b' a
mapOrdering :: forall b b' a. (b -> b') -> Order b a -> Order b' a
mapOrdering b -> b'
f (Order a -> a -> b
g) =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> b -> b'
f (a -> a -> b
g a
a1 a
a2))

knownUnknownOrder ::
  IsOrderingKnownEq b =>
  Order b a
  -> Order b a
knownUnknownOrder :: forall b a. IsOrderingKnownEq b => Order b a -> Order b a
knownUnknownOrder =
  forall b b' a. (b -> b') -> Order b a -> Order b' a
mapOrdering forall t a. (IsOrderingKnownEq t, IsOrderingKnownEq a) => t -> a
knownUnknownOrdering

(*>>) ::
  Applicative f =>
  Order (f a1) a2
  -> Order (f b) a2
  -> Order (f b) a2
*>> :: forall (f :: * -> *) a1 a2 b.
Applicative f =>
Order (f a1) a2 -> Order (f b) a2 -> Order (f b) a2
(*>>) (Order a2 -> a2 -> f a1
f) (Order a2 -> a2 -> f b
g) =
  forall b a. (a -> a -> b) -> Order b a
Order (\a2
a1 a2
a2 -> a2 -> a2 -> f a1
f a2
a1 a2
a2 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a2 -> a2 -> f b
g a2
a1 a2
a2)

infixr 6 *>>

appendOrder ::
  Semigroup x =>
  Order x x
appendOrder :: forall x. Semigroup x => Order x x
appendOrder =
  forall b a. (a -> a -> b) -> Order b a
Order forall a. Semigroup a => a -> a -> a
(<>)

listOrder ::
  (IsOrdering b, Semigroup b) =>
  Order b a
  -> Order b [a]
listOrder :: forall b a. (IsOrdering b, Semigroup b) => Order b a -> Order b [a]
listOrder (Order a -> a -> b
f) =
  let lists :: [a] -> [a] -> b
lists [] [] =
        forall a. IsOrdering a => Prism' a ()
_EQ forall t b. AReview t b -> b -> t
# ()
      lists [] (a
_:[a]
_) =
        forall a. IsOrdering a => Prism' a ()
_LT forall t b. AReview t b -> b -> t
# ()
      lists (a
_:[a]
_) [] =
        forall a. IsOrdering a => Prism' a ()
_GT forall t b. AReview t b -> b -> t
# ()
      lists (a
h1:[a]
t1) (a
h2:[a]
t2) =
        a -> a -> b
f a
h1 a
h2 forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> b
lists [a]
t1 [a]
t2
  in  forall b a. (a -> a -> b) -> Order b a
Order [a] -> [a] -> b
lists

orderL ::
  Contravariant f =>
  Getting a s a
  -> f a
  -> f s
orderL :: forall (f :: * -> *) a s.
Contravariant f =>
Getting a s a -> f a -> f s
orderL =
  forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view

orderL' ::
  (Ord a, IsOrdering b) =>
  Getting a s a
  -> Order b s
orderL' :: forall a b s. (Ord a, IsOrdering b) => Getting a s a -> Order b s
orderL' Getting a s a
x =
  forall (f :: * -> *) a s.
Contravariant f =>
Getting a s a -> f a -> f s
orderL Getting a s a
x forall a b. (Ord a, IsOrdering b) => Order b a
ordOrder

orderS ::
  Contravariant f =>
  StateT a Identity b
  -> f b
  -> f a
orderS :: forall (f :: * -> *) a b.
Contravariant f =>
StateT a Identity b -> f b -> f a
orderS StateT a Identity b
x =
  forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall a. Identity a -> a
runIdentity forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT a Identity b
x)

orderS' ::
  (Ord x, IsOrdering b) =>
  StateT a Identity x
  -> Order b a
orderS' :: forall x b a.
(Ord x, IsOrdering b) =>
StateT a Identity x -> Order b a
orderS' StateT a Identity x
x =
  forall (f :: * -> *) a b.
Contravariant f =>
StateT a Identity b -> f b -> f a
orderS StateT a Identity x
x forall a b. (Ord a, IsOrdering b) => Order b a
ordOrder

duplicates ::
  KnownEqOrd OrderingKnownEq a =>
  (t -> a)
  -> [t]
  -> [(t, t)]
duplicates :: forall a t.
KnownEqOrd OrderingKnownEq a =>
(t -> a) -> [t] -> [(t, t)]
duplicates t -> a
ord [t]
t =
  let isEQ' :: Order OrderingKnownEq a -> a -> a -> Bool
      isEQ' :: forall a. Order OrderingKnownEq a -> a -> a -> Bool
isEQ' = forall b a. IsOrdering b => Order b a -> a -> a -> Bool
isEQ
      pairs ::
        [a]
        -> [(a, a)]
      pairs :: forall a. [a] -> [(a, a)]
pairs [] =
        []
      pairs (a
h:[a]
r) =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
h,) [a]
r forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [(a, a)]
pairs [a]
r
  in  forall a. (a -> Bool) -> [a] -> [a]
filter (\(t
t1, t
t2) -> forall a. Order OrderingKnownEq a -> a -> a -> Bool
isEQ' forall b a. KnownEqOrd b a => Order b a
knownEqCompare (t -> a
ord t
t1) (t -> a
ord t
t2)) (forall a. [a] -> [(a, a)]
pairs [t]
t)

class Ord a => KnownEqOrd b a where
  knownEqCompare ::
    Order b a

areEqual ::
  (Eq a, IsOrdering b) =>
  a
  -> a
  -> Order b a
  -> Order b a
areEqual :: forall a b.
(Eq a, IsOrdering b) =>
a -> a -> Order b a -> Order b a
areEqual a
a1' a
a2' (Order a -> a -> b
f) =
  forall b a. (a -> a -> b) -> Order b a
Order (\a
a1 a
a2 -> forall a. a -> a -> Bool -> a
bool (a -> a -> b
f a
a1' a
a2') (forall a. IsOrdering a => Prism' a ()
_EQ forall t b. AReview t b -> b -> t
# ()) ((a
a1 forall a. Eq a => a -> a -> Bool
== a
a1' Bool -> Bool -> Bool
&& a
a2 forall a. Eq a => a -> a -> Bool
== a
a2') Bool -> Bool -> Bool
|| (a
a1 forall a. Eq a => a -> a -> Bool
== a
a2' Bool -> Bool -> Bool
&& a
a2 forall a. Eq a => a -> a -> Bool
== a
a1')))

(.===.) ::
  (Ord a, IsOrdering b) =>
  a
  -> a
  -> Order b a
a
a1 .===. :: forall a b. (Ord a, IsOrdering b) => a -> a -> Order b a
.===. a
a2 =
  forall a b.
(Eq a, IsOrdering b) =>
a -> a -> Order b a -> Order b a
areEqual a
a1 a
a2 forall a b. (Ord a, IsOrdering b) => Order b a
ordOrder