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

open import lib.Base
open import lib.PathGroupoid

module lib.PathFunctor where

{- Nondependent stuff -}
module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  !-ap : {x y : A} (p : x == y)
    → ! (ap f p) == ap f (! p)
  !-ap idp = idp

  ap-! : {x y : A} (p : x == y)
    → ap f (! p) == ! (ap f p)
  ap-! idp = idp

  ∙-ap : {x y z : A} (p : x == y) (q : y == z)
    → ap f p ∙ ap f q == ap f (p ∙ q)
  ∙-ap idp q = idp

  ap-∙ : {x y z : A} (p : x == y) (q : y == z)
    → ap f (p ∙ q) == ap f p ∙ ap f q
  ap-∙ idp q = idp

  ∙∙-ap : {x y z w : A} (p : x == y) (q : y == z) (r : z == w)
    → ap f p ∙ ap f q ∙ ap f r == ap f (p ∙ q ∙ r)
  ∙∙-ap idp idp r = idp

  ap-∙∙ : {x y z w : A} (p : x == y) (q : y == z) (r : z == w)
    → ap f (p ∙ q ∙ r) == ap f p ∙ ap f q ∙ ap f r
  ap-∙∙ idp idp r = idp

  ap-∙∙∙ : {x y z w t : A} (p : x == y) (q : y == z) (r : z == w) (s : w == t)
    → ap f (p ∙ q ∙ r ∙ s) == ap f p ∙ ap f q ∙ ap f r ∙ ap f s
  ap-∙∙∙ idp idp idp s = idp

  ∙'-ap : {x y z : A} (p : x == y) (q : y == z)
    → ap f p ∙' ap f q == ap f (p ∙' q)
  ∙'-ap p idp = idp

  ap-∙' : {x y z : A} (p : x == y) (q : y == z)
    → ap f (p ∙' q) == ap f p ∙' ap f q
  ap-∙' p idp = idp

{- Dependent stuff -}
module _ {i j} {A : Type i} {B : A → Type j} (f : Π A B) where

  apd-∙ : {x y z : A} (p : x == y) (q : y == z)
    → apd f (p ∙ q) == apd f p ∙ᵈ apd f q
  apd-∙ idp idp = idp

  apd-∙' : {x y z : A} (p : x == y) (q : y == z)
    → apd f (p ∙' q) == apd f p ∙'ᵈ apd f q
  apd-∙' idp idp = idp

  apd-! : {x y : A} (p : x == y)
    → apd f (! p) == !ᵈ (apd f p)
  apd-! idp = idp

{- Over stuff -}
module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  (f : {a : A} → B a → C a) where

  ap↓-◃ : {x y z : A} {u : B x} {v : B y} {w : B z}
    {p : x == y} {p' : y == z} (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
    → ap↓ f (q ◃ r) == ap↓ f q ◃ ap↓ f r
  ap↓-◃ {p = idp} {p' = idp} idp idp = idp

  ap↓-▹! : {x y z : A} {u : B x} {v : B y} {w : B z}
    {p : x == y} {p' : z == y} (q : u == v [ B ↓ p ]) (r : w == v [ B ↓ p' ])
    → ap↓ f (q ▹! r) == ap↓ f q ▹! ap↓ f r
  ap↓-▹! {p = idp} {p' = idp} idp idp = idp

{- Fuse and unfuse -}
∘-ap : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  {x y : A} (p : x == y) → ap g (ap f p) == ap (g ∘ f) p
∘-ap f g idp = idp

ap-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  {x y : A} (p : x == y) → ap (g ∘ f) p == ap g (ap f p)
ap-∘ f g idp = idp

ap-cst : ∀ {i j} {A : Type i} {B : Type j} (b : B) {x y : A} (p : x == y)
  → ap (cst b) p == idp
ap-cst b idp = idp

ap-idf : ∀ {i} {A : Type i} {u v : A} (p : u == v) → ap (idf A) p == p
ap-idf idp = idp

{- Functoriality of [coe] -}
coe-∙ : ∀ {i} {A B C : Type i} (p : A == B) (q : B == C) (a : A)
  → coe (p ∙ q) a == coe q (coe p a)
coe-∙ idp q a = idp

coe-! : ∀ {i} {A B : Type i} (p : A == B) (b : B) → coe (! p) b == coe! p b
coe-! idp b = idp

coe!-inv-r : ∀ {i} {A B : Type i} (p : A == B) (b : B)
  → coe p (coe! p b) == b
coe!-inv-r idp b = idp

coe!-inv-l : ∀ {i} {A B : Type i} (p : A == B) (a : A)
  → coe! p (coe p a) == a
coe!-inv-l idp a = idp

coe-inv-adj : ∀ {i} {A B : Type i} (p : A == B) (a : A) →
  ap (coe p) (coe!-inv-l p a) == coe!-inv-r p (coe p a)
coe-inv-adj idp a = idp

coe!-inv-adj : ∀ {i} {A B : Type i} (p : A == B) (b : B) →
  ap (coe! p) (coe!-inv-r p b) == coe!-inv-l p (coe! p b)
coe!-inv-adj idp b = idp

coe-ap-! : ∀ {i j} {A : Type i} (P : A → Type j) {a b : A} (p : a == b)
  (x : P b)
  → coe (ap P (! p)) x == coe! (ap P p) x
coe-ap-! P idp x = idp

{- Functoriality of transport -}
transp-∙ : ∀ {i j} {A : Type i} {B : A → Type j} {x y z : A}
  (p : x == y) (q : y == z) (b : B x)
  → transport B (p ∙ q) b == transport B q (transport B p b)
transp-∙ idp _ _ = idp

transp-∙' : ∀ {i j} {A : Type i} {B : A → Type j} {x y z : A}
  (p : x == y) (q : y == z) (b : B x)
  → transport B (p ∙' q) b == transport B q (transport B p b)
transp-∙' _ idp _ = idp

{- Naturality of homotopies -}

-- One should use [↓-='-out] and [apd] together, or even lib.cubical,
-- for homotopy naturality.

{- for functions with two arguments -}
module _ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : A → B → C) where

  ap2 : {x y : A} {w z : B}
    → (x == y) → (w == z) → f x w == f y z
  ap2 idp idp = idp

  ap2-out : {x y : A} {w z : B} (p : x == y) (q : w == z)
    → ap2 p q == ap (λ u → f u w) p ∙ ap (λ v → f y v) q
  ap2-out idp idp = idp

  ap2-idp-l : {x : A} {w z : B} (q : w == z)
    → ap2 (idp {a = x}) q == ap (f x) q
  ap2-idp-l idp = idp

  ap2-idp-r : {x y : A} {w : B} (p : x == y)
    → ap2 p (idp {a = w}) == ap (λ z → f z w) p
  ap2-idp-r idp = idp

{- ap2 lemmas -}
module _ {i j} {A : Type i} {B : Type j} where

  ap2-fst : {x y : A} {w z : B} (p : x == y) (q : w == z)
    → ap2 (curry fst) p q == p
  ap2-fst idp idp = idp

  ap2-snd : {x y : A} {w z : B} (p : x == y) (q : w == z)
    → ap2 (curry snd) p q == q
  ap2-snd idp idp = idp

  ap-ap2 : ∀ {k l} {C : Type k} {D : Type l}
    (g : C → D) (f : A → B → C) {x y : A} {w z : B}
    (p : x == y) (q : w == z)
    → ap g (ap2 f p q) == ap2 (λ a b → g (f a b)) p q
  ap-ap2 g f idp idp = idp

  ap2-ap-l : ∀ {k l} {C : Type k} {D : Type l}
    (g : B → C → D) (f : A → B) {x y : A} {w z : C}
    (p : x == y) (q : w == z)
    → ap2 g (ap f p) q == ap2 (λ a c → g (f a) c) p q
  ap2-ap-l g f idp idp = idp

  ap2-ap-r : ∀ {k l} {C : Type k} {D : Type l}
    (g : A → C → D) (f : B → C) {x y : A} {w z : B}
    (p : x == y) (q : w == z)
    → ap2 g p (ap f q) == ap2 (λ a b → g a (f b)) p q
  ap2-ap-r g f idp idp = idp

  ap2-diag : (f : A → A → B)
    {x y : A} (p : x == y)
    → ap2 f p p == ap (λ x → f x x) p
  ap2-diag f idp = idp

-- unsure where this belongs
transp-cst=idf : ∀ {i} {A : Type i} {a x y : A} (p : x == y) (q : a == x)
  → transport (λ x → a == x) p q == q ∙ p
transp-cst=idf idp q = ! (∙-unit-r q)

{- for functions with more arguments -}
module _ {i₀ i₁ i₂ j} {A₀ : Type i₀} {A₁ : Type i₁} {A₂ : Type i₂}
  {B : Type j} (f : A₀ → A₁ → A₂ → B) where

  ap3 : {x₀ y₀ : A₀} {x₁ y₁ : A₁} {x₂ y₂ : A₂}
    → (x₀ == y₀) → (x₁ == y₁) → (x₂ == y₂) → f x₀ x₁ x₂ == f y₀ y₁ y₂
  ap3 idp idp idp = idp

module _ {i₀ i₁ i₂ i₃ j} {A₀ : Type i₀} {A₁ : Type i₁} {A₂ : Type i₂} {A₃ : Type i₃}
  {B : Type j} (f : A₀ → A₁ → A₂ → A₃ → B) where

  ap4 : {x₀ y₀ : A₀} {x₁ y₁ : A₁} {x₂ y₂ : A₂} {x₃ y₃ : A₃}
    → (x₀ == y₀) → (x₁ == y₁) → (x₂ == y₂) → (x₃ == y₃) → f x₀ x₁ x₂ x₃ == f y₀ y₁ y₂ y₃
  ap4 idp idp idp idp = idp

module _ {i₀ i₁ i₂ i₃ i₄ j} {A₀ : Type i₀} {A₁ : Type i₁} {A₂ : Type i₂} {A₃ : Type i₃}
  {A₄ : Type i₄} {B : Type j} (f : A₀ → A₁ → A₂ → A₃ → A₄ → B) where

  ap5 : {x₀ y₀ : A₀} {x₁ y₁ : A₁} {x₂ y₂ : A₂} {x₃ y₃ : A₃} {x₄ y₄ : A₄}
    → (x₀ == y₀) → (x₁ == y₁) → (x₂ == y₂) → (x₃ == y₃) → (x₄ == y₄)
    → f x₀ x₁ x₂ x₃ x₄ == f y₀ y₁ y₂ y₃ y₄
  ap5 idp idp idp idp idp = idp

module _ {i₀ i₁ i₂ i₃ i₄ i₅ j} {A₀ : Type i₀} {A₁ : Type i₁} {A₂ : Type i₂} {A₃ : Type i₃}
  {A₄ : Type i₄} {A₅ : Type i₅} {B : Type j} (f : A₀ → A₁ → A₂ → A₃ → A₄ → A₅ → B) where

  ap6 : {x₀ y₀ : A₀} {x₁ y₁ : A₁} {x₂ y₂ : A₂} {x₃ y₃ : A₃} {x₄ y₄ : A₄} {x₅ y₅ : A₅}
    → (x₀ == y₀) → (x₁ == y₁) → (x₂ == y₂) → (x₃ == y₃) → (x₄ == y₄) → (x₅ == y₅)
    → f x₀ x₁ x₂ x₃ x₄ x₅ == f y₀ y₁ y₂ y₃ y₄ y₅
  ap6 idp idp idp idp idp idp = idp


module CTL.Modalities.EG where

open import FStream.Core
open import Library

-- Possibly forever : s₀ ⊧ φ ⇔ ∃ s₀ R s₁ R ... ∀ i . sᵢ ⊧ φ
{-# NO_POSITIVITY_CHECK #-} -- Not necessary from EGda 2.6 upwards
record EG' {i : Size} {ℓ₁ ℓ₂} {C : Container ℓ₁}
  (props : FStream' C (Set ℓ₂)) : Set (ℓ₁ ⊔ ℓ₂) where
  coinductive
  field
    nowE   : head props
    laterE : {j : Size< i} → E (fmap EG' (inF (tail props)))
open EG' public

EG : ∀ {i : Size} {ℓ₁ ℓ₂} {C : Container ℓ₁}
   → FStream C (Set ℓ₂) → Set (ℓ₁ ⊔ ℓ₂)
EG props = EPred EG' (inF props)

mutual
  EGₛ' : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
       → FStream' C (Set ℓ₂) → FStream' {i} C (Set (ℓ₁ ⊔ ℓ₂))
  head (EGₛ' props) = EG' props
  tail (EGₛ' props) = EGₛ (tail props)

  EGₛ : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
      → FStream C (Set ℓ₂) → FStream {i} C (Set (ℓ₁ ⊔ ℓ₂))
  inF (EGₛ props) = fmap EGₛ' (inF props)


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

module Categories.Category.Construction.Adjoints where

open import Level
open import Data.Product using (_×_ ; _,_)

open import Categories.Category
open import Categories.Category.Helper
open import Categories.Adjoint
open import Categories.Adjoint.Compose
open import Categories.Adjoint.Mate
open import Categories.Functor renaming (id to idF)
open import Categories.NaturalTransformation renaming (id to idN)
open import Categories.NaturalTransformation.NaturalIsomorphism
open import Categories.NaturalTransformation.Equivalence renaming (_≃_ to _≊_)

import Categories.Morphism.Reasoning as MR

private
  variable
    o o′ ℓ ℓ′ e e′ : Level

-- category of adjunctions between two fixed categories
module _ (C : Category o ℓ e) (D : Category o′ ℓ′ e′) where
  private
    module C = Category C
    module D = Category D

  record AdjointObj : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      L   : Functor C D
      R   : Functor D C
      L⊣R : L ⊣ R

    module L = Functor L
    module R = Functor R
    module L⊣R = Adjoint L⊣R

  record Adjoint⇒ (X Y : AdjointObj) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    private
      module X = AdjointObj X
      module Y = AdjointObj Y

    field
      mate : HaveMate X.L⊣R Y.L⊣R

    open HaveMate mate public

  private
    _≈_ : ∀ {A B} → Adjoint⇒ A B → Adjoint⇒ A B → Set (o ⊔ e ⊔ o′ ⊔ e′)
    f ≈ g = Adjoint⇒.α f ≊ Adjoint⇒.α g × Adjoint⇒.β f ≊ Adjoint⇒.β g

    id : {X : AdjointObj} → Adjoint⇒ X X
    id {X} = record
      { mate = record
        { α    = idN
        ; β    = idN
        ; mate = record
          { commute₁ = C.∘-resp-≈ˡ R.identity
          ; commute₂ = D.∘-resp-≈ʳ L.identity
          }
        }
      }
      where open AdjointObj X

    _∘_ : ∀ {X Y Z} → Adjoint⇒ Y Z → Adjoint⇒ X Y → Adjoint⇒ X Z
    _∘_ {X} {Y} {Z} f g = record
      { mate = record
        { α    = f.α ∘ᵥ g.α
        ; β    = g.β ∘ᵥ f.β
        ; mate = record
          { commute₁ = λ {W} →
            let open C.HomReasoning
                open MR C
            in begin
            X.R.F₁ (f.α.η W D.∘ g.α.η W) C.∘ X.L⊣R.unit.η W            ≈⟨ X.R.homomorphism ⟩∘⟨refl ⟩
            (X.R.F₁ (f.α.η W) C.∘ X.R.F₁ (g.α.η W)) C.∘ X.L⊣R.unit.η W ≈⟨ pullʳ g.commute₁ ⟩
            X.R.F₁ (f.α.η W) C.∘ g.β.η (Y.L.F₀ W) C.∘ Y.L⊣R.unit.η W   ≈⟨ pullˡ (g.β.sym-commute _) ⟩
            (g.β.η (Z.L.F₀ W) C.∘ Y.R.F₁ (f.α.η W)) C.∘ Y.L⊣R.unit.η W ≈⟨ pullʳ f.commute₁ ⟩
            g.β.η (Z.L.F₀ W) C.∘ f.β.η (Z.L.F₀ W) C.∘ Z.L⊣R.unit.η W   ≈⟨ C.sym-assoc ⟩
            (g.β.η (Z.L.F₀ W) C.∘ f.β.η (Z.L.F₀ W)) C.∘ Z.L⊣R.unit.η W ∎
          ; commute₂ = λ {W} →
            let open D.HomReasoning
                open MR D
            in begin
              X.L⊣R.counit.η W D.∘ X.L.F₁ (g.β.η W C.∘ f.β.η W)            ≈⟨ refl⟩∘⟨ X.L.homomorphism ⟩
              X.L⊣R.counit.η W D.∘ X.L.F₁ (g.β.η W) D.∘ X.L.F₁ (f.β.η W)   ≈⟨ pullˡ g.commute₂ ⟩
              (Y.L⊣R.counit.η W D.∘ g.α.η (Y.R.F₀ W)) D.∘ X.L.F₁ (f.β.η W) ≈⟨ pullʳ (g.α.commute _) ⟩
              Y.L⊣R.counit.η W D.∘ Y.L.F₁ (f.β.η W) D.∘ g.α.η (Z.R.F₀ W)   ≈⟨ pullˡ f.commute₂ ⟩
              (Z.L⊣R.counit.η W D.∘ f.α.η (Z.R.F₀ W)) D.∘ g.α.η (Z.R.F₀ W) ≈⟨ D.assoc ⟩
              Z.L⊣R.counit.η W D.∘ f.α.η (Z.R.F₀ W) D.∘ g.α.η (Z.R.F₀ W)   ∎
          }
        }
      }
      where module X = AdjointObj X
            module Y = AdjointObj Y
            module Z = AdjointObj Z
            module f = Adjoint⇒ f
            module g = Adjoint⇒ g

  Adjoints : Category (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) (o ⊔ e ⊔ o′ ⊔ e′)
  Adjoints = categoryHelper record
     { Obj       = AdjointObj
     ; _⇒_       = Adjoint⇒
     ; _≈_       = _≈_
     ; id        = id
     ; _∘_       = _∘_
     ; assoc     = D.assoc , C.sym-assoc
     ; identityˡ = D.identityˡ , C.identityʳ
     ; identityʳ = D.identityʳ , C.identityˡ
     ; equiv     = record
       { refl  = D.Equiv.refl , C.Equiv.refl
       ; sym   = λ { (eq₁ , eq₂) → D.Equiv.sym eq₁ , C.Equiv.sym eq₂ }
       ; trans = λ { (eq₁ , eq₂) (eq₃ , eq₄) → D.Equiv.trans eq₁ eq₃ , C.Equiv.trans eq₂ eq₄ }
       }
     ; ∘-resp-≈  = λ { (eq₁ , eq₂) (eq₃ , eq₄) → D.∘-resp-≈ eq₁ eq₃ , C.∘-resp-≈ eq₄ eq₂ }
     }

module _ o ℓ e where
  private
    _≈_ : ∀ {A B : Category o ℓ e} → AdjointObj A B → AdjointObj A B → Set (o ⊔ ℓ ⊔ e)
    f ≈ g = f.L ≃ g.L × f.R ≃ g.R
      where module f = AdjointObj f
            module g = AdjointObj g

    id : {A : Category o ℓ e} → AdjointObj A A
    id = record
      { L   = idF
      ; R   = idF
      ; L⊣R = ⊣-id
      }

    _∘_ : {A B C : Category o ℓ e} → AdjointObj B C → AdjointObj A B → AdjointObj A C
    f ∘ g = record
      { L   = f.L ∘F g.L
      ; R   = g.R ∘F f.R
      ; L⊣R = g.L⊣R ∘⊣ f.L⊣R
      }
      where module f = AdjointObj f
            module g = AdjointObj g

  Adjunctions : Category (suc (o ⊔ ℓ ⊔ e)) (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e)
  Adjunctions = categoryHelper record
    { Obj       = Category o ℓ e
    ; _⇒_       = AdjointObj
    ; _≈_       = _≈_
    ; id        = id
    ; _∘_       = _∘_
    ; assoc     = λ {_ _ _ _ f g h} → associator (AdjointObj.L f) (AdjointObj.L g) (AdjointObj.L h)
                                    , sym-associator (AdjointObj.R h) (AdjointObj.R g) (AdjointObj.R f)
    ; identityˡ = unitorˡ , unitorʳ
    ; identityʳ = unitorʳ , unitorˡ
    ; equiv     = record
      { refl  = ≃.refl , ≃.refl
      ; sym   = λ { (α , β) → ≃.sym α , ≃.sym β }
      ; trans = λ { (α₁ , β₁) (α₂ , β₂) → ≃.trans α₁ α₂ , ≃.trans β₁ β₂ }
      }
    ; ∘-resp-≈  = λ { (α₁ , β₁) (α₂ , β₂) → α₁ ⓘₕ α₂ , β₂ ⓘₕ β₁ }
    }


{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Instances.IntMod where

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

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
open import Cubical.Data.Bool hiding (isProp≤)
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_)
open import Cubical.Data.Nat.Mod
open import Cubical.Data.Nat.Order
open import Cubical.Data.Int renaming (_+_ to _+ℤ_)
open import Cubical.Data.Fin
open import Cubical.Data.Fin.Arithmetic
open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid.Base
open import Cubical.Algebra.Semigroup.Base
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Instances.Unit
open import Cubical.Algebra.Group.Instances.Bool
open import Cubical.Algebra.Group.Instances.Int

open GroupStr
open IsGroup
open IsMonoid

ℤGroup/_ : ℕ → Group₀
ℤGroup/ zero = ℤGroup
fst (ℤGroup/ suc n) = Fin (suc n)
1g (snd (ℤGroup/ suc n)) = 0
GroupStr._·_ (snd (ℤGroup/ suc n)) = _+ₘ_
inv (snd (ℤGroup/ suc n)) = -ₘ_
isGroup (snd (ℤGroup/ suc n)) = makeIsGroup
                                isSetFin
                                (λ x y z → sym (+ₘ-assoc x y z))
                                +ₘ-rUnit
                                +ₘ-lUnit
                                +ₘ-rCancel
                                +ₘ-lCancel

ℤGroup/1≅Unit : GroupIso (ℤGroup/ 1) UnitGroup₀
ℤGroup/1≅Unit = contrGroupIsoUnit isContrFin1

Bool≅ℤGroup/2 : GroupIso BoolGroup (ℤGroup/ 2)
Iso.fun (fst Bool≅ℤGroup/2) false = 1
Iso.fun (fst Bool≅ℤGroup/2) true = 0
Iso.inv (fst Bool≅ℤGroup/2) (zero , p) = true
Iso.inv (fst Bool≅ℤGroup/2) (suc zero , p) = false
Iso.inv (fst Bool≅ℤGroup/2) (suc (suc x) , p) =
  ⊥.rec (¬-<-zero (predℕ-≤-predℕ (predℕ-≤-predℕ p)))
Iso.rightInv (fst Bool≅ℤGroup/2) (zero , p) =
  Σ≡Prop (λ _ → isProp≤) refl
Iso.rightInv (fst Bool≅ℤGroup/2) (suc zero , p) =
  Σ≡Prop (λ _ → isProp≤) refl
Iso.rightInv (fst Bool≅ℤGroup/2) (suc (suc x) , p) =
  ⊥.rec (¬-<-zero (predℕ-≤-predℕ (predℕ-≤-predℕ p)))
Iso.leftInv (fst Bool≅ℤGroup/2) false = refl
Iso.leftInv (fst Bool≅ℤGroup/2) true = refl
snd Bool≅ℤGroup/2 =
  makeIsGroupHom λ { false false → refl
                   ; false true → refl
                   ; true false → refl
                   ; true true → refl}

ℤGroup/2≅Bool : GroupIso (ℤGroup/ 2) BoolGroup
ℤGroup/2≅Bool = invGroupIso Bool≅ℤGroup/2

-- Definition of the quotient map homomorphism ℤ → ℤGroup/ (suc n)
-- as a group homomorphism.
ℤ→Fin : (n : ℕ) → ℤ → Fin (suc n)
ℤ→Fin n (pos x) = x mod (suc n) , mod< n x
ℤ→Fin n (negsuc x) = -ₘ (suc x mod suc n , mod< n (suc x))

ℤ→Fin-presinv : (n : ℕ) (x : ℤ) → ℤ→Fin n (- x) ≡ -ₘ ℤ→Fin n x
ℤ→Fin-presinv n (pos zero) =
  Σ≡Prop (λ _ → isProp≤) ((λ _ → zero) ∙ sym (cong fst help))
  where
  help : (-ₘ_ {n = n} 0) ≡ 0
  help = GroupTheory.inv1g (ℤGroup/ (suc n))
ℤ→Fin-presinv n (pos (suc x)) = Σ≡Prop (λ _ → isProp≤) refl
ℤ→Fin-presinv n (negsuc x) =
  sym (GroupTheory.invInv (ℤGroup/ (suc n)) _)

-ₘ1-id : (n : ℕ)
      → Path (Fin (suc n)) (-ₘ (1 mod (suc n) , mod< n 1))
                            (n mod (suc n) , mod< n n)
-ₘ1-id zero = refl
-ₘ1-id (suc n) =
     cong -ₘ_ (FinPathℕ ((1 mod suc (suc n)) , mod< (suc n) 1) 1
                (modIndBase (suc n) 1 (n , +-comm n 2)) .snd)
   ∙ Σ≡Prop (λ _ → isProp≤)
      ((+inductionBase (suc n) _
        (λ x _ → ((suc (suc n)) ∸ x) mod (suc (suc n))) λ _ x → x) 1
        (n , (+-comm n 2)))

suc-ₘ1 : (n y : ℕ)
  → ((suc y mod suc n) , mod< n (suc y)) -ₘ (1 mod (suc n) , mod< n 1)
   ≡ (y mod suc n , mod< n y)
suc-ₘ1 zero y =
  isContr→isProp
    (isOfHLevelRetractFromIso 0 (fst ℤGroup/1≅Unit) isContrUnit) _ _
suc-ₘ1 (suc n) y =
     (λ i → ((suc y mod suc (suc n)) , mod< (suc n) (suc y))
         +ₘ (-ₘ1-id (suc n) i))
   ∙ Σ≡Prop (λ _ → isProp≤)
      (cong (_mod (2 +ℕ n))
         (cong (_+ℕ (suc n) mod (2 +ℕ n))
           (mod+mod≡mod (suc (suc n)) 1 y))
      ∙∙ sym (mod+mod≡mod (suc (suc n))
             ((1 mod suc (suc n))
              +ℕ (y mod suc (suc n))) (suc n))
      ∙∙ (mod-rCancel (suc (suc n)) ((1 mod suc (suc n))
                                     +ℕ (y mod suc (suc n))) (suc n)
          ∙ cong (_mod (suc (suc n)))
           (cong (_+ℕ (suc n mod suc (suc n)))
                 (+-comm (1 mod suc (suc n)) (y mod suc (suc n)))
           ∙ sym (+-assoc (y mod suc (suc n))
                  (1 mod suc (suc n)) (suc n mod suc (suc n))))
      ∙∙ mod-rCancel (suc (suc n)) (y mod suc (suc n))
            ((1 mod suc (suc n)) +ℕ (suc n mod suc (suc n)))
      ∙∙ (cong (_mod (2 +ℕ n))
            (cong ((y mod suc (suc n)) +ℕ_)
                    (sym (mod+mod≡mod (suc (suc n)) 1 (suc n))
                  ∙ zero-charac (suc (suc n)))
                  ∙ +-comm _ 0)
       ∙ mod-idempotent y)))

1-ₘsuc : (n y : ℕ)
  →     ((1 mod (suc n) , mod< n 1)
     +ₘ (-ₘ (((suc y mod suc n) , mod< n (suc y)))))
       ≡ -ₘ ((y mod suc n) , mod< n y)
1-ₘsuc n y =
     sym (GroupTheory.invInv (ℤGroup/ (suc n)) _)
   ∙ cong -ₘ_
      (GroupTheory.invDistr (ℤGroup/ (suc n))
        (modInd n 1 , mod< n 1) (-ₘ (modInd n (suc y) , mod< n (suc y)))
      ∙ cong (_-ₘ (modInd n 1 , mod< n 1))
       (GroupTheory.invInv (ℤGroup/ (suc n)) (modInd n (suc y) , mod< n (suc y)))
       ∙ suc-ₘ1 n y)

isHomℤ→Fin : (n : ℕ) → IsGroupHom (snd ℤGroup) (ℤ→Fin n) (snd (ℤGroup/ (suc n)))
isHomℤ→Fin n =
  makeIsGroupHom
    λ { (pos x) y → pos+case x y
      ; (negsuc x) (pos y) →
             cong (ℤ→Fin n) (+Comm (negsuc x) (pos y))
          ∙∙ pos+case y (negsuc x)
          ∙∙ +ₘ-comm (ℤ→Fin n (pos y)) (ℤ→Fin n (negsuc x))
      ; (negsuc x) (negsuc y) →
           sym (cong (ℤ→Fin n) (-Dist+ (pos (suc x)) (pos (suc y))))
        ∙∙ ℤ→Fin-presinv n (pos (suc x) +ℤ (pos (suc y)))
        ∙∙ cong -ₘ_ (pos+case (suc x) (pos (suc y)))
        ∙∙ GroupTheory.invDistr (ℤGroup/ (suc n))
             (modInd n (suc x)
            , mod< n (suc x)) (modInd n (suc y) , mod< n (suc y))
        ∙∙ +ₘ-comm (ℤ→Fin n (negsuc y)) (ℤ→Fin n (negsuc x))}
  where
  +1case :  (y : ℤ) → ℤ→Fin n (1 +ℤ y) ≡ ℤ→Fin n 1 +ₘ ℤ→Fin n y
  +1case (pos zero) = sym (GroupStr.·IdR (snd (ℤGroup/ (suc n))) _)
  +1case (pos (suc y)) =
       cong (ℤ→Fin n) (+Comm 1 (pos (suc y)))
     ∙ Σ≡Prop (λ _ → isProp≤) (mod+mod≡mod (suc n) 1 (suc y))
  +1case (negsuc zero) =
      Σ≡Prop (λ _ → isProp≤) refl
    ∙ sym (GroupStr.·InvR (snd (ℤGroup/ (suc n))) (modInd n 1 , mod< n 1))
  +1case (negsuc (suc y)) =
    Σ≡Prop (λ _ → isProp≤)
      (cong fst (cong (ℤ→Fin n) (+Comm 1 (negsuc (suc y))))
      ∙∙ cong fst (cong -ₘ_ (refl {x = suc y mod suc n , mod< n (suc y)}))
      ∙∙ cong fst (sym (1-ₘsuc n (suc y)))
       ∙ λ i → fst ((1 mod (suc n) , mod< n 1)
         +ₘ (-ₘ (((suc (suc y) mod suc n) , mod< n (suc (suc y)))))))

  pos+case : (x : ℕ) (y : ℤ)
    → ℤ→Fin n (pos x +ℤ y) ≡ ℤ→Fin n (pos x) +ₘ ℤ→Fin n y
  pos+case zero y =
      cong (ℤ→Fin n) (+Comm 0 y)
    ∙ sym (GroupStr.·IdL (snd (ℤGroup/ (suc n))) (ℤ→Fin n y))
  pos+case (suc zero) y = +1case y
  pos+case (suc (suc x)) y =
       cong (ℤ→Fin n) (cong (_+ℤ y) (+Comm (pos (suc x)) 1)
                     ∙ sym (+Assoc 1 (pos (suc x)) y))
    ∙∙ +1case (pos (suc x) +ℤ y)
    ∙∙ (cong ((modInd n 1 , mod< n 1) +ₘ_) (pos+case (suc x) y)
     ∙∙ sym (+ₘ-assoc (modInd n 1 , mod< n 1)
              (modInd n (suc x) , mod< n (suc x)) (ℤ→Fin n y))
     ∙∙ cong (_+ₘ ℤ→Fin n y) (lem x))
    where
    lem : (x : ℕ)
      → (modInd n 1 , mod< n 1) +ₘ (modInd n (suc x) , mod< n (suc x))
        ≡ ℤ→Fin n (pos (suc (suc x)))
    lem x =
      Σ≡Prop (λ _ → isProp≤) (sym (mod+mod≡mod (suc n) 1 (suc x)))


{-# OPTIONS --without-K #-}
open import Type using (Type₀; Type_)
open import Type.Identities
open import Function.NP using (Π; _∘_; const)
open import Function.Extensionality using (FunExt)
open import Data.One using (0₁)
open import Data.Two.Base using (0₂; 1₂)
open import Data.Product.NP using (_,_; fst)
open import Data.Sum.NP using (inl; inr)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; idp; ap; !_; _∙_; tr)
open import HoTT using (ua; UA; module Equivalences)
open        Equivalences using (_≃_)

open import Explore.Core
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Product
open        Explore.Product.Operators
open import Explore.Sum
open import Explore.Properties
open import Explore.Explorable
open import Explore.Isomorphism
import      Explore.Universe.Type

module Explore.Universe.FromE
  (X : Type₀) (Xᵉ : ∀ {ℓ} → Explore ℓ X) where

open Explore.Universe.Type {X}

explore : ∀ {ℓ} u → Explore ℓ (El u)
explore 𝟘ᵁ = 𝟘ᵉ
explore 𝟙ᵁ = 𝟙ᵉ
explore 𝟚ᵁ = 𝟚ᵉ
explore (u₀ ×ᵁ u₁) = explore u₀ ×ᵉ explore u₁
explore (u₀ ⊎ᵁ u₁) = explore u₀ ⊎ᵉ explore u₁
explore (Σᵁ u f) = exploreΣ (explore u) λ {x} → explore (f x)
explore Xᵁ = Xᵉ
explore (≃ᵁ u A e) = explore-iso e (explore u)

module FromXⁱ (Xⁱ : ∀ {ℓ p} → ExploreInd p (Xᵉ {ℓ})) where
  explore-ind : ∀ {ℓ p} u → ExploreInd {ℓ} p (explore u)
  explore-ind 𝟘ᵁ = 𝟘ⁱ
  explore-ind 𝟙ᵁ = 𝟙ⁱ
  explore-ind 𝟚ᵁ = 𝟚ⁱ
  explore-ind (u₀ ×ᵁ u₁) = explore-ind u₀ ×ⁱ explore-ind u₁
  explore-ind (u₀ ⊎ᵁ u₁) = explore-ind u₀ ⊎ⁱ explore-ind u₁
  explore-ind (Σᵁ u f) = exploreΣ-ind (explore-ind u) λ {x} → explore-ind (f x)
  explore-ind Xᵁ = Xⁱ
  explore-ind (≃ᵁ u A e) = explore-iso-ind e (explore-ind u)

  module _ (u : U) where
    private
      uᵉ : ∀ {ℓ} → Explore ℓ (El u)
      uᵉ = explore u
      uⁱ : ∀ {ℓ p} → ExploreInd {ℓ} p uᵉ
      uⁱ = explore-ind u

    open FromExploreInd uⁱ public hiding (⟦explore⟧)

    ΣᵉU : ∀ {ℓ} → (El u → Type ℓ) → Type ℓ
    ΣᵉU = Σᵉ uᵉ
    ΠᵉU : ∀ {ℓ} → (El u → Type ℓ) → Type ℓ
    ΠᵉU = Πᵉ uᵉ

  module Xᴱ = FromExploreInd Xⁱ
  ΣᵉX : ∀ {ℓ} → (X → Type ℓ) → Type ℓ
  ΣᵉX = Σᵉ Xᵉ
  ΠᵉX : ∀ {ℓ} → (X → Type ℓ) → Type ℓ
  ΠᵉX = Πᵉ Xᵉ

  open Adequacy _≡_
  module FromXˢ-ok (Xˢ-ok : Adequate-sum Xᴱ.sum){{_ : UA}}{{_ : FunExt}} where
    adequate-sum : ∀ u → Adequate-sum (sum u)
    adequate-sum 𝟘ᵁ       = 𝟘ˢ-ok
    adequate-sum 𝟙ᵁ       = 𝟙ˢ-ok
    adequate-sum 𝟚ᵁ       = 𝟚ˢ-ok
    adequate-sum (u₀ ×ᵁ u₁) = adequate-sumΣ (adequate-sum u₀) (adequate-sum u₁)
    adequate-sum (u₀ ⊎ᵁ u₁) = adequate-sum⊎ (adequate-sum u₀) (adequate-sum u₁)
    adequate-sum (Σᵁ u f) = adequate-sumΣ (adequate-sum u) (λ {x} → adequate-sum (f x))
    adequate-sum Xᵁ = Xˢ-ok
    adequate-sum (≃ᵁ u A e) = sum-iso-ok e (adequate-sum u)

  module FromXˡ (Xˡ : ∀ {ℓ} → Lookup {ℓ} Xᵉ) where
    lookup : ∀ {ℓ} u → Lookup {ℓ} (explore u)
    lookup 𝟘ᵁ = 𝟘ˡ
    lookup 𝟙ᵁ = 𝟙ˡ
    lookup 𝟚ᵁ = 𝟚ˡ
    lookup (u₀ ×ᵁ u₁) = lookup× {eᴬ = explore u₀} {eᴮ = explore u₁} (lookup u₀) (lookup u₁)
    lookup (u₀ ⊎ᵁ u₁) = lookup⊎ {eᴬ = explore u₀} {eᴮ = explore u₁} (lookup u₀) (lookup u₁)
    lookup (Σᵁ u f) = lookupΣ {eᴬ = explore u} {eᴮ = λ {x} → explore (f x)} (lookup u) (λ {x} → lookup (f x))
    lookup Xᵁ = Xˡ
    lookup (≃ᵁ u A e) = lookup-iso e {Aᵉ = explore u} (lookup u)

  module FromXᶠ (Xᶠ : ∀ {ℓ} → Focus {ℓ} Xᵉ) where
    focus : ∀ {ℓ} u → Focus {ℓ} (explore u)
    focus 𝟘ᵁ = 𝟘ᶠ
    focus 𝟙ᵁ = 𝟙ᶠ
    focus 𝟚ᵁ = 𝟚ᶠ
    focus (u₀ ×ᵁ u₁) = focus× {eᴬ = explore u₀} {eᴮ = explore u₁} (focus u₀) (focus u₁)
    focus (u₀ ⊎ᵁ u₁) = focus⊎ {eᴬ = explore u₀} {eᴮ = explore u₁} (focus u₀) (focus u₁)
    focus (Σᵁ u f) = focusΣ {eᴬ = explore u} {eᴮ = λ {x} → explore (f x)} (focus u) (λ {x} → focus (f x))
    focus Xᵁ = Xᶠ
    focus (≃ᵁ u A e) = focus-iso e {Aᵉ = explore u} (focus u)

  module FromΣᵉX-ok (ΣᵉX-ok : ∀ {ℓ} → Adequate-Σ {ℓ} ΣᵉX){{_ : UA}}{{_ : FunExt}} where
    Σᵉ-ok : ∀ {ℓ} u → Adequate-Σ {ℓ} (ΣᵉU u)
    Σᵉ-ok 𝟘ᵁ       = Σᵉ𝟘-ok
    Σᵉ-ok 𝟙ᵁ       = Σᵉ𝟙-ok
    Σᵉ-ok 𝟚ᵁ       = Σᵉ𝟚-ok
    Σᵉ-ok (u₀ ×ᵁ u) = Σᵉ×-ok {eᴬ = explore u₀} {eᴮ = explore u} (Σᵉ-ok u₀) (Σᵉ-ok u)
    Σᵉ-ok (u₀ ⊎ᵁ u) = Σᵉ⊎-ok {eᴬ = explore u₀} {eᴮ = explore u} (Σᵉ-ok u₀) (Σᵉ-ok u)
    Σᵉ-ok (Σᵁ u f) = ΣᵉΣ-ok {eᴬ = explore u} {eᴮ = λ {x} → explore (f x)} (Σᵉ-ok u) (λ {x} → Σᵉ-ok (f x))
    Σᵉ-ok Xᵁ = ΣᵉX-ok
    Σᵉ-ok (≃ᵁ u A e) = Σ-iso-ok e {Aᵉ = explore u} (Σᵉ-ok u)

  module FromΠᵉX-ok (ΠᵉX-ok : ∀ {ℓ} → Adequate-Π {ℓ} ΠᵉX){{_ : UA}}{{_ : FunExt}} where
    Πᵉ-ok : ∀ {ℓ} u → Adequate-Π {ℓ} (ΠᵉU u)
    Πᵉ-ok 𝟘ᵁ       = Πᵉ𝟘-ok
    Πᵉ-ok 𝟙ᵁ       = Πᵉ𝟙-ok
    Πᵉ-ok 𝟚ᵁ       = Πᵉ𝟚-ok
    Πᵉ-ok (u₀ ×ᵁ u) = Πᵉ×-ok {eᴬ = explore u₀} {eᴮ = explore u} (Πᵉ-ok u₀) (Πᵉ-ok u)
    Πᵉ-ok (u₀ ⊎ᵁ u) = Πᵉ⊎-ok {eᴬ = explore u₀} {eᴮ = explore u} (Πᵉ-ok u₀) (Πᵉ-ok u)
    Πᵉ-ok (Σᵁ u f) = ΠᵉΣ-ok {eᴬ = explore u} {eᴮ = λ {x} → explore (f x)} (Πᵉ-ok u) (λ {x} → Πᵉ-ok (f x))
    Πᵉ-ok Xᵁ = ΠᵉX-ok
    Πᵉ-ok (≃ᵁ u A e) = Π-iso-ok e {Aᵉ = explore u} (Πᵉ-ok u)

module From⟦Xᵉ⟧≡ (⟦Xᵉ⟧≡ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ Xᵉ Xᵉ) {ℓ₀ ℓ₁} ℓᵣ where
  ⟦explore⟧≡ : ∀ u → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ (explore u) (explore u)
  ⟦explore⟧≡ 𝟘ᵁ        = ⟦𝟘ᵉ⟧ {ℓᵣ = ℓᵣ}
  ⟦explore⟧≡ 𝟙ᵁ        = ⟦𝟙ᵉ⟧ {ℓᵣ = ℓᵣ} {_≡_} {idp}
  ⟦explore⟧≡ 𝟚ᵁ        = ⟦𝟚ᵉ⟧ {ℓᵣ = ℓᵣ} {_≡_} {idp} {idp}
  ⟦explore⟧≡ (u₀ ×ᵁ u₁) = ⟦explore×⟧≡ {ℓᵣ = ℓᵣ} (⟦explore⟧≡ u₀) (⟦explore⟧≡ u₁)
  ⟦explore⟧≡ (u₀ ⊎ᵁ u₁) = ⟦explore⊎⟧≡ {ℓᵣ = ℓᵣ} (⟦explore⟧≡ u₀) (⟦explore⟧≡ u₁)
  ⟦explore⟧≡ (Σᵁ u F)  = ⟦exploreΣ⟧≡ {ℓᵣ = ℓᵣ} (⟦explore⟧≡ u) (λ x → ⟦explore⟧≡ (F x))
  ⟦explore⟧≡ Xᵁ        = ⟦Xᵉ⟧≡ ℓᵣ
  ⟦explore⟧≡ (≃ᵁ u A e) = ⟦explore-iso⟧ e {ℓᵣ = ℓᵣ} (ap (fst e)) (⟦explore⟧≡ u)

module FromΠX (ΠX : (X → U) → U) where
  Πᵁ : (u : U) (v : El u → U) → U
  Πᵁ 𝟘ᵁ        v = 𝟙ᵁ
  Πᵁ 𝟙ᵁ        v = v _
  Πᵁ 𝟚ᵁ        v = v 0₂ ×ᵁ v 1₂
  Πᵁ (u ×ᵁ u₁) v = Πᵁ u λ x → Πᵁ u₁ λ y → v (x , y)
  Πᵁ (u ⊎ᵁ u₁) v = (Πᵁ u (v ∘ inl)) ×ᵁ (Πᵁ u₁ (v ∘ inr))
  Πᵁ (Σᵁ u f)  v = Πᵁ u λ x → Πᵁ (f x) (v ∘ _,_ x)
  Πᵁ Xᵁ        v = ΠX v
  Πᵁ (≃ᵁ u A e)v = Πᵁ u (v ∘ fst e)

  _→ᵁ_ : (u : U) (v : U) → U
  u →ᵁ v = Πᵁ u (const v)

  module FromΠX≃ (ΠX≃ : ∀ v → El (ΠX v) ≃ Π X (El ∘ v)) where
    private
      module ΠX≃ {v} = Equivalences.Equiv (ΠX≃ v)

    module _ {{_ : FunExt}}{{_ : UA}} where
      Πᵁ-Π : ∀ u v → El (Πᵁ u v) ≡ Π (El u) (El ∘ v)
      Πᵁ-Π 𝟘ᵁ        v = ! Π𝟘-uniq₀ _
      Πᵁ-Π 𝟙ᵁ        v = ! Π𝟙-uniq _
      Πᵁ-Π 𝟚ᵁ        v = ! Π𝟚-×
      Πᵁ-Π (u ×ᵁ u₁) v = Πᵁ-Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π u₁ _) ∙ ! ΠΣ-curry
      Πᵁ-Π (u ⊎ᵁ u₁) v = ×= (Πᵁ-Π u (v ∘ inl)) (Πᵁ-Π u₁ (v ∘ inr)) ∙ ! dist-×-Π
      Πᵁ-Π (Σᵁ u f)  v = Πᵁ-Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π (f _) _) ∙ ! ΠΣ-curry
      Πᵁ-Π Xᵁ        v = ua (ΠX≃ v)
      Πᵁ-Π (≃ᵁ u A e)v = Πᵁ-Π u (v ∘ fst e) ∙ Π≃ e λ _ → idp

      →ᵁ-→ : ∀ u v → El (u →ᵁ v) ≡ (El u → El v)
      →ᵁ-→ u v = Πᵁ-Π u (const v)

    Πᵁ→Π : ∀ u v → El (Πᵁ u v) → Π (El u) (El ∘ v)
    Πᵁ→Π 𝟘ᵁ v x₂ ()
    Πᵁ→Π 𝟙ᵁ v x₂ x₃ = x₂
    Πᵁ→Π 𝟚ᵁ v (x , y) 0₂ = x
    Πᵁ→Π 𝟚ᵁ v (x , y) 1₂ = y
    Πᵁ→Π (u ×ᵁ u₁) v x (z , t) = Πᵁ→Π u₁ (v ∘ _,_ z) (Πᵁ→Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) x z) t
    Πᵁ→Π (u ⊎ᵁ _) v (x , _) (inl y) = Πᵁ→Π u (v ∘ inl) x y
    Πᵁ→Π (_ ⊎ᵁ u) v (_ , x) (inr y) = Πᵁ→Π u (v ∘ inr) x y
    Πᵁ→Π (Σᵁ u f) v x       (y , z) = Πᵁ→Π (f _) (v ∘ _,_ y) (Πᵁ→Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) x y) z
    Πᵁ→Π Xᵁ v = ΠX≃.·→
    Πᵁ→Π (≃ᵁ u A e) v f x = tr (El ∘ v) (·←-inv-r x) (Πᵁ→Π u (v ∘ ·→) f (·← x))
      where open Equivalences.Equiv e

    Π→Πᵁ : ∀ u v → Π (El u) (El ∘ v) → El (Πᵁ u v)
    Π→Πᵁ 𝟘ᵁ v f = 0₁
    Π→Πᵁ 𝟙ᵁ v f = f 0₁
    Π→Πᵁ 𝟚ᵁ v f = f 0₂ , f 1₂
    Π→Πᵁ (u ×ᵁ u₁) v f = Π→Πᵁ u (λ x → Πᵁ u₁ (v ∘ _,_ x))
                           (λ x → Π→Πᵁ u₁ (v ∘ _,_ x) (f ∘ _,_ x))
    Π→Πᵁ (u ⊎ᵁ u₁) v f = Π→Πᵁ u (v ∘ inl) (f ∘ inl) ,
                           Π→Πᵁ u₁ (v ∘ inr) (f ∘ inr)
    Π→Πᵁ (Σᵁ u F) v f = Π→Πᵁ u (λ x → Πᵁ (F x) (v ∘ _,_ x))
                          (λ x → Π→Πᵁ (F x) (v ∘ _,_ x) (f ∘ _,_ x))
    Π→Πᵁ Xᵁ v = ΠX≃.·←
    Π→Πᵁ (≃ᵁ u A e) v f = Π→Πᵁ u (v ∘ ·→) (f ∘ ·→)
      where open Equivalences.Equiv e

    →ᵁ→→ : ∀ u v → El (u →ᵁ v) → (El u → El v)
    →ᵁ→→ u v = Πᵁ→Π u (const v)

    →→→ᵁ : ∀ u v → (El u → El v) → El (u →ᵁ v)
    →→→ᵁ u v = Π→Πᵁ u (const v)


mutual

  record R : Set₁ where
    field
      A : Set

    B : Set
    B = A

    field
      C : Set

    D : Set
    D = A → B → C

  record S : Set₁ where
    field
      A : Set

    B : Set
    B = A

    field
      C : Set

    D : Set
    D = A → B → C


module FSC where

-- focused sequent calculus

{-
open import Relation.Binary.PropositionalEquality
open import Data.Nat hiding (_>_)
-}

open import StdLibStuff

open import Syntax

data FSC-Ctx (n : ℕ) : Ctx n → Set where
 ε : FSC-Ctx n ε
 _∷_ : {Γ : Ctx n} → (t : Type n) → FSC-Ctx n Γ → FSC-Ctx n (t ∷ Γ)
 _∷h_ : {Γ : Ctx n} → Form Γ $o → FSC-Ctx n Γ → FSC-Ctx n Γ

data HVar {n : ℕ} : {Γ-t : Ctx n} → FSC-Ctx n Γ-t → Set where
 zero : {Γ-t : Ctx n} {h : Form Γ-t $o} {Γ : FSC-Ctx n Γ-t} → HVar (h ∷h Γ)
 succ : {Γ-t : Ctx n} {h : Form Γ-t $o} {Γ : FSC-Ctx n Γ-t} → HVar Γ → HVar (h ∷h Γ)
 skip : {Γ-t : Ctx n} {t : Type n} {Γ : FSC-Ctx n Γ-t} → HVar Γ → HVar (t ∷ Γ)

lookup-hyp : {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) → HVar Γ → Form Γ-t $o
lookup-hyp .(h ∷h Γ) (zero {._} {h} {Γ}) = h
lookup-hyp .(h ∷h Γ) (succ {._} {h} {Γ} x) = lookup-hyp Γ x
lookup-hyp .(t ∷ Γ) (skip {Γ-t} {t} {Γ} x) = weak (lookup-hyp Γ x)

mutual
 data _⊢_ {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) : Form Γ-t $o → Set where
  ||-I-l : {F G : Form Γ-t $o} →
         Γ ⊢ F →
         Γ ⊢ (F || G)
  ||-I-r : {F G : Form Γ-t $o} →
         Γ ⊢ G →
         Γ ⊢ (F || G)
  &-I : {F G : Form Γ-t $o} →
         Γ ⊢ F →   Γ ⊢ G →
         Γ ⊢ (F & G)
  ?-I : {t : Type n} {F : Form (t ∷ Γ-t) $o}
   (G : Form Γ-t t) →
   Γ ⊢ sub G F →
   Γ ⊢ (?[ t ] F)
  ?'-I : {t : Type n} {F : Form Γ-t (t > $o)}
   (G : Form Γ-t t) →
   Γ ⊢ (F · G) →
   Γ ⊢ (?'[ t ] F)
  =>-I : {F G : Form Γ-t $o} →
        (F ∷h Γ) ⊢ G →
        Γ ⊢ (F => G)
  ~-I : {F : Form Γ-t $o} →
        (F ∷h Γ) ⊢ $false →
        Γ ⊢ (~ F)
  !-I : {t : Type n} {F : Form (t ∷ Γ-t) $o} →
   (t ∷ Γ) ⊢ F →
   Γ ⊢ (![ t ] F)
  !'-I : {t : Type n} {F : Form Γ-t (t > $o)} →
   (t ∷ Γ) ⊢ (weak F · ($ this {refl})) →
   Γ ⊢ (!'[ t ] F)
  $true-I :
   Γ ⊢ $true
  ==-I : {t : Type n} {F G : Form Γ-t t} →
   Γ ⊢ t ∋ F == G →
   Γ ⊢ (F == G)  -- compute eq

  elim : {F : Form Γ-t $o} →
   (x : HVar Γ) →
   Γ , lookup-hyp Γ x ⊢ F →
   Γ ⊢ F
  ac : {t : Type n} {F : Form Γ-t $o} →
   Γ , (![ t > $o ] ((?[ t ] ($ (next this) {refl} · $ this {refl})) => ($ this {refl} · (ι t ($ (next this) {refl} · $ this {refl}))))) ⊢ F →
   Γ ⊢ F
  ac' : {t : Type n} {F : Form Γ-t $o} →
   Γ , (![ t > $o ] ((?'[ t ] ($ this {refl})) => ($ this {refl} · (ι' t ($ this {refl}))))) ⊢ F →
   Γ ⊢ F

  raa : {F : Form Γ-t $o} →
   Γ ⊢ (~ (~ F)) →
   Γ ⊢ F

  reduce : {t u : Type n} {F : Form Γ-t u → Form Γ-t $o} {G : Form (t ∷ Γ-t) u} {H : Form Γ-t t} →
   Γ ⊢ (F (sub H G)) →
   Γ ⊢ (F ((^[ t ] G) · H))

 data _,_⊢_ {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) : Form Γ-t $o → Form Γ-t $o → Set where
  use : {F G : Form Γ-t $o} →
   Γ ⊢ $o ∋ G ↔ F →
   Γ , F ⊢ G
  $false-E : {H : Form Γ-t $o} →
   Γ , $false ⊢ H
  ~-E : {F H : Form Γ-t $o} →
   Γ ⊢ F →
   Γ , ~ F ⊢ H
  ||-E : {F G H : Form Γ-t $o} →
   Γ ⊢ (F => H) →
   Γ ⊢ (G => H) →
   Γ , F || G ⊢ H

  &-E-l : {F G H : Form Γ-t $o} →
   Γ , F ⊢ H →
   Γ , F & G ⊢ H
  &-E-r : {F G H : Form Γ-t $o} →
   Γ , G ⊢ H →
   Γ , F & G ⊢ H
  ?-E : {t : Type n} {F : Form (t ∷ Γ-t) $o} {H : Form Γ-t $o} →
   Γ , sub (ι t F) F ⊢ H →
   Γ , ?[ t ] F ⊢ H
  ?'-E : {t : Type n} {F : Form Γ-t (t > $o)} {H : Form Γ-t $o} →
   Γ , (F · ι' t F) ⊢ H →
   Γ , ?'[ t ] F ⊢ H
  =>-E : {F G H : Form Γ-t $o} →
   Γ ⊢ F →
   Γ , G ⊢ H →
   Γ , F => G ⊢ H
  !-E : {t : Type n} {F : Form (t ∷ Γ-t) $o} {H : Form Γ-t $o}
   (G : Form Γ-t t) →
   Γ , sub G F ⊢ H →
   Γ , ![ t ] F ⊢ H
  !'-E : {t : Type n} {F : Form Γ-t (t > $o)} {H : Form Γ-t $o}
   (G : Form Γ-t t) →
   Γ , (F · G) ⊢ H →
   Γ , !'[ t ] F ⊢ H
  r-bool-ext : {F G H : Form Γ-t $o} →
   Γ , ((F => G) & (G => F)) ⊢ H →
   Γ , F == G ⊢ H  -- compute eq
  r-fun-ext : {t u : Type n} {F G : Form Γ-t (t > u)} {H : Form Γ-t $o}
   (I : Form Γ-t t) →
   Γ , (F · I) == (G · I) ⊢ H →
   Γ , F == G ⊢ H  -- compute eq

  reduce : {t u : Type n} {F : Form Γ-t u → Form Γ-t $o} {G : Form (t ∷ Γ-t) u} {H : Form Γ-t t} {I : Form Γ-t $o} →
   Γ , (F (sub H G)) ⊢ I →
   Γ , (F ((^[ t ] G) · H)) ⊢ I

 data _⊢_∋_==_ {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) : (t : Type n) (F G : Form Γ-t t) → Set where
  simp : {t : Type n} {F G : Form Γ-t t} →
   Γ ⊢ t ∋ F ↔ G →
   Γ ⊢ t ∋ F == G
  step : {t : Type n} {F G : Form Γ-t t} (F' G' : Form Γ-t t) →
   (x : HVar Γ) →
   Γ , lookup-hyp Γ x ⊢ F' == G' →
   Γ ⊢ t ∋ F ↔ F' →
   Γ ⊢ t ∋ G' == G →
   Γ ⊢ t ∋ F == G
  bool-ext :  {F G : Form Γ-t $o} →
   Γ ⊢ ((F => G) & (G => F)) →
   Γ ⊢ $o ∋ F == G
  fun-ext : {t u : Type n} {F G : Form Γ-t (t > u)} →
   (t ∷ Γ) ⊢ u ∋ ((weak F) · $ this {refl}) == ((weak G) · $ this {refl}) →
   Γ ⊢ (t > u) ∋ F == G

 data _⊢_∋_↔_ {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) : (t : Type n) → Form Γ-t t → Form Γ-t t → Set where
  head-var : (t : Type n) (x : Var Γ-t) (p : lookup-Var Γ-t x ≡ t) →
   Γ ⊢ t ∋ $ x {p} ↔ $ x {p}
  head-const : (t : Type n) (c : Form Γ-t t) →
   Γ ⊢ t ∋ c ↔ c
  head-app : (t₁ t₂ : Type n) (F₁ F₂ : Form Γ-t (t₁ > t₂)) (G₁ G₂ : Form Γ-t t₁) →
   Γ ⊢ (t₁ > t₂) ∋ F₁ == F₂ → Γ ⊢ t₁ ∋ G₁ == G₂ →
   Γ ⊢ t₂ ∋ (F₁ · G₁) ↔ (F₂ · G₂)
  head-lam : (t₁ t₂ : Type n) (F₁ F₂ : Form (t₁ ∷ Γ-t) t₂) →
   (t₁ ∷ Γ) ⊢ t₂ ∋ F₁ == F₂ →
   Γ ⊢ (t₁ > t₂) ∋ (lam t₁ F₁) ↔ (lam t₁ F₂)
  head-lam-eta-left : (t₁ t₂ : Type n) (F₁ : Form Γ-t (t₁ > t₂)) (F₂ : Form (t₁ ∷ Γ-t) t₂) →
   (t₁ ∷ Γ) ⊢ t₂ ∋ (weak F₁ · $ this {refl}) == F₂ →
   Γ ⊢ (t₁ > t₂) ∋ F₁ ↔ lam t₁ F₂
  head-lam-eta-right : (t₁ t₂ : Type n) (F₁ : Form Γ-t (t₁ > t₂)) (F₂ : Form (t₁ ∷ Γ-t) t₂) →
   (t₁ ∷ Γ) ⊢ t₂ ∋ F₂ == (weak F₁ · $ this {refl}) →
   Γ ⊢ (t₁ > t₂) ∋ lam t₁ F₂ ↔ F₁

  reduce-l : {t u v : Type n} {F₁ : Form Γ-t v → Form Γ-t t} {G : Form (u ∷ Γ-t) v} {H : Form Γ-t u} {F₂ : Form Γ-t t} →
   Γ ⊢ t ∋ (F₁ (sub H G)) ↔ F₂ →
   Γ ⊢ t ∋ (F₁ ((^[ u ] G) · H)) ↔ F₂
  reduce-r : {t u v : Type n} {F₂ : Form Γ-t v → Form Γ-t t} {G : Form (u ∷ Γ-t) v} {H : Form Γ-t u} {F₁ : Form Γ-t t} →
   Γ ⊢ t ∋ F₁ ↔ (F₂ (sub H G)) →
   Γ ⊢ t ∋ F₁ ↔ (F₂ ((^[ u ] G) · H))

 data _,_⊢_==_ {n : ℕ} {Γ-t : Ctx n} {t : Type n} (Γ : FSC-Ctx n Γ-t) : Form Γ-t $o → Form Γ-t t → Form Γ-t t → Set where
  use : {F G : Form Γ-t t} →
   Γ , F == G ⊢ F == G
  use' : {F G : Form Γ-t t} {H : Form Γ-t $o} →
   headNorm 2 (F == G) ≡ headNorm 2 H →
   Γ , H ⊢ F == G
  use-sym : {F G : Form Γ-t t} →
   Γ , F == G ⊢ G == F  -- compute eq

  &-E-l : {F G : Form Γ-t $o} {H₁ H₂ : Form Γ-t t} →
   Γ , F ⊢ H₁ == H₂ →
   Γ , F & G ⊢ H₁ == H₂
  &-E-r : {F G : Form Γ-t $o} {H₁ H₂ : Form Γ-t t} →
   Γ , G ⊢ H₁ == H₂ →
   Γ , F & G ⊢ H₁ == H₂
  ?-E : {u : Type n} {F : Form (u ∷ Γ-t) $o} {H₁ H₂ : Form Γ-t t} →
   Γ , sub (ι u F) F ⊢ H₁ == H₂ →
   Γ , ?[ u ] F ⊢ H₁ == H₂
  ?'-E : {u : Type n} {F : Form Γ-t (u > $o)} {H₁ H₂ : Form Γ-t t} →
   Γ , (F · ι' u F) ⊢ H₁ == H₂ →
   Γ , ?'[ u ] F ⊢ H₁ == H₂
  =>-E : {F G : Form Γ-t $o} {H₁ H₂ : Form Γ-t t} →
   Γ ⊢ F →
   Γ , G ⊢ H₁ == H₂ →
   Γ , F => G ⊢ H₁ == H₂
  !-E : {u : Type n} {F : Form (u ∷ Γ-t) $o} {H₁ H₂ : Form Γ-t t}
   (G : Form Γ-t u) →
   Γ , sub G F ⊢ H₁ == H₂ →
   Γ , ![ u ] F ⊢ H₁ == H₂
  !'-E : {u : Type n} {F : Form Γ-t (u > $o)} {H₁ H₂ : Form Γ-t t}
   (G : Form Γ-t u) →
   Γ , (F · G) ⊢ H₁ == H₂ →
   Γ , !'[ u ] F ⊢ H₁ == H₂
  r-bool-ext : {F G : Form Γ-t $o} {H I : Form Γ-t t} →
   Γ , ((F => G) & (G => F)) ⊢ H == I →
   Γ , F == G ⊢ H == I  -- compute eq
  r-fun-ext : {u v : Type n} {F G : Form Γ-t (u > v)} {H I : Form Γ-t t}
   (J : Form Γ-t u) →
   Γ , (F · J) == (G · J) ⊢ H == I →
   Γ , F == G ⊢ H == I  -- compute eq

  reduce : {u v : Type n} {F : Form Γ-t v → Form Γ-t $o} {G : Form (u ∷ Γ-t) v} {H : Form Γ-t u} {I₁ I₂ : Form Γ-t t} →
   Γ , (F (sub H G)) ⊢ I₁ == I₂ →
   Γ , (F ((^[ u ] G) · H)) ⊢ I₁ == I₂


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

-- Let us assume that extensionality of functions cannot be proved
-- inside "plain" Agda. In that case the code below shows that the
-- REWRITE functionality is not a conservative extension, even if we
-- only use propositional equality as the rewriting relation, and do
-- not use any postulates.

-- Jesper, 2019-05-13: This example is not confluent!

module RewriteExt-confluence where

open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

data Unit : Set where
  unit : Unit

module _ {a b} {A : Set a} {B : A → Set b} {f g : (x : A) → B x}
         (f≡g : ∀ x → f x ≡ g x) where

  private

    id : Unit → (x : A) → B x → B x
    id unit _ x = x

    f≡g′ : ∀ u x → id u x (f x) ≡ g x
    f≡g′ unit = f≡g

    {-# REWRITE f≡g′ #-}

    ext′ : ∀ u → (λ x → id u x (f x)) ≡ g
    ext′ u = refl

  ext : f ≡ g
  ext = ext′ unit


------------------------------------------------------------------------
-- Encoder and decoder instances for Atom.χ-ℕ-atoms
------------------------------------------------------------------------

module Coding.Instances.Nat where

open import Atom

-- The code-Var and code-Const instances are hidden: they are replaced
-- by the code-ℕ instance.

open import Coding.Instances χ-ℕ-atoms public
  hiding (rep-Var; rep-Const)


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

module LibraBFT.Impl.Base.Types where
  open import LibraBFT.Prelude
  open import LibraBFT.Hash

  NodeId : Set
  NodeId = ℕ

  _≟NodeId_ : (n1 n2 : NodeId) → Dec (n1 ≡ n2)
  _≟NodeId_ = _≟ℕ_

  UID : Set
  UID = Hash

  _≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁)
  _≟UID_ = _≟Hash_


module Test where

open import IO using (run; putStrLn)
import IO.Primitive as Prim using (IO)
open import Data.Nat.Show as Nat using (show)
open import Data.Unit using (⊤)

open import Vector

main : Prim.IO ⊤
main = run (putStrLn (Nat.show (length gravity₂)))


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

-- In this module, we define the syntax of D<:
module DsubDef where

open import Data.List as List
open import Data.List.All
open import Data.Nat as ℕ
open import Data.Maybe as Maybe
open import Data.Product
open import Data.Sum
open import Data.Empty renaming (⊥ to False)
open import Function

open import Data.Nat.Properties as ℕₚ
open import Data.Maybe.Properties as Maybeₚ
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Utils

infix 8 _∙A
infix 6 Π_∙_ ⟨A:_⋯_⟩

-- Types
--
-- Notations in Agda should be more readable than in Coq.
-- * ⊤ is a supertype of all types.
-- * ⊥ is a subtype of all types.
-- * (x ∙A) represents a path dependent type (x.A).
-- * (Π S ∙ U) represents a dependent function type (∀(x : S)U).
-- * (⟨A: S ⋯ U ⟩) represents a type declaration ({A : S .. U}).
data Typ : Set where
  ⊤       : Typ
  ⊥       : Typ
  _∙A     : (n : ℕ) → Typ
  Π_∙_    : (S U : Typ) → Typ
  ⟨A:_⋯_⟩ : (S U : Typ) → Typ

-- typing context
Env : Set
Env = List Typ

-- shifting operation of de Bruijn indices
infixl 7 _↑_
_↑_ : Typ → ℕ → Typ
⊤ ↑ n           = ⊤
⊥ ↑ n           = ⊥
(x ∙A) ↑ n with n ≤? x
... | yes n≤x   = suc x ∙A
... | no n>x    = x ∙A
(Π S ∙ U) ↑ n   = Π S ↑ n ∙ U ↑ suc n
⟨A: S ⋯ U ⟩ ↑ n = ⟨A: S ↑ n ⋯ U ↑ n ⟩

-- The remaining are technical setup.
infix 4 _↦_∈_
data _↦_∈_ : ℕ → Typ → Env → Set where
  hd : ∀ {T Γ} → 0 ↦ T ↑ 0 ∈ T ∷ Γ
  tl : ∀ {n T T′ Γ} → n ↦ T ∈ Γ → suc n ↦ T ↑ 0 ∈ T′ ∷ Γ

env-lookup : Env → ℕ → Maybe Typ
env-lookup Γ n = Maybe.map (repeat (suc n) (_↑ 0)) (lookupOpt Γ n)

↦∈⇒lookup : ∀ {x T Γ} → x ↦ T ∈ Γ → env-lookup Γ x ≡ just T
↦∈⇒lookup hd = refl
↦∈⇒lookup {x} {_} {Γ} (tl T∈Γ) with lookupOpt Γ x | ↦∈⇒lookup T∈Γ
... | just T′ | eq = cong (just ∘ (_↑ zero)) (just-injective eq)
... | nothing | ()

lookup⇒↦∈ : ∀ {x T Γ} → env-lookup Γ x ≡ just T → x ↦ T ∈ Γ
lookup⇒↦∈ {x} {_} {[]} ()
lookup⇒↦∈ {zero} {_} {T ∷ Γ} refl = hd
lookup⇒↦∈ {suc x} {_} {T ∷ Γ} eq with lookupOpt Γ x | λ {T} → lookup⇒↦∈ {x} {T} {Γ}
lookup⇒↦∈ refl | just T′ | rec = tl $ rec refl
lookup⇒↦∈ ()   | nothing | _

⟨A:⟩-injective : ∀ {S U S′ U′} → ⟨A: S ⋯ U ⟩ ≡ ⟨A: S′ ⋯ U′ ⟩ → S ≡ S′ × U ≡ U′
⟨A:⟩-injective refl = refl , refl

↑-idx : ℕ → ℕ → ℕ
↑-idx x n with n ≤? x
... | yes p = suc x
... | no ¬p = x

↑-var : ∀ x n → x ∙A ↑ n ≡ ↑-idx x n ∙A
↑-var x n with n ≤? x
... | yes p = refl
... | no ¬p = refl

↑-↑-comm : ∀ T m n → m ≤ n → T ↑ m ↑ suc n ≡ T ↑ n ↑ m
↑-↑-comm ⊤ m n m≤n                                  = refl
↑-↑-comm ⊥ m n m≤n                                  = refl
↑-↑-comm (x ∙A) m n m≤n with n ≤? x
... | yes n≤x
    rewrite ≤?-yes (≤-trans m≤n n≤x)
          | ≤?-yes n≤x
          | ≤?-yes (≤-step (≤-trans m≤n n≤x))       = refl
... | no n>x with m ≤? x
...             | yes m≤x rewrite proj₂ $ ≤?-no n>x = refl
...             | no m>x with suc n ≤? x
...                         | yes 1+n≤x             = ⊥-elim (m>x (≤-trans (≤-step m≤n) 1+n≤x))
...                         | no 1+n>x              = refl
↑-↑-comm (Π S ∙ U) m n m≤n
  rewrite ↑-↑-comm S m n m≤n
        | ↑-↑-comm U (suc m) (suc n) (s≤s m≤n)      = refl
↑-↑-comm ⟨A: S ⋯ U ⟩ m n m≤n
  rewrite ↑-↑-comm S m n m≤n | ↑-↑-comm U m n m≤n   = refl

-- These two judgments are about to capture the characteristics of the image of
-- interpretation functions from F<:⁻ to D<:.
--
-- Covar quantifies the types in D<: which appears in the covariant positions in the
-- image of the interpretation function.
data Covar : Typ → Set where
  cv⊤  : Covar ⊤
  cv∙A : ∀ n → Covar (n ∙A)
  cvΠ  : ∀ {S U} → Covar S → Covar U → Covar (Π ⟨A: ⊥ ⋯ S ⟩ ∙ U)

-- Contra quantifies the types in D<: which appears in the contravariant positions in
-- the image of the interpretation function.
data Contra : Typ → Set where
  ctt : ∀ {T} → Covar T → Contra ⟨A: ⊥ ⋯ T ⟩

ContraEnv : Env → Set
ContraEnv = All Contra

↑-Covar : ∀ {T} n → Covar T → Covar (T ↑ n)
↑-Covar n cv⊤       = cv⊤
↑-Covar n (cv∙A x)
  rewrite ↑-var x n = cv∙A _
↑-Covar n (cvΠ S U) = cvΠ (↑-Covar n S) (↑-Covar (suc n) U)

↑-Contra : ∀ {T} n → Contra T → Contra (T ↑ n)
↑-Contra n (ctt T) = ctt (↑-Covar n T)

↑-injective : ∀ {S U n} → S ↑ n ≡ U ↑ n → S ≡ U
↑-injective {⊤} {⊤} {n} eq = refl
↑-injective {⊤} {⊥} {n} ()
↑-injective {⊤} {x ∙A} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {⊤} {Π S ∙ U} {n} ()
↑-injective {⊤} {⟨A: S ⋯ U ⟩} {n} ()
↑-injective {⊥} {⊤} {n} ()
↑-injective {⊥} {⊥} {n} eq = refl
↑-injective {⊥} {x ∙A} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {⊥} {Π S ∙ U} {n} ()
↑-injective {⊥} {⟨A: S ⋯ U ⟩} {n} ()
↑-injective {x ∙A} {⊤} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {x ∙A} {⊥} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {x ∙A} {y ∙A} {n} eq
  with n ≤? x | n ≤? y
↑-injective {x ∙A} {y ∙A} {n} refl
    | yes n≤x | yes n≤y    = refl
↑-injective {x ∙A} {y ∙A} {n} refl
    | yes n≤x | no n>y     = ⊥-elim (n>y (≤-step n≤x))
↑-injective {x ∙A} {y ∙A} {n} refl
    | no n>x  | yes n≤y    = ⊥-elim (n>x (≤-step n≤y))
↑-injective {x ∙A} {y ∙A} {n} refl
    | no n>x  | no n>y     = refl
↑-injective {x ∙A} {Π S ∙ U} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {x ∙A} {⟨A: S ⋯ U ⟩} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {Π S ∙ U} {⊤} {n} ()
↑-injective {Π S ∙ U} {⊥} {n} ()
↑-injective {Π S ∙ U} {x ∙A} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {Π S ∙ U} {Π S′ ∙ U′} {n} eq
  with S ↑ n | U ↑ suc n | S′ ↑ n | U′ ↑ suc n
     | ↑-injective {S} {S′} {n} | ↑-injective {U} {U′} {suc n}
...  | _ | _ | _ | _ | rec₁ | rec₂
     with eq
...     | refl             = cong₂ Π_∙_ (rec₁ refl) (rec₂ refl)
↑-injective {Π S ∙ U} {⟨A: _ ⋯ _ ⟩} {n} ()
↑-injective {⟨A: S ⋯ U ⟩} {⊤} {n} ()
↑-injective {⟨A: S ⋯ U ⟩} {⊥} {n} ()
↑-injective {⟨A: S ⋯ U ⟩} {x ∙A} {n} eq
  rewrite ↑-var x n        = case eq of λ ()
↑-injective {⟨A: S ⋯ U ⟩} {Π _ ∙ _} {n} ()
↑-injective {⟨A: S ⋯ U ⟩} {⟨A: S′ ⋯ U′ ⟩} {n} eq
  with S ↑ n | U ↑ n | S′ ↑ n | U′ ↑ n
     | ↑-injective {S} {S′} {n} | ↑-injective {U} {U′} {n}
...  | _ | _ | _ | _ | rec₁ | rec₂
     with eq
...     | refl             = cong₂ ⟨A:_⋯_⟩ (rec₁ refl) (rec₂ refl)

↑-⊥-inv : ∀ {S n} → S ↑ n ≡ ⊥ → S ≡ ⊥
↑-⊥-inv {⊤} {n} ()
↑-⊥-inv {⊥} {n} refl = refl
↑-⊥-inv {x ∙A} {n} eq
  rewrite ↑-var x n  = case eq of λ ()
↑-⊥-inv {Π _ ∙ _} {n} ()
↑-⊥-inv {⟨A: _ ⋯ _ ⟩} {n} ()

⟨A:⟩-↑-inv : ∀ {T n S U} → ⟨A: S ⋯ U ⟩ ≡ T ↑ n → ∃₂ λ S′ U′ → T ≡ ⟨A: S′ ⋯ U′ ⟩ × S ≡ S′ ↑ n × U ≡ U′ ↑ n
⟨A:⟩-↑-inv {⊤} ()
⟨A:⟩-↑-inv {⊥} ()
⟨A:⟩-↑-inv {x ∙A} {n} eq
  rewrite ↑-var x n             = case eq of λ ()
⟨A:⟩-↑-inv {Π _ ∙ _} ()
⟨A:⟩-↑-inv {⟨A: S′ ⋯ U′ ⟩} refl = S′ , U′ , refl , refl , refl

↦∈ContraEnv : ∀ {Γ n T} → n ↦ T ∈ Γ → ContraEnv Γ → Contra T
↦∈ContraEnv hd (T ∷ cT)       = ↑-Contra 0 T
↦∈ContraEnv (tl T∈Γ) (_ ∷ cT) = ↑-Contra 0 (↦∈ContraEnv T∈Γ cT)

lookupContraEnv : ∀ {Γ n T} → env-lookup Γ n ≡ just T → ContraEnv Γ → Contra T
lookupContraEnv lk cT = ↦∈ContraEnv (lookup⇒↦∈ lk) cT

lookupContraBot : ∀ {Γ n} → ContraEnv Γ → ¬ env-lookup Γ n ≡ just ⊥
lookupContraBot all eq with lookupContraEnv eq all
... | ()

lookupContraBndBot : ∀ {Γ n S} → ContraEnv Γ → ¬ env-lookup Γ n ≡ just ⟨A: S ⋯ ⊥ ⟩
lookupContraBndBot all eq with lookupContraEnv eq all
... | ctt ()

lookupContraBndBnd : ∀ {Γ n T S U} → ContraEnv Γ →
                       ¬ env-lookup Γ n ≡ just ⟨A: T ⋯ ⟨A: S ⋯ U ⟩ ⟩
lookupContraBndBnd all eq with lookupContraEnv eq all
... | ctt ()

lookupContra⊥Lb : ∀ {Γ n S U} → ContraEnv Γ →
                    env-lookup Γ n ≡ just ⟨A: S ⋯ U ⟩ → S ≡ ⊥
lookupContra⊥Lb all eq with lookupContraEnv eq all
... | ctt _ = refl

Typ-measure : Typ → ℕ
Typ-measure ⊤           = 1
Typ-measure ⊥           = 1
Typ-measure (_ ∙A)      = 2
Typ-measure (Π S ∙ U)   = 1 + Typ-measure S + Typ-measure U
Typ-measure ⟨A: S ⋯ U ⟩ = 1 + Typ-measure S + Typ-measure U

Typ-measure-↑ : ∀ T n → Typ-measure (T ↑ n) ≡ Typ-measure T
Typ-measure-↑ ⊤ n                 = refl
Typ-measure-↑ ⊥ n                 = refl
Typ-measure-↑ (x ∙A) n
  rewrite ↑-var x n               = refl
Typ-measure-↑ (Π S ∙ U) n
  rewrite Typ-measure-↑ S n
        | Typ-measure-↑ U (suc n) = refl
Typ-measure-↑ ⟨A: S ⋯ U ⟩ n
  rewrite Typ-measure-↑ S n
        | Typ-measure-↑ U n       = refl

-- Definition of Invertible Contexts
--
-- As per Definition 9, we define a predicate for invertible contexts.
record InvertibleEnv (P : Env → Set) : Set where
  field
    no-⊥       : ∀ {Γ n} → P Γ → ¬ env-lookup Γ n ≡ just ⊥
    no-bnd-⊥   : ∀ {Γ n S} → P Γ → ¬ env-lookup Γ n ≡ just ⟨A: S ⋯ ⊥ ⟩
    no-bnd-bnd : ∀ {Γ n T S U} → P Γ → ¬ env-lookup Γ n ≡ just ⟨A: T ⋯ ⟨A: S ⋯ U ⟩ ⟩
    ⊥-lb       : ∀ {Γ n S U} → P Γ → env-lookup Γ n ≡ just ⟨A: S ⋯ U ⟩ → S ≡ ⊥

contraInvertible : InvertibleEnv ContraEnv
contraInvertible = record
  { no-⊥       = lookupContraBot
  ; no-bnd-⊥   = lookupContraBndBot
  ; no-bnd-bnd = lookupContraBndBnd
  ; ⊥-lb       = lookupContra⊥Lb
  }

-- Properties of Invertible Contexts
--
-- Just by knowing the contexts being invertible, we can already derive many
-- properties of D<:. In the following module, we show that in invertible contexts,
-- inversion properties are recovered. For technical reasons, we leave the subtyping
-- judgment open in order to accomodate multiple definition of subtyping in D<:.
--
-- These properties are discussed in Section 4.4.
module InvertibleProperties {P : Env → Set}
                            (invertible : InvertibleEnv P)
                            (_⊢_<:_ : Env → Typ → Typ → Set) where
  open InvertibleEnv invertible public

  -- We define <:ᵢ to describe a fragment of <: under the restriction of invertible contexts.
  infix 4 _⊢ᵢ_<:_
  data _⊢ᵢ_<:_ : Env → Typ → Typ → Set where
    ditop   : ∀ {Γ T} → Γ ⊢ᵢ T <: ⊤
    dibot   : ∀ {Γ T} → Γ ⊢ᵢ ⊥ <: T
    direfl  : ∀ {Γ T} → Γ ⊢ᵢ T <: T
    ditrans : ∀ {Γ S U} T →
                (S<:T : Γ ⊢ᵢ S <: T) →
                (T<:U : Γ ⊢ᵢ T <: U) →
                Γ ⊢ᵢ S <: U
    dibnd   : ∀ {Γ S U S′ U′} →
                (S′<:S : Γ ⊢ᵢ S′ <: S) →
                (U<:U′ : Γ ⊢ᵢ U <: U′) →
                Γ ⊢ᵢ ⟨A: S ⋯ U ⟩ <: ⟨A: S′ ⋯ U′ ⟩
    diall   : ∀ {Γ S U S′ U′} →
                (S′<:S : Γ ⊢ᵢ S′ <: S) →
                (U<:U′ : (Γ ‣ S′ !) ⊢ U <: U′) →
                Γ ⊢ᵢ Π S ∙ U <: Π S′ ∙ U′
    disel   : ∀ {Γ n U} →
                (T∈Γ : env-lookup Γ n ≡ just ⟨A: ⊥ ⋯ U ⟩) →
                Γ ⊢ᵢ n ∙A <: U

  module _ where

    ⊤<: : ∀ {Γ T} → Γ ⊢ᵢ ⊤ <: T → T ≡ ⊤
    ⊤<: ditop  = refl
    ⊤<: direfl = refl
    ⊤<: (ditrans T S<:T T<:U) with ⊤<: S<:T
    ... | refl = ⊤<: T<:U

    <:⊥ : ∀ {Γ T} → Γ ⊢ᵢ T <: ⊥ → P Γ → T ≡ ⊥
    <:⊥ dibot pΓ       = refl
    <:⊥ direfl pΓ      = refl
    <:⊥ (ditrans T S<:T T<:U) pΓ with <:⊥ T<:U pΓ
    ... | refl         = <:⊥ S<:T pΓ
    <:⊥ (disel T∈Γ) pΓ = ⊥-elim (no-bnd-⊥ pΓ T∈Γ)

    ⟨A:⟩<: : ∀ {Γ T S U} → Γ ⊢ᵢ ⟨A: S ⋯ U ⟩ <: T → T ≡ ⊤ ⊎ ∃₂ (λ S′ U′ → T ≡ ⟨A: S′ ⋯ U′ ⟩)
    ⟨A:⟩<: ditop            = inj₁ refl
    ⟨A:⟩<: direfl           = inj₂ (-, -, refl)
    ⟨A:⟩<: (ditrans T S<:T T<:U) with ⟨A:⟩<: S<:T
    ... | inj₁ refl         = inj₁ (⊤<: T<:U)
    ... | inj₂ (_ , _ , refl) with ⟨A:⟩<: T<:U
    ... | inj₁ eq           = inj₁ eq
    ... | inj₂ (_ , _ , eq) = inj₂ (-, -, eq)
    ⟨A:⟩<: (dibnd D₁ D₂)    = inj₂ (-, -, refl)

    <:⟨A:⟩ : ∀ {Γ T S U} → Γ ⊢ᵢ T <: ⟨A: S ⋯ U ⟩ → P Γ →
               T ≡ ⊥ ⊎ ∃₂ (λ S′ U′ → T ≡ ⟨A: S′ ⋯ U′ ⟩)
    <:⟨A:⟩ dibot pΓ           = inj₁ refl
    <:⟨A:⟩ direfl pΓ          = inj₂ (-, -, refl)
    <:⟨A:⟩ (ditrans T S<:T T<:U) pΓ with <:⟨A:⟩ T<:U pΓ
    ... | inj₁ refl           = inj₁ (<:⊥ S<:T pΓ)
    ... | inj₂ (S′ , U′ , refl) with <:⟨A:⟩ S<:T pΓ
    ... | inj₁ eq             = inj₁ eq
    ... | inj₂ (S″ , U″ , eq) = inj₂ (S″ , U″ , eq)
    <:⟨A:⟩ (dibnd D₁ D₂) pΓ   = inj₂ (-, -, refl)
    <:⟨A:⟩ (disel T∈Γ) pΓ     = ⊥-elim (no-bnd-bnd pΓ T∈Γ)

    ⟨A:⟩<:⟨A:⟩ : ∀ {Γ S S′ U U′} → Γ ⊢ᵢ ⟨A: S ⋯ U ⟩ <: ⟨A: S′ ⋯ U′ ⟩ → P Γ →
                   Γ ⊢ᵢ S′ <: S × Γ ⊢ᵢ U <: U′
    ⟨A:⟩<:⟨A:⟩ direfl pΓ                  = direfl , direfl
    ⟨A:⟩<:⟨A:⟩ (ditrans T S<:T T<:U) pΓ with ⟨A:⟩<: S<:T
    ... | inj₁ refl with ⊤<: T<:U
    ... | ()
    ⟨A:⟩<:⟨A:⟩ (ditrans T S<:T T<:U) pΓ | inj₂ (_ , _ , refl)
      with ⟨A:⟩<:⟨A:⟩ S<:T pΓ | ⟨A:⟩<:⟨A:⟩ T<:U pΓ
    ... | S″<:S , U<:U″ | S′<:S″ , U″<:U′ = ditrans _ S′<:S″ S″<:S , ditrans _ U<:U″ U″<:U′
    ⟨A:⟩<:⟨A:⟩ (dibnd D₁ D₂) pΓ           = D₁ , D₂

    infix 4 _reach_from_
    data _reach_from_ : Env → Typ → ℕ → Set where
      /_/ : ∀ {Γ n T} →
              env-lookup Γ n ≡ just ⟨A: ⊥ ⋯ T ⟩ →
              Γ reach T from n
      _∷_ : ∀ {Γ n m T} →
              env-lookup Γ n ≡ just ⟨A: ⊥ ⋯ m ∙A ⟩ →
              Γ reach T from m →
              Γ reach T from n

    rf-concat : ∀ {Γ T m n} → Γ reach T from m → Γ reach m ∙A from n → Γ reach T from n
    rf-concat m↝T / B∈Γ /       = B∈Γ ∷ m↝T
    rf-concat m↝T (B∈Γ ∷ n↝m∙A) = B∈Γ ∷ rf-concat m↝T n↝m∙A

    ∙A<: : ∀ {Γ n T} → Γ ⊢ᵢ n ∙A <: T →
             T ≡ ⊤ ⊎ T ≡ n ∙A ⊎ ∃ λ T′ → Γ reach T′ from n × Γ ⊢ᵢ T′ <: T
    ∙A<: ditop                            = inj₁ refl
    ∙A<: direfl                           = inj₂ (inj₁ refl)
    ∙A<: (ditrans T S<:T T<:U) with ∙A<: S<:T
    ... | inj₁ refl                       = inj₁ (⊤<: T<:U)
    ... | inj₂ (inj₁ refl)                = ∙A<: T<:U
    ... | inj₂ (inj₂ (T′ , n↝T′ , T′<:T)) = inj₂ (inj₂ (T′ , n↝T′ , ditrans _ T′<:T T<:U))
    ∙A<: (disel T∈Γ)                      = inj₂ (inj₂ (-, / T∈Γ / , direfl))

    <:∙A : ∀ {Γ n T} → Γ ⊢ᵢ T <: n ∙A → P Γ →
             T ≡ ⊥ ⊎
             T ≡ n ∙A ⊎
             ∃ (λ m → T ≡ m ∙A × Γ reach n ∙A from m)
    <:∙A dibot pΓ                             = inj₁ refl
    <:∙A direfl pΓ                            = inj₂ (inj₁ refl)
    <:∙A (ditrans T S<:T T<:U) pΓ with <:∙A T<:U pΓ
    ... | inj₁ refl                           = inj₁ (<:⊥ S<:T pΓ)
    ... | inj₂ (inj₁ refl)                    = <:∙A S<:T pΓ
    ... | inj₂ (inj₂ (m , refl , m↝n∙A))
        with <:∙A S<:T pΓ
    ...    | inj₁ refl                        = inj₁ refl
    ...    | inj₂ (inj₁ refl)                 = inj₂ (inj₂ (-, refl , m↝n∙A))
    ...    | inj₂ (inj₂ (m′ , refl , m′↝m∙A)) = inj₂ (inj₂ (-, refl , rf-concat m↝n∙A m′↝m∙A))
    <:∙A (disel T∈Γ) pΓ                       = inj₂ (inj₂ (-, refl , / T∈Γ /))

    Π<: : ∀ {Γ S U T} → Γ ⊢ᵢ Π S ∙ U <: T →
            T ≡ ⊤ ⊎ ∃₂ (λ S′ U′ → T ≡ Π S′ ∙ U′)
    Π<: ditop                 = inj₁ refl
    Π<: direfl                = inj₂ (-, -, refl)
    Π<: (ditrans T S<:T T<:U) with Π<: S<:T
    ... | inj₁ refl           = inj₁ (⊤<: T<:U)
    ... | inj₂ (_ , _ , refl) = Π<: T<:U
    Π<: (diall D₁ D₂)         = inj₂ (-, -, refl)

    <:Π : ∀ {Γ S U T} → Γ ⊢ᵢ T <: Π S ∙ U → P Γ →
            T ≡ ⊥ ⊎
            ∃ (λ n → T ≡ n ∙A) ⊎
            ∃₂ (λ S′ U′ → T ≡ Π S′ ∙ U′)
    <:Π dibot pΓ                       = inj₁ refl
    <:Π direfl pΓ                      = inj₂ (inj₂ (-, -, refl))
    <:Π (ditrans T S<:T T<:U) pΓ with <:Π T<:U pΓ
    ... | inj₁ refl                    = inj₁ (<:⊥ S<:T pΓ)
    ... | inj₂ (inj₁ (_ , refl)) with <:∙A S<:T pΓ
    ... | inj₁ eq                      = inj₁ eq
    ... | inj₂ (inj₁ eq)               = inj₂ (inj₁ (-, eq))
    ... | inj₂ (inj₂ (_ , eq , _))     = inj₂ (inj₁ (-, eq))
    <:Π (ditrans T S<:T T<:U) pΓ | inj₂ (inj₂ (_ , _ , refl))
                                       = <:Π S<:T pΓ
    <:Π (diall D₁ D₂) pΓ               = inj₂ (inj₂ (-, -, refl))
    <:Π (disel T∈Γ) pΓ                 = inj₂ (inj₁ (-, refl))

-- Terms and Values
infix 6 var_ val_
infix 6 ⟨A=_⟩ _$$_
infixr 7 lt_inn_
infixr 6 Λ_∙_

mutual
  -- Values
  --
  -- * (⟨A= T ⟩) represents a type tag ({A = T}).
  -- * (Λ T ∙ t) represents a lambda expression (λ(x : T)t)
  data Val : Set where
    ⟨A=_⟩  : (T : Typ) → Val
    Λ_∙_   : (T : Typ) → (t : Trm) → Val

  -- Terms
  --
  -- * (var x) represents a variable.
  -- * (val v) represents a value as a term.
  -- * (x $$ y) is an application of two variables.
  -- * (lt t inn u) represents let binding (let x = t in u).
  data Trm  : Set where
    var_    : ℕ → Trm
    val_    : (v : Val) → Trm
    _$$_    : (x y : ℕ) → Trm
    lt_inn_ : Trm → Trm → Trm

-- substitution operation
record Subst (T : Set) : Set where
  infixl 5 _[_/_]
  field
    _[_/_] : T → ℕ → ℕ → T

open Subst {{...}} public

infixl 5 _[_/_]ᵥ _[_/_]ₜ _[_/_]T

ℕsubst : ℕ → ℕ → ℕ → ℕ
ℕsubst x n m with x ≟ m
... | yes x≡m = n
... | no x≢m  = x

instance
  substℕ : Subst ℕ
  substℕ = record { _[_/_] = ℕsubst }

_[_/_]T : Typ → ℕ → ℕ → Typ
⊤ [ n / m ]T           = ⊤
⊥ [ n / m ]T           = ⊥
x ∙A [ n / m ]T        = (x [ n / m ]) ∙A
Π S ∙ U [ n / m ]T     = Π S [ n / m ]T ∙ (U [ suc n / suc m ]T)
⟨A: S ⋯ U ⟩ [ n / m ]T = ⟨A: S [ n / m ]T ⋯ U [ n / m ]T ⟩

instance
  substTyp : Subst Typ
  substTyp = record { _[_/_] = _[_/_]T }

mutual
  _[_/_]ᵥ : Val → ℕ → ℕ → Val
  ⟨A= T ⟩ [ n / m ]ᵥ = ⟨A= T [ n / m ] ⟩
  Λ T ∙ t [ n / m ]ᵥ = Λ T [ n / m ] ∙ (t [ suc n / suc m ]ₜ)

  _[_/_]ₜ : Trm → ℕ → ℕ → Trm
  var x [ n / m ]ₜ      = var (x [ n / m ])
  val v [ n / m ]ₜ      = val (v [ n / m ]ᵥ)
  x $$ y [ n / m ]ₜ     = (x [ n / m ]) $$ (y [ n / m ])
  lt t inn u [ n / m ]ₜ = lt (t [ n / m ]ₜ) inn (u [ suc n / suc m ]ₜ)

instance
  substVal : Subst Val
  substVal = record { _[_/_] = _[_/_]ᵥ }

  substTrm : Subst Trm
  substTrm = record { _[_/_] = _[_/_]ₜ }

data Closed : ℕ → Typ → Set where
  cl-⊤   : ∀ {n} → Closed n ⊤
  cl-⊥   : ∀ {n} → Closed n ⊥
  cl-∙A  : ∀ {n m} (m≥n : m ≥ n) → Closed n (m ∙A)
  cl-Π   : ∀ {n S U} → Closed n S → Closed (suc n) U → Closed n (Π S ∙ U)
  cl-⟨A⟩ : ∀ {n S U} → Closed n S → Closed n U → Closed n ⟨A: S ⋯ U ⟩

infix 7 _↓
_↓ : ∀ {n T} → Closed (suc n) T → Typ
cl-⊤ ↓              = ⊤
cl-⊥ ↓              = ⊥
cl-∙A {_} {m} m≥n ↓ = pred m ∙A
cl-Π S U ↓          = Π S ↓ ∙ (U ↓)
cl-⟨A⟩ S U ↓        = ⟨A: S ↓ ⋯ U ↓ ⟩


-- Andreas, 2019-06-26, issue #3855
-- Mark erased hypotheses as such in a non-erased goal.
-- Same for irrelevance.

Goal :
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  → Set
Goal A B C D = λ A B C D → {!!}

-- Goal: Set
-- ————————————————————————————————————————————————————————————
-- D      : Set  (erased, irrelevant)
-- C      : Set  (irrelevant)
-- B      : Set  (erased)
-- A      : Set
-- D = D₁ : Set  (not in scope, erased, irrelevant)
-- C = C₁ : Set  (not in scope, irrelevant)
-- B = B₁ : Set  (not in scope, erased)
-- A = A₁ : Set  (not in scope)

-- Don't show erasure in erased goal!

@0 ErasedGoal :
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  → Set
ErasedGoal A B C D = λ A B C D → {!!}

-- Goal: Set
-- ————————————————————————————————————————————————————————————
-- D      : Set  (irrelevant)
-- C      : Set  (irrelevant)
-- B      : Set
-- A      : Set
-- D = D₁ : Set  (not in scope, irrelevant)
-- C = C₁ : Set  (not in scope, irrelevant)
-- B = B₁ : Set  (not in scope)
-- A = A₁ : Set  (not in scope)

-- Don't show irrelevance in irrelevant goal!

@irr IrrGoal :
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  (        A : Set)
  (@0      B : Set)
  (@irr    C : Set)
  (@0 @irr D : Set)
  → Set
IrrGoal A B C D = λ A B C D → {!!}

-- Goal: Set
-- ————————————————————————————————————————————————————————————
-- D      : Set  (erased)
-- C      : Set
-- B      : Set  (erased)
-- A      : Set
-- D = D₁ : Set  (not in scope, erased)
-- C = C₁ : Set  (not in scope)
-- B = B₁ : Set  (not in scope, erased)
-- A = A₁ : Set  (not in scope)


-- Andreas, 2015-11-09, issue 1710 reported by vejkse
-- {-# OPTIONS -v tc.with:20 #-}

record wrap (A : Set) : Set where
  field
    out : A
open wrap public

record MapsFrom (A : Set) : Set₁ where
  field
    cod : Set
    map : A → cod
open MapsFrom public

wrapped : (A : Set) → MapsFrom A
cod (wrapped A) = wrap A
out (map (wrapped A) a) with a
... | _ = a


{-

In this file we apply the cubical machinery to Martin Hötzel-Escardó's
structure identity principle:

https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#sns

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.SIP where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence renaming (ua-pathToEquiv to ua-pathToEquiv')
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Function
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Data.Sigma

open import Cubical.Foundations.Structure public

private
  variable
    ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ : Level
    S : Type ℓ₁ → Type ℓ₂

-- Note that for any equivalence (f , e) : X ≃ Y the type  ι (X , s) (Y , t) (f , e) need not to be
-- a proposition. Indeed this type should correspond to the ways s and t can be identified
-- as S-structures. This we call a standard notion of structure or SNS.
-- We will use a different definition, but the two definitions are interchangeable.
SNS : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃)
SNS {ℓ₁} S ι = ∀ {X : Type ℓ₁} (s t : S X) → ι (X , s) (X , t) (idEquiv X) ≃ (s ≡ t)

-- We introduce the notation for structure preserving equivalences a
-- bit differently, but this definition doesn't actually change from
-- Escardó's notes.
_≃[_]_ : (A : TypeWithStr ℓ₁ S) (ι : StrEquiv S ℓ₂) (B : TypeWithStr ℓ₁ S) → Type (ℓ-max ℓ₁ ℓ₂)
A ≃[ ι ] B = Σ[ e ∈ typ A ≃ typ B ] (ι A B e)

-- The following PathP version of SNS is a bit easier to work with
-- for the proof of the SIP
UnivalentStr : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃)
UnivalentStr {ℓ₁} S ι =
  {A B : TypeWithStr ℓ₁ S} (e : typ A ≃ typ B)
  → ι A B e ≃ PathP (λ i → S (ua e i)) (str A) (str B)

-- A quick sanity-check that our definition is interchangeable with
-- Escardó's. The direction SNS→UnivalentStr corresponds more or less
-- to a dependent EquivJ formulation of Escardó's homomorphism-lemma.
UnivalentStr→SNS : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃)
  → UnivalentStr S ι → SNS S ι
UnivalentStr→SNS S ι θ {X = X} s t =
  ι (X , s) (X , t) (idEquiv X)
    ≃⟨ θ (idEquiv X) ⟩
  PathP (λ i → S (ua (idEquiv X) i)) s t
    ≃⟨ transportEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = X} j i)) s t) ⟩
  s ≡ t
  ■

SNS→UnivalentStr : (ι : StrEquiv S ℓ₃) → SNS S ι → UnivalentStr S ι
SNS→UnivalentStr {S = S} ι θ {A = A} {B = B} e = EquivJ P C e (str A) (str B)
  where
  Y = typ B

  P : (X : Type _) → X ≃ Y → Type _
  P X e' = (s : S X) (t : S Y) → ι (X , s) (Y , t) e' ≃ PathP (λ i → S (ua e' i)) s t

  C : (s t : S Y) → ι (Y , s) (Y , t) (idEquiv Y) ≃ PathP (λ i → S (ua (idEquiv Y) i)) s t
  C s t =
    ι (Y , s) (Y , t) (idEquiv Y)
      ≃⟨ θ s t ⟩
    s ≡ t
      ≃⟨ transportEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = Y} (~ j) i)) s t) ⟩
    PathP (λ i → S (ua (idEquiv Y) i)) s t
    ■

TransportStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S) → Type (ℓ-max (ℓ-suc ℓ) ℓ₁)
TransportStr {ℓ} {S = S} α =
  {X Y : Type ℓ} (e : X ≃ Y) (s : S X) → equivFun (α e) s ≡ subst S (ua e) s

TransportStr→UnivalentStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S)
  → TransportStr α → UnivalentStr S (EquivAction→StrEquiv α)
TransportStr→UnivalentStr {S = S} α τ {X , s} {Y , t} e =
  equivFun (α e) s ≡ t
    ≃⟨ pathToEquiv (cong (_≡ t) (τ e s)) ⟩
  subst S (ua e) s ≡ t
    ≃⟨ invEquiv (PathP≃Path _ _ _) ⟩
  PathP (λ i → S (ua e i)) s t
  ■

UnivalentStr→TransportStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S)
  → UnivalentStr S (EquivAction→StrEquiv α) → TransportStr α
