{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeInType          #-}
{-# LANGUAGE TypeOperators       #-}

-- |
-- Module      : Data.Type.Predicate.Logic
-- Copyright   : (c) Justin Le 2018
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Logical and algebraic connectives for predicates, as well as common
-- logical combinators.
module Data.Type.Predicate.Logic (
  -- * Top and bottom
    Evident, Impossible
  -- * Logical connectives
  , type Not, decideNot
  , type (&&&), decideAnd
  , type (|||), decideOr, type (^||), type (||^)
  , type (^^^), decideXor
  , type (==>), proveImplies, Implies
  , type (<==>), Equiv
  -- * Logical deductions
  , compImpl, explosion, atom
  , complementation, doubleNegation, tripleNegation, negateTwice
  , contrapositive, contrapositive'
  -- ** Lattice
  , projAndFst, projAndSnd, injOrLeft, injOrRight
  ) where

import           Data.Singletons
import           Data.Singletons.Decide
import           Data.Type.Predicate
import           Data.Void

-- | @p '&&&' q@ is a predicate that both @p@ and @q@ are true.
data (&&&) :: Predicate k -> Predicate k -> Predicate k
type instance Apply (p &&& q) a = (p @@ a, q @@ a)
infixr 3 &&&

instance (Decidable p, Decidable q) => Decidable (p &&& q) where
    decide :: Sing a -> Decision ((p &&& q) @@ a)
decide (x :: Sing a) = Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p &&& q) @@ a)
forall k1 (p :: k1 ~> *) (q :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p &&& q) @@ a)
decideAnd @p @q @a (Sing a -> Decision (p @@ a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @p Sing a
x) (Sing a -> Decision (q @@ a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @q Sing a
x)

instance (Provable p, Provable q) => Provable (p &&& q) where
    prove :: Sing a -> (p &&& q) @@ a
prove x :: Sing a
x = (Sing a -> p @@ a
forall k1 (p :: k1 ~> *). Provable p => Prove p
prove @p Sing a
x, Sing a -> q @@ a
forall k1 (p :: k1 ~> *). Provable p => Prove p
prove @q Sing a
x)

-- | Decide @p '&&&' q@ based on decisions of @p@ and @q@.
decideAnd
    :: forall p q a. ()
    => Decision (p @@ a)
    -> Decision (q @@ a)
    -> Decision ((p &&& q) @@ a)
decideAnd :: Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p &&& q) @@ a)
decideAnd = \case
    Proved p :: p @@ a
p    -> ((q @@ a) -> (p @@ a, q @@ a))
-> ((p @@ a, q @@ a) -> q @@ a)
-> Decision (q @@ a)
-> Decision (p @@ a, q @@ a)
forall a b. (a -> b) -> (b -> a) -> Decision a -> Decision b
mapDecision (p @@ a
p,) (p @@ a, q @@ a) -> q @@ a
forall a b. (a, b) -> b
snd
    Disproved v :: Refuted (p @@ a)
v -> \_ -> Refuted (p @@ a, q @@ a) -> Decision ((p &&& q) @@ a)
forall a. Refuted a -> Decision a
Disproved (Refuted (p @@ a, q @@ a) -> Decision ((p &&& q) @@ a))
-> Refuted (p @@ a, q @@ a) -> Decision ((p &&& q) @@ a)
forall a b. (a -> b) -> a -> b
$ \(p :: p @@ a
p, _) -> Refuted (p @@ a)
v p @@ a
p

-- | @p '|||' q@ is a predicate that either @p@ and @q@ are true.
data (|||) :: Predicate k -> Predicate k -> Predicate k
type instance Apply (p ||| q) a = Either (p @@ a) (q @@ a)
infixr 2 |||

-- | Prefers @p@ over @q@.
instance (Decidable p, Decidable q) => Decidable (p ||| q) where
    decide :: Sing a -> Decision ((p ||| q) @@ a)
decide (x :: Sing a) = Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p ||| q) @@ a)
forall k1 (p :: k1 ~> *) (q :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p ||| q) @@ a)
decideOr @p @q @a (Sing a -> Decision (p @@ a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @p Sing a
x) (Sing a -> Decision (q @@ a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @q Sing a
x)

-- | Decide @p '|||' q@ based on decisions of @p@ and @q@.
--
-- Prefers @p@ over @q@.
decideOr
    :: forall p q a. ()
    => Decision (p @@ a)
    -> Decision (q @@ a)
    -> Decision ((p ||| q) @@ a)
decideOr :: Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p ||| q) @@ a)
decideOr = \case
    Proved p :: p @@ a
