{-# OPTIONS --without-K #-}

open import lib.Base
open import lib.NType
open import lib.Relation
open import lib.types.Bool
open import lib.types.Int

module lib.types.List where

infixr 80 _::_

data List {i} (A : Type i) : Type i where
  nil : List A
  _::_ : A → List A → List A

data HList {i} : List (Type i) → Type (lsucc i) where
  nil : HList nil
  _::_ : {A : Type i} {L : List (Type i)} → A → HList L → HList (A :: L)

hlist-curry-type : ∀ {i j} (L : List (Type i))
  (B : HList L → Type (lmax i j)) → Type (lmax i j)
hlist-curry-type nil B = B nil
hlist-curry-type {j = j} (A :: L) B =
  (x : A) → hlist-curry-type {j = j} L (λ xs → B (x :: xs))

hlist-curry : ∀ {i j} {L : List (Type i)} {B : HList L → Type (lmax i j)}
  (f : Π (HList L) B) → hlist-curry-type {j = j} L B
hlist-curry {L = nil} f = f nil
hlist-curry {L = A :: _} f = λ x → hlist-curry (λ xs → f (x :: xs))

infixr 80 _++_
_++_ : ∀ {i} {A : Type i} → List A → List A → List A
nil ++ l = l
(x :: l₁) ++ l₂ = x :: (l₁ ++ l₂)

++-nil-r : ∀ {i} {A : Type i} (l : List A) → l ++ nil == l
++-nil-r nil      = idp
++-nil-r (a :: l) = ap (a ::_) $ ++-nil-r l

-- [any] in Haskell
data Any {i j} {A : Type i} (P : A → Type j) : List A → Type (lmax i j) where
  here : ∀ {a} {l} → P a → Any P (a :: l)
  there : ∀ {a} {l} → Any P l → Any P (a :: l)

infix 80 _∈_
_∈_ : ∀ {i} {A : Type i} → A → List A → Type i
a ∈ l = Any (_== a) l

Any-dec : ∀ {i j} {A : Type i} (P : A → Type j) → (∀ a → Dec (P a)) → (∀ l → Dec (Any P l))
Any-dec P _   nil       = inr λ{()}
Any-dec P dec (a :: l) with dec a
... | inl p = inl $ here p
... | inr p⊥ with Any-dec P dec l
...   | inl ∃p = inl $ there ∃p
...   | inr ∃p⊥ = inr λ{(here p) → p⊥ p; (there ∃p) → ∃p⊥ ∃p}

∈-dec : ∀ {i} {A : Type i} → has-dec-eq A → ∀ a l → Dec (a ∈ l)
∈-dec dec a l = Any-dec (_== a) (λ a' → dec a' a) l

Any-++-l : ∀ {i j} {A : Type i} (P : A → Type j)
  → ∀ l₁ l₂ → Any P l₁ → Any P (l₁ ++ l₂)
Any-++-l P _ _ (here p)   = here p
Any-++-l P _ _ (there ∃p) = there (Any-++-l P _ _ ∃p)

∈-++-l : ∀ {i} {A : Type i} (a : A) → ∀ l₁ l₂ → a ∈ l₁ → a ∈ (l₁ ++ l₂)
∈-++-l a = Any-++-l (_== a)

Any-++-r : ∀ {i j} {A : Type i} (P : A → Type j)
  → ∀ l₁ l₂ → Any P l₂ → Any P (l₁ ++ l₂)
Any-++-r P nil      _ ∃p = ∃p
Any-++-r P (a :: l) _ ∃p = there (Any-++-r P l _ ∃p)

∈-++-r : ∀ {i} {A : Type i} (a : A) → ∀ l₁ l₂ → a ∈ l₂ → a ∈ (l₁ ++ l₂)
∈-++-r a = Any-++-r (_== a)

Any-++ : ∀ {i j} {A : Type i} (P : A → Type j)
  → ∀ l₁ l₂ → Any P (l₁ ++ l₂) → (Any P l₁) ⊔ (Any P l₂)
Any-++ P nil       l₂ ∃p         = inr ∃p
Any-++ P (a :: l₁) l₂ (here p)   = inl (here p)
Any-++ P (a :: l₁) l₂ (there ∃p) with Any-++ P l₁ l₂ ∃p
... | inl ∃p₁ = inl (there ∃p₁)
... | inr ∃p₂ = inr ∃p₂

∈-++ : ∀ {i} {A : Type i} (a : A) → ∀ l₁ l₂ → a ∈ (l₁ ++ l₂) → (a ∈ l₁) ⊔ (a ∈ l₂)
∈-++ a = Any-++ (_== a)

-- [map] in Haskell
map : ∀ {i j} {A : Type i} {B : Type j} → (A → B) → (List A → List B)
map f nil = nil
map f (a :: l) = f a :: map f l

-- [foldr] in Haskell
foldr : ∀ {i j} {A : Type i} {B : Type j} → (A → B → B) → B → List A → B
foldr f b nil = b
foldr f b (a :: l) = f a (foldr f b l)

-- [concat] in Haskell
concat : ∀ {i} {A : Type i} → List (List A) → List A
concat l = foldr _++_ nil l

ℤsum = foldr _ℤ+_ 0

-- [filter] in Haskell
-- Note that [Bool] is currently defined as a coproduct.
filter : ∀ {i j k} {A : Type i} {Keep : A → Type j} {Drop : A → Type k}
  → ((a : A) → Keep a ⊔ Drop a) → List A → List A
filter p nil = nil
filter p (a :: l) with p a
... | inl _ = a :: filter p l
... | inr _ = filter p l


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.TypeSchema(x : X) where
  open X(x)
  open import Data.Vec hiding (_>>=_)

  data NameType : Set where
    Regular : NameType
    Datacon : ℕ → NameType

  data TypeSchema ( n : Set) : NameType → Set where
    ∀′_·_⇒_ : (v : ℕ) → QConstraint (n ⨁ v) → Type (n ⨁ v) → TypeSchema n Regular
    DC∀′_,_·_⇒_⟶_ : (a b : ℕ){l : ℕ} → QConstraint ((n ⨁ a) ⨁ b)
                   → Vec (Type ((n ⨁ a) ⨁ b)) l → n → TypeSchema n (Datacon l)
    DC∀_·_⟶_ : (a : ℕ){l : ℕ} → Vec (Type (n ⨁ a)) l → n → TypeSchema n (Datacon l)

  private
    module PlusN-f n = Functor (Monad.is-functor (PlusN-is-monad {n}))
    module Vec-f {n} = Functor (vec-is-functor {n})
    module Type-f    = Functor (type-is-functor)
    module QC-f      = Functor (qconstraint-is-functor)

  private
    fmap-schema : {A B : Set}{x : NameType} → (A → B) → TypeSchema A x → TypeSchema B x
    fmap-schema f (∀′ n · Q ⇒ τ) = ∀′ n · QC-f.map (pn.map f) Q ⇒ Type-f.map (pn.map f) τ
        where module pn = PlusN-f n
    fmap-schema f (DC∀′ a , b · Q ⇒ τs ⟶ K) = DC∀′ a , b · QC-f.map (pb.map (pa.map f)) Q
                                                          ⇒ map (Type-f.map (pb.map (pa.map f))) τs
                                                          ⟶ f K
        where module pa = PlusN-f a
              module pb = PlusN-f b
    fmap-schema f (DC∀ a · τs ⟶ K) = DC∀ a · map (Type-f.map (pa.map f)) τs ⟶ f K
        where module pa = PlusN-f a

    fmap-schema-id : {A : Set}{x : NameType} {f : A → A}
                   → isIdentity f → isIdentity (fmap-schema {A}{A}{x} f)
    fmap-schema-id isid {∀′ n · Q ⇒ τ} = cong₂ (∀′_·_⇒_ n) (QC-f.identity (pn.identity isid))
                                                           (Type-f.identity (pn.identity isid))
       where module pn = PlusN-f n
    fmap-schema-id isid {DC∀′ a , b · Q ⇒ τs ⟶ K}
      = cong₃ (DC∀′_,_·_⇒_⟶_ a b)
              (QC-f.identity (pb.identity (pa.identity isid)))
              (Vec-f.identity (Type-f.identity (pb.identity (pa.identity isid))))
              isid
        where module pa = PlusN-f a
              module pb = PlusN-f b
    fmap-schema-id isid {DC∀ a · τs ⟶ K}
      = cong₂ (DC∀_·_⟶_ a)
              (Vec-f.identity (Type-f.identity (pa.identity isid)))
              isid
        where module pa = PlusN-f a

    fmap-schema-comp :  {A B C : Set}{s : NameType} {f : A → B} {g : B → C} {x : TypeSchema A s}
                     → fmap-schema (g ∘ f) x ≡ fmap-schema g (fmap-schema f x)
    fmap-schema-comp {x = ∀′ n · Q ⇒ τ} = cong₂ (∀′_·_⇒_ n)
                                                (Functor.composite (qconstraint-is-functor ∘f pnf))
                                                (Functor.composite (type-is-functor ∘f pnf))
        where pnf = Monad.is-functor (PlusN-is-monad {n})
    fmap-schema-comp {x = DC∀′ a , b · Q ⇒ τs ⟶ K}
      = cong₃ (DC∀′_,_·_⇒_⟶_ a b)
              (Functor.composite (qconstraint-is-functor ∘f pbf ∘f paf ))
              (Functor.composite (vec-is-functor ∘f type-is-functor ∘f pbf ∘f paf))
              refl
        where module pa = PlusN-f a
              module pb = PlusN-f b
              paf = Monad.is-functor (PlusN-is-monad {a})
              pbf = Monad.is-functor (PlusN-is-monad {b})
    fmap-schema-comp {x = DC∀ a · τs ⟶ K}
      = cong₂ (DC∀_·_⟶_ a)
              (Functor.composite (vec-is-functor ∘f type-is-functor ∘f paf))
              refl
        where module pa = PlusN-f a
              paf = Monad.is-functor (PlusN-is-monad {a})

  type-schema-is-functor : ∀{s} → Functor (λ x → TypeSchema x s)
  type-schema-is-functor = record { map       = fmap-schema
                                  ; identity  = fmap-schema-id
                                  ; composite = fmap-schema-comp
                                  }


-- {-# OPTIONS -v tc.term.args:30 -v tc.meta:50 #-}
module Issue795 where

data Q (A : Set) : Set where

F : (N : Set → Set) → Set₁
F N = (A : Set) → N (Q A) → N A

postulate
   N : Set → Set
   f : F N
   R : (N : Set → Set) → Set
   funny-term : ∀ N → (f : F N) → R N

-- This should work now:  WAS: "Refuse to construct infinite term".
thing : R N
thing = funny-term _ (λ A → f _)
  -- funny-term ?N : F ?N -> R ?N
  -- funny-term ?N : ((A : Set) -> ?N (Q A) -> ?N A) -> R ?N
  -- A : F ?N |- f (?A A) :=> ?N (Q (?A A)) -> ?N (?A A)
  --   |- λ A → f (?A A) <=:  (A : Set) -> N (Q A) -> N A

{- What is happening here?

Agda first creates a (closed) meta variable

  ?N : Set -> Set

Then it checks

  λ A → f ?   against type F ?N = (A : Set) -> ?N (Q A) -> ?N A

(After what it does now, it still needs to check that

  R ?N  is a subtype of R N

It would be smart if that was done first.)

In context A : Set, continues to check

  f ?  against type  ?N (Q A) -> ?N A

Since the type of f is F N = (A : Set) -> N (Q A) -> N A, the created meta,
dependent on A : Set is

  ?A : Set -> Set

and we are left with checking that the inferred type of f (?A A),

  N (Q (?A A)) -> N (?A A)

is a subtype of

  ?N (Q A) -> ?N A

This yields two equations

  ?N (Q A) = N (Q (?A A))

  ?N A     = N (?A A)

The second one is solved as

  ?N = λ z → N (?A z)

simpliying the remaining equation to

  N (?A (Q A)) = N (Q (?A A))

and further to

  ?A (Q A) = Q (?A A)

The expected solution is, of course, the identity, but it cannot be
found mechanically from this equation.

At this point, another solution is ?A = Q.
In general, any power of Q is a solution.

If Agda postponed here, it would come to the problem

  R ?N  =  R N

simplified to ?N = N and instantiated to

  λ z → N (?A z)  =  N

This would solve ?A to be the identity.
-}


-- Reported by nils.anders.danielsson, Feb 7 2014
-- The code below is accepted by Agda 2.3.2.2.

module Issue1048 where

module M (_ : Set) where

  data D : Set where
    c₁ : D
    c₂ : D → D

postulate A : Set

open M A

postulate
  ♭ : D → D
  ♯ : D → D

data S : D → Set where
  s : (d : D) → S (♭ d) → S (c₂ d)

postulate
  f : S (♭ (♯ c₁)) → S c₁

Foo : S (c₂ (♯ c₁)) → Set₁
Foo (s ._ x) with f x
... | _ = Set

-- Bug.agda:24,1-25,14
-- The constructor c₁ does not construct an element of D
-- when checking that the type (x : S (♭ (♯ c₁))) → S M.c₁ → Set₁ of
-- the generated with function is well-formed

-- Fixed.  Need to normalize constructor in checkInternal.


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.IdUPiPi {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as T hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Irrelevance as S
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Introductions.Sigma
open import Definition.LogicalRelation.Substitution.Introductions.Fst
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.Lambda
open import Definition.LogicalRelation.Substitution.Introductions.Application
open import Definition.LogicalRelation.Substitution.Introductions.Cast
open import Definition.LogicalRelation.Substitution.Introductions.Id
open import Definition.LogicalRelation.Substitution.Introductions.Transp
open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst
open import Definition.LogicalRelation.Substitution.MaybeEmbed
open import Definition.LogicalRelation.Substitution.Escape
open import Definition.LogicalRelation.Substitution.Introductions.Universe
open import Definition.LogicalRelation.Substitution.Reduction
open import Definition.LogicalRelation.Substitution.Weakening
open import Definition.LogicalRelation.Substitution.ProofIrrelevance
open import Definition.LogicalRelation.Fundamental.Variable

open import Tools.Product
open import Tools.Nat
import Tools.PropositionalEquality as PE

lemma0 : ∀ σ A → (wk1 (wk1 (subst σ A))) PE.≡ subst (liftSubst (liftSubst σ)) (wk1 (wk1 A))
lemma0 σ A = PE.trans (PE.cong wk1 (PE.sym (Idsym-subst-lemma σ A))) (PE.sym (Idsym-subst-lemma (liftSubst σ) (wk1 A)))

lemma1 : ∀ {σ rA} A A' B →
                   wk1d (subst (liftSubst σ) B) [
                        cast ⁰ (wk1 (wk1 (subst σ A')))
                               (wk1 (wk1 (subst σ A)))
                               (Idsym (Univ rA ⁰) (wk1 (wk1 (subst σ A))) (wk1 (wk1 (subst σ A'))) (var 1))
                               (var 0)]↑
                   PE.≡
                     subst (liftSubst (liftSubst σ)) (U.wk (lift (step id)) B [
                     cast ⁰ (wk1 (wk1 A'))
                            (wk1 (wk1 A))
                            (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1))
                            (var 0)]↑)
lemma1 {σ} {rA} A A' B = PE.trans (PE.cong₂ (λ X Y → X [ Y ]↑) (PE.sym (Idsym-subst-lemma-wk1d σ B))
  (PE.cong₃ (λ X Y Z → cast ⁰ X Y Z (var 0)) (lemma0 σ A') (lemma0 σ A)
    (PE.trans (PE.cong₂ (λ X Y → Idsym (Univ rA ⁰) X Y (var 1)) (lemma0 σ A) (lemma0 σ A'))
    (PE.sym (subst-Idsym (liftSubst (liftSubst σ)) (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1))))))
  (PE.sym ((singleSubstLift↑ (liftSubst σ) (U.wk (lift (step id)) B) _)))

lemma2 : ∀ {σ} B → U.wk (lift (step id)) (subst (liftSubst σ) B)
                             PE.≡
                             subst (liftSubst (liftSubst σ)) (U.wk (lift (step id)) B)
lemma2 B = PE.sym (Idsym-subst-lemma-wk1d _ B)

Id-U-ΠΠ-resᵗᵛ : ∀ {A B A' B' rA Γ} ([Γ] : ⊩ᵛ Γ) →
        let l    = ∞
            lΠ = ⁰
            [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ emb< [Γ])
            [UΠ] = maybeEmbᵛ {A = Univ ! _} [Γ] (Uᵛ emb< [Γ])
            Id-U-ΠΠ-res A A' B B' =
                        (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰)
                            (wk1d B [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                            (wk1d B') ° ¹ ° ¹)

        in
           ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ [ rA , ι lΠ ] / [Γ])
           ([A'] : Γ ⊩ᵛ⟨ l ⟩ A' ^ [ rA , ι lΠ ] / [Γ])
           ([UB] : Γ ∙ A ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A])
           ([UB'] : Γ ∙ A' ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A'])
           ([A]ₜ : Γ ⊩ᵛ⟨ l ⟩ A ∷ Univ rA lΠ ^ [ ! , next lΠ ] / [Γ] / [UA])
           ([B]ₜ : Γ ∙ A ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ B ∷ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A] / (λ {Δ} {σ} → [UB] {Δ} {σ}))
           ([A']ₜ : Γ ⊩ᵛ⟨ l ⟩ A' ∷ Univ rA lΠ ^ [ ! , next lΠ ] / [Γ] / [UA])
           ([B']ₜ :  Γ ∙ A' ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ B' ∷ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A'] / (λ {Δ} {σ} → [UB'] {Δ} {σ})) →
           let [IdAA'] = Idᵛ {A = Univ rA ⁰} {t = A} {u = A'} [Γ] (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ [A']ₜ
               [ΓId] = _∙_ {A = Id (Univ rA ⁰) A A'} [Γ] [IdAA']
               [wA'] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A'} {lG = ⁰} [Γ] [IdAA'] [A']ₜ
               [wA']' = wk1ᵛ {A = A'} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A']
               [wA]' = wk1ᵛ {A = A} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A]
               [wA] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A} {lG = ⁰} [Γ] [IdAA'] [A]ₜ
               [ΓIdA'] = _∙_ {A = wk1 A'} [ΓId] [wA']'
               [wwA']' = wk1ᵛ {A = wk1 A'} {F = wk1 A'}  [ΓId] [wA']' [wA']'
               [wwA'] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A'} {lG = ⁰} [ΓId] [wA']' [wA']
               [wwA] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A} {lG = ⁰} [ΓId] [wA']' [wA]
               [wwUA'] = λ {Δ} {σ} r → maybeEmbᵛ {A = Univ r _ } [ΓIdA'] (λ {Δ} {σ} → Uᵛ emb< [ΓIdA'] {Δ} {σ}) {Δ} {σ}
               [wwIdAA'] = Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A)} {u = wk1 (wk1 A')} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA] [wwA']
               [SProp] = Uᵛ {rU = %} ∞< [ΓId]
           in
           ([var0]ₜ : (Γ ∙ Id (Univ rA ⁰) A A' ^ [ % , ι ¹ ] ∙ wk1 A' ^ [ rA , ι ⁰ ]) ⊩ᵛ⟨ ∞ ⟩ var 0 ∷ wk1 (wk1 A') ^ [ rA , ι ⁰ ] / [ΓIdA'] / [wwA']')
           ([var1]ₜ : (Γ ∙ Id (Univ rA ⁰) A A' ^ [ % , ι ¹ ] ∙ wk1 A' ^ [ rA , ι ⁰ ]) ⊩ᵛ⟨ ∞ ⟩ var 1 ∷  Id (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) ^ [ % , ι ¹ ] / [ΓIdA'] / [wwIdAA'])
         →  Γ ∙ Id (Univ rA ⁰) A A' ^ [ % , ι ¹ ] ⊩ᵛ⟨ ∞ ⟩ Id-U-ΠΠ-res  A A' B B' ∷ SProp ¹ ^ [ ! , ∞ ] / [ΓId] / (λ {Δ} {σ} → [SProp] {Δ} {σ})
Id-U-ΠΠ-resᵗᵛ {A} {B} {A'} {B'} {rA} {Γ}
        [Γ] [A] [A'] [UB] [UB'] [A]ₜ [B]ₜ [A']ₜ [B']ₜ [var0]ₜ [var1]ₜ =
  let l = ∞
      lΠ = ⁰
      [SProp] = Uᵛ {rU = %} ∞< [Γ]
      [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ emb< [Γ])
      [UΠ] = maybeEmbᵛ {A = Univ ! _} [Γ] (Uᵛ emb< [Γ])
      ⊢AΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UA] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([A]ₜ ⊢Δ [σ]))
      ⊢A'Δ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UA] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([A']ₜ ⊢Δ [σ]))
      ⊢A = λ {Δ} {σ} ⊢Δ [σ] → escape (proj₁ ([A] {Δ} {σ} ⊢Δ [σ]))
      ⊢A' = λ {Δ} {σ} ⊢Δ [σ] → escape (proj₁ ([A'] {Δ} {σ} ⊢Δ [σ]))
      [ΓA]  = (_∙_ {Γ} {A} [Γ] [A])
      [ΓA'] = (_∙_ {Γ} {A'} [Γ]  [A'])
      ⊢BΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UB] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([B]ₜ {Δ} {σ} ⊢Δ [σ]))
      [A]'  = univᵛ {A = A} [Γ] (≡is≤ PE.refl) (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ
      [A']'  = univᵛ {A = A'} [Γ] (≡is≤ PE.refl) (λ {Δ} {σ} → [UA] {Δ} {σ}) [A']ₜ
      [B]'  = univᵛ {A = B} [ΓA] (≡is≤ PE.refl) (λ {Δ} {σ} → [UB] {Δ} {σ}) [B]ₜ
      [B]  = maybeEmbᵛ {A = B} [ΓA] [B]'
      [B']'  = univᵛ {A = B'} [ΓA'] (≡is≤ PE.refl) (λ {Δ} {σ} → [UB'] {Δ} {σ}) [B']ₜ
      [B']  = maybeEmbᵛ {A = B'} [ΓA'] [B']'
      ⊢B'Δ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UB'] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([B']ₜ {Δ} {σ} ⊢Δ [σ]))
      [liftσ] = λ {Δ} {σ} ⊢Δ [σ] → liftSubstS {F = A} {σ = σ} {Δ = Δ} [Γ] ⊢Δ [A] [σ]
      [liftσ'] = λ {Δ} {σ} ⊢Δ [σ] → liftSubstS {F = A'} {σ = σ} {Δ = Δ} [Γ] ⊢Δ [A'] [σ]
      [ΠAB] = Πᵗᵛ {A} {B} (≡is≤ PE.refl) (≡is≤ PE.refl) [Γ] [A] (λ {Δ} {σ} → [UB] {Δ} {σ}) [A]ₜ [B]ₜ
      [ΠA'B'] = Πᵗᵛ {A'} {B'} (≡is≤ PE.refl) (≡is≤ PE.refl) [Γ] [A'] (λ {Δ} {σ} → [UB'] {Δ} {σ}) [A']ₜ [B']ₜ
      [IdAA']ₜ = Idᵗᵛ {A = Univ rA ⁰} {t = A} {u = A'} [Γ] (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ [A']ₜ (Uᵗᵛ [Γ])
      [IdAA'] = Idᵛ {A = Univ rA ⁰} {t = A} {u = A'} [Γ] (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ [A']ₜ
      Id-U-ΠΠ-res A A' B B' = ∃ (Id (Univ rA ⁰) A A') ▹
                      (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰)
                        ((U.wk (lift (step id)) B) [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                        (U.wk (lift (step id)) B') ° ¹ ° ¹)
      [ΓId] = _∙_ {A = Id (Univ rA ⁰) A A'} [Γ] [IdAA']
      [wSProp] = Uᵛ {rU = %} ∞< [ΓId]
      [wA'] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A'} {lG = ⁰} [Γ] [IdAA'] [A']ₜ
      [wA']' = wk1ᵛ {A = A'} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A']
      [wA]' = wk1ᵛ {A = A} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A]
      [wA] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A} {lG = ⁰} [Γ] [IdAA'] [A]ₜ
      [ΓIdA'] = _∙_ {A = wk1 A'} [ΓId] [wA']'
      [wwU¹] = λ {Δ} {σ} r → Uᵛ {rU = r} ∞< [ΓIdA'] {Δ} {σ}
      [wwUA'] = λ {Δ} {σ} r → maybeEmbᵛ {A = Univ r _ } [ΓIdA'] (λ {Δ} {σ} → Uᵛ emb< [ΓIdA'] {Δ} {σ}) {Δ} {σ}
      [wwUA']ᵗ = Uᵗᵛ [ΓIdA']
      [ΓIdA] = _∙_ {A = wk1 A} [ΓId] [wA]'
      [wwA'] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A'} {lG = ⁰} [ΓId] [wA']' [wA']
      [wwA] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A} {lG = ⁰} [ΓId] [wA']' [wA]
      [wwA']' = wk1ᵛ {A = wk1 A'} {F = wk1 A'}  [ΓId] [wA']' [wA']'
      [wwA]' = wk1ᵛ {A = wk1 A} {F = wk1 A'}  [ΓId] [wA']' [wA]'
      [wwU0A] = maybeEmbᵛ {A = Univ ! _ } [ΓIdA] (λ {Δ} {σ} → Uᵛ emb< [ΓIdA] {Δ} {σ})
      [wB'] = wk1dᵗᵛ {F = A'} {F' = Id (Univ rA ⁰) A A'} {G = B'} [Γ] [A'] [IdAA'] (λ {Δ} {σ} → [UB'] {Δ} {σ}) (λ {Δ} {σ} → [wwUA'] {Δ} {σ} !) [B']ₜ
      [wB] = wk1dᵗᵛ {F = A} {F' = Id (Univ rA ⁰) A A'} {G = B} [Γ] [A] [IdAA'] (λ {Δ} {σ} → [UB] {Δ} {σ}) (λ {Δ} {σ} → [wwU0A] {Δ} {σ}) [B]ₜ
      [wwIdAA'] = Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A)} {u = wk1 (wk1 A')} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA] [wwA']
      [wwIdA'A] = Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A')} {u = wk1 (wk1 A)} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA'] [wwA]
   in Πᵗᵛ {wk1 A'} {Id (U ⁰) (U.wk (lift (step id)) B [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A))
                                   (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                                              (U.wk (lift (step id)) B')} (<is≤ 0<1) (≡is≤ PE.refl) [ΓId] [wA']' (λ {Δ} {σ} → [wwU¹] {Δ} {σ} %) [wA']
                            (Idᵗᵛ {A = U ⁰} {t = (U.wk (lift (step id)) B [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A))
                                      (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)}
                                 {u = U.wk (lift (step id)) B'} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} !)
                            (subst↑STerm {F = wk1 A'} {F' = wk1 A} {G = wk1d B}
                                         {t = cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0)}
                                         [ΓId] [wA']' [wA]' (λ {Δ} {σ} → [wwUA'] {Δ} {σ} !) (λ {Δ} {σ} → [wwU0A] {Δ} {σ}) [wB]
                                         (castᵗᵛ {A = wk1 (wk1 A')} {B = wk1 (wk1 A)} {t = var 0} {e = (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1))}
                                                 [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA'] [wwA] [wwA']' [wwA]' [var0]ₜ
                                                 (Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A')} {u = wk1 (wk1 A)} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA'] [wwA])
                                                 (IdSymᵗᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A)} {u = wk1 (wk1 A')} {e = var 1} [ΓIdA'] ((λ {Δ} {σ} → [wwU¹] {Δ} {σ} !))
                                                          (λ {Δ} {σ} → [wwUA']ᵗ {Δ} {σ}) (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA)
                                                          [wwA] [wwA'] [wwIdAA'] [wwIdA'A] [var1]ₜ))) [wB']
                                                          (λ {Δ} {σ} → Uᵗᵛ [ΓIdA'] {Δ} {σ}))

abstract
  Id-U-ΠΠᵗᵛ : ∀ {A B A' B' rA Γ} ([Γ] : ⊩ᵛ Γ) →
        let l    = ∞
            lΠ = ⁰
            [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ emb< [Γ])
            [UΠ] = maybeEmbᵛ {A = Univ ! _} [Γ] (Uᵛ emb< [Γ])
        in
           ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ [ rA , ι lΠ ] / [Γ])
           ([A'] : Γ ⊩ᵛ⟨ l ⟩ A' ^ [ rA , ι lΠ ] / [Γ])
           ([UB] : Γ ∙ A ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A])
           ([UB'] : Γ ∙ A' ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A'])
           ([A]ₜ : Γ ⊩ᵛ⟨ l ⟩ A ∷ Univ rA lΠ ^ [ ! , next lΠ ] / [Γ] / [UA])
           ([B]ₜ : Γ ∙ A ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ B ∷ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A] / (λ {Δ} {σ} → [UB] {Δ} {σ}))
           ([A']ₜ : Γ ⊩ᵛ⟨ l ⟩ A' ∷ Univ rA lΠ ^ [ ! , next lΠ ] / [Γ] / [UA])
           ([B']ₜ :  Γ ∙ A' ^ [ rA , ι lΠ ] ⊩ᵛ⟨ l ⟩ B' ∷ Univ ! lΠ ^ [ ! , next lΠ ] / [Γ] ∙ [A'] / (λ {Δ} {σ} → [UB'] {Δ} {σ}))
         → [ Γ ⊩ᵛ⟨ l ⟩ (Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰))
                    ≡ ∃ (Id (Univ rA ⁰) A A') ▹
                      (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰)
                        ((U.wk (lift (step id)) B) [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                        (U.wk (lift (step id)) B') ° ¹ ° ¹)
                  ∷ SProp ¹ ^ [ ! , next ¹ ] / [Γ] ]

  Id-U-ΠΠᵗᵛ {A} {B} {A'} {B'} {rA} {Γ} [Γ] [A] [A'] [UB] [UB'] [A]ₜ [B]ₜ [A']ₜ [B']ₜ =
    let l = ∞
        lΠ = ⁰
        [SProp] = Uᵛ {rU = %} ∞< [Γ]
        [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ emb< [Γ])
        [UΠ] = maybeEmbᵛ {A = Univ ! _} [Γ] (Uᵛ emb< [Γ])
        ⊢AΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UA] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([A]ₜ ⊢Δ [σ]))
        ⊢A'Δ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UA] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([A']ₜ ⊢Δ [σ]))
        ⊢A = λ {Δ} {σ} ⊢Δ [σ] → escape (proj₁ ([A] {Δ} {σ} ⊢Δ [σ]))
        ⊢A' = λ {Δ} {σ} ⊢Δ [σ] → escape (proj₁ ([A'] {Δ} {σ} ⊢Δ [σ]))
        [ΓA]  = (_∙_ {Γ} {A} [Γ] [A])
        [ΓA'] = (_∙_ {Γ} {A'} [Γ]  [A'])
        ⊢BΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UB] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([B]ₜ {Δ} {σ} ⊢Δ [σ]))
        [A]'  = univᵛ {A = A} [Γ] (≡is≤ PE.refl) (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ
        [A']'  = univᵛ {A = A'} [Γ] (≡is≤ PE.refl) (λ {Δ} {σ} → [UA] {Δ} {σ}) [A']ₜ
        [B]'  = univᵛ {A = B} [ΓA] (≡is≤ PE.refl) (λ {Δ} {σ} → [UB] {Δ} {σ}) [B]ₜ
        [B]  = maybeEmbᵛ {A = B} [ΓA] [B]'
        [B']'  = univᵛ {A = B'} [ΓA'] (≡is≤ PE.refl) (λ {Δ} {σ} → [UB'] {Δ} {σ}) [B']ₜ
        [B']  = maybeEmbᵛ {A = B'} [ΓA'] [B']'
        ⊢B'Δ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UB'] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([B']ₜ {Δ} {σ} ⊢Δ [σ]))
        [liftσ] = λ {Δ} {σ} ⊢Δ [σ] → liftSubstS {F = A} {σ = σ} {Δ = Δ} [Γ] ⊢Δ [A] [σ]
        [liftσ'] = λ {Δ} {σ} ⊢Δ [σ] → liftSubstS {F = A'} {σ = σ} {Δ = Δ} [Γ] ⊢Δ [A'] [σ]
        [ΠAB] = Πᵗᵛ {A} {B} (≡is≤ PE.refl) (≡is≤ PE.refl) [Γ] [A] (λ {Δ} {σ} → [UB] {Δ} {σ}) [A]ₜ [B]ₜ
        [ΠA'B'] = Πᵗᵛ {A'} {B'} (≡is≤ PE.refl) (≡is≤ PE.refl) [Γ] [A'] (λ {Δ} {σ} → [UB'] {Δ} {σ}) [A']ₜ [B']ₜ
        [IdAA']ₜ = Idᵗᵛ {A = Univ rA ⁰} {t = A} {u = A'} [Γ] (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ [A']ₜ (Uᵗᵛ [Γ])
        [IdAA'] = Idᵛ {A = Univ rA ⁰} {t = A} {u = A'} [Γ] (λ {Δ} {σ} → [UA] {Δ} {σ}) [A]ₜ [A']ₜ
        Id-U-ΠΠ-res A A' B B' = ∃ (Id (Univ rA ⁰) A A') ▹
                         (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰)
                         ((U.wk (lift (step id)) B) [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                         (U.wk (lift (step id)) B') ° ¹ ° ¹)
        [ΓId] = _∙_ {A = Id (Univ rA ⁰) A A'} [Γ] [IdAA']
        [wSProp] = Uᵛ {rU = %} ∞< [ΓId]
        [wA'] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A'} {lG = ⁰} [Γ] [IdAA'] [A']ₜ
        [wA']' = wk1ᵛ {A = A'} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A']
        [wA]' = wk1ᵛ {A = A} {F = Id (Univ rA ⁰) A A'} [Γ] [IdAA'] [A]
        [wA] = wk1ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = A} {lG = ⁰} [Γ] [IdAA'] [A]ₜ
        [ΓIdA'] = _∙_ {A = wk1 A'} [ΓId] [wA']'
        [wwU¹] = λ {Δ} {σ} r → Uᵛ {rU = r} ∞< [ΓIdA'] {Δ} {σ}
        [wwUA'] = λ {Δ} {σ} r → maybeEmbᵛ {A = Univ r _ } [ΓIdA'] (λ {Δ} {σ} → Uᵛ emb< [ΓIdA'] {Δ} {σ}) {Δ} {σ}
        [ΓIdA] = _∙_ {A = wk1 A} [ΓId] [wA]'
        [wwA'] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A'} {lG = ⁰} [ΓId] [wA']' [wA']
        [wwA] = wk1ᵗᵛ {F = wk1 A'} {G = wk1 A} {lG = ⁰} [ΓId] [wA']' [wA]
        [wwA']' = wk1ᵛ {A = wk1 A'} {F = wk1 A'}  [ΓId] [wA']' [wA']'
        [wwA]' = wk1ᵛ {A = wk1 A} {F = wk1 A'}  [ΓId] [wA']' [wA]'
        [wwU0A] = maybeEmbᵛ {A = Univ ! _ } [ΓIdA] (λ {Δ} {σ} → Uᵛ emb< [ΓIdA] {Δ} {σ})
        [wB'] = wk1dᵗᵛ {F = A'} {F' = Id (Univ rA ⁰) A A'} {G = B'} [Γ] [A'] [IdAA'] (λ {Δ} {σ} → [UB'] {Δ} {σ}) (λ {Δ} {σ} → [wwUA'] {Δ} {σ} !) [B']ₜ
        [wB] = wk1dᵗᵛ {F = A} {F' = Id (Univ rA ⁰) A A'} {G = B} [Γ] [A] [IdAA'] (λ {Δ} {σ} → [UB] {Δ} {σ}) (λ {Δ} {σ} → [wwU0A] {Δ} {σ}) [B]ₜ
        [wwIdAA'] = Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A)} {u = wk1 (wk1 A')} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA] [wwA']
        [wwIdA'A] = Idᵛ {A = Univ rA ⁰} {t = wk1 (wk1 A')} {u = wk1 (wk1 A)} [ΓIdA'] (λ {Δ} {σ} → [wwUA'] {Δ} {σ} rA) [wwA'] [wwA]
        [var0]ₜ : (Γ ∙ Id (Univ rA ⁰) A A' ^ [ % , ι ¹ ] ∙ wk1 A' ^ [ rA , ι ⁰ ]) ⊩ᵛ⟨ ∞ ⟩ var 0 ∷ wk1 (wk1 A') ^ [ rA , ι ⁰ ] / [ΓIdA'] / [wwA']'
        [var0]ₜ = proj₂ (fundamentalVar here [ΓIdA'])
        [var1]ₜ : (Γ ∙ Id (Univ rA ⁰) A A' ^ [ % , ι ¹ ] ∙ wk1 A' ^ [ rA , ι ⁰ ]) ⊩ᵛ⟨ ∞ ⟩ var 1 ∷  Id (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) ^ [ % , ι ¹ ] / [ΓIdA'] / [wwIdAA']
        [var1]ₜ = let X = fundamentalVar (there here) [ΓIdA'] in S.irrelevanceTerm {A = Id (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A'))} {t = var 1}
                                                                                [ΓIdA'] [ΓIdA'] (proj₁ X) [wwIdAA'] (proj₂ X)
        [Id-U-ΠΠ-res] : Γ ⊩ᵛ⟨ ∞ ⟩ Id-U-ΠΠ-res  A A' B B' ∷ SProp ¹ ^ [ ! , ∞ ] / [Γ] / [SProp]
        [Id-U-ΠΠ-res] = ∃ᵗᵛ {F = Id (Univ rA ⁰) A A'} {G = (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰)
                            ((U.wk (lift (step id)) B) [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑)
                            (U.wk (lift (step id)) B') ° ¹ ° ¹)} [Γ] [IdAA'] (λ {Δ} {σ} → [wSProp] {Δ} {σ}) [IdAA']ₜ
                            (Id-U-ΠΠ-resᵗᵛ {A} {B} {A'} {B'} [Γ] [A] [A'] (λ {Δ} {σ} → [UB] {Δ} {σ}) (λ {Δ} {σ} → [UB'] {Δ} {σ}) [A]ₜ [B]ₜ [A']ₜ [B']ₜ [var0]ₜ [var1]ₜ)
        [Id-U-ΠΠ] : Γ ⊩ᵛ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰) ⇒ Id-U-ΠΠ-res A A' B B' ∷ SProp ¹ ^ ∞  / [Γ]
        [Id-U-ΠΠ] = λ {Δ} {σ} ⊢Δ [σ] → let Aσ  = ⊢AΔ {Δ} {σ} ⊢Δ [σ]
                                           Bσ = ⊢BΔ {Δ ∙ subst σ A ^ _} {liftSubst σ} (⊢Δ ∙ ⊢A {Δ} {σ} ⊢Δ [σ]) ([liftσ] {Δ} {σ} ⊢Δ [σ])
                                           A'σ = ⊢A'Δ {Δ} {σ} ⊢Δ [σ]
                                           B'σ = ⊢B'Δ {Δ ∙ subst σ A' ^ _} {liftSubst σ} (⊢Δ ∙ ⊢A' {Δ} {σ} ⊢Δ [σ]) ([liftσ'] {Δ} {σ} ⊢Δ [σ])
                                           X : Δ ⊢ Id (U ⁰) (Π (subst σ A) ^ rA ° ⁰ ▹ (subst (liftSubst σ) B) ° ⁰ ° ⁰) (Π (subst σ A') ^ rA ° ⁰ ▹ (subst (liftSubst σ) B') ° ⁰ ° ⁰)
                                                   ⇒ Id-U-ΠΠ-res (subst σ A) (subst σ A') (subst (liftSubst σ) B) (subst (liftSubst σ) B')
                                                   ∷ SProp ¹ ^ ∞
                                           X = Id-U-ΠΠ {Δ} {subst σ A} {subst σ A'} {rA} {subst (liftSubst σ) B} {subst (liftSubst σ) B'} Aσ Bσ A'σ B'σ
                                       in  PE.subst (λ BB → Δ ⊢ Id (U ⁰) (Π (subst σ A) ^ rA ° ⁰ ▹ (subst (liftSubst σ) B) ° ⁰ ° ⁰) (Π (subst σ A') ^ rA ° ⁰ ▹ (subst (liftSubst σ) B') ° ⁰ ° ⁰)
                                                                   ⇒ BB  ∷ SProp ¹ ^ ∞ )
                                                    (PE.cong₃ (λ X Y Z → ∃ Id (Univ rA ⁰) (subst σ A) (subst σ A') ▹ Π X ^ rA ° ⁰ ▹ Id (U ⁰) Y Z ° ¹ ° ¹)
                                                              ((PE.sym (Idsym-subst-lemma σ A'))) (lemma1 A A' B) (lemma2 B'))  X
        [id] , [eq] = redSubstTermᵛ {SProp ¹} {Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰)} {Id-U-ΠΠ-res A A' B B'}
                                    [Γ] [Id-U-ΠΠ]
                                    (λ {Δ} {σ} → [SProp] {Δ} {σ}) [Id-U-ΠΠ-res]
    in modelsTermEq [SProp] [id] [Id-U-ΠΠ-res] [eq]


{-# OPTIONS --prop --rewriting --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

postulate
  A : Prop
  a : A
  B : Set
  b : B
  f : A → B → Set₁
  g : B → Set₁

  rew₁ : ∀ y → f a y ≡ g y
  rew₂ : ∀ x → f x b ≡ Set
  rew₃ : ∀ y → g y ≡ Set

{-# REWRITE rew₁ rew₂ rew₃ #-}


{- Jesper Cockx, 26-05-2014
   Issue 1023
-}

{-# OPTIONS --cubical-compatible #-}

module TerminationAndUnivalence where

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

J : ∀ {a b} {A : Set a} {x : A} (P : (y : A) → x ≡ y → Set b) →
    (p : P x refl) {y : A} (e : x ≡ y) → P y e
J P p refl = p

data ⊥ : Set where

data WOne : Set where
  wrap : (⊥ → WOne) → WOne

FOne = ⊥ → WOne

f : WOne → FOne
f x ()

g : FOne → WOne
g x = wrap (λ ())

postulate iso : WOne ≡ FOne

noo : (X : Set) → (WOne ≡ X) → X → ⊥
noo .WOne refl (wrap x) = noo FOne iso x

absurd : ⊥
absurd = noo FOne iso (λ ())


-- A variant of code reported by Andreas Abel.

{-# OPTIONS --guardedness --sized-types #-}

open import Agda.Builtin.Size

data ⊥ : Set where

mutual
  data D : Size → Set where
    inn : ∀ i → D' i → D (↑ i)

  record D' (i : Size) : Set where
    coinductive
    constructor ♯
    field ♭   : D i
open D'

iter : ∀{i} → D i → ⊥
iter (inn i t) = iter (♭ t)

-- Should be rejected by termination checker
bla : D' ∞
♭ bla = inn ∞ bla

false : ⊥
false = iter (♭ bla)


open import Oscar.Prelude
open import Oscar.Data.Maybe
open import Oscar.Class
open import Oscar.Class.Fmap
open import Oscar.Class.Pure
open import Oscar.Class.Apply
open import Oscar.Class.Bind
open import Oscar.Class.IsFunctor
open import Oscar.Class.IsPrefunctor
open import Oscar.Class.IsPrecategory
open import Oscar.Class.IsCategory
import Oscar.Property.Category.Function
import Oscar.Class.Reflexivity.Function
import Oscar.Class.Transextensionality.Proposequality

module Oscar.Property.Monad.Maybe where

instance

  𝓕mapMaybe : ∀ {𝔬₁ 𝔬₂} → 𝓕map Maybe 𝔬₁ 𝔬₂
  𝓕mapMaybe .𝓕map.fmap′ f ∅ = ∅
  𝓕mapMaybe .𝓕map.fmap′ f (↑ x) = ↑ f x

  𝓟ureMaybe : ∀ {𝔬} → 𝓟ure (Maybe {𝔬})
  𝓟ureMaybe .𝓟ure.pure = ↑_

  𝓐pplyMaybe : ∀ {𝔬₁ 𝔬₂} → 𝓐pply Maybe 𝔬₁ 𝔬₂
  𝓐pplyMaybe .𝓐pply.apply ∅ x = ∅
  𝓐pplyMaybe .𝓐pply.apply (↑ f) x = fmap′ f x

  𝓑indMaybe : ∀ {𝔬₁ 𝔬₂} → 𝓑ind Maybe 𝔬₁ 𝔬₂
  𝓑indMaybe .𝓑ind.bind ∅ _ = ∅
  𝓑indMaybe .𝓑ind.bind (↑ x) f = f x
{-
  FmapMaybe : ∀ {𝔬} → Fmap (Maybe {𝔬})
  FmapMaybe .Fmap.fmap = fmap′
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsPrefunctor .IsPrefunctor.`IsPrecategory₁ = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsPrefunctor .IsPrefunctor.`IsPrecategory₂ = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsPrefunctor .IsPrefunctor.`𝓢urjtranscommutativity = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsPrefunctor .IsPrefunctor.`𝓢urjextensionality = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsCategory₁ = !
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsCategory₂ .IsCategory.`IsPrecategory .IsPrecategory.`𝓣ransextensionality = {!!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsCategory₂ .IsCategory.`IsPrecategory .IsPrecategory.`𝓣ransassociativity = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsCategory₂ .IsCategory.`𝓣ransleftidentity = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`IsCategory₂ .IsCategory.`𝓣ransrightidentity = {!!}
  FmapMaybe .Fmap.isFunctor .IsFunctor.`𝒮urjidentity = {!!}
-}


module Issue87 where

data I : Set where

data D : I -> Set where
  d : forall {i} (x : D i) -> D i

bar : forall {i} -> D i -> D i -> D i
bar (d x) (d     y) with y
bar (d x) (d {i} y) | z = d {i} y

-- Panic: unbound variable i
-- when checking that the expression i has type I


open import Level hiding ( suc ; zero )
open import Algebra
module sym5n where

open import Symmetric
open import Data.Unit
open import Function.Inverse as Inverse using (_↔_; Inverse; _InverseOf_)
open import Function
open import Data.Nat hiding (_⊔_) -- using (ℕ; suc; zero)
open import Relation.Nullary
open import Data.Empty
open import Data.Product

open import Gutil
open import Putil
open import Solvable using (solvable)
open import  Relation.Binary.PropositionalEquality hiding ( [_] )

open import Data.Fin
open import Data.Fin.Permutation hiding (_∘ₚ_)

infixr  200 _∘ₚ_
_∘ₚ_ = Data.Fin.Permutation._∘ₚ_

-- open import IO
open import Data.String hiding (toList)
open import Data.Unit
open import Agda.Builtin.String

sym5solvable : (n : ℕ) → String -- ¬ solvable (Symmetric 5)
sym5solvable n = FListtoStr (CommFListN 5 n) where

   open import Data.List using ( List ; [] ; _∷_ )
   open Solvable (Symmetric 5)

   open import FLutil
   open import Data.List.Fresh hiding ([_])
   open import Relation.Nary using (⌊_⌋)

   p0id :  FL→perm (zero :: zero :: zero :: (zero :: (zero :: f0))) =p= pid
   p0id = pleq _ _ refl

   open import Data.List.Fresh.Relation.Unary.Any
   open import FLComm

   stage4FList = CommFListN 5 0
   stage6FList = CommFListN 5 3

   -- stage5FList = {!!}
   -- s2=s3 :  CommFListN 5 2 ≡ CommFListN 5 3
   -- s2=s3 = refl

   FLtoStr : {n : ℕ} → (x : FL n) → String
   FLtoStr f0 = "f0"
   FLtoStr (x :: y) = primStringAppend ( primStringAppend (primShowNat (toℕ x)) " :: " ) (FLtoStr y)

   FListtoStr : {n : ℕ} → (x : FList n) → String
   FListtoStr [] = ""
   FListtoStr (cons a x x₁) = primStringAppend (FLtoStr a) (primStringAppend "\n" (FListtoStr x))

open import Codata.Musical.Notation
open import Data.Maybe hiding (_>>=_)
open import Data.List
open import Data.Char
open import IO.Primitive
open import Codata.Musical.Costring

postulate
    getArgs : IO (List (List Char))
{-# FOREIGN GHC import qualified System.Environment #-}
{-# COMPILE GHC getArgs = System.Environment.getArgs #-}

charToDigit : Char → Maybe ℕ
charToDigit '0' = just ( 0)
charToDigit '1' = just ( 1)
charToDigit '2' = just ( 2)
charToDigit '3' = just ( 3)
charToDigit '4' = just ( 4)
charToDigit '5' = just ( 5)
charToDigit '6' = just ( 6)
charToDigit '7' = just ( 7)
charToDigit '8' = just ( 8)
charToDigit '9' = just ( 9)
charToDigit _   = nothing

getNumArg1 : (List (List Char)) → ℕ
getNumArg1 [] = 0
getNumArg1 ([] ∷ y) = 0
getNumArg1 ((x ∷ _) ∷ y) with charToDigit x
... | just n = n
... | nothing  = 0

--
-- CommFListN 5 x is too slow use compiler
-- agda --compile sym5n.agda
--

main : IO ⊤
main = getArgs >>= (λ x →  putStrLn $ toCostring $ sym5solvable $ getNumArg1 x )


{-# OPTIONS --allow-unsolved-metas #-}

open import Agda.Builtin.Equality

postulate
  cong₂ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {x y : A} {u v : B}
        → (f : A → B → C) → x ≡ y → u ≡ v → f x u ≡ f y v

test = cong₂ (λ A B → A → B)


{-# OPTIONS --cubical --safe --guardedness #-}

module Data.PolyP where

open import Data.PolyP.RecursionSchemes public
open import Data.PolyP.Universe public
open import Data.PolyP.Composition public
open import Data.PolyP.Types public
open import Data.PolyP.Currying public


open import IO using ( run ; putStrLn )
open import Data.String using ( _++_ )
open import Data.Natural using ( # ; _+_ ; toString )

module Data.Bindings.Examples.HelloFour where

main = run (putStrLn ("Hello, " ++ toString (#(2) + #(2)) ++ "."))


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Binary.Equality.Setoid directly.
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Relation.Binary

module Data.Vec.Relation.Equality.Setoid
  {a ℓ} (S : Setoid a ℓ) where

open import Data.Vec.Relation.Binary.Equality.Setoid S public


{-# OPTIONS --without-K #-}

open import Base
open import Spaces.Circle
open import Integers

module Spaces.LoopSpaceCircle where

-- Path fibration

path-fib : S¹ → Set
path-fib t = (t ≡ base)

tot-path-fib : Set
tot-path-fib = Σ S¹ path-fib

tot-path-fib-is-contr : is-contr tot-path-fib
tot-path-fib-is-contr = pathto-is-contr base

-- Universal cover

succ-path : ℤ ≡ ℤ
succ-path = eq-to-path succ-equiv

universal-cover : S¹ → Set
universal-cover = S¹-rec-nondep Set ℤ succ-path

tot-cover : Set
tot-cover = Σ S¹ universal-cover

-- Transport in the universal cover
loop-to-succ : (n : ℤ) → transport universal-cover loop n ≡ succ n
loop-to-succ n = ! (trans-ap (λ A → A) universal-cover loop n)
                 ∘ (ap (λ t → transport (λ A → A) t n)
                        (S¹-β-loop-nondep Set ℤ succ-path)
                 ∘ trans-id-eq-to-path succ-equiv n)

{- The flattening lemma

Here is an HIT declaration for the CW-complex of real numbers:

data ℝ : Set where
  z : ℤ → ℝ
  e : (n : ℤ) → z n ≡ z (succ n)

We want to show that [tot-cover] has the same introduction and elimination
rules.
-}

-- Introduction rules

R-z : ℤ → tot-cover
R-z n = (base , n)

R-e : (n : ℤ) → R-z n ≡ R-z (succ n)
R-e n = Σ-eq loop (loop-to-succ n)

-- Elimination rule
module Tot-cover-is-ℝ
  {i}
  (P : tot-cover → Set i)
  (z : (n : ℤ) → P (R-z n))
  (e : (n : ℤ) → transport P (R-e n) (z n) ≡ z (succ n)) where

  -- I redefine [R-e] and [e] to have something involving
  -- [transport universal-cover loop] instead of [succ]
  R-e' : (n : ℤ) → R-z n ≡ R-z (transport universal-cover loop n)
  R-e' n = Σ-eq loop refl

  e' : (n : ℤ) → transport P (R-e' n) (z n)
                 ≡ z (transport universal-cover loop n)
  e' n = (trans-totalpath universal-cover P {x = (base , n)}
                          {y = (base , transport universal-cover loop n)}
                          loop refl z
         ∘ move!-transp-left (λ z → P (base , z)) _ (loop-to-succ n)
           (z (succ n))
           (! (trans-totalpath universal-cover P {x = (base , n)}
                               {y = (base , succ n)} loop (loop-to-succ n) z)
            ∘ e n))
          ∘ apd z (! (loop-to-succ n))

  -- Now I can prove what I want by induction on the circle

  P-base : (t : universal-cover base) → P (base , t)
  P-base t = z t

  P-loop : (t : universal-cover base)
    → transport (λ x → (u : universal-cover x) → P (x , u)) loop P-base t
      ≡ P-base t
  P-loop t = transport (λ t → transport
                                (λ x → (u : universal-cover x) → P (x , u))
                                loop P-base t ≡ P-base t)
               (trans-trans-opposite universal-cover loop t)
               (! (trans-totalpath universal-cover P
                                   loop refl z)
               ∘ e' (transport universal-cover (! loop) t))

  P-R-rec : (x : S¹) → (t : universal-cover x) → P (x , t)
  P-R-rec = S¹-rec (λ x → (t : universal-cover x) → P (x , t))
                   P-base (funext P-loop)

  -- Here is the conclusion of the elimination rule
  R-rec : (t : tot-cover) → P t
  R-rec (x , y) = P-R-rec x y

-- We can now prove that [tot-cover] is contractible using [R-rec], that’s a
-- little tedious but not difficult

P-R-contr : (x : tot-cover) → Set _
P-R-contr x = R-z O ≡ x

R-contr-base : (n : ℤ) → P-R-contr (R-z n)
R-contr-base O = refl
R-contr-base (pos O) = R-e O
R-contr-base (pos (S y)) = R-contr-base (pos y) ∘ R-e (pos y)
R-contr-base (neg O) = ! (R-e (neg O))
R-contr-base (neg (S y)) = R-contr-base (neg y) ∘ ! (R-e (neg (S y)))

R-contr-loop : (n : ℤ)
  → transport P-R-contr (R-e n) (R-contr-base n) ≡ (R-contr-base (succ n))
R-contr-loop O = trans-cst≡id (R-e O) refl
R-contr-loop (pos O) = trans-cst≡id (R-e (pos O)) (R-e O)
R-contr-loop (pos (S y)) = trans-cst≡id (R-e (pos (S y)))
  (R-contr-base (pos y) ∘ R-e (pos y))
R-contr-loop (neg O) = trans-cst≡id (R-e (neg O))
  (! (R-e (neg O))) ∘ opposite-left-inverse (R-e (neg O))
R-contr-loop (neg (S y)) =
  ((trans-cst≡id (R-e (neg (S y))) (R-contr-base (neg y) ∘ ! (R-e (neg (S y))))
   ∘ concat-assoc (R-contr-base (neg y)) (! (R-e (neg (S y))))
                  (R-e (neg (S y))))
   ∘ (whisker-left (R-contr-base (neg y))
                   (opposite-left-inverse (R-e (neg (S y))))))
   ∘ refl-right-unit (R-contr-base (neg y))

R-contr : (x : tot-cover) → P-R-contr x
R-contr = Tot-cover-is-ℝ.R-rec P-R-contr R-contr-base R-contr-loop

tot-cover-is-contr : is-contr tot-cover
tot-cover-is-contr = (R-z O , λ x → ! (R-contr x))

-- We define now a fiberwise map between the two fibrations [path-fib]
-- and [universal-cover]
fiberwise-map : (x : S¹) → (path-fib x → universal-cover x)
fiberwise-map x p = transport universal-cover (! p) O

-- This induces an equivalence on the total spaces, because both total spaces
-- are contractible
total-is-equiv : is-equiv (total-map fiberwise-map)
total-is-equiv = contr-to-contr-is-equiv (total-map fiberwise-map)
                                         tot-path-fib-is-contr
                                         tot-cover-is-contr

-- Hence an equivalence fiberwise
fiberwise-map-is-equiv : (x : S¹) → is-equiv (fiberwise-map x)
fiberwise-map-is-equiv x = fiberwise-is-equiv fiberwise-map total-is-equiv x

-- We can then conclude that the based loop space of the circle is equivalent to
-- the type of the integers
ΩS¹≃ℤ : (base ≡ base) ≃ ℤ
ΩS¹≃ℤ = (fiberwise-map base , fiberwise-map-is-equiv base)

-- We can also deduce that the circle is 1-truncated

ΩS¹-is-set : is-set (base ≡ base)
ΩS¹-is-set = equiv-types-truncated _ (ΩS¹≃ℤ ⁻¹) ℤ-is-set

S¹-is-gpd : is-gpd S¹
S¹-is-gpd =
  S¹-rec _
    (S¹-rec _
      ΩS¹-is-set  -- [base ≡ base] is a set
      (π₁ (is-truncated-is-prop _ _ _)))
    (funext
      (S¹-rec _
        (π₁ (is-truncated-is-prop _ _ _))
        (prop-has-all-paths (≡-is-truncated _ (is-truncated-is-prop _)) _ _)))


open import Coinduction using ( ∞ ; ♯_ ; ♭ )
open import Data.Bool using ( Bool ; true ; false ; if_then_else_ )
open import Data.Empty using ( ⊥ )
open import Data.Maybe using ( Maybe ; just ; nothing )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Data.Unit using ( ⊤ ; tt )
open import Data.Natural using ( Natural ; # )
open import Data.String using ( String )
open import Data.ByteString using ( ByteString ; strict ; length )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )

module System.IO.Transducers.Session where

-- Unidirectional sessions.  These can be viewed as trees,
-- where each node is labelled by a set A, and has a child
-- for each element of A.

-- These are a lot like session types, but are unidirectional,
-- not bidirectional, and are not designed to support session
-- mobility.

-- They are also a lot like arenas in game semantics, but again
-- are unidirectional.

-- They're a lot like the container types from Ghani, Hancock
-- and Pattison's "Continuous functions on final coalgebras".
-- Note that we are supporting weighted sets, similar to theirs,
-- in order to support induction over weights of input,
-- e.g. on bytestring input we can do induction over the length
-- of the bytestring.

-- Finally, they are a lot like automata: states are sessions,
-- acceptors are leaves, transitions correspond to children.

infixr 4 _∼_
infixr 6 _⊕_
infixr 7 _&_ _&*_

-- Weighting for a set

Weighted : Set → Set
Weighted A = A → Natural

-- Discrete weighting function

δ : ∀ {A} → (Weighted A)
δ a = # 1

-- Sessions are trees of weighted sets

data Session : Set₁ where
  I : Session
  Σ : {A : Set} → (W : Weighted A) → (F : ∞ (A → Session)) → Session

-- Equivalence of sessions

data _∼_ : Session → Session → Set₁ where
  I : I ∼ I
  Σ : {A : Set} → (W : Weighted A) → {F₁ F₂ : ∞ (A → Session)} →
    ∞ (∀ a → ♭ F₁ a ∼ ♭ F₂ a) → (Σ W F₁ ∼ Σ W F₂)

∼-refl : ∀ {S} → (S ∼ S)
∼-refl {I}     = I
∼-refl {Σ V F} = Σ V (♯ λ a → ∼-refl {♭ F a})

∼-sym : ∀ {S T} → (S ∼ T) → (T ∼ S)
∼-sym I       = I
∼-sym (Σ V F) = Σ V (♯ λ a → ∼-sym (♭ F a))

∼-trans : ∀ {S T U} → (S ∼ T) → (T ∼ U) → (S ∼ U)
∼-trans I       I        = I
∼-trans (Σ V F) (Σ .V G) = Σ V (♯ λ a → ∼-trans (♭ F a) (♭ G a))

-- Inital alphabet

Γ : Session → Set
Γ I           = ⊥
Γ (Σ {A} W F) = A

Δ : ∀ S → (Weighted (Γ S))
Δ I       ()
Δ (Σ W F) a = W a

_/_ : ∀ S → (Γ S) → Session
I       / ()
(Σ W F) / a = ♭ F a

-- IsI S is inhabited whenever S ≡ I

IsI : Session → Set
IsI I       = ⊤
IsI (Σ V F) = ⊥

-- IsΣ S is inhabited whenever S is of the form Σ V F

IsΣ : Session → Set
IsΣ I       = ⊥
IsΣ (Σ V F) = ⊤

-- IsΣ respects ≡.

IsΣ-≡ : ∀ {S} {isΣ : IsΣ S} {T} → (S ≡ T) → (IsΣ T)
IsΣ-≡ {Σ V F} refl = tt
IsΣ-≡ {I}  {} refl

-- Singletons

⟨_w/_⟩ : (A : Set) → (Weighted A) → Session
⟨ A w/ W ⟩ = Σ W (♯ λ a → I)

⟨_⟩ : Set → Session
⟨ A ⟩ = ⟨ A w/ δ ⟩

-- Sequencing

_&_ : Session → Session → Session
I       & T = T
(Σ V F) & T = Σ V (♯ λ a → ♭ F a & T)

-- Units and associativity

unit₁ : ∀ {S} → (I & S ∼ S)
unit₁ = ∼-refl

unit₂ : ∀ {S} → (S & I ∼ S)
unit₂ {I} = I
unit₂ {Σ V F} = Σ V (♯ λ a → unit₂ {♭ F a})

assoc : ∀ {S T U} → (S & (T & U) ∼ (S & T) & U)
assoc {I} = ∼-refl
assoc {Σ V F} = Σ V (♯ λ a → assoc {♭ F a})

-- Lazy choice

_+_ : Session → Session → Session
S + T = Σ δ (♯ λ b → if b then S else T)

-- Strict choice

_⊕_ : Session → Session → Session
I ⊕ T = I
S ⊕ I = I
S ⊕ T = S + T

-- Lazy option

¿ : Session → Session
¿ S = S + I

-- Lazy Kleene star

-- It would be nice if I could just define * S = ¿ (S & * S),
-- but that doesn't pass the termination checker, so I have
-- to expand out the definition.

hd : Session → Set
hd I           = Bool
hd (Σ {A} W F) = A

wt : ∀ S → (Weighted (hd S))
wt I       = δ
wt (Σ W F) = W

mutual

  tl : ∀ S T → (hd S) → Session
  tl I       T true  = T &* T
  tl I       T false = I
  tl (Σ W F) T a     = (♭ F a) &* T

  _&*_ : Session → Session → Session
  S &* T = Σ (wt S) (♯ tl S T)

* : Session → Session
* S = I &* S

+ : Session → Session
+ S = S &* S

-- Bytes

Bytes' : Session
Bytes' = + ⟨ ByteString strict w/ length ⟩

Bytes : Session
Bytes = * ⟨ ByteString strict w/ length ⟩

-- TODO: weight strings by their length?

Strings' : Session
Strings' = + ⟨ String ⟩

Strings : Session
Strings = * ⟨ String ⟩


{-# OPTIONS --allow-unsolved-metas #-}
module Issue107 where

data Bool : Set where
  true : Bool
  false : Bool

data False : Set where
record True : Set where

T : Bool -> Set
T false = False
T _  = True

foo : ((a : Bool) -> T a) -> True
foo f = f _


-- Andreas, 2016-05-04, discussion with Ulf
-- Projections should be treated in the same way asonstructors,
-- what parameters concerns

-- {-# OPTIONS -v tc.mod.apply:15  #-}
-- {-# OPTIONS -v tc.term.con:50 -v tc.term.def:10 #-}

module _ where

module M (A : Set) where

  data D : Set where
    c : A → D

  record R : Set where
    field f : A
    g = f
  open R public

open module N A = M A

-- After module copy, constructor parameter is still hidden

check : ∀ A → A → D A
check A x = c {A = A} x

pat : ∀ A → D A → Set
pat A (c x) = A

-- Field parameter should be hidden

infer : ∀ A → R A → A
infer A r = f r

-- and skipped on the lhs.

copat : ∀ A (a : A) → R A
f (copat A a) = a


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Binary.Equality.DecSetoid directly.
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Relation.Binary

module Data.List.Relation.Equality.DecSetoid
  {a ℓ} (DS : DecSetoid a ℓ) where

open import Data.List.Relation.Binary.Equality.DecSetoid DS public


open import Agda.Builtin.Equality

postulate
  X : Set
  rigid0 : ((@0 x : X) → X) → X

mutual
  H : ((@ω x : X) → X) → X
  H f = rigid0 _

  testω : (f : (@0 x : X) → X) → H (\ (@ω x) → f x) ≡ rigid0 (\ (@0 x) → f x)
  testω f = refl


------------------------------------------------------------------------------
-- The LTC-PCF Booleans type
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- N.B. This module is re-exported by LTC-Bool.Data.Bool.

module LTC-PCF.Data.Bool.Type where

open import LTC-PCF.Base

------------------------------------------------------------------------------
-- The LTC-PCF Booleans type (inductive predicate for total Booleans).
data Bool : D → Set where
  btrue : Bool true
  bfalse : Bool false

-- The rule of proof by case analysis.
Bool-ind : (A : D → Set) → A true → A false → ∀ {b} → Bool b → A b
Bool-ind A At Af btrue  = At
Bool-ind A At Af bfalse = Af


{-# OPTIONS --without-K #-}
module Simplify where

open import FT
open import HoTT

-- just flip.  It is he caller's responsibility to do other things
flip : {b₁ b₂ : FT} → b₂ ⇛ b₁ → b₁ ⇛ b₂
flip unite₊⇛ = uniti₊⇛
flip uniti₊⇛ = unite₊⇛
flip swap₊⇛ = swap₊⇛
flip assocl₊⇛ = assocr₊⇛
flip assocr₊⇛ = assocl₊⇛
flip unite⋆⇛ = uniti⋆⇛
flip uniti⋆⇛ = unite⋆⇛
flip swap⋆⇛ = swap⋆⇛
flip assocl⋆⇛ = assocr⋆⇛
flip assocr⋆⇛ = assocl⋆⇛
flip distz⇛ = factorz⇛
flip factorz⇛ = distz⇛
flip dist⇛ = factor⇛
flip factor⇛ = dist⇛
flip id⇛ = id⇛
flip (sym⇛ p) = p
flip (p ◎ q) = flip q ◎ flip p
flip (p ⊕ q) = flip p ⊕ flip q
flip (p ⊗ q) = flip p ⊗ flip q

flip-id-lemma : ∀ {b} → flip {b} {b} id⇛ ≡ id⇛
flip-id-lemma = λ {b} → refl id⇛

-- we're going to be pretty brute-force about this, for now
-- All this is going to be one huge mutual definition.
mutual
  simplify : {b₁ b₂ : FT} → b₁ ⇛ b₂ → b₁ ⇛ b₂
  -- all the basic (atomic) combinators simplify to themselves
  simplify unite₊⇛ = unite₊⇛
  simplify uniti₊⇛ = uniti₊⇛
  simplify swap₊⇛ = swap₊⇛
  simplify assocl₊⇛ = assocl₊⇛
  simplify assocr₊⇛ = assocr₊⇛
  simplify unite⋆⇛ = unite⋆⇛
  simplify uniti⋆⇛ = uniti⋆⇛
  simplify swap⋆⇛ = swap⋆⇛
  simplify assocl⋆⇛ = assocl⋆⇛
  simplify assocr⋆⇛ = assocr⋆⇛
  simplify distz⇛ = distz⇛
  simplify factorz⇛ = factorz⇛
  simplify dist⇛ = dist⇛
  simplify factor⇛ = factor⇛
  simplify id⇛ = id⇛
  simplify (sym⇛ p) = flip (simplify p)
  simplify (p ◎ q) = scomp (simplify p)  (simplify q)
  simplify (p ⊕ q) = simplify p ⊕ simplify q
  simplify (p ⊗ q) = simplify p ⊗ simplify q

  -- split on p, and then only on those q that we want to simplify
  scomp : {b₁ b₂ b₃ : FT} → b₁ ⇛ b₂ → b₂ ⇛ b₃ → b₁ ⇛ b₃
  scomp id⇛ p = p
  scomp unite₊⇛ id⇛ = unite₊⇛
  scomp unite₊⇛ uniti₊⇛ = id⇛
  scomp unite₊⇛ q = unite₊⇛ ◎ q -- more?
  scomp uniti₊⇛ unite₊⇛ = id⇛
  scomp uniti₊⇛ id⇛ = uniti₊⇛
  scomp uniti₊⇛ q = uniti₊⇛ ◎ q
  scomp swap₊⇛ swap₊⇛ = id⇛
  scomp swap₊⇛ id⇛ = swap₊⇛
  scomp swap₊⇛ (q ◎ q₁) = scomp swap₊⇛ q ◎ q₁
  scomp swap₊⇛ q = swap₊⇛ ◎ q
  scomp assocl₊⇛ assocr₊⇛ = id⇛
  scomp assocl₊⇛ id⇛ = assocl₊⇛
  scomp assocl₊⇛ q = assocl₊⇛ ◎ q
  scomp assocr₊⇛ assocl₊⇛ = id⇛
  scomp assocr₊⇛ id⇛ = assocr₊⇛
  scomp assocr₊⇛ q = assocr₊⇛ ◎ q
  scomp unite⋆⇛ uniti⋆⇛ = id⇛
  scomp unite⋆⇛ id⇛ = unite⋆⇛
  scomp unite⋆⇛ q = unite⋆⇛ ◎ q
  scomp uniti⋆⇛ unite⋆⇛ = id⇛
  scomp uniti⋆⇛ id⇛ = uniti⋆⇛
  scomp uniti⋆⇛ q = uniti⋆⇛ ◎ q
  scomp swap⋆⇛ swap⋆⇛ = id⇛
  scomp swap⋆⇛ id⇛ = swap⋆⇛
  scomp swap⋆⇛ q = swap⋆⇛ ◎ q
  scomp assocl⋆⇛ assocr⋆⇛ = id⇛
  scomp assocl⋆⇛ id⇛ = assocl⋆⇛
  scomp assocl⋆⇛ q = assocl⋆⇛ ◎ q
  scomp assocr⋆⇛ assocl⋆⇛ = id⇛
  scomp assocr⋆⇛ id⇛ = assocr⋆⇛
  scomp assocr⋆⇛ q = assocr⋆⇛ ◎ q
  scomp distz⇛ id⇛ = distz⇛
  scomp distz⇛ q = distz⇛ ◎ q
  scomp factorz⇛ distz⇛ = id⇛
  scomp factorz⇛ id⇛ = factorz⇛
  scomp factorz⇛ q = factorz⇛ ◎ q
  scomp dist⇛ q = dist⇛ ◎ q -- Can't simplify?
  scomp factor⇛ dist⇛ = id⇛
  scomp factor⇛ id⇛ = factor⇛
  scomp factor⇛ q = factor⇛ ◎ q
  scomp (sym⇛ p) q = (flip p) ◎ q -- won't happen from simplify
  scomp (p₁ ◎ p₂) id⇛ = scomp p₁ p₂
  scomp (p₁ ◎ p₂) q = scomp p₁ p₂ ◎ q
  scomp (p₁ ⊕ p₂) id⇛ = p₁ ⊕ p₂
  scomp (p₁ ⊕ p₂) (q₁ ⊕ q₂) = scomp p₁ q₁ ⊕ scomp p₂ q₂
  scomp (p₁ ⊕ p₂) q = (p₁ ⊕ p₂) ◎ q
  scomp (p₁ ⊗ p₂) id⇛ = p₁ ⊗ p₂
  scomp (p₁ ⊗ p₂) (q ◎ q₁) = scomp (p₁ ⊗ p₂) q ◎ q₁
  scomp (p₁ ⊗ p₂) (q ⊗ q₁) = scomp p₁ q ⊗ scomp p₂ q₁
  scomp (p₁ ⊗ p₂) q = (p₁ ⊗ p₂) ◎ q

-- testing
test1 : ∀ {b₁ : FT} → b₁ ⇛ b₁
test1 = simplify (id⇛ ◎ id⇛ ◎ id⇛)

test2 : ∀ {b₁ : FT} → TIMES ONE b₁ ⇛ TIMES ONE b₁
test2 = simplify ((sym⇛ uniti⋆⇛) ◎ id⇛ ◎ uniti⋆⇛)


{-

This file contains:

- the coequalizer of sets as a HIT as performed in https://1lab.dev/Data.Set.Coequaliser.html

-}
{-# OPTIONS --safe #-}
module Cubical.HITs.SetCoequalizer.Properties where

open import Cubical.HITs.SetCoequalizer.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ' ℓ'' : Level
    A : Type ℓ
    B : Type ℓ'

-- Some helpful lemmas, similar to those in Cubical/HITs/SetQuotients/Properties.agda
elimProp : {f g : A → B} {C : SetCoequalizer f g → Type ℓ}
         → (Cprop : (x : SetCoequalizer f g) → isProp (C x))
         → (Cinc : (b : B) → C (inc b))
         → (x : SetCoequalizer f g) → C x
elimProp Cprop Cinc (inc x) = Cinc x
elimProp {f = f} {g = g} Cprop Cinc (coeq a i) =
  isProp→PathP (λ i → Cprop (coeq a i)) (Cinc (f a)) (Cinc (g a)) i
elimProp Cprop Cinc (squash x y p q i j) =
  isOfHLevel→isOfHLevelDep
    2 (λ x → isProp→isSet (Cprop x)) (g x) (g y) (cong g p) (cong g q) (squash x y p q) i j
  where
  g = elimProp Cprop Cinc

elimProp2 : {A' : Type ℓ} {B' : Type ℓ'} {f g : A → B} {f' g' : A' → B'}
            {C : SetCoequalizer f g → SetCoequalizer f' g' → Type (ℓ-max ℓ ℓ')}
          → (Cprop : (x : SetCoequalizer f g) → (y : SetCoequalizer f' g') → isProp (C x y))
          → (Cinc : (b : B) → (b' : B') → C (inc b) (inc b'))
          → (x : SetCoequalizer f g) → (y : SetCoequalizer f' g') → C x y
elimProp2 Cprop Cinc = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                                (λ x → elimProp (λ y → Cprop (inc x) y) (Cinc x))

elimProp3 : {A' A'' : Type ℓ} {B' B'' : Type ℓ'} {f g : A → B} {f' g' : A' → B'}
            {f'' g'' : A'' → B''}
            {C : SetCoequalizer f g → SetCoequalizer f' g' → SetCoequalizer f'' g''
               → Type (ℓ-max ℓ ℓ')}
          → (Cprop : (x : SetCoequalizer f g)
                   → (y : SetCoequalizer f' g')
                   → (z : SetCoequalizer f'' g'')
                   → isProp (C x y z))
          → (Cinc : (b : B) → (b' : B') → (b'' : B'') → C (inc b) (inc b') (inc b''))
          → (x : SetCoequalizer f g) → (y : SetCoequalizer f' g') → (z : SetCoequalizer f'' g'')
          → C x y z
elimProp3 Cprop Cinc = elimProp (λ x → isPropΠ2 (λ y z → Cprop x y z))
                                (λ x → elimProp2 (λ y z → Cprop (inc x) y z) (Cinc x))

rec : {C : Type ℓ''} {f g : A → B}
    → (Cset : (x y : C) → (p q : x ≡ y) → p ≡ q)
    → (h : B → C)
    → (hcoeqs : (a : A) → h (f a) ≡ h (g a))
    → SetCoequalizer f g → C
rec Cset h hcoeqs (inc x) = h x
rec Cset h hcoeqs (coeq a i) = hcoeqs a i
rec Cset h hcoeqs (squash x y p q i j) =
    Cset (g x) (g y) (λ i → g (p i)) (λ i → g (q i)) i j
  where g = rec Cset h hcoeqs

rec2 : {A' : Type ℓ} {B' : Type ℓ'} {C : Type ℓ''} {f g : A → B} {f' g' : A' → B'}
     → (Cset : (x y : C) → (p q : x ≡ y) → p ≡ q)
     → (h : B → B' → C)
     → (hcoeqsl : (a : A) (b' : B') → h (f a) b' ≡ h (g a) b')
     → (hcoeqsr : (a' : A') (b : B) → h b (f' a') ≡ h b (g' a'))
     → SetCoequalizer f g → SetCoequalizer f' g' → C
rec2 Cset h hcoeqsl hcoeqsr =
  rec
    (isSetΠ (λ _ → Cset))
    (λ b → rec Cset (λ b' → h b b') (λ a' → hcoeqsr a' b))
    (λ a → funExt (elimProp (λ _ → Cset _ _) (λ b' → hcoeqsl a b')))

module UniversalProperty where
  {- The proof of the universal property of the coequalizer of sets.

  A ==f=g==> B --inc--> SetCoequalizer f g
              \         .
                \       .
                  h   ∃! inducedHom
                    \   .
                      \ .
                        C
  commuting diagram
  -}
  inducedHom : {C : Type ℓ''} {f g : A → B}
             → (Cset : (x y : C) → (p q : x ≡ y) → p ≡ q)
             → (h : B → C)
             → (hcoeq : (a : A) → h (f a) ≡ h (g a))
             → SetCoequalizer f g → C
  inducedHom Cset h hcoeq = rec Cset h hcoeq

  commutativity : {C : Type ℓ''} {f g : A → B}
                → (Cset : (x y : C) → (p q : x ≡ y) → p ≡ q)
                → (h : B → C)
                → (hcoeq : (a : A) → h (f a) ≡ h (g a))
                → ((b : B) → h b ≡ inducedHom Cset h hcoeq (inc b))
  commutativity Cset h hcoeq = λ b → refl

  uniqueness : {C : Type ℓ''}
             → (f g : A → B)
             → (Cset : (x y : C) → (p q : x ≡ y) → p ≡ q)
             → (h : B → C)
             → (hcoeq : (a : A) → h (f a) ≡ h (g a))
             → (i : SetCoequalizer f g → C)
             → (icommutativity : (b : B) → h b ≡ i (inc b))
             → (i ≡ inducedHom Cset h hcoeq)
  uniqueness f g Cset h hcoeq i icommutativity = λ j x → q x j
    where q : (x : SetCoequalizer f g) → i x ≡ inducedHom Cset h hcoeq x
          q = elimProp
                (λ _ → Cset _ _)
                (λ b → i (inc b) ≡⟨ sym (icommutativity b) ⟩
                      h b       ≡⟨ refl ⟩
                      inducedHom Cset h hcoeq (inc b) ∎)


module Haskell.RangedSetsProp.RangesProperties where

open import Haskell.RangedSetsProp.library

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat renaming (_==_ to eqq; _<_ to ltt)

open import Haskell.Prim
open import Haskell.Prim.Ord
open import Haskell.Prim.Bool
open import Haskell.Prim.Maybe
open import Haskell.Prim.Enum
open import Haskell.Prim.Eq

open import Haskell.Prim.Foldable
open import Haskell.Prim.List
open import Haskell.Prim.Integer
open import Haskell.Prim.Double

open import Haskell.RangedSets.Boundaries
open import Haskell.RangedSets.Ranges
open import Haskell.RangedSetsProp.BoundariesProperties

postulate
  prop_range_creation : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → {r1 r2 : Boundary a} →
                        {r3 r4 : Boundary a} → (r1 ≡ r3) → (r2 ≡ r4) → (Rg r1 r2) ≡ Rg r3 r4

prop_intersection_sym : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (r1 : Range a) → (r2 : Range a) →
                        rangeIntersection r1 r2 ≡ rangeIntersection r2 r1
prop_intersection_sym ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) =
   begin
      rangeIntersection r1 r2
     =⟨⟩
      if_then_else_ (rangeIsEmpty r1 || rangeIsEmpty r2) emptyRange (Rg (max l1 l2) (min u1 u2))
     =⟨ cong (ifThenElseHelper emptyRange (Rg (max l1 l2) (min u1 u2))) (prop_or_sym (rangeIsEmpty r1) (rangeIsEmpty r2)) ⟩
      if_then_else_ (rangeIsEmpty r2 || rangeIsEmpty r1) emptyRange (Rg (max l1 l2) (min u1 u2))
     =⟨ cong (if_then_else_ (rangeIsEmpty r2 || rangeIsEmpty r1) emptyRange)
     (prop_range_creation (prop_max_sym l1 l2) (prop_min_sym u1 u2))  ⟩
      if_then_else_ (rangeIsEmpty r2 || rangeIsEmpty r1) emptyRange (Rg (max l2 l1) (min u2 u1))
     =⟨⟩
      rangeIntersection r2 r1
   end

prop_singletonRangeHas : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (x : a) → (rangeHas ⦃ o ⦄ (singletonRange x) x) ≡ true
prop_singletonRangeHas ⦃ o ⦄ ⦃ dio ⦄ x =
   begin
      (rangeHas (singletonRange x) x)
     =⟨⟩
      (rangeHas (Rg (BoundaryBelow x) (BoundaryAbove x)) x)
     =⟨⟩
      ((x />/ (BoundaryBelow x)) && (not (x />/ (BoundaryAbove x))))
     =⟨⟩
      ((x >= x) && (not (x > x)))
     =⟨ cong (_&& (not (x > x))) (gteq ⦃ o ⦄ refl) ⟩
      (true && (not (x > x)))
     =⟨ cong (true &&_) (gt ⦃ o ⦄ refl) ⟩
      (true && true)
     =⟨⟩
      true
   end

prop_singletonRangeHasOnly : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (x y : a) → (rangeHas ⦃ o ⦄ (singletonRange x) y) ≡ (x == y)
prop_singletonRangeHasOnly ⦃ o ⦄ ⦃ dio ⦄ v1 v2 =
   begin
      (rangeHas (singletonRange v1) v2)
     =⟨⟩
      (rangeHas (Rg (BoundaryBelow v1) (BoundaryAbove v1)) v2)
     =⟨⟩
      ((v2 />/ (BoundaryBelow v1)) && (not (v2 />/ (BoundaryAbove v1))))
     =⟨⟩
      ((v2 >= v1) && (not (v2 > v1)))
     =⟨ eq1 v2 v1 ⟩
      (v1 == v2)
   end

prop_singletonRangeConverse : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (x : a) → rangeSingletonValue (singletonRange x) ≡ Just x
prop_singletonRangeConverse ⦃ o ⦄ ⦃ dio ⦄ v =
   begin
      rangeSingletonValue (singletonRange v)
     =⟨⟩
      rangeSingletonValue (Rg (BoundaryBelow v) (BoundaryAbove v))
     =⟨⟩
      if_then_else_ (v == v) (Just v) Nothing
     =⟨ propIf2 (v == v) (eq0 ⦃ o ⦄ refl) ⟩
      Just v
   end

prop_emptyNonSingleton : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → rangeSingletonValue ⦃ o ⦄ ⦃ dio ⦄ emptyRange ≡ Nothing
prop_emptyNonSingleton = refl

prop_fullNonSingleton : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → rangeSingletonValue ⦃ o ⦄ ⦃ dio ⦄ fullRange ≡ Nothing
prop_fullNonSingleton = refl

rs : Double → Double → List (Range Double)
rs x y = (Rg (BoundaryBelow x) (BoundaryBelow y)) ∷ (Rg (BoundaryAbove x) (BoundaryBelow y)) ∷ (Rg (BoundaryBelow x) (BoundaryAbove y)) ∷ (Rg (BoundaryAbove x) (BoundaryAbove y)) ∷ []

length' : List a → Nat
length' [] = 0
length' (x ∷ []) = 1
length' (x ∷ xs) = 1 + (length' xs)

prop_unionRangeLengthHelper3 : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
                 → (r1 r2 : (Range a)) → (b : Bool)
                 → ((eqq ((length' (if_then_else_ b ((Rg (min (rangeLower r1) (rangeLower r2)) (max (rangeUpper r1) (rangeUpper r2))) ∷ []) (r1 ∷ r2 ∷ [])))) 1)
                 || (eqq (length' ((if_then_else_ b ((Rg (min (rangeLower r1) (rangeLower r2)) (max (rangeUpper r1) (rangeUpper r2))) ∷ []) (r1 ∷ r2 ∷ [])))) 2)) ≡ true
prop_unionRangeLengthHelper3 ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) true =
  begin
    ((eqq (length' ((Rg (min l1 l2) (max u1 u2)) ∷ [])) 1) || (eqq (length' ((Rg (min l1 l2) (max u1 u2)) ∷ [])) 2))
   =⟨⟩
    ((eqq 1 1) || (eqq 1 2))
   =⟨⟩
     (true || false)
   =⟨⟩
     true
   end
prop_unionRangeLengthHelper3 ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) false =
  begin
    ((eqq (length' (r1 ∷ r2 ∷ [])) 1) || (eqq (length' (r1 ∷ r2 ∷ [])) 2))
   =⟨⟩
    ((eqq 2 1) || (eqq 2 2))
   =⟨⟩
     (false || true)
   =⟨⟩
     true
   end

prop_unionRangeLengthHelper2 : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
                 → (r1 r2 : (Range a)) → (b : Bool)
                 → ((eqq (length' (if_then_else_ b (r1 ∷ []) (rangeU2 r1 r2))) 1) || (eqq (length' ((if_then_else_ b (r1 ∷ []) (rangeU2 r1 r2)))) 2)) ≡ true
prop_unionRangeLengthHelper2 ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) true =
    begin
     ((eqq (length' (r1 ∷ [])) 1) || (eqq (length' (r1 ∷ [])) 2))
   =⟨⟩
    ((eqq 1 1) || (eqq 1 2))
   =⟨⟩
     (true || false)
   =⟨⟩
     true
   end
prop_unionRangeLengthHelper2 ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) false =
    begin
     ((eqq (length' (rangeU2 r1 r2)) 1) || (eqq (length' (rangeU2 r1 r2)) 2))
   =⟨⟩
     ((eqq (length' (if_then_else_ ((max l1 l2) <= (min u1 u2)) ((Rg (min l1 l2) (max u1 u2)) ∷ []) (r1 ∷ r2 ∷ []))) 1)
     || (eqq (length' (if_then_else_ ((max l1 l2) <= (min u1 u2)) ((Rg (min l1 l2) (max u1 u2)) ∷ []) (r1 ∷ r2 ∷ []))) 2))
   =⟨ prop_unionRangeLengthHelper3 r1 r2 (((max l1 l2) <= (min u1 u2))) ⟩
     true
   end

prop_unionRangeLengthHelper : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
                 → (r1 r2 : (Range a)) → (b : Bool)
                 → ((eqq (length' (if_then_else_ b (r2 ∷ []) (rangeU1 r1 r2))) 1) || (eqq (length' ((if_then_else_ b (r2 ∷ []) (rangeU1 r1 r2)))) 2)) ≡ true
prop_unionRangeLengthHelper ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) true =
    begin
     ((eqq (length' (r2 ∷ [])) 1) || (eqq (length' (r2 ∷ [])) 2))
   =⟨⟩
    ((eqq 1 1) || (eqq 1 2))
   =⟨⟩
     (true || false)
   =⟨⟩
     true
   end
prop_unionRangeLengthHelper ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) false =
    begin
     ((eqq (length' (rangeU1 r1 r2)) 1) || (eqq (length' (rangeU1 r1 r2)) 2))
   =⟨⟩
     ((eqq (length' (if_then_else_ (rangeIsEmpty r2) (r1 ∷ []) (rangeU2 r1 r2))) 1)
     || (eqq (length' (if_then_else_ (rangeIsEmpty r2) (r1 ∷ []) (rangeU2 r1 r2))) 2))
   =⟨ prop_unionRangeLengthHelper2 r1 r2 (rangeIsEmpty r2) ⟩
     true
   end

prop_unionRangeLength : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
                 → (r1 r2 : (Range a)) → ((eqq (length' (rangeUnion r1 r2)) 1) || (eqq (length' (rangeUnion r1 r2)) 2)) ≡ true
prop_unionRangeLength ⦃ o ⦄ ⦃ dio ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) =
   begin
     ((eqq (length' (rangeUnion r1 r2)) 1) || (eqq (length' (rangeUnion r1 r2)) 2))
   =⟨⟩
     ((eqq (length' (if_then_else_ (rangeIsEmpty r1) (r2 ∷ []) (rangeU1 r1 r2))) 1) || (eqq (length' (if_then_else_ (rangeIsEmpty r1) (r2 ∷ []) (rangeU1 r1 r2))) 2))
   =⟨ prop_unionRangeLengthHelper r1 r2 (rangeIsEmpty r1) ⟩
     true
   end

prop_UnionRange1 : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
                 → (r1 r2 : (Range a)) → ⦃ ne1 : IsFalse (rangeIsEmpty r1) ⦄ → ⦃ ne2 : IsFalse (rangeIsEmpty r2) ⦄
                 → ⦃ ne3 : IsFalse ((max (rangeLower r1) (rangeLower r2)) <= (min (rangeUpper r1) (rangeUpper r2))) ⦄ → (n : a)
                 → (rangeListHas1 n (rangeUnion ⦃ ord ⦄ ⦃ diso ⦄ r1 r2)) ≡ ((rangeHas ⦃ ord ⦄ r1 n) || (rangeHas ⦃ ord ⦄ r2 n))
prop_UnionRange1 ⦃ ord ⦄ ⦃ diso ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) ⦃ ne1 ⦄ ⦃ ne2 ⦄ ⦃ ne3 ⦄ n =
   begin
     (rangeListHas1 n (rangeUnion r1 r2))
   =⟨⟩
     (rangeListHas1 n (if_then_else_ (rangeIsEmpty r1) (r2 ∷ []) (rangeU1 r1 r2)))
   =⟨ propIf (rangeListHas1 n) (rangeIsEmpty r1) ⟩
     if_then_else_ (rangeIsEmpty r1) (rangeListHas1 n (r2 ∷ [])) (rangeListHas1 n (rangeU1 r1 r2))
   =⟨ propIf3 (rangeIsEmpty r1) ne1 ⟩
     rangeListHas1 n (rangeU1 r1 r2)
   =⟨ cong (rangeListHas1 n) (propIf3 (rangeIsEmpty r2) ne2) ⟩
     (rangeListHas1 n (rangeU2 r1 r2))
   =⟨ cong (rangeListHas1 n) (propIf3 ((max l1 l2) <= (min u1 u2)) ne3) ⟩
     (rangeListHas1 n (r1 ∷ r2 ∷ []))
   =⟨⟩
     ((rangeHas r1 n) || (rangeHas r2 n))
   end

-- prop_UnionRange1' : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄
--                  → (r1 r2 : (Range a)) → ⦃ne1 : IsFalse (rangeIsEmpty r1)⦄ → ⦃ne2 : IsFalse (rangeIsEmpty r2)⦄
--                  → ⦃ne3 : IsTrue ((max (rangeLower r1) (rangeLower r2)) <= (min (rangeUpper r1) (rangeUpper r2)))⦄ → (n : a)
--                  → (rangeListHas1 n (rangeUnion ⦃ord⦄ ⦃diso⦄ r1 r2)) ≡ ((rangeHas ⦃ord⦄ r1 n) || (rangeHas ⦃ord⦄ r2 n))
-- prop_UnionRange1' ⦃ord⦄ ⦃diso⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) ⦃ne1⦄ ⦃ne2⦄ ⦃ne3⦄ n =
--    begin
--      (rangeListHas1 n (rangeUnion r1 r2))
--    =⟨⟩
--      (rangeListHas1 n (if_then_else_ (rangeIsEmpty r1) (r2 ∷ []) (rangeU1 r1 r2)))
--    =⟨ propIf (rangeListHas1 n) (rangeIsEmpty r1) ⟩
--      if_then_else_ (rangeIsEmpty r1) (rangeListHas1 n (r2 ∷ [])) (rangeListHas1 n (rangeU1 r1 r2))
--    =⟨ propIf3 (rangeIsEmpty r1) ne1 ⟩
--      rangeListHas1 n (rangeU1 r1 r2)
--    =⟨ cong (rangeListHas1 n) (propIf3 (rangeIsEmpty r2) ne2) ⟩
--      (rangeListHas1 n (rangeU2 r1 r2))
--    =⟨ cong (rangeListHas1 n) (propIf2 ((max l1 l2) <= (min u1 u2)) ne3) ⟩
--      (rangeListHas1 n ((Rg (min l1 l2) (max u1 u2)) ∷ []))
--    =⟨⟩
--     ((n />/ (min l1 l2)) && not (n />/ (max u1 u2)))
--    =⟨⟩
--     ((n />/ (if (compare l1 l2 == LT) then l1 else l2)) && not (n />/ (if (compare u1 u2 == GT) then u1 else u2)))
--    =⟨⟩
--      ((rangeHas r1 n) || (rangeHas r2 n))
--    end

prop_emptyRange : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (r : Range a) → not (rangeIsEmpty r) ≡ (rangeLower r <= rangeUpper r)
prop_emptyRange ⦃ o ⦄ ⦃ dio ⦄ r@(Rg l u) =
  begin
    not (rangeIsEmpty r)
  =⟨⟩
    not (u <= l)
  =⟨ eq2 u l ⟩
    l < u
  =⟨ lteq l u ⟩
    l <= u
  end

prop_rangeHas : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄ → {r : (Range a)} → {n : a}
                        → (rangeHas1 ⦃ ord ⦄ n r) ≡ (rangeHas ⦃ ord ⦄ r n)
prop_rangeHas {r = (Rg x y)} {n} =
   begin
     rangeHas1 n (Rg x y)
   =⟨⟩
     (n />/ x) && (not (n />/ y))
   =⟨⟩
     rangeHas (Rg x y) n
   end

prop_IntersectionRange : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄ → (r1 r2 : (Range a))
                        → ⦃ ff : IsFalse (rangeIsEmpty r1 || rangeIsEmpty r2) ⦄  → (n : a)
                        → ((rangeHas r1 n) && (rangeHas r2 n)) ≡ (rangeHas (rangeIntersection r1 r2) n)

prop_IntersectionRange ⦃ ord ⦄ ⦃ diso ⦄ r1@(Rg x1 y1) r2@(Rg x2 y2) ⦃ ff ⦄ n =
   begin
     ((rangeHas r1 n) && (rangeHas r2 n))
   =⟨⟩
     ((n />/ x1) && (not (n />/ y1))) && ((n />/ x2) && (not (n />/ y2)))
   =⟨ prop_and_assoc (n />/ x1) (not (n />/ y1)) (n />/ x2 && (not (n />/ y2))) ⟩
     ((n />/ x1) && ((not (n />/ y1)) && ((n />/ x2) && (not (n />/ y2)))))
   =⟨ cong ((n />/ x1) &&_) (sym (prop_and_assoc (not (n />/ y1)) (n />/ x2) (not (n />/ y2)))) ⟩
     ((n />/ x1) && (not (n />/ y1) && (n />/ x2)) && (not (n />/ y2)))
   =⟨ sym (prop_and_assoc (n />/ x1) (not (n />/ y1) && (n />/ x2)) (not (n />/ y2))) ⟩
     (((n />/ x1) && (not (n />/ y1) && (n />/ x2))) && (not (n />/ y2)))
   =⟨ cong (_&& (not (n />/ y2))) (cong ((n />/ x1) &&_) (prop_and_comm (not (n />/ y1)) (n />/ x2))) ⟩
     (((n />/ x1) && ((n />/ x2) && not (n />/ y1))) && (not (n />/ y2)))
   =⟨ cong (_&& (not (n />/ y2))) (sym (prop_and_assoc (n />/ x1) (n />/ x2) (not (n />/ y1)))) ⟩
     ((((n />/ x1) && (n />/ x2)) && not (n />/ y1)) && (not (n />/ y2)))
   =⟨ prop_and_assoc ((n />/ x1) && (n />/ x2)) (not (n />/ y1)) (not (n />/ y2)) ⟩
     (((n />/ x1) && (n />/ x2)) && (not (n />/ y1) && (not (n />/ y2))))
   =⟨ cong ((n />/ x1 && n />/ x2) &&_) (prop_demorgan2 (n />/ y1) (n />/ y2)) ⟩
     (n />/ x1 && n />/ x2) && (not ((n />/ y1) || (n />/ y2)))
   =⟨ cong (_&& (not ((n />/ y1) || (n />/ y2)))) (boundaries0 n x1 x2) ⟩
     (n />/ (max x1 x2)) && (not ((n />/ y1) || (n />/ y2)))
   =⟨ cong ((n />/ (max x1 x2)) &&_) (cong not (boundaries1 n y1 y2)) ⟩
     (n />/ (max x1 x2)) && not (n />/ (min y1 y2))
   =⟨⟩
     rangeHas (Rg (max (rangeLower r1) (rangeLower r2)) (min (rangeUpper r1) (rangeUpper r2))) n
   =⟨ sym (cong (rangeHas1 n) (propIf3 (rangeIsEmpty r1 || rangeIsEmpty r2) ff)) ⟩
     rangeHas1 n (rangeIntersection r1 r2)
   =⟨ prop_rangeHas ⦃ ord ⦄ ⦃ diso ⦄ {(rangeIntersection r1 r2)} ⟩
     rangeHas (rangeIntersection r1 r2) n
   end

prop_notEmptyRanges : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄ → (r1 r2 : (Range a))
                    → (not ((rangeIsEmpty r1) || (rangeIsEmpty r2))) ≡ (((rangeLower r1) < (rangeUpper r1)) && ((rangeLower r2) < (rangeUpper r2)))
prop_notEmptyRanges ⦃ ord ⦄ ⦃ diso ⦄ r1@(Rg l1 u1) r2@(Rg l2 u2) =
   begin
      not ((rangeIsEmpty r1 )|| (rangeIsEmpty r2))
   =⟨⟩
      (not (((rangeUpper r1) <= (rangeLower r1)) || ((rangeUpper r2) <= (rangeLower r2))))
   =⟨ sym (prop_demorgan2 ((rangeUpper r1) <= (rangeLower r1)) ((rangeUpper r2) <= (rangeLower r2))) ⟩
      ((not ((rangeUpper r1) <= (rangeLower r1)))) && (not ((rangeUpper r2) <= (rangeLower r2)))
   =⟨ cong (not ((rangeUpper r1) <= (rangeLower r1)) &&_) (eq2 (rangeUpper r2) (rangeLower r2)) ⟩
      ((not ((rangeUpper r1) <= (rangeLower r1))) && ((rangeLower r2) < (rangeUpper r2)))
   =⟨ cong (_&& ((rangeLower r2) < (rangeUpper r2))) (eq2 (rangeUpper r1) (rangeLower r1)) ⟩
      (((rangeLower r1) < (rangeUpper r1)) && ((rangeLower r2) < (rangeUpper r2)))
    end

prop_intersectionOverlap : ⦃ ord : Ord a ⦄ → ⦃ diso : DiscreteOrdered a ⦄ → (r1 r2 : (Range a))
                            → ⦃ ff : IsFalse (rangeIsEmpty r1 || rangeIsEmpty r2) ⦄
                            → ⦃ tr : IsTrue (((rangeLower r1) < (rangeUpper r1)) && ((rangeLower r2) < (rangeUpper r2))) ⦄
                            → (rangeIsEmpty (rangeIntersection r1 r2)) ≡ not (rangeOverlap r1 r2)
prop_intersectionOverlap ⦃ ord ⦄ ⦃ diso ⦄ r1@(Rg _ _) r2@(Rg _ _) ⦃ ff ⦄ ⦃ tr ⦄ =
   begin
     (rangeIsEmpty (rangeIntersection r1 r2))
   =⟨⟩
     rangeIsEmpty (if_then_else_ (rangeIsEmpty r1 || rangeIsEmpty r2) emptyRange (Rg (max (rangeLower r1) (rangeLower r2)) (min (rangeUpper r1) (rangeUpper r2))))
   =⟨ cong rangeIsEmpty (propIf3 (rangeIsEmpty r1 || rangeIsEmpty r2) ff) ⟩
     (rangeIsEmpty (Rg (max (rangeLower r1) (rangeLower r2)) (min (rangeUpper r1) (rangeUpper r2))))
   =⟨⟩
     ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2)))
   =⟨ sym (prop_or_false ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2)))) ⟩
     (false ||  ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2))))
   =⟨ cong (_|| ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2)))) (sym (propIsFalse (rangeIsEmpty r1 || rangeIsEmpty r2) ff)) ⟩
     (((rangeIsEmpty r1) || (rangeIsEmpty r2)) || ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2))))
   =⟨ prop_or_assoc (rangeIsEmpty r1) (rangeIsEmpty r2) ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2))) ⟩
     ((rangeIsEmpty r1) || ((rangeIsEmpty r2) || ((min (rangeUpper r1) (rangeUpper r2)) <= (max (rangeLower r1) (rangeLower r2)))))
   =⟨ cong ((rangeIsEmpty r1) ||_) (cong ((rangeIsEmpty r2) ||_) (eq3 (rangeUpper r1) (rangeUpper r2) (rangeLower r1) (rangeLower r2) ⦃ tr ⦄)) ⟩
     ((rangeIsEmpty r1) || ((rangeIsEmpty r2) || (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1)))
   =⟨ not-not ((rangeIsEmpty r1) || (rangeIsEmpty r2) || (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1)) ⟩
     not (not ((rangeIsEmpty r1) || (rangeIsEmpty r2) || (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1)))
   =⟨ cong (not) (demorgan3 (rangeIsEmpty r1) (rangeIsEmpty r2) (rangeUpper r1 <= rangeLower r2) (rangeUpper r2 <= rangeLower r1)) ⟩
     not (not (rangeIsEmpty r1) && not (rangeIsEmpty r2) && ((not (rangeUpper r1 <= rangeLower r2)) && (not (rangeUpper r2 <= rangeLower r1))))
   =⟨ cong not (cong ((not (rangeIsEmpty r1)) &&_) (cong ((not (rangeIsEmpty r2)) &&_) (prop_demorgan2 (rangeUpper r1 <= rangeLower r2) (rangeUpper r2 <= rangeLower r1)))) ⟩
     not (not (rangeIsEmpty r1) && not (rangeIsEmpty r2) && not ((rangeUpper r1 <= rangeLower r2) || (rangeUpper r2 <= rangeLower r1)))
   =⟨⟩
     not (rangeOverlap r1 r2)
   end


------------------------------------------------------------------------------
-- Testing the FOL schemata
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOL.SchemataATP where

open import FOL.Base

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

postulate id₁ : {A₁ : D → Set} → ∀ {x} → A₁ x → A₁ x
{-# ATP prove id₁ #-}

id₂ : {A₁ : D → Set} → ∀ {x} → A₁ x → A₁ x
id₂ {A} {x} = prf
  where
    postulate prf : A x → A x
    {-# ATP prove prf #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Algebra

module Algebra.Properties.BooleanAlgebra
  {b₁ b₂} (B : BooleanAlgebra b₁ b₂)
  where

open BooleanAlgebra B
import Algebra.Properties.DistributiveLattice
private
  open module DL = Algebra.Properties.DistributiveLattice
                     distributiveLattice public
    hiding (replace-equality)
open import Algebra.Structures _≈_
open import Algebra.FunctionProperties _≈_
open import Algebra.FunctionProperties.Consequences setoid
open import Relation.Binary.Reasoning.Setoid setoid
open import Relation.Binary
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (_⇔_; module Equivalence)
open import Data.Product using (_,_)

------------------------------------------------------------------------
-- Some simple generalisations

∨-complementˡ : LeftInverse ⊤ ¬_ _∨_
∨-complementˡ = comm+invʳ⇒invˡ ∨-comm ∨-complementʳ

∨-complement : Inverse ⊤ ¬_ _∨_
∨-complement = ∨-complementˡ , ∨-complementʳ

∧-complementˡ : LeftInverse ⊥ ¬_ _∧_
∧-complementˡ = comm+invʳ⇒invˡ ∧-comm ∧-complementʳ

∧-complement : Inverse ⊥ ¬_ _∧_
∧-complement = ∧-complementˡ , ∧-complementʳ

------------------------------------------------------------------------
-- The dual construction is also a boolean algebra

∧-∨-isBooleanAlgebra : IsBooleanAlgebra _∧_ _∨_ ¬_ ⊥ ⊤
∧-∨-isBooleanAlgebra = record
  { isDistributiveLattice = ∧-∨-isDistributiveLattice
  ; ∨-complementʳ         = ∧-complementʳ
  ; ∧-complementʳ         = ∨-complementʳ
  ; ¬-cong                = ¬-cong
  }

∧-∨-booleanAlgebra : BooleanAlgebra _ _
∧-∨-booleanAlgebra = record
  { _∧_              = _∨_
  ; _∨_              = _∧_
  ; ⊤                = ⊥
  ; ⊥                = ⊤
  ; isBooleanAlgebra = ∧-∨-isBooleanAlgebra
  }

------------------------------------------------------------------------
-- (∨, ∧, ⊥, ⊤) and (∧, ∨, ⊤, ⊥) are commutative semirings

∧-identityʳ : RightIdentity ⊤ _∧_
∧-identityʳ x = begin
  x ∧ ⊤          ≈⟨ ∧-congˡ (sym (∨-complementʳ _)) ⟩
  x ∧ (x ∨ ¬ x)  ≈⟨ ∧-absorbs-∨ _ _ ⟩
  x              ∎

∧-identityˡ : LeftIdentity ⊤ _∧_
∧-identityˡ = comm+idʳ⇒idˡ ∧-comm ∧-identityʳ

∧-identity : Identity ⊤ _∧_
∧-identity = ∧-identityˡ , ∧-identityʳ

∨-identityʳ : RightIdentity ⊥ _∨_
∨-identityʳ x = begin
  x ∨ ⊥          ≈⟨ ∨-congˡ $ sym (∧-complementʳ _) ⟩
  x ∨ x ∧ ¬ x    ≈⟨ ∨-absorbs-∧ _ _ ⟩
  x              ∎

∨-identityˡ : LeftIdentity ⊥ _∨_
∨-identityˡ = comm+idʳ⇒idˡ ∨-comm ∨-identityʳ

∨-identity : Identity ⊥ _∨_
∨-identity = ∨-identityˡ , ∨-identityʳ

∧-zeroʳ : RightZero ⊥ _∧_
∧-zeroʳ x = begin
  x ∧ ⊥          ≈⟨ ∧-congˡ $ sym (∧-complementʳ _) ⟩
  x ∧  x  ∧ ¬ x  ≈˘⟨ ∧-assoc _ _ _ ⟩
  (x ∧ x) ∧ ¬ x  ≈⟨ ∧-congʳ $ ∧-idempotent _ ⟩
  x       ∧ ¬ x  ≈⟨ ∧-complementʳ _ ⟩
  ⊥              ∎

∧-zeroˡ : LeftZero ⊥ _∧_
∧-zeroˡ = comm+zeʳ⇒zeˡ ∧-comm ∧-zeroʳ

∧-zero : Zero ⊥ _∧_
∧-zero = ∧-zeroˡ , ∧-zeroʳ

∨-zeroʳ : ∀ x → x ∨ ⊤ ≈ ⊤
∨-zeroʳ x = begin
  x ∨ ⊤          ≈⟨ ∨-congˡ $ sym (∨-complementʳ _) ⟩
  x ∨  x  ∨ ¬ x  ≈˘⟨ ∨-assoc _ _ _ ⟩
  (x ∨ x) ∨ ¬ x  ≈⟨ ∨-congʳ $ ∨-idempotent _ ⟩
  x       ∨ ¬ x  ≈⟨ ∨-complementʳ _ ⟩
  ⊤              ∎

∨-zeroˡ : LeftZero ⊤ _∨_
∨-zeroˡ _ = ∨-comm _ _ ⟨ trans ⟩ ∨-zeroʳ _

∨-zero : Zero ⊤ _∨_
∨-zero = ∨-zeroˡ , ∨-zeroʳ

∨-isMagma : IsMagma _∨_
∨-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = ∨-cong
  }

∧-isMagma : IsMagma _∧_
∧-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = ∧-cong
  }

∨-isSemigroup : IsSemigroup _∨_
∨-isSemigroup = record
  { isMagma = ∨-isMagma
  ; assoc   = ∨-assoc
  }

∧-isSemigroup : IsSemigroup _∧_
∧-isSemigroup = record
  { isMagma = ∧-isMagma
  ; assoc   = ∧-assoc
  }

∨-⊥-isMonoid : IsMonoid _∨_ ⊥
∨-⊥-isMonoid = record
  { isSemigroup = ∨-isSemigroup
  ; identity    = ∨-identity
  }

∧-⊤-isMonoid : IsMonoid _∧_ ⊤
∧-⊤-isMonoid = record
  { isSemigroup = ∧-isSemigroup
  ; identity    = ∧-identity
  }

∨-⊥-isCommutativeMonoid : IsCommutativeMonoid _∨_ ⊥
∨-⊥-isCommutativeMonoid = record
  { isSemigroup = ∨-isSemigroup
  ; identityˡ   = ∨-identityˡ
  ; comm        = ∨-comm
  }

∧-⊤-isCommutativeMonoid : IsCommutativeMonoid _∧_ ⊤
∧-⊤-isCommutativeMonoid = record
  { isSemigroup = ∧-isSemigroup
  ; identityˡ   = ∧-identityˡ
  ; comm        = ∧-comm
  }

∨-∧-isCommutativeSemiring : IsCommutativeSemiring _∨_ _∧_ ⊥ ⊤
∨-∧-isCommutativeSemiring = record
  { +-isCommutativeMonoid = ∨-⊥-isCommutativeMonoid
  ; *-isCommutativeMonoid = ∧-⊤-isCommutativeMonoid
  ; distribʳ              = ∧-∨-distribʳ
  ; zeroˡ                 = ∧-zeroˡ
  }

∨-∧-commutativeSemiring : CommutativeSemiring _ _
∨-∧-commutativeSemiring = record
  { _+_                   = _∨_
  ; _*_                   = _∧_
  ; 0#                    = ⊥
  ; 1#                    = ⊤
  ; isCommutativeSemiring = ∨-∧-isCommutativeSemiring
  }

∧-∨-isCommutativeSemiring : IsCommutativeSemiring _∧_ _∨_ ⊤ ⊥
∧-∨-isCommutativeSemiring = record
  { +-isCommutativeMonoid = ∧-⊤-isCommutativeMonoid
  ; *-isCommutativeMonoid = ∨-⊥-isCommutativeMonoid
  ; distribʳ = ∨-∧-distribʳ
  ; zeroˡ    = ∨-zeroˡ
  }

∧-∨-commutativeSemiring : CommutativeSemiring _ _
∧-∨-commutativeSemiring = record
  { _+_                   = _∧_
  ; _*_                   = _∨_
  ; 0#                    = ⊤
  ; 1#                    = ⊥
  ; isCommutativeSemiring = ∧-∨-isCommutativeSemiring
  }

------------------------------------------------------------------------
-- Some other properties

-- I took the statement of this lemma (called Uniqueness of
-- Complements) from some course notes, "Boolean Algebra", written
-- by Gert Smolka.

private
  lemma : ∀ x y → x ∧ y ≈ ⊥ → x ∨ y ≈ ⊤ → ¬ x ≈ y
  lemma x y x∧y=⊥ x∨y=⊤ = begin
    ¬ x                ≈˘⟨ ∧-identityʳ _ ⟩
    ¬ x ∧ ⊤            ≈˘⟨ ∧-congˡ x∨y=⊤ ⟩
    ¬ x ∧ (x ∨ y)      ≈⟨ ∧-∨-distribˡ _ _ _ ⟩
    ¬ x ∧ x ∨ ¬ x ∧ y  ≈⟨ ∨-congʳ $ ∧-complementˡ _ ⟩
    ⊥ ∨ ¬ x ∧ y        ≈˘⟨ ∨-congʳ x∧y=⊥ ⟩
    x ∧ y ∨ ¬ x ∧ y    ≈˘⟨ ∧-∨-distribʳ _ _ _ ⟩
    (x ∨ ¬ x) ∧ y      ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩
    ⊤ ∧ y              ≈⟨ ∧-identityˡ _ ⟩
    y                  ∎

¬⊥=⊤ : ¬ ⊥ ≈ ⊤
¬⊥=⊤ = lemma ⊥ ⊤ (∧-identityʳ _) (∨-zeroʳ _)

¬⊤=⊥ : ¬ ⊤ ≈ ⊥
¬⊤=⊥ = lemma ⊤ ⊥ (∧-zeroʳ _) (∨-identityʳ _)

¬-involutive : Involutive ¬_
¬-involutive x = lemma (¬ x) x (∧-complementˡ _) (∨-complementˡ _)

deMorgan₁ : ∀ x y → ¬ (x ∧ y) ≈ ¬ x ∨ ¬ y
deMorgan₁ x y = lemma (x ∧ y) (¬ x ∨ ¬ y) lem₁ lem₂
  where
  lem₁ = begin
    (x ∧ y) ∧ (¬ x ∨ ¬ y)          ≈⟨ ∧-∨-distribˡ _ _ _ ⟩
    (x ∧ y) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y  ≈⟨ ∨-congʳ $ ∧-congʳ $ ∧-comm _ _ ⟩
    (y ∧ x) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y  ≈⟨ ∧-assoc _ _ _ ⟨ ∨-cong ⟩ ∧-assoc _ _ _ ⟩
    y ∧ (x ∧ ¬ x) ∨ x ∧ (y ∧ ¬ y)  ≈⟨ (∧-congˡ $ ∧-complementʳ _) ⟨ ∨-cong ⟩
                                      (∧-congˡ $ ∧-complementʳ _) ⟩
    (y ∧ ⊥) ∨ (x ∧ ⊥)              ≈⟨ ∧-zeroʳ _ ⟨ ∨-cong ⟩ ∧-zeroʳ _ ⟩
    ⊥ ∨ ⊥                          ≈⟨ ∨-identityʳ _ ⟩
    ⊥                              ∎

  lem₃ = begin
    (x ∧ y) ∨ ¬ x          ≈⟨ ∨-∧-distribʳ _ _ _ ⟩
    (x ∨ ¬ x) ∧ (y ∨ ¬ x)  ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩
    ⊤ ∧ (y ∨ ¬ x)          ≈⟨ ∧-identityˡ _ ⟩
    y ∨ ¬ x                ≈⟨ ∨-comm _ _ ⟩
    ¬ x ∨ y                ∎

  lem₂ = begin
    (x ∧ y) ∨ (¬ x ∨ ¬ y)  ≈˘⟨ ∨-assoc _ _ _ ⟩
    ((x ∧ y) ∨ ¬ x) ∨ ¬ y  ≈⟨ ∨-congʳ lem₃ ⟩
    (¬ x ∨ y) ∨ ¬ y        ≈⟨ ∨-assoc _ _ _ ⟩
    ¬ x ∨ (y ∨ ¬ y)        ≈⟨ ∨-congˡ $ ∨-complementʳ _ ⟩
    ¬ x ∨ ⊤                ≈⟨ ∨-zeroʳ _ ⟩
    ⊤                      ∎

deMorgan₂ : ∀ x y → ¬ (x ∨ y) ≈ ¬ x ∧ ¬ y
deMorgan₂ x y = begin
  ¬ (x ∨ y)          ≈˘⟨ ¬-cong $ ((¬-involutive _) ⟨ ∨-cong ⟩ (¬-involutive _)) ⟩
  ¬ (¬ ¬ x ∨ ¬ ¬ y)  ≈˘⟨ ¬-cong $ deMorgan₁ _ _ ⟩
  ¬ ¬ (¬ x ∧ ¬ y)    ≈⟨ ¬-involutive _ ⟩
  ¬ x ∧ ¬ y          ∎

-- One can replace the underlying equality with an equivalent one.

replace-equality :
  {_≈′_ : Rel Carrier b₂} →
  (∀ {x y} → x ≈ y ⇔ (x ≈′ y)) → BooleanAlgebra _ _
replace-equality {_≈′_} ≈⇔≈′ = record
  { _≈_              = _≈′_
  ; _∨_              = _∨_
  ; _∧_              = _∧_
  ; ¬_               = ¬_
  ; ⊤                = ⊤
  ; ⊥                = ⊥
  ; isBooleanAlgebra =  record
    { isDistributiveLattice = DistributiveLattice.isDistributiveLattice
                                (DL.replace-equality ≈⇔≈′)
    ; ∨-complementʳ         = λ x → to ⟨$⟩ ∨-complementʳ x
    ; ∧-complementʳ         = λ x → to ⟨$⟩ ∧-complementʳ x
    ; ¬-cong                = λ i≈j → to ⟨$⟩ ¬-cong (from ⟨$⟩ i≈j)
    }
  } where open module E {x y} = Equivalence (≈⇔≈′ {x} {y})

------------------------------------------------------------------------
-- (⊕, ∧, id, ⊥, ⊤) is a commutative ring

-- This construction is parameterised over the definition of xor.

module XorRing
  (xor : Op₂ Carrier)
  (⊕-def : ∀ x y → xor x y ≈ (x ∨ y) ∧ ¬ (x ∧ y))
  where

  private
    infixl 6 _⊕_

    _⊕_ : Op₂ Carrier
    _⊕_ = xor

    helper : ∀ {x y u v} → x ≈ y → u ≈ v → x ∧ ¬ u ≈ y ∧ ¬ v
    helper x≈y u≈v = x≈y ⟨ ∧-cong ⟩ ¬-cong u≈v

  ⊕-cong : Congruent₂ _⊕_
  ⊕-cong {x} {y} {u} {v} x≈y u≈v = begin
    x ⊕ u                ≈⟨ ⊕-def _ _ ⟩
    (x ∨ u) ∧ ¬ (x ∧ u)  ≈⟨ helper (x≈y ⟨ ∨-cong ⟩ u≈v)
                                   (x≈y ⟨ ∧-cong ⟩ u≈v) ⟩
    (y ∨ v) ∧ ¬ (y ∧ v)  ≈˘⟨ ⊕-def _ _ ⟩
    y ⊕ v                ∎

  ⊕-comm : Commutative _⊕_
  ⊕-comm x y = begin
    x ⊕ y                ≈⟨ ⊕-def _ _ ⟩
    (x ∨ y) ∧ ¬ (x ∧ y)  ≈⟨ helper (∨-comm _ _) (∧-comm _ _) ⟩
    (y ∨ x) ∧ ¬ (y ∧ x)  ≈˘⟨ ⊕-def _ _ ⟩
    y ⊕ x                ∎

  ⊕-¬-distribˡ : ∀ x y → ¬ (x ⊕ y) ≈ ¬ x ⊕ y
  ⊕-¬-distribˡ x y = begin
    ¬ (x ⊕ y)                              ≈⟨ ¬-cong $ ⊕-def _ _ ⟩
    ¬ ((x ∨ y) ∧ (¬ (x ∧ y)))              ≈⟨ ¬-cong (∧-∨-distribʳ _ _ _) ⟩
    ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (x ∧ y)))  ≈⟨ ¬-cong $ ∨-congˡ $ ∧-congˡ $ ¬-cong (∧-comm _ _) ⟩
    ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (y ∧ x)))  ≈⟨ ¬-cong $ lem _ _ ⟨ ∨-cong ⟩ lem _ _ ⟩
    ¬ ((x ∧ ¬ y) ∨ (y ∧ ¬ x))              ≈⟨ deMorgan₂ _ _ ⟩
    ¬ (x ∧ ¬ y) ∧ ¬ (y ∧ ¬ x)              ≈⟨ ∧-congʳ $ deMorgan₁ _ _ ⟩
    (¬ x ∨ (¬ ¬ y)) ∧ ¬ (y ∧ ¬ x)          ≈⟨ helper (∨-congˡ $ ¬-involutive _) (∧-comm _ _) ⟩
    (¬ x ∨ y) ∧ ¬ (¬ x ∧ y)                ≈˘⟨ ⊕-def _ _ ⟩
    ¬ x ⊕ y                                ∎
    where
    lem : ∀ x y → x ∧ ¬ (x ∧ y) ≈ x ∧ ¬ y
    lem x y = begin
      x ∧ ¬ (x ∧ y)          ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩
      x ∧ (¬ x ∨ ¬ y)        ≈⟨ ∧-∨-distribˡ _ _ _ ⟩
      (x ∧ ¬ x) ∨ (x ∧ ¬ y)  ≈⟨ ∨-congʳ $ ∧-complementʳ _ ⟩
      ⊥ ∨ (x ∧ ¬ y)          ≈⟨ ∨-identityˡ _ ⟩
      x ∧ ¬ y                ∎

  ⊕-¬-distribʳ : ∀ x y → ¬ (x ⊕ y) ≈ x ⊕ ¬ y
  ⊕-¬-distribʳ x y = begin
    ¬ (x ⊕ y)  ≈⟨ ¬-cong $ ⊕-comm _ _ ⟩
    ¬ (y ⊕ x)  ≈⟨ ⊕-¬-distribˡ _ _ ⟩
    ¬ y ⊕ x    ≈⟨ ⊕-comm _ _ ⟩
    x ⊕ ¬ y    ∎

  ⊕-annihilates-¬ : ∀ x y → x ⊕ y ≈ ¬ x ⊕ ¬ y
  ⊕-annihilates-¬ x y = begin
    x ⊕ y        ≈˘⟨ ¬-involutive _ ⟩
    ¬ ¬ (x ⊕ y)  ≈⟨ ¬-cong $ ⊕-¬-distribˡ _ _ ⟩
    ¬ (¬ x ⊕ y)  ≈⟨ ⊕-¬-distribʳ _ _ ⟩
    ¬ x ⊕ ¬ y    ∎

  ⊕-identityˡ : LeftIdentity ⊥ _⊕_
  ⊕-identityˡ x = begin
    ⊥ ⊕ x                ≈⟨ ⊕-def _ _ ⟩
    (⊥ ∨ x) ∧ ¬ (⊥ ∧ x)  ≈⟨ helper (∨-identityˡ _) (∧-zeroˡ _) ⟩
    x ∧ ¬ ⊥              ≈⟨ ∧-congˡ ¬⊥=⊤ ⟩
    x ∧ ⊤                ≈⟨ ∧-identityʳ _ ⟩
    x                    ∎

  ⊕-identityʳ : RightIdentity ⊥ _⊕_
  ⊕-identityʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-identityˡ _

  ⊕-identity : Identity ⊥ _⊕_
  ⊕-identity = ⊕-identityˡ , ⊕-identityʳ

  ⊕-inverseˡ : LeftInverse ⊥ id _⊕_
  ⊕-inverseˡ x = begin
    x ⊕ x               ≈⟨ ⊕-def _ _ ⟩
    (x ∨ x) ∧ ¬ (x ∧ x) ≈⟨ helper (∨-idempotent _) (∧-idempotent _) ⟩
    x ∧ ¬ x             ≈⟨ ∧-complementʳ _ ⟩
    ⊥                   ∎

  ⊕-inverseʳ : RightInverse ⊥ id _⊕_
  ⊕-inverseʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-inverseˡ _

  ⊕-inverse : Inverse ⊥ id _⊕_
  ⊕-inverse = ⊕-inverseˡ , ⊕-inverseʳ

  ∧-distribˡ-⊕ : _∧_ DistributesOverˡ _⊕_
  ∧-distribˡ-⊕ x y z = begin
    x ∧ (y ⊕ z)                ≈⟨ ∧-congˡ $ ⊕-def _ _ ⟩
    x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))  ≈˘⟨ ∧-assoc _ _ _ ⟩
    (x ∧ (y ∨ z)) ∧ ¬ (y ∧ z)  ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩
    (x ∧ (y ∨ z)) ∧
    (¬ y ∨ ¬ z)                ≈˘⟨ ∨-identityˡ _ ⟩
    ⊥ ∨
    ((x ∧ (y ∨ z)) ∧
    (¬ y ∨ ¬ z))               ≈⟨ ∨-congʳ lem₃ ⟩
    ((x ∧ (y ∨ z)) ∧ ¬ x) ∨
    ((x ∧ (y ∨ z)) ∧
    (¬ y ∨ ¬ z))               ≈˘⟨ ∧-∨-distribˡ _ _ _ ⟩
    (x ∧ (y ∨ z)) ∧
    (¬ x ∨ (¬ y ∨ ¬ z))        ≈˘⟨ ∧-congˡ $ ∨-congˡ (deMorgan₁ _ _) ⟩
    (x ∧ (y ∨ z)) ∧
    (¬ x ∨ ¬ (y ∧ z))          ≈˘⟨ ∧-congˡ (deMorgan₁ _ _) ⟩
    (x ∧ (y ∨ z)) ∧
    ¬ (x ∧ (y ∧ z))            ≈⟨ helper refl lem₁ ⟩
    (x ∧ (y ∨ z)) ∧
    ¬ ((x ∧ y) ∧ (x ∧ z))      ≈⟨ ∧-congʳ $ ∧-∨-distribˡ _ _ _ ⟩
    ((x ∧ y) ∨ (x ∧ z)) ∧
    ¬ ((x ∧ y) ∧ (x ∧ z))      ≈˘⟨ ⊕-def _ _ ⟩
    (x ∧ y) ⊕ (x ∧ z)          ∎
      where
      lem₂ = begin
        x ∧ (y ∧ z)  ≈˘⟨ ∧-assoc _ _ _ ⟩
        (x ∧ y) ∧ z  ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩
        (y ∧ x) ∧ z  ≈⟨ ∧-assoc _ _ _ ⟩
        y ∧ (x ∧ z)  ∎

      lem₁ = begin
        x ∧ (y ∧ z)        ≈˘⟨ ∧-congʳ (∧-idempotent _) ⟩
        (x ∧ x) ∧ (y ∧ z)  ≈⟨ ∧-assoc _ _ _ ⟩
        x ∧ (x ∧ (y ∧ z))  ≈⟨ ∧-congˡ lem₂ ⟩
        x ∧ (y ∧ (x ∧ z))  ≈˘⟨ ∧-assoc _ _ _ ⟩
        (x ∧ y) ∧ (x ∧ z)  ∎

      lem₃ = begin
        ⊥                      ≈˘⟨ ∧-zeroʳ _ ⟩
        (y ∨ z) ∧ ⊥            ≈˘⟨ ∧-congˡ (∧-complementʳ _) ⟩
        (y ∨ z) ∧ (x ∧ ¬ x)    ≈˘⟨ ∧-assoc _ _ _ ⟩
        ((y ∨ z) ∧ x) ∧ ¬ x    ≈⟨ ∧-comm _ _ ⟨ ∧-cong ⟩ refl  ⟩
        (x ∧ (y ∨ z)) ∧ ¬ x    ∎

  ∧-distribʳ-⊕ : _∧_ DistributesOverʳ _⊕_
  ∧-distribʳ-⊕ = comm+distrˡ⇒distrʳ ⊕-cong ∧-comm ∧-distribˡ-⊕

  ∧-distrib-⊕ : _∧_ DistributesOver _⊕_
  ∧-distrib-⊕ = ∧-distribˡ-⊕ , ∧-distribʳ-⊕

  private

    lemma₂ : ∀ x y u v →
             (x ∧ y) ∨ (u ∧ v) ≈
             ((x ∨ u) ∧ (y ∨ u)) ∧
             ((x ∨ v) ∧ (y ∨ v))
    lemma₂ x y u v = begin
        (x ∧ y) ∨ (u ∧ v)              ≈⟨ ∨-∧-distribˡ _ _ _ ⟩
        ((x ∧ y) ∨ u) ∧ ((x ∧ y) ∨ v)  ≈⟨ ∨-∧-distribʳ _ _ _
                                            ⟨ ∧-cong ⟩
                                          ∨-∧-distribʳ _ _ _ ⟩
        ((x ∨ u) ∧ (y ∨ u)) ∧
        ((x ∨ v) ∧ (y ∨ v))            ∎

  ⊕-assoc : Associative _⊕_
  ⊕-assoc x y z = sym $ begin
    x ⊕ (y ⊕ z)                                ≈⟨ refl ⟨ ⊕-cong ⟩ ⊕-def _ _ ⟩
    x ⊕ ((y ∨ z) ∧ ¬ (y ∧ z))                  ≈⟨ ⊕-def _ _ ⟩
      (x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))) ∧
    ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)))              ≈⟨ lem₃ ⟨ ∧-cong ⟩ lem₄ ⟩
    (((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧
    (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈⟨ ∧-assoc _ _ _ ⟩
    ((x ∨ y) ∨ z) ∧
    (((x ∨ ¬ y) ∨ ¬ z) ∧
     (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)))  ≈⟨ ∧-congˡ lem₅ ⟩
    ((x ∨ y) ∨ z) ∧
    (((¬ x ∨ ¬ y) ∨ z) ∧
     (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)))  ≈˘⟨ ∧-assoc _ _ _ ⟩
    (((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧
    (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈⟨ lem₁ ⟨ ∧-cong ⟩ lem₂ ⟩
      (((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z) ∧
    ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z)              ≈˘⟨ ⊕-def _ _ ⟩
    ((x ∨ y) ∧ ¬ (x ∧ y)) ⊕ z                  ≈˘⟨ ⊕-def _ _ ⟨ ⊕-cong ⟩ refl ⟩
    (x ⊕ y) ⊕ z                                ∎
    where
    lem₁ = begin
      ((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)  ≈˘⟨ ∨-∧-distribʳ _ _ _ ⟩
      ((x ∨ y) ∧ (¬ x ∨ ¬ y)) ∨ z        ≈˘⟨ ∨-congʳ $ ∧-congˡ (deMorgan₁ _ _) ⟩
      ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z          ∎

    lem₂' = begin
      (x ∨ ¬ y) ∧ (¬ x ∨ y)              ≈˘⟨ ∧-identityˡ _ ⟨ ∧-cong ⟩ ∧-identityʳ _ ⟩
      (⊤ ∧ (x ∨ ¬ y)) ∧ ((¬ x ∨ y) ∧ ⊤)  ≈˘⟨  (∨-complementˡ _ ⟨ ∧-cong ⟩ ∨-comm _ _)
                                                ⟨ ∧-cong ⟩
                                              (∧-congˡ $ ∨-complementˡ _) ⟩
      ((¬ x ∨ x) ∧ (¬ y ∨ x)) ∧
      ((¬ x ∨ y) ∧ (¬ y ∨ y))            ≈˘⟨ lemma₂ _ _ _ _ ⟩
      (¬ x ∧ ¬ y) ∨ (x ∧ y)              ≈˘⟨ deMorgan₂ _ _ ⟨ ∨-cong ⟩ ¬-involutive _ ⟩
      ¬ (x ∨ y) ∨ ¬ ¬ (x ∧ y)            ≈˘⟨ deMorgan₁ _ _ ⟩
      ¬ ((x ∨ y) ∧ ¬ (x ∧ y))            ∎

    lem₂ = begin
      ((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)  ≈˘⟨ ∨-∧-distribʳ _ _ _ ⟩
      ((x ∨ ¬ y) ∧ (¬ x ∨ y)) ∨ ¬ z          ≈⟨ ∨-congʳ lem₂' ⟩
      ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ ¬ z          ≈˘⟨ deMorgan₁ _ _ ⟩
      ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z)          ∎

    lem₃ = begin
      x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))          ≈⟨ ∨-congˡ $ ∧-congˡ $ deMorgan₁ _ _ ⟩
      x ∨ ((y ∨ z) ∧ (¬ y ∨ ¬ z))        ≈⟨ ∨-∧-distribˡ _ _ _ ⟩
      (x ∨ (y ∨ z)) ∧ (x ∨ (¬ y ∨ ¬ z))  ≈˘⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟩
      ((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)  ∎

    lem₄' = begin
      ¬ ((y ∨ z) ∧ ¬ (y ∧ z))    ≈⟨ deMorgan₁ _ _ ⟩
      ¬ (y ∨ z) ∨ ¬ ¬ (y ∧ z)    ≈⟨ deMorgan₂ _ _ ⟨ ∨-cong ⟩ ¬-involutive _ ⟩
      (¬ y ∧ ¬ z) ∨ (y ∧ z)      ≈⟨ lemma₂ _ _ _ _ ⟩
      ((¬ y ∨ y) ∧ (¬ z ∨ y)) ∧
      ((¬ y ∨ z) ∧ (¬ z ∨ z))    ≈⟨ (∨-complementˡ _ ⟨ ∧-cong ⟩ ∨-comm _ _)
                                      ⟨ ∧-cong ⟩
                                   (∧-congˡ $ ∨-complementˡ _) ⟩
      (⊤ ∧ (y ∨ ¬ z)) ∧
      ((¬ y ∨ z) ∧ ⊤)            ≈⟨ ∧-identityˡ _ ⟨ ∧-cong ⟩ ∧-identityʳ _ ⟩
      (y ∨ ¬ z) ∧ (¬ y ∨ z)      ∎

    lem₄ = begin
      ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)))  ≈⟨ deMorgan₁ _ _ ⟩
      ¬ x ∨ ¬ ((y ∨ z) ∧ ¬ (y ∧ z))  ≈⟨ ∨-congˡ lem₄' ⟩
      ¬ x ∨ ((y ∨ ¬ z) ∧ (¬ y ∨ z))  ≈⟨ ∨-∧-distribˡ _ _ _ ⟩
      (¬ x ∨ (y     ∨ ¬ z)) ∧
      (¬ x ∨ (¬ y ∨ z))              ≈˘⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟩
      ((¬ x ∨ y)     ∨ ¬ z) ∧
      ((¬ x ∨ ¬ y) ∨ z)              ≈⟨ ∧-comm _ _ ⟩
      ((¬ x ∨ ¬ y) ∨ z) ∧
      ((¬ x ∨ y)     ∨ ¬ z)          ∎

    lem₅ = begin
      ((x ∨ ¬ y) ∨ ¬ z) ∧
      (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈˘⟨ ∧-assoc _ _ _ ⟩
      (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧
      ((¬ x ∨ y) ∨ ¬ z)                          ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩
      (((¬ x ∨ ¬ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧
      ((¬ x ∨ y) ∨ ¬ z)                          ≈⟨ ∧-assoc _ _ _ ⟩
      ((¬ x ∨ ¬ y) ∨ z) ∧
      (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ∎

  ⊕-isMagma : IsMagma _⊕_
  ⊕-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = ⊕-cong
    }

  ⊕-isSemigroup : IsSemigroup _⊕_
  ⊕-isSemigroup = record
    { isMagma = ⊕-isMagma
    ; assoc   = ⊕-assoc
    }

  ⊕-⊥-isMonoid : IsMonoid _⊕_ ⊥
  ⊕-⊥-isMonoid = record
    { isSemigroup = ⊕-isSemigroup
    ; identity    = ⊕-identity
    }

  ⊕-⊥-isGroup : IsGroup _⊕_ ⊥ id
  ⊕-⊥-isGroup = record
    { isMonoid = ⊕-⊥-isMonoid
    ; inverse  = ⊕-inverse
    ; ⁻¹-cong  = id
    }

  ⊕-⊥-isAbelianGroup : IsAbelianGroup _⊕_ ⊥ id
  ⊕-⊥-isAbelianGroup = record
    { isGroup = ⊕-⊥-isGroup
    ; comm    = ⊕-comm
    }

  ⊕-∧-isRing : IsRing _⊕_ _∧_ id ⊥ ⊤
  ⊕-∧-isRing = record
    { +-isAbelianGroup = ⊕-⊥-isAbelianGroup
    ; *-isMonoid = ∧-⊤-isMonoid
    ; distrib = ∧-distrib-⊕
    }

  isCommutativeRing : IsCommutativeRing _⊕_ _∧_ id ⊥ ⊤
  isCommutativeRing = record
    { isRing = ⊕-∧-isRing
    ; *-comm = ∧-comm
    }

  commutativeRing : CommutativeRing _ _
  commutativeRing = record
    { _+_               = _⊕_
    ; _*_               = _∧_
    ; -_                = id
    ; 0#                = ⊥
    ; 1#                = ⊤
    ; isCommutativeRing = isCommutativeRing
    }

infixl 6 _⊕_

_⊕_ : Op₂ Carrier
x ⊕ y = (x ∨ y) ∧ ¬ (x ∧ y)

module DefaultXorRing = XorRing _⊕_ (λ _ _ → refl)