UnivalentStr→TransportStr {S = S} α θ e s =
  invEq (θ e) (transport-filler (cong S (ua e)) s)

invTransportStr : {S : Type ℓ → Type ℓ₂} (α : EquivAction S) (τ : TransportStr α)
  {X Y : Type ℓ} (e : X ≃ Y) (t : S Y) → invEq (α e) t ≡ subst⁻ S (ua e) t
invTransportStr {S = S} α τ e t =
  sym (transport⁻Transport (cong S (ua e)) (invEq (α e) t))
  ∙∙ sym (cong (subst⁻ S (ua e)) (τ e (invEq (α e) t)))
  ∙∙ cong (subst⁻ S (ua e)) (retEq (α e) t)

--- We can now define an invertible function
---
---    sip : A ≃[ ι ] B → A ≡ B

module _ {S : Type ℓ₁ → Type ℓ₂} {ι : StrEquiv S ℓ₃}
  (θ : UnivalentStr S ι) (A B : TypeWithStr ℓ₁ S)
  where

  sip : A ≃[ ι ] B → A ≡ B
  sip (e , p) i = ua e i , θ e .fst p i

  SIP : A ≃[ ι ] B ≃ (A ≡ B)
  SIP =
    sip , isoToIsEquiv (compIso (Σ-cong-iso (invIso univalenceIso) (equivToIso ∘ θ)) ΣPathIsoPathΣ)

  sip⁻ : A ≡ B → A ≃[ ι ] B
  sip⁻ = invEq SIP