p    -> \_ -> Either (p @@ a) (q @@ a) -> Decision ((p ||| q) @@ a)
forall a. a -> Decision a
Proved (Either (p @@ a) (q @@ a) -> Decision ((p ||| q) @@ a))
-> Either (p @@ a) (q @@ a) -> Decision ((p ||| q) @@ a)
forall a b. (a -> b) -> a -> b
$ (p @@ a) -> Either (p @@ a) (q @@ a)
forall a b. a -> Either a b
Left p @@ a
p
    Disproved v :: Refuted (p @@ a)
v -> ((q @@ a) -> Either (p @@ a) (q @@ a))
-> (Either (p @@ a) (q @@ a) -> q @@ a)
-> Decision (q @@ a)
-> Decision (Either (p @@ a) (q @@ a))
forall a b. (a -> b) -> (b -> a) -> Decision a -> Decision b
mapDecision (q @@ a) -> Either (p @@ a) (q @@ a)
forall a b. b -> Either a b
Right (((p @@ a) -> q @@ a)
-> ((q @@ a) -> q @@ a) -> Either (p @@ a) (q @@ a) -> q @@ a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Void -> q @@ a
forall a. Void -> a
absurd (Void -> q @@ a) -> Refuted (p @@ a) -> (p @@ a) -> q @@ a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refuted (p @@ a)
v) (q @@ a) -> q @@ a
forall a. a -> a
id)

-- | Left-biased "or".  In proofs, prioritize a proof of the left side over
-- a proof of the right side.
--
-- @since 0.1.2.0
type p ^|| q = p ||| Not p &&& q

-- | Right-biased "or".  In proofs, prioritize a proof of the right side over
-- a proof of the left side.
--
-- @since 0.1.2.0
type p ||^ q = p &&& Not q ||| q

-- | @p '^^^' q@ is a predicate that either @p@ and @q@ are true, but not
-- both.
type p ^^^ q = (p &&& Not q) ||| (Not p &&& q)

-- | Decide @p '^^^' q@ based on decisions of @p@ and @q@.
decideXor
    :: forall p q a. ()
    => Decision (p @@ a)
    -> Decision (q @@ a)
    -> Decision ((p ^^^ q) @@ a)
decideXor :: Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p ^^^ q) @@ a)
decideXor p :: Decision (p @@ a)
p q :: Decision (q @@ a)
q = Decision ((p &&& Not q) @@ a)
-> Decision ((Not p &&& q) @@ a) -> Decision ((p ^^^ q) @@ a)
forall k1 (p :: k1 ~> *) (q :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p ||| q) @@ a)
decideOr @(p &&& Not q) @(Not p &&& q) @a
                  (Decision (p @@ a)
-> Decision (Not q @@ a) -> Decision ((p &&& Not q) @@ a)
forall k1 (p :: k1 ~> *) (q :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p &&& q) @@ a)
decideAnd @p @(Not q) @a Decision (p @@ a)
p (Decision (q @@ a) -> Decision (Not q @@ a)
forall k1 (p :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (Not p @@ a)
decideNot @q @a Decision (q @@ a)
q))
                  (Decision (Not p @@ a)
-> Decision (q @@ a) -> Decision ((Not p &&& q) @@ a)
forall k1 (p :: k1 ~> *) (q :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (q @@ a) -> Decision ((p &&& q) @@ a)
decideAnd @(Not p) @q @a (Decision (p @@ a) -> Decision (Not p @@ a)
forall k1 (p :: k1 ~> *) (a :: k1).
Decision (p @@ a) -> Decision (Not p @@ a)
decideNot @p @a Decision (p @@ a)
p) Decision (q @@ a)
q)

-- | @p ==> q@ is true if @q@ is provably true under the condition that @p@
-- is true.
data (==>) :: Predicate k -> Predicate k -> Predicate k
type instance Apply (p ==> q) a = p @@ a -> q @@ a

infixr 1 ==>

instance Decidable (Impossible ==> p) where
instance Provable (Impossible ==> p) where
    prove :: Sing a -> (Impossible ==> p) @@ a
prove = Impossible --> p
forall k1 (p :: k1 ~> *). Impossible --> p
explosion @p

instance (Decidable (p ==> q), Decidable q) => Decidable (Not q ==> Not p) where
    decide :: Sing a -> Decision ((Not q ==> Not p) @@ a)
decide x :: Sing a
x = case Sing a -> Decision ((p ==> q) @@ a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @(p ==> q) Sing a
x of
      Proved pq :: (p ==> q) @@ a
pq     -> ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a. a -> Decision a
Proved (((Apply q a -> Void) -> Apply p a -> Void)
 -> Decision ((Not q ==> Not p) @@ a))
-> ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a b. (a -> b) -> a -> b
$ \vq :: Apply q a -> Void
vq p :: Apply p a
p -> Apply q a -> Void
vq ((p ==> q) @@ a
Apply p a -> Apply q a
pq Apply p a
p)
      Disproved vpq :: Refuted ((p ==> q) @@ a)
vpq -> case Sing a -> Decision (Apply q a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @q Sing a
x of
        Proved    q :: Apply q a
q  -> Refuted ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a. Refuted a -> Decision a
Disproved (Refuted ((Apply q a -> Void) -> Apply p a -> Void)
 -> Decision ((Not q ==> Not p) @@ a))
-> Refuted ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a b. (a -> b) -> a -> b
$ \_     -> Refuted ((p ==> q) @@ a)
vpq (Apply q a -> Apply p a -> Apply q a
forall a b. a -> b -> a
const Apply q a
q)
        Disproved vq :: Apply q a -> Void
vq -> Refuted ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a. Refuted a -> Decision a
Disproved (Refuted ((Apply q a -> Void) -> Apply p a -> Void)
 -> Decision ((Not q ==> Not p) @@ a))
-> Refuted ((Apply q a -> Void) -> Apply p a -> Void)
-> Decision ((Not q ==> Not p) @@ a)
forall a b. (a -> b) -> a -> b
$ \vnpnq :: (Apply q a -> Void) -> Apply p a -> Void
vnpnq -> Refuted ((p ==> q) @@ a)
vpq (Void -> Apply q a
forall a. Void -> a
absurd (Void -> Apply q a)
-> (Apply p a -> Void) -> Apply p a -> Apply q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Apply q a -> Void) -> Apply p a -> Void
vnpnq Apply q a -> Void
vq)
instance Provable (p ==> q) => Provable (Not q ==> Not p) where
    prove :: Sing a -> (Not q ==> Not p) @@ a
prove = (p --> q) -> Not q --> Not p
forall k (p :: k ~> *) (q :: k ~> *). (p --> q) -> Not q --> Not p
contrapositive @p @q (Provable (p ==> q) => Prove (p ==> q)
forall k1 (p :: k1 ~> *). Provable p => Prove p
prove @(p ==> q))

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (p &&& q ==> p) where
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (p &&& q ==> p) where
    prove :: Sing a -> ((p &&& q) ==> p) @@ a
prove = (p &&& q) --> p
forall k1 (p :: Predicate k1) (q :: Predicate k1). (p &&& q) --> p
projAndFst @p @q

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (p &&& q ==> q) where
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (p &&& q ==> q) where
    prove :: Sing a -> ((p &&& q) ==> q) @@ a
prove = (p &&& q) --> q
forall k1 (p :: Predicate k1) (q :: Predicate k1). (p &&& q) --> q
projAndSnd @p @q

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (p &&& p ==> p) where
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (p &&& p ==> p) where
    prove :: Sing a -> ((p &&& p) ==> p) @@ a
prove = (p &&& p) --> p
forall k1 (p :: Predicate k1) (q :: Predicate k1). (p &&& q) --> p
projAndFst @p @p

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (p ==> p ||| q)
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (p ==> p ||| q) where
    prove :: Sing a -> (p ==> (p ||| q)) @@ a
prove = p --> (p ||| q)
forall k (p :: k ~> *) (q :: k ~> *). p --> (p ||| q)
injOrLeft @p @q

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (q ==> p ||| q)
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (q ==> p ||| q) where
    prove :: Sing a -> (q ==> (p ||| q)) @@ a
prove = q --> (p ||| q)
forall k (p :: Predicate k) (q :: Predicate k). q --> (p ||| q)
injOrRight @p @q

-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Decidable (p ==> p ||| p)
-- | @since 0.1.1.0
instance {-# OVERLAPPING #-} Provable (p ==> p ||| p) where
    prove :: Sing a -> (p ==> (p ||| p)) @@ a
prove = p --> (p ||| p)
forall k (p :: k ~> *) (q :: k ~> *). p --> (p ||| q)
injOrLeft @p @p

-- | @'Implies' p q@ is a constraint that @p '==>' q@ is 'Provable'; that
-- is, you can prove that @p@ implies @q@.
type Implies  p q = Provable  (p ==> q)

-- | @'Equiv' p q@ is a constraint that @p '<==>' q@ is 'Provable'; that
-- is, you can prove that @p@ is logically equivalent to @q@.
type Equiv  p q = Provable  (p <==> q)

-- | If @q@ is provable, then so is @p '==>' q@.
--
-- This can be used as an easy plug-in 'Provable' instance for @p '==>' q@
-- if @q@ is 'Provable':
--
-- @
-- instance Provable (p ==> MyPred) where
--     prove = proveImplies @MyPred
-- @
--
-- This instance isn't provided polymorphically because of overlapping
-- instance issues.
proveImplies :: Prove q -> Prove (p ==> q)
proveImplies :: Prove q -> Prove (p ==> q)
proveImplies q :: Prove q
q x :: Sing a
x _ = Sing a -> q @@ a
Prove q
q Sing a
x

-- | Two-way implication, or logical equivalence
type (p <==> q) = p ==> q &&& q ==> p
infixr 1 <==>

-- | From @'Impossible' @@ a@, you can prove anything.  Essentially
-- a lifted version of 'absurd'.
explosion :: Impossible --> p
explosion :: Sing a -> (Impossible @@ a) -> p @@ a
explosion x :: Sing a
x v :: Impossible @@ a
v = Void -> p @@ a
forall a. Void -> a
absurd (Void -> p @@ a) -> Void -> p @@ a
forall a b. (a -> b) -> a -> b
$ Impossible @@ a
Sing a -> Void
v Sing a
x

-- | 'Evident' can be proven from all predicates.
atom :: p --> Evident
atom :: Sing a -> (p @@ a) -> Evident @@ a
atom = Sing a -> (p @@ a) -> Evident @@ a
forall a b. a -> b -> a
const

-- | We cannot have both @p@ and @'Not' p@.
--
-- (Renamed in v0.1.4.0; used to be @excludedMiddle@)
--
-- @since 0.1.4.0
complementation :: forall p. (p &&& Not p) --> Impossible
complementation :: Sing a -> ((p &&& Not p) @@ a) -> Impossible @@ a
complementation _ (p, notP) _ = Apply p a -> Void
notP Apply p a
p

-- | @since 0.1.3.0
instance {-# OVERLAPPING #-} Provable (p &&& Not p ==> Impossible) where
    prove :: Sing a -> ((p &&& Not p) ==> Impossible) @@ a
prove = (p &&& Not p) --> Impossible
forall k1 (p :: Predicate k1). (p &&& Not p) --> Impossible
complementation @p

-- | If p implies q, then not q implies not p.
contrapositive
    :: (p --> q)
    -> (Not q --> Not p)
contrapositive :: (p --> q) -> Not q --> Not p
contrapositive f :: p --> q
f x :: Sing a
x vQ :: Not q @@ a
vQ p :: Apply p a
p = Not q @@ a
Refuted (q @@ a)
vQ (Sing a -> Apply p a -> q @@ a
p --> q
f Sing a
x Apply p a
p)

-- | Reverse direction of 'contrapositive'.  Only possible if @q@ is
-- 'Decidable' on its own, without the help of @p@, which makes this much
-- less useful.
contrapositive'
    :: forall p q. Decidable q
    => (Not q --> Not p)
    -> (p --> q)
contrapositive' :: (Not q --> Not p) -> p --> q
contrapositive' f :: Not q --> Not p
f x :: Sing a
x p :: p @@ a
p = Decision (Apply q a) -> Refuted (Refuted (Apply q a)) -> Apply q a
forall a. Decision a -> Refuted (Refuted a) -> a
elimDisproof (Sing a -> Decision (Apply q a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @q Sing a
x) (Refuted (Refuted (Apply q a)) -> Apply q a)
-> Refuted (Refuted (Apply q a)) -> Apply q a
forall a b. (a -> b) -> a -> b
$ \vQ :: Refuted (Apply q a)
vQ ->
    Sing a -> (Not q @@ a) -> Refuted (p @@ a)
Not q --> Not p
f Sing a
x Not q @@ a
Refuted (Apply q a)
vQ p @@ a
p

-- | Logical double negation.  Only possible if @p@ is 'Decidable'.
--
-- This is because in constructivist logic, not (not p) does not imply p.
-- However, p implies not (not p) (see 'negateTwice'), and not (not (not
-- p)) implies not p (see 'tripleNegation')
doubleNegation :: forall p. Decidable p => Not (Not p) --> p
doubleNegation :: Not (Not p) --> p
doubleNegation x :: Sing a
x vvP :: Not (Not p) @@ a
vvP = Decision (Apply p a) -> Refuted (Refuted (Apply p a)) -> Apply p a
forall a. Decision a -> Refuted (Refuted a) -> a
elimDisproof (Sing a -> Decision (Apply p a)
forall k1 (p :: k1 ~> *). Decidable p => Decide p
decide @p Sing a
x) (Refuted (Refuted (Apply p a)) -> Apply p a)
-> Refuted (Refuted (Apply p a)) -> Apply p a
forall a b. (a -> b) -> a -> b
$ \vP :: Refuted (Apply p a)
vP ->
    Not (Not p) @@ a
Refuted (Refuted (Apply p a))
vvP Refuted (Apply p a)
vP

-- | In constructivist logic, not (not (not p)) implies not p.
--
-- @since 0.1.4.0
tripleNegation :: forall p. Not (Not (Not p)) --> Not p
tripleNegation :: Sing a -> (Not (Not (Not p)) @@ a) -> Not p @@ a
tripleNegation _ vvvP :: Not (Not (Not p)) @@ a
vvvP p :: Apply p a
p = Not (Not (Not p)) @@ a
(Refuted (Apply p a) -> Void) -> Void
vvvP ((Refuted (Apply p a) -> Void) -> Void)
-> (Refuted (Apply p a) -> Void) -> Void
forall a b. (a -> b) -> a -> b
$ \vP :: Refuted (Apply p a)
vP -> Refuted (Apply p a)
vP Apply p a
p

-- | In constructivist logic, p implies not (not p).
--
-- @since 0.1.4.0
negateTwice :: p --> Not (Not p)
negateTwice :: Sing a -> (p @@ a) -> Not (Not p) @@ a
negateTwice _ p :: p @@ a
p vP :: (p @@ a) -> Void
vP = (p @@ a) -> Void
vP p @@ a
p

-- | If @p '&&&' q@ is true, then so is @p@.
projAndFst :: (p &&& q) --> p
projAndFst :: Sing a -> ((p &&& q) @@ a) -> p @@ a
projAndFst _ = ((p &&& q) @@ a) -> p @@ a
forall a b. (a, b) -> a
fst

-- | If @p '&&&' q@ is true, then so is @q@.
projAndSnd :: (p &&& q) --> q
projAndSnd :: Sing a -> ((p &&& q) @@ a) -> q @@ a
projAndSnd _ = ((p &&& q) @@ a) -> q @@ a
forall a b. (a, b) -> b
snd

-- | If @p@ is true, then so is @p '|||' q@.
injOrLeft :: forall p q. p --> (p ||| q)
injOrLeft :: Sing a -> (p @@ a) -> (p ||| q) @@ a
injOrLeft _ = (p @@ a) -> (p ||| q) @@ a
forall a b. a -> Either a b
Left

-- | If @q@ is true, then so is @p '|||' q@.
injOrRight :: forall p q. q --> (p ||| q)
injOrRight :: Sing a -> (q @@ a) -> (p ||| q) @@ a
injOrRight _ = (q @@ a) -> (p ||| q) @@ a
forall a b. b -> Either a b
Right