{-# OPTIONS -v treeless.opt:20 -v treeless.opt.unused:30 #-}

module _ where

open import Common.Prelude

-- First four arguments are unused.
maybe : ∀ {a b} {A : Set a} {B : Set b} → B → (A → B) → Maybe A → B
maybe z f nothing = z
maybe z f (just x) = f x

mapMaybe : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Maybe A → Maybe B
mapMaybe f x = maybe nothing (λ y → just (f y)) x

maybeToNat : Maybe Nat → Nat
maybeToNat m = maybe 0 (λ x → x) m

foldr : {A B : Set} → (A → B → B) → B → List A → B
foldr f z [] = z
foldr f z (x ∷ xs) = f x (foldr f z xs)

main : IO Unit
main = printNat (maybeToNat (just 42))
    ,, printNat (maybeToNat (mapMaybe (10 +_) (just 42)))
    ,, printNat (foldr _+_ 0 (1 ∷ 2 ∷ 3 ∷ 4 ∷ []))


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

open import lib.Basics
open import lib.NType2
open import lib.Equivalence2
open import lib.NConnected
open import lib.types.TLevel
open import lib.types.Truncation
open import lib.types.Group
open import lib.groups.LoopSpace
open import lib.groups.Homomorphism

module lib.types.EilenbergMacLane1 {i} where

module _ (G : Group i) where

  postulate  -- HIT
    EM₁ : Type i
    embase' : EM₁
    emloop' : Group.El G → embase' == embase'
    emloop-comp' : ∀ g₁ g₂ → emloop' (Group.comp G g₁ g₂) == emloop' g₁ ∙ emloop' g₂
    EM₁-level' : has-level ⟨ 1 ⟩ EM₁

  ⊙EM₁ : Ptd i
  ⊙EM₁ = ⊙[ EM₁ , embase' ]

module _ {G : Group i} where
  private
    module G = Group G

  embase = embase' G
  emloop = emloop' G
  emloop-comp = emloop-comp' G

  instance
    EM₁-level : {n : ℕ₋₂} → has-level (S (S (S n))) (EM₁ G)
    EM₁-level {⟨-2⟩} = EM₁-level' G
    EM₁-level {S n} = raise-level _ EM₁-level

  abstract
    -- This was in the original paper, but is actually derivable.
    emloop-ident : emloop G.ident == idp
    emloop-ident = ! $ anti-whisker-right (emloop G.ident) $
      ap emloop (! $ G.unit-r G.ident) ∙ emloop-comp G.ident G.ident

  module EM₁Elim {j} {P : EM₁ G → Type j}
    {{_ : (x : EM₁ G) → has-level ⟨ 1 ⟩ (P x)}}
    (embase* : P embase)
    (emloop* : (g : G.El) → embase* == embase* [ P ↓ emloop g ])
    (emloop-comp* : (g₁ g₂ : G.El) →
       emloop* (G.comp g₁ g₂) == emloop* g₁ ∙ᵈ emloop* g₂
       [ (λ p → embase* == embase* [ P ↓ p ]) ↓ emloop-comp g₁ g₂ ])
    where

    postulate  -- HIT
      f : Π (EM₁ G) P
      embase-β : f embase ↦ embase*
    {-# REWRITE embase-β #-}

    postulate  -- HIT
      emloop-β : (g : G.El) → apd f (emloop g) == emloop* g

  open EM₁Elim public using () renaming (f to EM₁-elim)

  module EM₁Rec {j} {C : Type j}
    {{_ : has-level ⟨ 1 ⟩ C}} (embase* : C)
    (hom* : G →ᴳ (Ω^S-group 0 ⊙[ C , embase* ])) where

    private
      module M = EM₁Elim {P = λ _ → C}
        embase* (λ g → ↓-cst-in (GroupHom.f hom* g))
        (λ g₁ g₂ → ↓-cst-in2 (GroupHom.pres-comp hom* g₁ g₂)
                 ∙'ᵈ ↓-cst-in-∙ (emloop g₁) (emloop g₂)
                      (GroupHom.f hom* g₁) (GroupHom.f hom* g₂))

    f = M.f

    emloop-β : (g : G.El) → ap f (emloop g) == GroupHom.f hom* g
    emloop-β g = apd=cst-in {f = f} (M.emloop-β g)

  open EM₁Rec public using () renaming (f to EM₁-rec)

-- basic lemmas about [EM₁]

module _ {G : Group i} where
  private
    module G = Group G

  abstract
    emloop-inv : ∀ g → emloop' G (G.inv g) == ! (emloop g)
    emloop-inv g = cancels-inverse _ _ lemma
      where
        cancels-inverse : ∀ {i} {A : Type i} {x y : A}
          (p : x == y) (q : y == x) → p ∙ q == idp → p == ! q
        cancels-inverse p idp r = ! (∙-unit-r p) ∙ r

        lemma : emloop' G (G.inv g) ∙ emloop g  == idp
        lemma = ! (emloop-comp (G.inv g) g) ∙ ap emloop (G.inv-l g) ∙ emloop-ident

    {- EM₁ is 0-connected -}
    instance
      EM₁-conn : is-connected 0 (EM₁ G)
      EM₁-conn = has-level-in ([ embase ] , Trunc-elim
        (EM₁-elim
          {P = λ x → [ embase ] == [ x ]}
          {{λ _ → raise-level _ (=-preserves-level Trunc-level)}}
          idp
          (λ _ → prop-has-all-paths-↓)
          (λ _ _ → set-↓-has-all-paths-↓)))


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

open import lib.Basics
open import lib.NConnected
open import lib.types.Nat
open import lib.types.TLevel
open import lib.types.Empty
open import lib.types.Group
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Paths
open import lib.types.Sigma
open import lib.types.Truncation
open import lib.cubical.Square

module lib.types.LoopSpace where

module _ {i} where

  ⊙Ω : Ptd i → Ptd i
  ⊙Ω (A , a) = ⊙[ (a == a) , idp ]

  Ω : Ptd i → Type i
  Ω = fst ∘ ⊙Ω

  ⊙Ω^ : (n : ℕ) → Ptd i → Ptd i
  ⊙Ω^ O X = X
  ⊙Ω^ (S n) X = ⊙Ω (⊙Ω^ n X)

  Ω^ : (n : ℕ) → Ptd i → Type i
  Ω^ n X = fst (⊙Ω^ n X)

idp^ : ∀ {i} (n : ℕ) {X : Ptd i} → Ω^ n X
idp^ n {X} = snd (⊙Ω^ n X)

{- for n ≥ 1, we have a group structure on the loop space -}
module _ {i} where
  !^ : (n : ℕ) (t : n ≠ O) {X : Ptd i} → Ω^ n X → Ω^ n X
  !^ O t = ⊥-rec (t idp)
  !^ (S n) _ = !

  conc^ : (n : ℕ) (t : n ≠ O) {X : Ptd i} → Ω^ n X → Ω^ n X → Ω^ n X
  conc^ O t = ⊥-rec (t idp)
  conc^ (S n) _ = _∙_

{- ap and ap2 for pointed functions -}

private
  pt-lemma : ∀ {i} {A : Type i} {x y : A} (p : x == y)
    → ! p ∙ (idp ∙' p) == idp
  pt-lemma idp = idp

⊙ap : ∀ {i j} {X : Ptd i} {Y : Ptd j}
  → fst (X ⊙→ Y) → fst (⊙Ω X ⊙→ ⊙Ω Y)
⊙ap (f , fpt) = ((λ p → ! fpt ∙ ap f p ∙' fpt) , pt-lemma fpt)

⊙ap2 : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → fst (X ⊙× Y ⊙→ Z) → fst (⊙Ω X ⊙× ⊙Ω Y ⊙→ ⊙Ω Z)
⊙ap2 (f , fpt) = ((λ {(p , q) → ! fpt ∙ ap2 (curry f) p q ∙' fpt}) ,
                  pt-lemma fpt)

⊙ap-∘ : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
  → ⊙ap (g ⊙∘ f) == ⊙ap g ⊙∘ ⊙ap f
⊙ap-∘ (g , idp) (f , idp) = ⊙λ= (λ p → ap-∘ g f p) idp

⊙ap-idf : ∀ {i} {X : Ptd i} → ⊙ap (⊙idf X) == ⊙idf _
⊙ap-idf = ⊙λ= ap-idf idp

⊙ap2-fst : ∀ {i j} {X : Ptd i} {Y : Ptd j}
  → ⊙ap2 {X = X} {Y = Y} ⊙fst == ⊙fst
⊙ap2-fst = ⊙λ= (uncurry ap2-fst) idp

⊙ap2-snd : ∀ {i j} {X : Ptd i} {Y : Ptd j}
  → ⊙ap2 {X = X} {Y = Y} ⊙snd == ⊙snd
⊙ap2-snd = ⊙λ= (uncurry ap2-snd) idp

⊙ap-ap2 : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (G : fst (Z ⊙→ W)) (F : fst (X ⊙× Y ⊙→ Z))
  → ⊙ap G ⊙∘ ⊙ap2 F == ⊙ap2 (G ⊙∘ F)
⊙ap-ap2 (g , idp) (f , idp) =
  ⊙λ= (uncurry (ap-ap2 g (curry f))) idp

⊙ap2-ap : ∀ {i j k l m}
  {X : Ptd i} {Y : Ptd j} {U : Ptd k} {V : Ptd l} {Z : Ptd m}
  (G : fst ((U ⊙× V) ⊙→ Z)) (F₁ : fst (X ⊙→ U)) (F₂ : fst (Y ⊙→ V))
  → ⊙ap2 G ⊙∘ pair⊙→ (⊙ap F₁) (⊙ap F₂) == ⊙ap2 (G ⊙∘ pair⊙→ F₁ F₂)
⊙ap2-ap (g , idp) (f₁ , idp) (f₂ , idp) =
  ⊙λ= (λ {(p , q) → ap2-ap-l (curry g) f₁ p (ap f₂ q)
                  ∙ ap2-ap-r (λ x v → g (f₁ x , v)) f₂ p q})
      idp

⊙ap2-diag : ∀ {i j} {X : Ptd i} {Y : Ptd j} (F : fst (X ⊙× X ⊙→ Y))
  → ⊙ap2 F ⊙∘ ⊙diag == ⊙ap (F ⊙∘ ⊙diag)
⊙ap2-diag (f , idp) = ⊙λ= (ap2-diag (curry f)) idp

{- ap and ap2 for higher loop spaces -}

ap^ : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → fst (X ⊙→ Y) → fst (⊙Ω^ n X ⊙→ ⊙Ω^ n Y)
ap^ O F = F
ap^ (S n) F = ⊙ap (ap^ n F)

ap2^ : ∀ {i j k} (n : ℕ) {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → fst ((X ⊙× Y) ⊙→ Z)
  → fst ((⊙Ω^ n X ⊙× ⊙Ω^ n Y) ⊙→ ⊙Ω^ n Z)
ap2^ O F = F
ap2^ (S n) F = ⊙ap2 (ap2^ n F)

ap^-idf : ∀ {i} (n : ℕ) {X : Ptd i} → ap^ n (⊙idf X) == ⊙idf _
ap^-idf O = idp
ap^-idf (S n) = ap ⊙ap (ap^-idf n) ∙ ⊙ap-idf

ap^-ap2^ : ∀ {i j k l} (n : ℕ) {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (G : fst (Z ⊙→ W)) (F : fst ((X ⊙× Y) ⊙→ Z))
  → ap^ n G ⊙∘ ap2^ n F == ap2^ n (G ⊙∘ F)
ap^-ap2^ O G F = idp
ap^-ap2^ (S n) G F = ⊙ap-ap2 (ap^ n G) (ap2^ n F) ∙ ap ⊙ap2 (ap^-ap2^ n G F)

ap2^-fst : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → ap2^ n {X} {Y} ⊙fst == ⊙fst
ap2^-fst O = idp
ap2^-fst (S n) = ap ⊙ap2 (ap2^-fst n) ∙ ⊙ap2-fst

ap2^-snd : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → ap2^ n {X} {Y} ⊙snd == ⊙snd
ap2^-snd O = idp
ap2^-snd (S n) = ap ⊙ap2 (ap2^-snd n) ∙ ⊙ap2-snd

ap2^-ap^ : ∀ {i j k l m} (n : ℕ)
  {X : Ptd i} {Y : Ptd j} {U : Ptd k} {V : Ptd l} {Z : Ptd m}
  (G : fst ((U ⊙× V) ⊙→ Z)) (F₁ : fst (X ⊙→ U)) (F₂ : fst (Y ⊙→ V))
  → ap2^ n G ⊙∘ pair⊙→ (ap^ n F₁) (ap^ n F₂) == ap2^ n (G ⊙∘ pair⊙→ F₁ F₂)
ap2^-ap^ O G F₁ F₂ = idp
ap2^-ap^ (S n) G F₁ F₂ =
  ⊙ap2-ap (ap2^ n G) (ap^ n F₁) (ap^ n F₂) ∙ ap ⊙ap2 (ap2^-ap^ n G F₁ F₂)

ap2^-diag : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j} (F : fst (X ⊙× X ⊙→ Y))
  → ap2^ n F ⊙∘ ⊙diag == ap^ n (F ⊙∘ ⊙diag)
ap2^-diag O F = idp
ap2^-diag (S n) F = ⊙ap2-diag (ap2^ n F) ∙ ap ⊙ap (ap2^-diag n F)

module _ {i} {X : Ptd i} where

  {- Prove these as lemmas now
   - so we don't have to deal with the n = O case later -}

  conc^-unit-l : (n : ℕ) (t : n ≠ O) (q : Ω^ n X)
    → (conc^ n t (idp^ n) q) == q
  conc^-unit-l O t _ = ⊥-rec (t idp)
  conc^-unit-l (S n) _ _ = idp

  conc^-unit-r : (n : ℕ) (t : n ≠ O) (q : Ω^ n X)
    → (conc^ n t q (idp^ n)) == q
  conc^-unit-r O t = ⊥-rec (t idp)
  conc^-unit-r (S n) _ = ∙-unit-r

  conc^-assoc : (n : ℕ) (t : n ≠ O) (p q r : Ω^ n X)
    → conc^ n t (conc^ n t p q) r == conc^ n t p (conc^ n t q r)
  conc^-assoc O t = ⊥-rec (t idp)
  conc^-assoc (S n) _ = ∙-assoc

  !^-inv-l : (n : ℕ) (t : n ≠ O) (p : Ω^ n X)
    → conc^ n t (!^ n t p) p == idp^ n
  !^-inv-l O t = ⊥-rec (t idp)
  !^-inv-l (S n) _ = !-inv-l

  !^-inv-r : (n : ℕ) (t : n ≠ O) (p : Ω^ n X)
    → conc^ n t p (!^ n t p) == idp^ n
  !^-inv-r O t = ⊥-rec (t idp)
  !^-inv-r (S n) _ = !-inv-r

abstract
  ap^-conc^ : ∀ {i j} (n : ℕ) (t : n ≠ O)
    {X : Ptd i} {Y : Ptd j} (F : fst (X ⊙→ Y)) (p q : Ω^ n X)
    → fst (ap^ n F) (conc^ n t p q)
      == conc^ n t (fst (ap^ n F) p) (fst (ap^ n F) q)
  ap^-conc^ O t _ _ _ = ⊥-rec (t idp)
  ap^-conc^ (S n) _ {X = X} {Y = Y} F p q =
    ! gpt ∙ ap g (p ∙ q) ∙' gpt
      =⟨ ap-∙ g p q |in-ctx (λ w → ! gpt ∙ w ∙' gpt) ⟩
    ! gpt ∙ (ap g p ∙ ap g q) ∙' gpt
      =⟨ lemma (ap g p) (ap g q) gpt ⟩
    (! gpt ∙ ap g p ∙' gpt) ∙ (! gpt ∙ ap g q ∙' gpt) ∎
    where
    g : Ω^ n X → Ω^ n Y
    g = fst (ap^ n F)

    gpt : g (idp^ n) == idp^ n
    gpt = snd (ap^ n F)

    lemma : ∀ {i} {A : Type i} {x y : A}
      → (p q : x == x) (r : x == y)
      → ! r ∙ (p ∙ q) ∙' r == (! r ∙ p ∙' r) ∙ (! r ∙ q ∙' r)
    lemma p q idp = idp

{- ap^ preserves (pointed) equivalences -}
module _ {i j} {X : Ptd i} {Y : Ptd j} where

  is-equiv-ap^ : (n : ℕ) (F : fst (X ⊙→ Y)) (e : is-equiv (fst F))
    → is-equiv (fst (ap^ n F))
  is-equiv-ap^ O F e = e
  is-equiv-ap^ (S n) F e =
         pre∙-is-equiv (! (snd (ap^ n F)))
    ∘ise post∙'-is-equiv (snd (ap^ n F))
    ∘ise snd (equiv-ap (_ , is-equiv-ap^ n F e) _ _)

  equiv-ap^ : (n : ℕ) (F : fst (X ⊙→ Y)) (e : is-equiv (fst F))
    → Ω^ n X ≃ Ω^ n Y
  equiv-ap^ n F e = (fst (ap^ n F) , is-equiv-ap^ n F e)

Ω^-level-in : ∀ {i} (m : ℕ₋₂) (n : ℕ) (X : Ptd i)
  → (has-level ((n -2) +2+ m) (fst X) → has-level m (Ω^ n X))
Ω^-level-in m O X pX = pX
Ω^-level-in m (S n) X pX =
  Ω^-level-in (S m) n X
    (transport (λ k → has-level k (fst X)) (! (+2+-βr (n -2) m)) pX)
    (idp^ n) (idp^ n)

Ω^-conn-in : ∀ {i} (m : ℕ₋₂) (n : ℕ) (X : Ptd i)
  → (is-connected ((n -2) +2+ m) (fst X)) → is-connected m (Ω^ n X)
Ω^-conn-in m O X pX = pX
Ω^-conn-in m (S n) X pX =
  path-conn $ Ω^-conn-in (S m) n X $
    transport (λ k → is-connected k (fst X)) (! (+2+-βr (n -2) m)) pX

{- Eckmann-Hilton argument -}
module _ {i} {X : Ptd i} where

  conc^2-comm : (α β : Ω^ 2 X) → conc^ 2 (ℕ-S≠O _) α β == conc^ 2 (ℕ-S≠O _) β α
  conc^2-comm α β = ! (⋆2=conc^ α β) ∙ ⋆2=⋆'2 α β ∙ ⋆'2=conc^ α β
    where
      ⋆2=conc^ : (α β : Ω^ 2 X) → α ⋆2 β == conc^ 2 (ℕ-S≠O _) α β
      ⋆2=conc^ α β = ap (λ π → π ∙ β) (∙-unit-r α)

      ⋆'2=conc^ : (α β : Ω^ 2  X) → α ⋆'2 β == conc^ 2 (ℕ-S≠O _) β α
      ⋆'2=conc^ α β = ap (λ π → β ∙ π) (∙-unit-r α)

{- Pushing truncation through loop space -}
module _ {i} where

  Trunc-Ω^ : (m : ℕ₋₂) (n : ℕ) (X : Ptd i)
    → ⊙Trunc m (⊙Ω^ n X) == ⊙Ω^ n (⊙Trunc ((n -2) +2+ m) X)
  Trunc-Ω^ m O X = idp
  Trunc-Ω^ m (S n) X =
    ⊙Trunc m (⊙Ω^ (S n) X)
      =⟨ ! (pair= (Trunc=-path [ _ ] [ _ ]) (↓-idf-ua-in _ idp)) ⟩
    ⊙Ω (⊙Trunc (S m) (⊙Ω^ n X))
      =⟨ ap ⊙Ω (Trunc-Ω^ (S m) n X) ⟩
    ⊙Ω^ (S n) (⊙Trunc ((n -2) +2+ S m) X)
      =⟨ +2+-βr (n -2) m |in-ctx (λ k → ⊙Ω^ (S n) (⊙Trunc k X)) ⟩
    ⊙Ω^ (S n) (⊙Trunc (S (n -2) +2+ m) X) ∎

  Ω-Trunc-equiv : (m : ℕ₋₂) (X : Ptd i)
    → Ω (⊙Trunc (S m) X) ≃ Trunc m (Ω X)
  Ω-Trunc-equiv m X = Trunc=-equiv [ snd X ] [ snd X ]

{- A loop space is a pregroup, and a group if it has the right level -}
module _ {i} (n : ℕ) (t : n ≠ O) (X : Ptd i) where

  Ω^-group-structure : GroupStructure (Ω^ n X)
  Ω^-group-structure = record {
    ident = idp^ n;
    inv = !^ n t;
    comp = conc^ n t;
    unitl = conc^-unit-l n t;
    unitr = conc^-unit-r n t;
    assoc = conc^-assoc n t;
    invr = !^-inv-r n t;
    invl = !^-inv-l n t
    }

  Ω^-Group : has-level ⟨ n ⟩ (fst X) → Group i
  Ω^-Group pX = group
    (Ω^ n X)
    (Ω^-level-in ⟨0⟩ n X $
       transport (λ t → has-level t (fst X)) (+2+-comm ⟨0⟩ (n -2)) pX)
    Ω^-group-structure

{- Our definition of Ω^ builds up loops on the outside,
 - but this is equivalent to building up on the inside -}
module _ {i} where
  ⊙Ω^-inner-path : (n : ℕ) (X : Ptd i)
    → ⊙Ω^ (S n) X == ⊙Ω^ n (⊙Ω X)
  ⊙Ω^-inner-path O X = idp
  ⊙Ω^-inner-path (S n) X = ap ⊙Ω (⊙Ω^-inner-path n X)

  ⊙Ω^-inner-out : (n : ℕ) (X : Ptd i)
    → fst (⊙Ω^ (S n) X ⊙→ ⊙Ω^ n (⊙Ω X))
  ⊙Ω^-inner-out O _ = (idf _ , idp)
  ⊙Ω^-inner-out (S n) X = ap^ 1 (⊙Ω^-inner-out n X)

  Ω^-inner-out : (n : ℕ) (X : Ptd i)
    → (Ω^ (S n) X → Ω^ n (⊙Ω X))
  Ω^-inner-out n X = fst (⊙Ω^-inner-out n X)

  Ω^-inner-out-conc^ : (n : ℕ) (t : n ≠ O)
    (X : Ptd i) (p q : Ω^ (S n) X)
    → Ω^-inner-out n X (conc^ (S n) (ℕ-S≠O _) p q)
      == conc^ n t (Ω^-inner-out n X p) (Ω^-inner-out n X q)
  Ω^-inner-out-conc^ O t X _ _ = ⊥-rec (t idp)
  Ω^-inner-out-conc^ (S n) t X p q =
    ap^-conc^ 1 (ℕ-S≠O _) (⊙Ω^-inner-out n X) p q

  Ω^-inner-is-equiv : (n : ℕ) (X : Ptd i)
    → is-equiv (fst (⊙Ω^-inner-out n X))
  Ω^-inner-is-equiv O X = is-eq (idf _) (idf _) (λ _ → idp) (λ _ → idp)
  Ω^-inner-is-equiv (S n) X =
    is-equiv-ap^ 1 (⊙Ω^-inner-out n X) (Ω^-inner-is-equiv n X)

  Ω^-inner-equiv : (n : ℕ) (X : Ptd i) → Ω^ (S n) X ≃ Ω^ n (⊙Ω X)
  Ω^-inner-equiv n X = _ , Ω^-inner-is-equiv n X


import Relation.Binary.Reasoning.Setoid as SetoidR
open import SingleSorted.AlgebraicTheory

import SingleSorted.Interpretation as Interpretation
import SingleSorted.Model as Model
import SingleSorted.UniversalInterpretation as UniversalInterpretation
import SingleSorted.Substitution as Substitution
import SingleSorted.SyntacticCategory as SyntacticCategory

module SingleSorted.UniversalModel
  {ℓt}
  {Σ : Signature}
  (T : Theory ℓt Σ) where

  open Theory T
  open Substitution T
  open UniversalInterpretation T
  open Interpretation.Interpretation ℐ
  open SyntacticCategory T

  𝒰 : Model.Model T cartesian-𝒮 ℐ
  𝒰 =
     record
        { model-eq = λ ε var-var →
                       let open SetoidR (eq-setoid (ax-ctx ε)) in
                         begin
                         interp-term (ax-lhs ε) var-var ≈⟨ interp-term-self (ax-lhs ε) var-var ⟩
                         ax-lhs ε ≈⟨ id-action ⟩
                         ax-lhs ε [ id-s ]s ≈⟨ eq-axiom ε id-s ⟩
                         ax-rhs ε [ id-s ]s ≈˘⟨ id-action ⟩
                         ax-rhs ε ≈˘⟨ interp-term-self (ax-rhs ε) var-var ⟩
                         interp-term (ax-rhs ε) var-var ∎ }


module Axiom.FunctionExtensionality where

open import Level using (zero)
open import Relation.Binary.PropositionalEquality

postulate
  fun-ext : Extensionality zero zero


module BFF where

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)
open import Level using () renaming (zero to ℓ₀)
import Category.Monad
import Category.Functor
open import Data.Maybe using (Maybe ; just ; nothing ; maybe′)
open Category.Monad.RawMonad {Level.zero} Data.Maybe.monad using (_>>=_)
open Category.Functor.RawFunctor {Level.zero} Data.Maybe.functor using (_<$>_)
open import Data.List using (List ; [] ; _∷_ ; map ; length)
open import Data.Vec using (Vec ; toList ; fromList ; allFin) renaming (lookup to lookupV ; map to mapV ; [] to []V ; _∷_ to _∷V_)
open import Function using (_∘_ ; flip)
open import Relation.Binary using (Setoid ; DecSetoid ; module DecSetoid)

open import FinMap
open import Generic using (sequenceV ; ≡-to-Π)
open import Structures using (Shaped ; module Shaped)
open import Instances using (VecShaped)
import CheckInsert
open import GetTypes using (VecVec-to-PartialVecVec ; PartialVecVec-to-PartialShapeShape)

module PartialShapeBFF (A : DecSetoid ℓ₀ ℓ₀) where
  open GetTypes.PartialShapeShape public using (Get ; module Get)
  open module A = DecSetoid A using (Carrier) renaming (_≟_ to deq)
  open CheckInsert A

  assoc : {n m : ℕ} → Vec (Fin n) m → Vec Carrier m → Maybe (FinMapMaybe n Carrier)
  assoc []V       []V       = just empty
  assoc (i ∷V is) (b ∷V bs) = (assoc is bs) >>= (checkInsert i b)

  enumerate : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → (s : S) → C (Fin (Shaped.arity ShapeT s)) s
  enumerate ShapeT s = fill s (allFin (arity s))
    where open Shaped ShapeT

  denumerate : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → {α : Set} {s : S} → (c : C α s) → Fin (Shaped.arity ShapeT s) → α
  denumerate ShapeT c = flip lookupV (Shaped.content ShapeT c)

  bff : (G : Get) → {i : Get.I G} → (j : Get.I G) → Get.SourceContainer G Carrier (Get.gl₁ G i) → Get.ViewContainer G Carrier (Get.gl₂ G j) → Maybe (Get.SourceContainer G (Maybe Carrier) (Get.gl₁ G j))
  bff G {i} j s v = let s′ = enumerate SourceShapeT (gl₁ i)
                        t′ = get s′
                        g  = fromFunc (denumerate SourceShapeT s)
                        g′ = delete-many (Shaped.content ViewShapeT t′) g
                        t  = enumerate SourceShapeT (gl₁ j)
                        h  = assoc (Shaped.content ViewShapeT (get t)) (Shaped.content ViewShapeT v)
                        h′ = (flip union (reshape g′ (Shaped.arity SourceShapeT (gl₁ j)))) <$> h
                    in ((λ f → fmapS f t) ∘ flip lookupM) <$> h′
    where open Get G

  sbff : (G : Get) → {i : Get.I G} → (j : Get.I G) → Get.SourceContainer G Carrier (Get.gl₁ G i) → Get.ViewContainer G Carrier (Get.gl₂ G j) → Maybe (Get.SourceContainer G Carrier (Get.gl₁ G j))
  sbff G j s v = bff G j s v >>= Shaped.sequence (Get.SourceShapeT G)

module PartialVecBFF (A : DecSetoid ℓ₀ ℓ₀) where
  open GetTypes.PartialVecVec public using (Get)
  open module A = DecSetoid A using (Carrier) renaming (_≟_ to deq)
  open CheckInsert A

  open PartialShapeBFF A public using (assoc)

  enumerate : {n : ℕ} → Vec Carrier n → Vec (Fin n) n
  enumerate {n} _ = PartialShapeBFF.enumerate A VecShaped n

  enumeratel : (n : ℕ) → Vec (Fin n) n
  enumeratel = PartialShapeBFF.enumerate A VecShaped

  denumerate : {n : ℕ} → Vec Carrier n → Fin n → Carrier
  denumerate = PartialShapeBFF.denumerate A VecShaped

  bff : (G : Get) → {i : Get.I G} → (j : Get.I G) → Vec Carrier (Get.gl₁ G i) → Vec Carrier (Get.gl₂ G j) → Maybe (Vec (Maybe Carrier) (Get.gl₁ G j))
  bff G j s v = PartialShapeBFF.bff A (PartialVecVec-to-PartialShapeShape G) j s v

  sbff : (G : Get) → {i : Get.I G} → (j : Get.I G) → Vec Carrier (Get.gl₁ G i) → Vec Carrier (Get.gl₂ G j) → Maybe (Vec Carrier (Get.gl₁ G j))
  sbff  G j s v = PartialShapeBFF.sbff A (PartialVecVec-to-PartialShapeShape G) j s v

module VecBFF (A : DecSetoid ℓ₀ ℓ₀) where
  open GetTypes.VecVec public using (Get)
  open module A = DecSetoid A using (Carrier) renaming (_≟_ to deq)
  open CheckInsert A

  open PartialVecBFF A public using (assoc ; enumerate ; denumerate)

  bff : (G : Get) → {n : ℕ} → (m : ℕ) → Vec Carrier n → Vec Carrier (Get.getlen G m) → Maybe (Vec (Maybe Carrier) m)
  bff G = PartialVecBFF.bff A (VecVec-to-PartialVecVec G)

  sbff : (G : Get) → {n : ℕ} → (m : ℕ) → Vec Carrier n → Vec Carrier (Get.getlen G m) → Maybe (Vec Carrier m)
  sbff G = PartialVecBFF.sbff A (VecVec-to-PartialVecVec G)


-- Andreas, 2012-05-04
module PruningNonMillerPatternFail where

data _≡_ {A : Set}(a : A) : A -> Set where
  refl : a ≡ a

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

-- bad variable y is not in head position under lambda, so do not prune
fail4 : let X : Nat -> Nat -> Nat
            X = _ -- λ x y → suc x
            Y : Nat → ((Nat → Nat) → Nat) -> Nat
            Y = _  -- More than one solution:
                   -- λ x f → x
                   -- λ x f → f (λ z → x)
        in  (C : Set) ->
            (({x y : Nat} -> X x x ≡ suc (Y x (λ k → k y))) ->
             ({x y : Nat} -> Y x (λ k → k x) ≡ x)           ->
             ({x y : Nat} -> X (Y x (λ k → k y)) y ≡ X x x) -> C) -> C
fail4 C k = k refl refl refl

-- this should not solve, since there are more than one solutions for Y


module Structure.Operator.Monoid.Monoids.Coset where

open import Functional
open import Function.Equals
open import Function.Equals.Proofs
import      Lvl
open import Logic
open import Logic.Predicate
open import Logic.Predicate.Equiv
open import Sets.PredicateSet renaming (_≡_ to _≡ₛ_)
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Function.Multi
open import Structure.Operator.Monoid
open import Structure.Operator.Monoid.Homomorphism
open import Structure.Operator.Monoid.Monoids.Function
open import Structure.Operator.Monoid.Submonoid
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Properties
open import Structure.Setoid renaming (_≡_ to _≡ₑ_)
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T : Type{ℓ}

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ function : ∀{f : T → T} → Function(f) ⦄ {_▫_ : T → T → T} (monoid : Monoid(_▫_)) where
  cosetₗ-submonoid : Submonoid(function-monoid)(⊶(_▫_))
  Submonoid.contains-identity cosetₗ-submonoid = [∃]-intro (_) ⦃ intro(identityₗ(_▫_)(_)) ⦄
  Submonoid.operator-closure  cosetₗ-submonoid {f}{g} ⦃ [∃]-intro a ⦃ pa ⦄ ⦄ ⦃ [∃]-intro b ⦃ pb ⦄ ⦄ =
    [∃]-intro (a ▫ b) ⦃ intro (\{x} →
      ((a ▫ b) ▫ x) 🝖[ _≡ₑ_ ]-[ associativity(_▫_) ]
      (a ▫ (b ▫ x)) 🝖[ _≡ₑ_ ]-[ _⊜_.proof pa ]
      f(b ▫ x)      🝖[ _≡ₑ_ ]-[ congruence₁(f) (_⊜_.proof pb) ]
      f(g(x))       🝖[ _≡ₑ_ ]-[]
      (f ∘ g)(x)    🝖-end
    ) ⦄

  cosetᵣ-submonoid : Submonoid(function-monoid)(⊶(swap(_▫_)))
  Submonoid.contains-identity cosetᵣ-submonoid = [∃]-intro (_) ⦃ intro(identityᵣ(_▫_)(_)) ⦄
  Submonoid.operator-closure  cosetᵣ-submonoid {f}{g} ⦃ [∃]-intro a ⦃ pa ⦄ ⦄ ⦃ [∃]-intro b ⦃ pb ⦄ ⦄ =
    [∃]-intro (b ▫ a) ⦃ intro (\{x} →
      (x ▫ (b ▫ a)) 🝖[ _≡ₑ_ ]-[ associativity(_▫_) ]-sym
      ((x ▫ b) ▫ a) 🝖[ _≡ₑ_ ]-[ _⊜_.proof pa ]
      f(x ▫ b)      🝖[ _≡ₑ_ ]-[ congruence₁(f) (_⊜_.proof pb) ]
      f(g(x))       🝖[ _≡ₑ_ ]-[]
      (f ∘ g)(x)    🝖-end
    ) ⦄

  cosetₗ-homomorphism : ∃(Homomorphism monoid (Submonoid.monoid cosetₗ-submonoid))
  ∃.witness cosetₗ-homomorphism a = [∃]-intro (a ▫_) ⦃ [∃]-intro a ⦃ reflexivity(_≡ₑ_) {a ▫_} ⦄ ⦄
  _⊜_.proof (Function.congruence (Homomorphism.function (∃.proof cosetₗ-homomorphism)) ab) {x}  = congruence₂ₗ(_▫_)(x) ab
  _⊜_.proof (Preserving.proof (Homomorphism.preserve-op (∃.proof cosetₗ-homomorphism))     {x}) = associativity(_▫_)
  _⊜_.proof (Preserving.proof (Homomorphism.preserve-id (∃.proof cosetₗ-homomorphism)))    {x}  = identityₗ(_▫_)(_)

  instance
    cosetₗ-surjective : Surjective([∃]-witness cosetₗ-homomorphism)
    Surjective.proof cosetₗ-surjective {[∃]-intro f ⦃ pf ⦄} = pf

  instance
    cosetₗ-injective : Injective([∃]-witness cosetₗ-homomorphism)
    Injective.proof cosetₗ-injective {x} {y} (intro xy) =
      x                    🝖[ _≡ₑ_ ]-[ identityᵣ(_▫_)(_) ]-sym
      x ▫ Monoid.id monoid 🝖[ _≡ₑ_ ]-[ xy {Monoid.id monoid} ]
      y ▫ Monoid.id monoid 🝖[ _≡ₑ_ ]-[ identityᵣ(_▫_)(_) ]
      y                    🝖-end

  instance
    cosetₗ-bijective : Bijective([∃]-witness cosetₗ-homomorphism)
    cosetₗ-bijective = injective-surjective-to-bijective([∃]-witness cosetₗ-homomorphism)

  {-
  cosetᵣ-homomorphism : ∃(Homomorphism monoid (Submonoid.monoid cosetᵣ-submonoid))
  ∃.witness cosetᵣ-homomorphism a = [∃]-intro (_▫ a) ⦃ [∃]-intro a ⦃ reflexivity(_≡ₑ_) {_▫ a} ⦄ ⦄
  _⊜_.proof (Function.congruence (Homomorphism.function (∃.proof cosetᵣ-homomorphism)) ab) {x}  = congruence₂ᵣ(_▫_)(x) ab
  _⊜_.proof (Preserving.proof (Homomorphism.preserve-op (∃.proof cosetᵣ-homomorphism)) {a} {b}) {x} =
    (x ▫ (a ▫ b)) 🝖[ _≡ₑ_ ]-[ {!!} ]
    ((x ▫ b) ▫ a) 🝖-end
  _⊜_.proof (Preserving.proof (Homomorphism.preserve-id (∃.proof cosetᵣ-homomorphism)))    {x}  = identityᵣ(_▫_)(_)
  -}


module Categories.Monoidal.Closed where


module Web.Semantic.DL.Category.Properties.Tensor where

open import Web.Semantic.DL.Category.Properties.Tensor.RespectsEquiv public using
  ( tensor-resp-≣ )

open import Web.Semantic.DL.Category.Properties.Tensor.Functor public using
  ( tensor-resp-id ; tensor-resp-compose )

open import Web.Semantic.DL.Category.Properties.Tensor.Isomorphisms public using
  ( symm-iso ; assoc-iso ; assoc⁻¹-iso
  ; unit₁-iso ; unit₁⁻¹-iso ; unit₂-iso ; unit₂⁻¹-iso )

open import Web.Semantic.DL.Category.Properties.Tensor.Coherence public using
  ( assoc-unit ; assoc-assoc ; assoc-symm )

open import Web.Semantic.DL.Category.Properties.Tensor.UnitNatural public using
  ( unit₁-natural ; unit₂-natural )

open import Web.Semantic.DL.Category.Properties.Tensor.SymmNatural public using
  ( symm-natural )

open import Web.Semantic.DL.Category.Properties.Tensor.AssocNatural public using
  ( assoc-natural )


-- Basic intuitionistic propositional calculus, without ∨ or ⊥.
-- Hilbert-style formalisation of syntax.
-- Nested terms.

module BasicIPC.Syntax.Hilbert where

open import BasicIPC.Syntax.Common public

-- Derivations.

infix 3 _⊢_
data _⊢_ (Γ : Cx Ty) : Ty → Set where
  var   : ∀ {A}     → A ∈ Γ → Γ ⊢ A
  app   : ∀ {A B}   → Γ ⊢ A ▻ B → Γ ⊢ A → Γ ⊢ B
  ci    : ∀ {A}     → Γ ⊢ A ▻ A
  ck    : ∀ {A B}   → Γ ⊢ A ▻ B ▻ A
  cs    : ∀ {A B C} → Γ ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  cpair : ∀ {A B}   → Γ ⊢ A ▻ B ▻ A ∧ B
  cfst  : ∀ {A B}   → Γ ⊢ A ∧ B ▻ A
  csnd  : ∀ {A B}   → Γ ⊢ A ∧ B ▻ B
  unit  : Γ ⊢ ⊤

infix 3 _⊢⋆_
_⊢⋆_ : Cx Ty → Cx Ty → Set
Γ ⊢⋆ ∅     = 𝟙
Γ ⊢⋆ Ξ , A = Γ ⊢⋆ Ξ × Γ ⊢ A

-- Monotonicity with respect to context inclusion.

mono⊢ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ A → Γ′ ⊢ A
mono⊢ η (var i)   = var (mono∈ η i)
mono⊢ η (app t u) = app (mono⊢ η t) (mono⊢ η u)
mono⊢ η ci        = ci
mono⊢ η ck        = ck
mono⊢ η cs        = cs
mono⊢ η cpair     = cpair
mono⊢ η cfst      = cfst
mono⊢ η csnd      = csnd
mono⊢ η unit      = unit

mono⊢⋆ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢⋆ Ξ → Γ′ ⊢⋆ Ξ
mono⊢⋆ {∅}     η ∙        = ∙
mono⊢⋆ {Ξ , A} η (ts , t) = mono⊢⋆ η ts , mono⊢ η t

-- Shorthand for variables.

v₀ : ∀ {A Γ} → Γ , A ⊢ A
v₀ = var i₀

v₁ : ∀ {A B Γ} → Γ , A , B ⊢ A
v₁ = var i₁

v₂ : ∀ {A B C Γ} → Γ , A , B , C ⊢ A
v₂ = var i₂

-- Reflexivity.

refl⊢⋆ : ∀ {Γ} → Γ ⊢⋆ Γ
refl⊢⋆ {∅}     = ∙
refl⊢⋆ {Γ , A} = mono⊢⋆ weak⊆ refl⊢⋆ , v₀

-- Deduction theorem.

lam : ∀ {A B Γ} → Γ , A ⊢ B → Γ ⊢ A ▻ B
lam (var top)     = ci
lam (var (pop i)) = app ck (var i)
lam (app t u)     = app (app cs (lam t)) (lam u)
lam ci            = app ck ci
lam ck            = app ck ck
lam cs            = app ck cs
lam cpair         = app ck cpair
lam cfst          = app ck cfst
lam csnd          = app ck csnd
lam unit          = app ck unit

lam⋆ : ∀ {Ξ Γ A} → Γ ⧺ Ξ ⊢ A → Γ ⊢ Ξ ▻⋯▻ A
lam⋆ {∅}     = I
lam⋆ {Ξ , B} = lam⋆ {Ξ} ∘ lam

lam⋆₀ : ∀ {Γ A} → Γ ⊢ A → ∅ ⊢ Γ ▻⋯▻ A
lam⋆₀ {∅}     = I
lam⋆₀ {Γ , B} = lam⋆₀ ∘ lam

-- Detachment theorem.

det : ∀ {A B Γ} → Γ ⊢ A ▻ B → Γ , A ⊢ B
det t = app (mono⊢ weak⊆ t) v₀

det⋆ : ∀ {Ξ Γ A} → Γ ⊢ Ξ ▻⋯▻ A → Γ ⧺ Ξ ⊢ A
det⋆ {∅}     = I
det⋆ {Ξ , B} = det ∘ det⋆ {Ξ}

det⋆₀ : ∀ {Γ A} → ∅ ⊢ Γ ▻⋯▻ A → Γ ⊢ A
det⋆₀ {∅}     = I
det⋆₀ {Γ , B} = det ∘ det⋆₀

-- Cut and multicut.

cut : ∀ {A B Γ} → Γ ⊢ A → Γ , A ⊢ B → Γ ⊢ B
cut t u = app (lam u) t

multicut : ∀ {Ξ A Γ} → Γ ⊢⋆ Ξ → Ξ ⊢ A → Γ ⊢ A
multicut {∅}     ∙        u = mono⊢ bot⊆ u
multicut {Ξ , B} (ts , t) u = app (multicut ts (lam u)) t

-- Transitivity.

trans⊢⋆ : ∀ {Γ″ Γ′ Γ} → Γ ⊢⋆ Γ′ → Γ′ ⊢⋆ Γ″ → Γ ⊢⋆ Γ″
trans⊢⋆ {∅}      ts ∙        = ∙
trans⊢⋆ {Γ″ , A} ts (us , u) = trans⊢⋆ ts us , multicut ts u

-- Contraction.

ccont : ∀ {A B Γ} → Γ ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = lam (lam (app (app v₁ v₀) v₀))

cont : ∀ {A B Γ} → Γ , A , A ⊢ B → Γ , A ⊢ B
cont t = det (app ccont (lam (lam t)))

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C Γ} → Γ ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = lam (lam (lam (app (app v₂ v₀) v₁)))

exch : ∀ {A B C Γ} → Γ , A , B ⊢ C → Γ , B , A ⊢ C
exch t = det (det (app cexch (lam (lam t))))

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C Γ} → Γ ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = lam (lam (lam (app v₂ (app v₁ v₀))))

comp : ∀ {A B C Γ} → Γ , B ⊢ C → Γ , A ⊢ B → Γ , A ⊢ C
comp t u = det (app (app ccomp (lam t)) (lam u))

-- Useful theorems in functional form.

pair : ∀ {A B Γ} → Γ ⊢ A → Γ ⊢ B → Γ ⊢ A ∧ B
pair t u = app (app cpair t) u

fst : ∀ {A B Γ} → Γ ⊢ A ∧ B → Γ ⊢ A
fst t = app cfst t

snd : ∀ {A B Γ} → Γ ⊢ A ∧ B → Γ ⊢ B
snd t = app csnd t

-- Closure under context concatenation.

concat : ∀ {A B Γ} Γ′ → Γ , A ⊢ B → Γ′ ⊢ A → Γ ⧺ Γ′ ⊢ B
concat Γ′ t u = app (mono⊢ (weak⊆⧺₁ Γ′) (lam t)) (mono⊢ weak⊆⧺₂ u)

-- Convertibility.

data _⋙_ {Γ : Cx Ty} : ∀ {A} → Γ ⊢ A → Γ ⊢ A → Set where
  refl⋙     : ∀ {A} → {t : Γ ⊢ A}
                     → t ⋙ t

  trans⋙    : ∀ {A} → {t t′ t″ : Γ ⊢ A}
                     → t ⋙ t′ → t′ ⋙ t″
                     → t ⋙ t″

  sym⋙      : ∀ {A} → {t t′ : Γ ⊢ A}
                     → t ⋙ t′
                     → t′ ⋙ t

  congapp⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ▻ B} → {u u′ : Γ ⊢ A}
                       → t ⋙ t′ → u ⋙ u′
                       → app t u ⋙ app t′ u′

  congi⋙    : ∀ {A} → {t t′ : Γ ⊢ A}
                     → t ⋙ t′
                     → app ci t ⋙ app ci t′

  congk⋙    : ∀ {A B} → {t t′ : Γ ⊢ A} → {u u′ : Γ ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app ck t) u ⋙ app (app ck t′) u′

  congs⋙    : ∀ {A B C} → {t t′ : Γ ⊢ A ▻ B ▻ C} → {u u′ : Γ ⊢ A ▻ B} → {v v′ : Γ ⊢ A}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app cs t) u) v ⋙ app (app (app cs t′) u′) v′

  congpair⋙ : ∀ {A B} → {t t′ : Γ ⊢ A} → {u u′ : Γ ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app cpair t) u ⋙ app (app cpair t′) u′

  congfst⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                       → t ⋙ t′
                       → app cfst t ⋙ app cfst t′

  congsnd⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                       → t ⋙ t′
                       → app csnd t ⋙ app csnd t′

  -- TODO: Verify this.
  beta▻ₖ⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app (app ck t) u ⋙ t

  -- TODO: Verify this.
  beta▻ₛ⋙   : ∀ {A B C} → {t : Γ ⊢ A ▻ B ▻ C} → {u : Γ ⊢ A ▻ B} → {v : Γ ⊢ A}
                         → app (app (app cs t) u) v ⋙ app (app t v) (app u v)

  -- TODO: What about eta for ▻?
  beta∧₁⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app cfst (app (app cpair t) u) ⋙ t

  beta∧₂⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app csnd (app (app cpair t) u) ⋙ u

  eta∧⋙     : ∀ {A B} → {t : Γ ⊢ A ∧ B}
                       → t ⋙ app (app cpair (app cfst t)) (app csnd t)

  eta⊤⋙    : ∀ {t : Γ ⊢ ⊤} → t ⋙ unit


{-# OPTIONS --instance-search-depth=10 #-}

open import Agda.Primitive

it : ∀ {a} {A : Set a} {{x : A}} -> A
it {{x}} = x

infixr 5 _,_
postulate
  Pair : ∀ {a} (A : Set a) {b} (B : Set b) -> Set (a ⊔ b)
  _,_  : ∀ {a} {A : Set a} {b} {B : Set b} -> A -> B -> Pair A B

data Constraint {a} {A : Set a} (x : A) : Set where
  mkConstraint : Constraint x

record Inner {l a} {A : Set a} (x : A) (_ : Constraint x) (C : Set l) : Set l where
  field
    value : C

Class : ∀ {l a} {A : Set a} (x : A) (C : Set l) -> Set l
Class x C = Inner x mkConstraint C

FunctionClass = λ
  {a} (A : Set a)
  -> Class A (A -> A)

DiagonalClass = λ
  {i} {I : Set i}
  {r} (R : I -> I -> Set r)
  x
  -> Class (R , x) (R x x)

DiagonalFunctionClass = λ
  {i} {I : Set i}
  {r} (R : I -> I -> Set r)
  x
  -> Class (R , x) (R x x -> R x x)

postulate
  toDiagonalFunctionClass : ∀
    {i} {I : Set i}
    {r} {R : I -> I -> Set r}
    {{iD : ∀ {x} -> DiagonalClass R x}}
    -> ∀ {x} -> DiagonalFunctionClass R x

DiagonalPropertyType = λ
  {i r p} {I : Set i}
  (R : I -> I -> Set r)
  (P : ∀ x -> R x x -> Set p)
  -> ∀ x (d : R x x) -> P _ d

DiagonalPropertyClass = λ
  {i r p} {I : Set i}
  (R : I -> I -> Set r)
  (P : ∀ x -> R x x -> Set p)
  (C : FunctionClass I)
  -> Class (R , P , C) (DiagonalPropertyType R P)

diagonalProperty : ∀
  {i r p} {I : Set i}
  {R : I -> I -> Set r}
  {P : ∀ x -> R x x -> Set p}
  {{C : FunctionClass I}}
  {{iDP : DiagonalPropertyClass R P C}}
  -> DiagonalPropertyType R P
diagonalProperty {{iDP = iDP}} = Inner.value iDP

-- works-1 works-2
fails : ∀
  {r p} {I : Set}
  {R : I -> I -> Set r}
  {P : ∀ x -> R x x -> Set p}
  (C : FunctionClass I)
  {{iDP : DiagonalPropertyClass R P C}}
  -> DiagonalPropertyType R P

-- works-1 C x d =
--   let instance iC = C
--   in diagonalProperty _ d

-- works-2 C x d =
--   let instance iC = C
--                iDF = toDiagonalFunctionClass
--   in diagonalProperty {{it}} _ d

fails C x d =
  let instance iC = C
               iDF = toDiagonalFunctionClass
  in diagonalProperty _ d -- Instance search depth exhausted


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

module BitVec where

open import Data.Bool       using (Bool; false; true; _∨_; _∧_)
open import Data.Fin        using (Fin; toℕ)
open import Data.List       using (List; []; _∷_; foldr)
open import Data.Nat        using (ℕ; zero; suc; _≡ᵇ_)
open import Data.Product    using (_×_; _,_; proj₂)
open import Data.String     using (String; fromList)
open import Data.Vec        using (Vec; []; _∷_; map; lookup; replicate; _[_]%=_; toList; zip; zipWith)

open import Function        using (_∘_)

-- Bit vector representation of finite sets

BitVec : ℕ → Set
BitVec = Vec Bool

show : {n : ℕ} → BitVec n → String
show = fromList ∘ toList ∘ map (λ {true → '1' ; false → '0'})

empty : {n : ℕ} → BitVec n
empty = replicate false

insert : {n : ℕ} → Fin n → BitVec n → BitVec n
insert k s = s [ k ]%= (λ _ → true)

infixr 5 _∪_
_∪_ : {n : ℕ} → BitVec n → BitVec n → BitVec n
_∪_ = zipWith _∨_

infixr 6 _∩_
_∩_ : {n : ℕ} → BitVec n → BitVec n → BitVec n
_∩_ = zipWith _∧_

infix 4 _∈_
_∈_ : {n : ℕ} → Fin n → BitVec n → Bool
b ∈ bv = lookup bv b

indices : {n : ℕ} → Vec (Fin n) n
indices {ℕ.zero} = []
indices {suc n} = Fin.zero ∷ map Fin.suc (indices {n})

elements : {n : ℕ} → BitVec n → List (Fin n)
elements {n} bv = foldr f [] (toList (zip bv indices))
  where f : Bool × Fin n → List (Fin n) → List (Fin n)
        f (false , _) xs = xs
        f (true  , x) xs = x ∷ xs


module WrongHidingInLambda where

f : (A : Set) -> A -> A
f = \{A} x -> x