------------------------------------------------------------------------
-- Bi-invertibility with erased proofs
------------------------------------------------------------------------

-- The development is based on the presentation of bi-invertibility
-- (for types and functions) and related things in the HoTT book, but
-- adapted to a setting with erasure.

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

open import Equality
open import Prelude as P hiding (id; _∘_; [_,_])

-- The code is parametrised by something like a "raw" category.

module Bi-invertibility.Erased
  {e⁺}
  (eq : ∀ {a p} → Equality-with-J a p e⁺)
  {o h}
  (Obj : Type o)
  (Hom : Obj → Obj → Type h)
  (id : {A : Obj} → Hom A A)
  (_∘′_ : {A B C : Obj} → Hom B C → Hom A B → Hom A C)
  where

open import Bi-invertibility eq Obj Hom id _∘′_ as Bi
  using (Has-left-inverse; Has-right-inverse; Is-bi-invertible;
         Has-quasi-inverse; _≊_; _≅_)
open Derived-definitions-and-properties eq
open import Equivalence eq as Eq using (_≃_)
open import Equivalence.Erased eq as EEq using (_≃ᴱ_)
open import Equivalence.Erased.Contractible-preimages eq as ECP
  using (Contractibleᴱ)
open import Erased.Without-box-cong eq
open import Function-universe eq as F hiding (id; _∘_)
open import Logical-equivalence using (_⇔_)
open import H-level eq
open import H-level.Closure eq
open import Preimage eq
open import Surjection eq using (_↠_)

private
  variable
    A B : Obj
    f   : Hom A B

  infixr 9 _∘_

  _∘_ : {A B C : Obj} → Hom B C → Hom A B → Hom A C
  _∘_ = _∘′_

-- Has-left-inverseᴱ f means that f has a left inverse. The proof is
-- erased.

Has-left-inverseᴱ : @0 Hom A B → Type h
Has-left-inverseᴱ f = ∃ λ f⁻¹ → Erased (f⁻¹ ∘ f ≡ id)

-- Has-right-inverseᴱ f means that f has a right inverse. The proof is
-- erased.

Has-right-inverseᴱ : @0 Hom A B → Type h
Has-right-inverseᴱ f = ∃ λ f⁻¹ → Erased (f ∘ f⁻¹ ≡ id)

-- Is-bi-invertibleᴱ f means that f has a left inverse and a (possibly
-- distinct) right inverse. The proofs are erased.

Is-bi-invertibleᴱ : @0 Hom A B → Type h
Is-bi-invertibleᴱ f =
  Has-left-inverseᴱ f × Has-right-inverseᴱ f

-- Has-quasi-inverseᴱ f means that f has a left inverse that is also a
-- right inverse. The proofs are erased.

Has-quasi-inverseᴱ : @0 Hom A B → Type h
Has-quasi-inverseᴱ f =
  ∃ λ f⁻¹ → Erased (f ∘ f⁻¹ ≡ id × f⁻¹ ∘ f ≡ id)

-- Some notions of isomorphism or equivalence.

infix 4 _≊ᴱ_ _≅ᴱ_

_≊ᴱ_ : Obj → Obj → Type h
A ≊ᴱ B = ∃ λ (f : Hom A B) → Is-bi-invertibleᴱ f

_≅ᴱ_ : Obj → Obj → Type h
A ≅ᴱ B = ∃ λ (f : Hom A B) → Has-quasi-inverseᴱ f

-- Morphisms with quasi-inverses are bi-invertible.

Has-quasi-inverseᴱ→Is-bi-invertibleᴱ :
  (@0 f : Hom A B) → Has-quasi-inverseᴱ f → Is-bi-invertibleᴱ f
Has-quasi-inverseᴱ→Is-bi-invertibleᴱ _ (f⁻¹ , [ f∘f⁻¹≡id , f⁻¹∘f≡id ]) =
    (f⁻¹ , [ f⁻¹∘f≡id ])
  , (f⁻¹ , [ f∘f⁻¹≡id ])

≅ᴱ→≊ᴱ : A ≅ᴱ B → A ≊ᴱ B
≅ᴱ→≊ᴱ = ∃-cong λ f → Has-quasi-inverseᴱ→Is-bi-invertibleᴱ f

-- Some conversion functions.

Has-left-inverse→Has-left-inverseᴱ :
  Has-left-inverse f → Has-left-inverseᴱ f
Has-left-inverse→Has-left-inverseᴱ = Σ-map P.id [_]→

@0 Has-left-inverse≃Has-left-inverseᴱ :
  Has-left-inverse f ≃ Has-left-inverseᴱ f
Has-left-inverse≃Has-left-inverseᴱ {f = f} =
  (∃ λ f⁻¹ →         f⁻¹ ∘ f ≡ id )  ↔⟨ (∃-cong λ _ → inverse $ erased Erased↔) ⟩□
  (∃ λ f⁻¹ → Erased (f⁻¹ ∘ f ≡ id))  □

Has-right-inverse→Has-right-inverseᴱ :
  Has-right-inverse f → Has-right-inverseᴱ f
Has-right-inverse→Has-right-inverseᴱ = Σ-map P.id [_]→

@0 Has-right-inverse≃Has-right-inverseᴱ :
  Has-right-inverse f ≃ Has-right-inverseᴱ f
Has-right-inverse≃Has-right-inverseᴱ {f = f} =
  (∃ λ f⁻¹ →         f ∘ f⁻¹ ≡ id )  ↔⟨ (∃-cong λ _ → inverse $ erased Erased↔) ⟩□
  (∃ λ f⁻¹ → Erased (f ∘ f⁻¹ ≡ id))  □

Is-bi-invertible→Is-bi-invertibleᴱ :
  Is-bi-invertible f → Is-bi-invertibleᴱ f
Is-bi-invertible→Is-bi-invertibleᴱ =
  Σ-map Has-left-inverse→Has-left-inverseᴱ
        Has-right-inverse→Has-right-inverseᴱ

@0 Is-bi-invertible≃Is-bi-invertibleᴱ :
  Is-bi-invertible f ≃ Is-bi-invertibleᴱ f
Is-bi-invertible≃Is-bi-invertibleᴱ {f = f} =
  Has-left-inverse  f × Has-right-inverse  f  ↝⟨ Has-left-inverse≃Has-left-inverseᴱ ×-cong
                                                 Has-right-inverse≃Has-right-inverseᴱ ⟩□
  Has-left-inverseᴱ f × Has-right-inverseᴱ f  □

Has-quasi-inverse→Has-quasi-inverseᴱ :
  Has-quasi-inverse f → Has-quasi-inverseᴱ f
Has-quasi-inverse→Has-quasi-inverseᴱ = Σ-map P.id [_]→

@0 Has-quasi-inverse≃Has-quasi-inverseᴱ :
  Has-quasi-inverse f ≃ Has-quasi-inverseᴱ f
Has-quasi-inverse≃Has-quasi-inverseᴱ {f = f} =
  (∃ λ f⁻¹ →         f ∘ f⁻¹ ≡ id × f⁻¹ ∘ f ≡ id )  ↔⟨ (∃-cong λ _ → inverse $ erased Erased↔) ⟩□
  (∃ λ f⁻¹ → Erased (f ∘ f⁻¹ ≡ id × f⁻¹ ∘ f ≡ id))  □

≊→≊ᴱ : A ≊ B → A ≊ᴱ B
≊→≊ᴱ = Σ-map P.id Is-bi-invertible→Is-bi-invertibleᴱ

@0 ≊≃≊ᴱ : (A ≊ B) ≃ (A ≊ᴱ B)
≊≃≊ᴱ {A = A} {B = B} =
  (∃ λ (f : Hom A B) → Is-bi-invertible  f)  ↝⟨ (∃-cong λ _ → Is-bi-invertible≃Is-bi-invertibleᴱ) ⟩□
  (∃ λ (f : Hom A B) → Is-bi-invertibleᴱ f)  □

≅→≅ᴱ : A ≅ B → A ≅ᴱ B
≅→≅ᴱ = Σ-map P.id Has-quasi-inverse→Has-quasi-inverseᴱ

@0 ≅≃≅ᴱ : (A ≅ B) ≃ (A ≅ᴱ B)
≅≃≅ᴱ {A = A} {B = B} =
  (∃ λ (f : Hom A B) → Has-quasi-inverse  f)  ↝⟨ (∃-cong λ _ → Has-quasi-inverse≃Has-quasi-inverseᴱ) ⟩□
  (∃ λ (f : Hom A B) → Has-quasi-inverseᴱ f)  □

-- The remaining code relies on some further assumptions, similar to
-- those of a precategory. However, note that Hom A B is not required
-- to be a set (some properties require Hom A A to be a set for some
-- A).

module More
  (@0 left-identity  : {A B : Obj} (f : Hom A B) → id ∘ f ≡ f)
  (@0 right-identity : {A B : Obj} (f : Hom A B) → f ∘ id ≡ f)
  (@0 associativity  : {A B C D : Obj}
                       (f : Hom C D) (g : Hom B C) (h : Hom A B) →
                       f ∘ (g ∘ h) ≡ (f ∘ g) ∘ h)
  where

  -- A workaround for Agda's lack of erased modules.

  private

    record Proofs : Type (o ⊔ h) where
      field
        lid : {A B : Obj} (f : Hom A B) → id ∘ f ≡ f
        rid : {A B : Obj} (f : Hom A B) → f ∘ id ≡ f
        ass : {A B C D : Obj}
              (f : Hom C D) (g : Hom B C) (h : Hom A B) →
              f ∘ (g ∘ h) ≡ (f ∘ g) ∘ h

    @0 proofs : Proofs
    proofs .Proofs.lid = left-identity
    proofs .Proofs.rid = right-identity
    proofs .Proofs.ass = associativity

    module BiM (p : Proofs) =
      Bi.More
        (Proofs.lid p)
        (Proofs.rid p)
        (Proofs.ass p)

  -- Bi-invertible morphisms have quasi-inverses.

  Is-bi-invertibleᴱ→Has-quasi-inverseᴱ :
    Is-bi-invertibleᴱ f → Has-quasi-inverseᴱ f
  Is-bi-invertibleᴱ→Has-quasi-inverseᴱ
    {f = f} ((f⁻¹₁ , [ f⁻¹₁∘f≡id ]) , (f⁻¹₂ , [ f∘f⁻¹₂≡id ])) =
      (f⁻¹₁ ∘ f ∘ f⁻¹₂)
    , [ (f ∘ f⁻¹₁ ∘ f ∘ f⁻¹₂    ≡⟨ cong (f ∘_) $ associativity _ _ _ ⟩
         f ∘ (f⁻¹₁ ∘ f) ∘ f⁻¹₂  ≡⟨ cong (λ f′ → f ∘ f′ ∘ f⁻¹₂) f⁻¹₁∘f≡id ⟩
         f ∘ id ∘ f⁻¹₂          ≡⟨ cong (f ∘_) $ left-identity _ ⟩
         f ∘ f⁻¹₂               ≡⟨ f∘f⁻¹₂≡id ⟩∎
         id                     ∎)
      , ((f⁻¹₁ ∘ f ∘ f⁻¹₂) ∘ f  ≡⟨ cong (λ f′ → (f⁻¹₁ ∘ f′) ∘ f) f∘f⁻¹₂≡id ⟩
         (f⁻¹₁ ∘ id) ∘ f        ≡⟨ cong (_∘ f) $ right-identity _ ⟩
         f⁻¹₁ ∘ f               ≡⟨ f⁻¹₁∘f≡id ⟩∎
         id                     ∎)
      ]

  -- Has-left-inverseᴱ f is contractible (with an erased proof) if f
  -- has a quasi-inverse (with erased proofs).

  Contractibleᴱ-Has-left-inverseᴱ :
    {@0 f : Hom A B} →
    Has-quasi-inverseᴱ f → Contractibleᴱ (Has-left-inverseᴱ f)
  Contractibleᴱ-Has-left-inverseᴱ
    {f = f} (f⁻¹ , [ f∘f⁻¹≡id , f⁻¹∘f≡id ]) =
    ECP.Contractibleᴱ-⁻¹ᴱ
      (_∘ f)
      (_∘ f⁻¹)
      (λ g →
         (g ∘ f⁻¹) ∘ f  ≡⟨ sym $ associativity _ _ _ ⟩
         g ∘ f⁻¹ ∘ f    ≡⟨ cong (g ∘_) f⁻¹∘f≡id ⟩
         g ∘ id         ≡⟨ right-identity _ ⟩∎
         g              ∎)
      (λ g →
         (g ∘ f) ∘ f⁻¹  ≡⟨ sym $ associativity _ _ _ ⟩
         g ∘ f ∘ f⁻¹    ≡⟨ cong (g ∘_) f∘f⁻¹≡id ⟩
         g ∘ id         ≡⟨ right-identity _ ⟩∎
         g              ∎)
      id

  -- Has-right-inverseᴱ f is contractible (with an erased proof) if f
  -- has a quasi-inverse (with erased proofs).

  Contractibleᴱ-Has-right-inverseᴱ :
    {@0 f : Hom A B} →
    Has-quasi-inverseᴱ f → Contractibleᴱ (Has-right-inverseᴱ f)
  Contractibleᴱ-Has-right-inverseᴱ
    {f = f} (f⁻¹ , [ f∘f⁻¹≡id , f⁻¹∘f≡id ]) =
    ECP.Contractibleᴱ-⁻¹ᴱ
      (f ∘_)
      (f⁻¹ ∘_)
      (λ g →
         f ∘ f⁻¹ ∘ g    ≡⟨ associativity _ _ _ ⟩
         (f ∘ f⁻¹) ∘ g  ≡⟨ cong (_∘ g) f∘f⁻¹≡id ⟩
         id ∘ g         ≡⟨ left-identity _ ⟩∎
         g              ∎)
      (λ g →
         f⁻¹ ∘ f ∘ g    ≡⟨ associativity _ _ _ ⟩
         (f⁻¹ ∘ f) ∘ g  ≡⟨ cong (_∘ g) f⁻¹∘f≡id ⟩
         id ∘ g         ≡⟨ left-identity _ ⟩∎
         g              ∎)
      id

  -- Is-bi-invertibleᴱ f is a proposition (in erased contexts).

  @0 Is-bi-invertibleᴱ-propositional :
    (f : Hom A B) → Is-proposition (Is-bi-invertibleᴱ f)
  Is-bi-invertibleᴱ-propositional f =     $⟨ BiM.Is-bi-invertible-propositional proofs f ⟩
    Is-proposition (Is-bi-invertible  f)  ↝⟨ H-level-cong _ 1 Is-bi-invertible≃Is-bi-invertibleᴱ ⦂ (_ → _) ⟩
    Is-proposition (Is-bi-invertibleᴱ f)  □

  -- If Hom A A is a set, where A is the domain of f, then
  -- Has-quasi-inverseᴱ f is a proposition (in erased contexts).

  @0 Has-quasi-inverseᴱ-propositional-domain :
    {f : Hom A B} →
    Is-set (Hom A A) →
    Is-proposition (Has-quasi-inverseᴱ f)
  Has-quasi-inverseᴱ-propositional-domain {f = f} s =
                                           $⟨ BiM.Has-quasi-inverse-propositional-domain proofs s ⟩
    Is-proposition (Has-quasi-inverse  f)  ↝⟨ H-level-cong _ 1 Has-quasi-inverse≃Has-quasi-inverseᴱ ⦂ (_ → _) ⟩□
    Is-proposition (Has-quasi-inverseᴱ f)  □

  -- If Hom B B is a set, where B is the codomain of f, then
  -- Has-quasi-inverseᴱ f is a proposition (in erased contexts).

  @0 Has-quasi-inverseᴱ-propositional-codomain :
    {f : Hom A B} →
    Is-set (Hom B B) →
    Is-proposition (Has-quasi-inverseᴱ f)
  Has-quasi-inverseᴱ-propositional-codomain {f = f} s =
                                           $⟨ BiM.Has-quasi-inverse-propositional-codomain proofs s ⟩
    Is-proposition (Has-quasi-inverse  f)  ↝⟨ H-level-cong _ 1 Has-quasi-inverse≃Has-quasi-inverseᴱ ⦂ (_ → _) ⟩□
    Is-proposition (Has-quasi-inverseᴱ f)  □

  -- There is a logical equivalence between Has-quasi-inverseᴱ f and
  -- Is-bi-invertibleᴱ f.

  Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ :
    Has-quasi-inverseᴱ f ⇔ Is-bi-invertibleᴱ f
  Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ = record
    { to   = Has-quasi-inverseᴱ→Is-bi-invertibleᴱ _
    ; from = Is-bi-invertibleᴱ→Has-quasi-inverseᴱ
    }

  -- There is a logical equivalence between A ≅ᴱ B and A ≊ᴱ B.

  ≅ᴱ⇔≊ᴱ : (A ≅ᴱ B) ⇔ (A ≊ᴱ B)
  ≅ᴱ⇔≊ᴱ = ∃-cong λ _ → Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ

  -- Is-bi-invertibleᴱ and Has-quasi-inverseᴱ are equivalent (with
  -- erased proofs) for morphisms with domain A for which Hom A A is a
  -- set.

  Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-domain :
    {f : Hom A B} →
    @0 Is-set (Hom A A) →
    Is-bi-invertibleᴱ f ≃ᴱ Has-quasi-inverseᴱ f
  Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-domain s = EEq.⇔→≃ᴱ
    (Is-bi-invertibleᴱ-propositional _)
    (Has-quasi-inverseᴱ-propositional-domain s)
    (_⇔_.from Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ)
    (_⇔_.to   Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ)

  -- Is-bi-invertibleᴱ and Has-quasi-inverseᴱ are equivalent (with
  -- erased proofs) for morphisms with codomain B for which Hom B B is
  -- a set.

  Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-codomain :
    {f : Hom A B} →
    @0 Is-set (Hom B B) →
    Is-bi-invertibleᴱ f ≃ᴱ Has-quasi-inverseᴱ f
  Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-codomain s = EEq.⇔→≃ᴱ
    (Is-bi-invertibleᴱ-propositional _)
    (Has-quasi-inverseᴱ-propositional-codomain s)
    (_⇔_.from Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ)
    (_⇔_.to   Has-quasi-inverseᴱ⇔Is-bi-invertibleᴱ)

  -- A ≊ᴱ B and A ≅ᴱ B are equivalent (with erased proofs) if Hom A A
  -- is a set.

  ≊ᴱ≃ᴱ≅ᴱ-domain :
    @0 Is-set (Hom A A) →
    (A ≊ᴱ B) ≃ᴱ (A ≅ᴱ B)
  ≊ᴱ≃ᴱ≅ᴱ-domain s =
    ∃-cong λ _ → Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-domain s

  -- A ≊ᴱ B and A ≅ᴱ B are equivalent (with erased proofs) if Hom B B
  -- is a set.

  ≊ᴱ≃ᴱ≅ᴱ-codomain :
    @0 Is-set (Hom B B) →
    (A ≊ᴱ B) ≃ᴱ (A ≅ᴱ B)
  ≊ᴱ≃ᴱ≅ᴱ-codomain s =
    ∃-cong λ _ → Is-bi-invertibleᴱ≃ᴱHas-quasi-inverseᴱ-codomain s

  -- An equality characterisation lemma for _≊ᴱ_.

  @0 equality-characterisation-≊ᴱ :
    (f g : A ≊ᴱ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≊ᴱ f g =
    f ≡ g                              ↝⟨ inverse $ Eq.≃-≡ (inverse ≊≃≊ᴱ) ⟩
    _≃_.from ≊≃≊ᴱ f ≡ _≃_.from ≊≃≊ᴱ g  ↝⟨ BiM.equality-characterisation-≊ proofs _ _ ⟩□
    proj₁ f ≡ proj₁ g                  □

  -- Two equality characterisation lemmas for _≅ᴱ_.

  @0 equality-characterisation-≅ᴱ-domain :
    Is-set (Hom A A) →
    (f g : A ≅ᴱ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≅ᴱ-domain s f g =
    f ≡ g                              ↝⟨ inverse $ Eq.≃-≡ (inverse ≅≃≅ᴱ) ⟩
    _≃_.from ≅≃≅ᴱ f ≡ _≃_.from ≅≃≅ᴱ g  ↝⟨ BiM.equality-characterisation-≅-domain proofs s _ _ ⟩□
    proj₁ f ≡ proj₁ g                  □

  @0 equality-characterisation-≅ᴱ-codomain :
    Is-set (Hom B B) →
    (f g : A ≅ᴱ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≅ᴱ-codomain s f g =
    f ≡ g                              ↝⟨ inverse $ Eq.≃-≡ (inverse ≅≃≅ᴱ) ⟩
    _≃_.from ≅≃≅ᴱ f ≡ _≃_.from ≅≃≅ᴱ g  ↝⟨ BiM.equality-characterisation-≅-codomain proofs s _ _ ⟩□
    proj₁ f ≡ proj₁ g                  □

  -- If f : Hom A B has a quasi-inverse, then Has-quasi-inverseᴱ f is
  -- equivalent to id ≡ id (in erased contexts), where id stands for
  -- either the identity at A or at B.

  @0 Has-quasi-inverseᴱ≃id≡id-domain :
    {f : Hom A B} →
    Has-quasi-inverseᴱ f →
    Has-quasi-inverseᴱ f ≃ (id ≡ id {A = A})
  Has-quasi-inverseᴱ≃id≡id-domain {f = f} q-inv =
    Has-quasi-inverseᴱ f  ↝⟨ inverse Has-quasi-inverse≃Has-quasi-inverseᴱ ⟩
    Has-quasi-inverse f   ↝⟨ BiM.Has-quasi-inverse≃id≡id-domain proofs (_≃_.from Has-quasi-inverse≃Has-quasi-inverseᴱ q-inv) ⟩□
    id ≡ id               □

  @0 Has-quasi-inverseᴱ≃id≡id-codomain :
    {f : Hom A B} →
    Has-quasi-inverseᴱ f →
    Has-quasi-inverseᴱ f ≃ (id ≡ id {A = B})
  Has-quasi-inverseᴱ≃id≡id-codomain {f = f} q-inv =
    Has-quasi-inverseᴱ f  ↝⟨ inverse Has-quasi-inverse≃Has-quasi-inverseᴱ ⟩
    Has-quasi-inverse f   ↝⟨ BiM.Has-quasi-inverse≃id≡id-codomain proofs (_≃_.from Has-quasi-inverse≃Has-quasi-inverseᴱ q-inv) ⟩□
    id ≡ id               □


------------------------------------------------------------------------
-- The classical definition of (strong) bisimilarity
------------------------------------------------------------------------

-- This module is largely based on "Enhancements of the bisimulation
-- proof method" by Pous and Sangiorgi.

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

open import Labelled-transition-system

module Bisimilarity.Classical {ℓ} (lts : LTS ℓ) where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude

open import Function-universe equality-with-J hiding (id; _∘_)

open LTS lts

open import Bisimilarity.Step lts _[_]⟶_ _[_]⟶_ as S hiding (⟨_,_⟩)
open import Indexed-container
  hiding (⟨_⟩; Bisimilarity; larger⇔smallest)
open import Relation

------------------------------------------------------------------------
-- Progressions, bisimulations and bisimilarity

-- Progressions.

Progression : ∀ {r s} → Rel₂ r Proc → Rel₂ s Proc → Type (ℓ ⊔ r ⊔ s)
Progression R S = R ⊆ Step S

module Progression
        {r s} {R : Rel₂ r Proc} {S : Rel₂ s Proc}
        (P : Progression R S)
        where

  -- Some "projections".

  left-to-right :
    ∀ {p p′ q μ} →
    R (p , q) → p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]⟶ q′ × S (p′ , q′)
  left-to-right pRq = Step.left-to-right (P pRq)

  right-to-left :
    ∀ {p q q′ μ} →
    R (p , q) → q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]⟶ p′ × S (p′ , q′)
  right-to-left pRq = Step.right-to-left (P pRq)

open Progression public

-- A "constructor" for Progression.

⟪_,_⟫ :
  ∀ {r s} {R : Rel₂ r Proc} {S : Rel₂ s Proc} →
  (∀ {p p′ q μ} →
   R (p , q) → p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]⟶ q′ × S (p′ , q′)) →
  (∀ {p q q′ μ} →
   R (p , q) → q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]⟶ p′ × S (p′ , q′)) →
  Progression R S
⟪ lr , rl ⟫ = λ pRq → S.⟨ lr pRq , rl pRq ⟩

-- Bisimulations.

Bisimulation : ∀ {r} → Rel₂ r Proc → Type (ℓ ⊔ r)
Bisimulation R = Progression R R

-- Bisimilarity with a level argument.

Bisimilarity′ : ∀ ℓ′ → Rel₂ (lsuc (ℓ ⊔ ℓ′)) Proc
Bisimilarity′ ℓ′ = gfp ℓ′ StepC

-- Bisimilarity′ ℓ′ is pointwise logically equivalent to
-- Bisimilarity′ lzero.
--
-- For this reason the code below is mostly restricted to
-- Bisimilarity′ lzero.

larger⇔smallest :
  ∀ ℓ′ {p} → Bisimilarity′ ℓ′ p ⇔ Bisimilarity′ lzero p
larger⇔smallest ℓ′ = Indexed-container.larger⇔smallest ℓ′

-- Bisimilarity.

Bisimilarity : Rel₂ (lsuc ℓ) Proc
Bisimilarity = Bisimilarity′ lzero

infix 4 _∼_

_∼_ : Proc → Proc → Type (lsuc ℓ)
p ∼ q = ∃ λ R → R ⊆ ⟦ StepC ⟧ R × R (p , q)

private

  -- The definition of _∼_ could also have been given more indirectly.

  indirect-∼ : _∼_ ≡ curry Bisimilarity
  indirect-∼ = refl

-- An unfolding lemma for Bisimilarity′.

Bisimilarity′↔ :
  ∀ {k} ℓ′ {pq} →
  Extensionality? k (ℓ ⊔ ℓ′) (ℓ ⊔ ℓ′) →

  Bisimilarity′ ℓ′ pq
    ↝[ k ]
  ∃ λ (R : Rel₂ (ℓ ⊔ ℓ′) Proc) → Bisimulation R × R pq

Bisimilarity′↔ {k} ℓ′ {pq} ext =
  Bisimilarity′ ℓ′ pq                                      ↔⟨⟩
  gfp ℓ′ StepC pq                                          ↔⟨⟩
  (∃ λ (R : Rel₂ (ℓ ⊔ ℓ′) Proc) → R ⊆ ⟦ StepC ⟧ R × R pq)  ↝⟨ (∃-cong λ _ → ×-cong₁ λ _ → ⊆-congʳ ext $
                                                               inverse-ext? Step↔StepC (lower-extensionality? k ℓ′ lzero ext)) ⟩□
  (∃ λ (R : Rel₂ (ℓ ⊔ ℓ′) Proc) → Bisimulation R × R pq)   □

-- An unfolding lemma for Bisimilarity.

Bisimilarity↔ :
  ∀ {k pq} →
  Extensionality? k ℓ ℓ →

  Bisimilarity pq
    ↝[ k ]
  ∃ λ (R : Rel₂ ℓ Proc) → Bisimulation R × R pq

Bisimilarity↔ = Bisimilarity′↔ lzero

-- A "constructor".

⟨_,_,_⟩ :
  ∀ {p q} →
  (R : Rel₂ ℓ Proc) → Bisimulation R → R (p , q) → p ∼ q
⟨ R , bisim , pRq ⟩ = _⇔_.from (Bisimilarity↔ _) (R , bisim , pRq)

------------------------------------------------------------------------
-- Bisimilarity is an equivalence relation

-- Reflexivity, proved generally for Bisimilarity′.

reflexive-∼′ : ∀ ℓ {p} → Bisimilarity′ ℓ (p , p)
reflexive-∼′ ℓ = _⇔_.from (Bisimilarity′↔ ℓ _)
  ( ↑ ℓ ∘ uncurry _≡_
  ,  ⟪ (λ p≡q p⟶p′ →
          _ , subst (_[ _ ]⟶ _)       (lower p≡q) p⟶p′ , lift refl)
     , (λ p≡q q⟶q′ →
          _ , subst (_[ _ ]⟶ _) (sym $ lower p≡q) q⟶q′ , lift refl)
     ⟫
  , lift refl
  )

-- Reflexivity.

reflexive-∼ : ∀ {p} → p ∼ p
reflexive-∼ = reflexive-∼′ lzero

-- Symmetry.

symmetric-∼ : ∀ {p q} → p ∼ q → q ∼ p
symmetric-∼ p∼q with _⇔_.to (Bisimilarity↔ _) p∼q
... | R , R-is-a-bisimulation , pRq =
  ⟨ R ⁻¹
  , ⟪ right-to-left R-is-a-bisimulation
    , left-to-right R-is-a-bisimulation
    ⟫
  , pRq
  ⟩

-- Transitivity.

transitive-∼ : ∀ {p q r} → p ∼ q → q ∼ r → p ∼ r
transitive-∼ p∼q q∼r with _⇔_.to (Bisimilarity↔ _) p∼q
                        | _⇔_.to (Bisimilarity↔ _) q∼r
... | R₁ , R-is₁ , pR₁q | R₂ , R-is₂ , qR₂r =
  ⟨ R₁ ⊙ R₂
  , ⟪_,_⟫ {R = _ ⊙ _}
      (λ { (q , pR₁q , qR₂r) p⟶p′ →
           let q′ , q⟶q′ , p′R₁q′ = left-to-right R-is₁ pR₁q p⟶p′
               r′ , r⟶r′ , q′R₂r′ = left-to-right R-is₂ qR₂r q⟶q′
           in r′ , r⟶r′ , (q′ , p′R₁q′ , q′R₂r′) })
      (λ { (q , pR₁q , qR₂r) r⟶r′ →
         let q′ , q⟶q′ , q′R₂r′ = right-to-left R-is₂ qR₂r r⟶r′
             p′ , p⟶p′ , p′R₁q′ = right-to-left R-is₁ pR₁q q⟶q′
         in p′ , p⟶p′ , (q′ , p′R₁q′ , q′R₂r′) })
  , (_ , pR₁q , qR₂r)
  ⟩

-- A function that can be used to aid the instance resolution
-- mechanism.

infix -2 ∼:_

∼:_ : ∀ {p q} → p ∼ q → p ∼ q
∼:_ = id

------------------------------------------------------------------------
-- Lemmas relating bisimulations and bisimilarity

-- Bisimilarity is a bisimulation.

bisimilarity-is-a-bisimulation : Bisimulation Bisimilarity
bisimilarity-is-a-bisimulation =
  Bisimilarity            ⊆⟨ gfp-out ℓ ⟩
  ⟦ StepC ⟧ Bisimilarity  ⊆⟨ _⇔_.from (Step↔StepC _) ⟩∎
  Step Bisimilarity       ∎

-- Bisimilarity is larger than every bisimulation.

bisimulation⊆∼ :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation R → R ⊆ Bisimilarity
bisimulation⊆∼ {r} {R} R-is-a-bisimulation =
  R                ⊆⟨ gfp-unfold lzero (

      R                 ⊆⟨ R-is-a-bisimulation ⟩
      Step R            ⊆⟨ Step↔StepC _ ⟩∎
      ⟦ StepC ⟧ R       ∎) ⟩

  Bisimilarity′ r  ⊆⟨ _⇔_.to (larger⇔smallest r) ⟩∎

  Bisimilarity     ∎

------------------------------------------------------------------------
-- Bisimulations up to bisimilarity

-- Bisimulations up to bisimilarity.

Bisimulation-up-to-bisimilarity :
  ∀ {r} → Rel₂ r Proc → Type (lsuc ℓ ⊔ r)
Bisimulation-up-to-bisimilarity R =
  Progression R (Bisimilarity ⊙ R ⊙ Bisimilarity)

-- If R is a bisimulation up to bisimilarity, then ∼R∼ is a
-- bisimulation.

bisimulation-up-to-∼⇒bisimulation :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation-up-to-bisimilarity R →
  Bisimulation (Bisimilarity ⊙ R ⊙ Bisimilarity)
bisimulation-up-to-∼⇒bisimulation R-is =
  ⟪_,_⟫ {R = _ ⊙ _ ⊙ _}
    (λ { (q , p∼q , r , qRr , r∼s) p⟶p′ →
       let q′ , q⟶q′ , p′∼q′ =
             left-to-right bisimilarity-is-a-bisimulation p∼q p⟶p′
           r′ , r⟶r′ , (q″ , q′∼q″ , r″ , q″Rr″ , r″∼r′) =
             left-to-right R-is qRr q⟶q′
           s′ , s⟶s′ , r′∼s′ =
             left-to-right bisimilarity-is-a-bisimulation r∼s r⟶r′
       in
         s′ , s⟶s′ , q″
       , transitive-∼ p′∼q′ q′∼q″
       , r″ , q″Rr″
       , transitive-∼ r″∼r′ r′∼s′ })
    (λ { (q , p∼q , r , qRr , r∼s) s⟶s′ →
       let r′ , r⟶r′ , r′∼s′ =
             right-to-left bisimilarity-is-a-bisimulation r∼s s⟶s′
           q′ , q⟶q′ , (q″ , q′∼q″ , r″ , q″Rr″ , r″∼r′) =
             right-to-left R-is qRr r⟶r′
           p′ , p⟶p′ , p′∼q′ =
             right-to-left bisimilarity-is-a-bisimulation p∼q q⟶q′
       in
         p′ , p⟶p′ , q″
       , transitive-∼ p′∼q′ q′∼q″
       , r″ , q″Rr″
       , transitive-∼ r″∼r′ r′∼s′ })

-- If R is a bisimulation up to bisimilarity, then R is contained in
-- bisimilarity.

bisimulation-up-to-∼⊆∼ :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation-up-to-bisimilarity R →
  R ⊆ Bisimilarity
bisimulation-up-to-∼⊆∼ {R = R} R-is =
  R                                ⊆⟨ (λ { {p , q} pRq → p , reflexive-∼ , q , pRq , reflexive-∼ }) ⟩
  Bisimilarity ⊙ R ⊙ Bisimilarity  ⊆⟨ bisimulation⊆∼ (bisimulation-up-to-∼⇒bisimulation R-is) ⟩∎
  Bisimilarity                     ∎

------------------------------------------------------------------------
-- Bisimulations up to union

-- Bisimulations up to ∪.

Bisimulation-up-to-∪ : ∀ {r} → Rel₂ r Proc → Type (lsuc ℓ ⊔ r)
Bisimulation-up-to-∪ R = Progression R (R ∪ Bisimilarity)

-- If _R_ is a bisimulation up to ∪, then _R_ ∪ _∼_ is a bisimulation.

bisimulation-up-to-∪⇒bisimulation :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation-up-to-∪ R →
  Bisimulation (R ∪ Bisimilarity)
bisimulation-up-to-∪⇒bisimulation R-is =
  ⟪ [ left-to-right R-is
    , (λ p∼q → Σ-map id (Σ-map id inj₂) ∘
               left-to-right bisimilarity-is-a-bisimulation p∼q)
    ]
  , [ right-to-left R-is
    , (λ p∼q → Σ-map id (Σ-map id inj₂) ∘
               right-to-left bisimilarity-is-a-bisimulation p∼q)
    ]
  ⟫

-- If R is a bisimulation up to ∪, then R is contained in
-- bisimilarity.

bisimulation-up-to-∪⊆∼ :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation-up-to-∪ R →
  R ⊆ Bisimilarity
bisimulation-up-to-∪⊆∼ {R = R} R-is =
  R                 ⊆⟨ inj₁ ⟩
  R ∪ Bisimilarity  ⊆⟨ bisimulation⊆∼ (bisimulation-up-to-∪⇒bisimulation R-is) ⟩∎
  Bisimilarity      ∎

------------------------------------------------------------------------
-- Bisimulations up to reflexive transitive closure

-- Bisimulations up to reflexive transitive closure.

Bisimulation-up-to-* : Rel₂ ℓ Proc → Type ℓ
Bisimulation-up-to-* R = Progression R (R *)

-- If R is a bisimulation up to reflexive transitive closure, then R *
-- is a bisimulation.

bisimulation-up-to-*⇒bisimulation :
  ∀ {R} → Bisimulation-up-to-* R → Bisimulation (R *)
bisimulation-up-to-*⇒bisimulation {R} R-is = ⟪ lr , rl ⟫
  where
  lr : ∀ {p p′ q μ} →
       (R *) (p , q) → p [ μ ]⟶ p′ →
       ∃ λ q′ → q [ μ ]⟶ q′ × (R *) (p′ , q′)
  lr (zero  , refl)           q⟶p′ = _ , q⟶p′ , zero , refl
  lr (suc n , r , pRr , rRⁿq) p⟶p′ =
    let r′ , r⟶r′ , p′R*r′ = left-to-right R-is pRr p⟶p′
        q′ , q⟶q′ , r′R*q′ = lr (n , rRⁿq) r⟶r′
    in q′ , q⟶q′ , *-trans p′R*r′ r′R*q′

  rl : ∀ {p q q′ μ} →
       (R *) (p , q) → q [ μ ]⟶ q′ →
       ∃ λ p′ → p [ μ ]⟶ p′ × (R *) (p′ , q′)
  rl (zero  , refl)           p⟶q′ = _ , p⟶q′ , zero , refl
  rl (suc n , r , pRr , rRⁿq) q⟶q′ =
    let r′ , r⟶r′ , r′R*q′ = rl (n , rRⁿq) q⟶q′
        p′ , p⟶p′ , p′R*r′ = right-to-left R-is pRr r⟶r′
    in p′ , p⟶p′ , *-trans p′R*r′ r′R*q′

-- If R is a bisimulation up to reflexive transitive closure, then R
-- is contained in bisimilarity.

bisimulation-up-to-*⊆∼ :
  ∀ {R} → Bisimulation-up-to-* R → R ⊆ Bisimilarity
bisimulation-up-to-*⊆∼ {R} R-is =
  R             ⊆⟨ (λ pRq → 1 , _ , pRq , refl) ⟩
  (R *)         ⊆⟨ bisimulation⊆∼ (bisimulation-up-to-*⇒bisimulation R-is) ⟩∎
  Bisimilarity  ∎

------------------------------------------------------------------------
-- Some preservation results

-- These results are not taken from "Enhancements of the bisimulation
-- proof method".

-- Equal processes are bisimilar.

≡⇒∼ : ∀ {p q} → p ≡ q → p ∼ q
≡⇒∼ refl = reflexive-∼

-- Precomposition with the lifting operator preserves the "is a
-- bisimulation" relation.

↑-preserves-bisimulations :
  ∀ {ℓ r} {R : Rel₂ r Proc} →
  Bisimulation R → Bisimulation (↑ ℓ ∘ R)
↑-preserves-bisimulations R-is =
  ⟪ (λ pRq → Σ-map id (Σ-map id lift) ∘ left-to-right R-is (lower pRq))
  , (λ pRq → Σ-map id (Σ-map id lift) ∘ right-to-left R-is (lower pRq))
  ⟫

-- The "times two" operator preserves the "is a bisimulation"
-- relation.

×2-preserves-bisimulations :
  ∀ {r} {R : Rel₂ r Proc} →
  Bisimulation R →
  Bisimulation (R ∪ R)
×2-preserves-bisimulations R-is =
  ⟪ (let f = λ pRq p⟶p′ →
               Σ-map id (Σ-map id inj₁) (left-to-right R-is pRq p⟶p′) in
     [ f , f ])
  , (let f = λ pRq q⟶q′ →
               Σ-map id (Σ-map id inj₁) (right-to-left R-is pRq q⟶q′) in
     [ f , f ])
  ⟫


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

module Definition.Typed.Consequences.Reduction where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Embedding
open import Tools.Product

-- Helper function where all reducible types can be reduced to WHNF.
whNorm′ : ∀ {A Γ l} ([A] : Γ ⊩⟨ l ⟩ A)
                → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B
whNorm′ (Uᵣ′ .⁰ 0<1 ⊢Γ) = U , Uₙ , idRed:*: (Uⱼ ⊢Γ)
whNorm′ (ℕᵣ D) = ℕ , ℕₙ , D
whNorm′ (ne′ K D neK K≡K) = K , ne neK , D
whNorm′ (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = Π F ▹ G , Πₙ , D
whNorm′ (emb′ 0<1 [A]) = whNorm′ [A]

-- Well-formed types can all be reduced to WHNF.
whNorm : ∀ {A Γ} → Γ ⊢ A → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B
whNorm A = whNorm′ (reducible A)

-- Helper function where reducible all terms can be reduced to WHNF.
whNormTerm′ : ∀ {a A Γ l} ([A] : Γ ⊩⟨ l ⟩ A) → Γ ⊩⟨ l ⟩ a ∷ A / [A]
                → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A
whNormTerm′ (Uᵣ′ a b c) (Uₜ A d typeA A≡A [t]) = A , typeWhnf typeA , d
whNormTerm′ (ℕᵣ x) (ιx (ℕₜ n d n≡n prop)) =
  let natN = natural prop
  in  n , naturalWhnf natN , convRed:*: d (sym (subset* (red x)))
whNormTerm′ (ne′ K D neK K≡K) (ιx (neₜ k d (neNfₜ neK₁ ⊢k k≡k))) =
  k , ne neK₁ , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Πₜ f d funcF f≡f [f] [f]₁) =
  f , functionWhnf funcF , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (emb′ 0<1 [A]) (ιx [a]) = whNormTerm′ [A] [a]

-- Well-formed terms can all be reduced to WHNF.
whNormTerm : ∀ {a A Γ} → Γ ⊢ a ∷ A → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A
whNormTerm {a} {A} ⊢a =
  let [A] , [a] = reducibleTerm ⊢a
  in  whNormTerm′ [A] [a]


module Selective.Examples.TestCall where

open import Selective.Libraries.Call
open import Prelude

AddReplyMessage : MessageType
AddReplyMessage = ValueType UniqueTag ∷ [ ValueType ℕ ]ˡ

AddReply : InboxShape
AddReply = [ AddReplyMessage ]ˡ

AddMessage : MessageType
AddMessage = ValueType UniqueTag ∷ ReferenceType AddReply ∷ ValueType ℕ ∷ [ ValueType ℕ ]ˡ

Calculator : InboxShape
Calculator = [ AddMessage ]ˡ

calculatorActor : ∀ {i} → ∞ActorM (↑ i) Calculator (Lift (lsuc lzero) ⊤) [] (λ _ → [])
calculatorActor .force = receive ∞>>= λ {
  (Msg Z (tag ∷ _ ∷ n ∷ m ∷ [])) .force →
    (Z ![t: Z ] (lift tag ∷ [ lift (n + m) ]ᵃ)) ∞>> (do
    strengthen []
    calculatorActor)
  ; (Msg (S ()) _)
  }

TestBox : InboxShape
TestBox = AddReply

calltestActor : ∀{i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
calltestActor .force = spawn∞ calculatorActor ∞>> do
    x ← call Z Z 0
         ((lift 10) ∷ [ lift 32 ]ᵃ)
         ⊆-refl Z
    strengthen []
    return-result x
  where
    return-result : SelectedMessage {TestBox} (call-select 0 [ Z ]ᵐ Z) →
                    ∀ {i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
    return-result record { msg = (Msg Z (tag ∷ n ∷ [])) } = return n
    return-result record { msg = (Msg (S x) x₁) ; msg-ok = () }


{-# OPTIONS -v treeless.opt:20 #-}
-- Test that inlining a recursive function doesn't throw
-- the compiler into a loop.
module _ where

open import Common.Prelude

f : Nat → Nat
f zero = zero
f (suc n) = f n
{-# INLINE f #-}

main : IO Unit
main = printNat (f 4)


{-# OPTIONS --safe #-}
module Cubical.Relation.Nullary where

open import Cubical.Relation.Nullary.Base public
open import Cubical.Relation.Nullary.Properties public


-- DontCares shouldn't end up in the generated with functions.
module Issue337 where

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

{-# BUILTIN NATURAL ℕ    #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}

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

postulate
  _≤_ : ℕ → ℕ → Set
  p₁  : 0 ≤ 1
  p₂  : 0 ≤ 1

data SList (bound : ℕ) : Set where
  []    : SList bound
  scons : (head : ℕ) →
          .(head ≤ bound) →
          (tail : SList head) →
          SList bound

l₁ : SList 1
l₁ = scons 0 p₁ []

l₂ : SList 1
l₂ = scons 0 p₂ []

l₁≡l₂ : l₁ ≡ l₂
l₁≡l₂ with Set
... | _ = refl


{-# OPTIONS --cubical #-}
module _ where

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path

data S1 : Set where
  base : S1
  loop : base ≡ base
postulate
  weird : S1 → I

bad : (x : S1) → I
bad base = {!!}
bad (loop x) = {!!}


module MLib.Prelude.DFS.ViaNat where

open import MLib.Prelude
open import MLib.Prelude.Finite

open FE using (_⇨_; cong)

open import Data.Digit using (fromDigits; toDigits; Digit)

module _ {c p} (A-finiteSet : FiniteSet c p) where
  module A = FiniteSet A-finiteSet
  open A using () renaming (Carrier to A)

  open LeftInverse
  open Nat using (_^_; _+_; _*_)

  private
    fromBool : Bool → Digit 2
    fromBool false = Fin.zero
    fromBool true = Fin.suc Fin.zero

    toBool : Digit 2 → Bool
    toBool Fin.zero = false
    toBool (Fin.suc Fin.zero) = true
    toBool (Fin.suc (Fin.suc ()))

    toBool-fromBool : ∀ b → toBool (fromBool b) ≡ b
    toBool-fromBool false = ≡.refl
    toBool-fromBool true = ≡.refl
--     fromBinary : (n : ℕ) → List Bool → ℕ
--     fromBinary n [] = 0 -- an empty table represents an empty binary string
--     fromBinary n (x ∷ xs) = Fin.toℕ x + n * from-n-ary n xs

-- --     -- div-rem m i = "i % m" , "i / m"
--     div-rem : ∀ n → ℕ → Fin n × ℕ
--     div-rem n k = {!!}

--     to-n-ary : (n : ℕ) → ℕ → List (Fin n)
--     to-n-ary n k =
--       let r , d = div-rem n k
--           rs = to-n-ary d
--       in {!!}
--         -- r ∷ rs

-- Goal: fromDigits
-- (List.tabulate (λ x → fromBool (.i ⟨$⟩ (from A.ontoFin ⟨$⟩ x))))
-- ≡
-- fromDigits
-- (List.tabulate (λ x → fromBool (.j ⟨$⟩ (from A.ontoFin ⟨$⟩ x))))

    lookupOrElse : ∀ {n} {a} {A : Set a} → A → Fin n → List A → A
    lookupOrElse z _ [] = z
    lookupOrElse _ Fin.zero (x ∷ xs) = x
    lookupOrElse z (Fin.suc n) (x ∷ xs) = lookupOrElse z n xs

    lookupOrElse-toList : ∀ {n} {a} {A : Set a} {z : A} (i : Fin n) (t : Table A n) → lookupOrElse z i (Table.toList t) ≡ Table.lookup t i
    lookupOrElse-toList Fin.zero t = ≡.refl
    lookupOrElse-toList (Fin.suc i) = lookupOrElse-toList i ∘ Table.tail

    *2-absurd : ∀ m n → m * 2 ≡ suc (n * 2) → ⊥
    *2-absurd zero zero ()
    *2-absurd zero (suc n) ()
    *2-absurd (suc m) zero ()
    *2-absurd (suc m) (suc n) = *2-absurd m n ∘ Nat.suc-injective ∘ Nat.suc-injective

    *2-injective : ∀ m n → m * 2 ≡ n * 2 → m ≡ n
    *2-injective zero zero _ = ≡.refl
    *2-injective zero (suc n) ()
    *2-injective (suc m) zero ()
    *2-injective (suc m) (suc n) = ≡.cong suc ∘ *2-injective m n ∘ Nat.suc-injective ∘ Nat.suc-injective

    01-+-*2 : (i j : Fin 2) (m n : ℕ) → Fin.toℕ i + m * 2 ≡ Fin.toℕ j + n * 2 → m ≡ n
    01-+-*2 Fin.zero Fin.zero = *2-injective
    01-+-*2 Fin.zero (Fin.suc Fin.zero) m n = ⊥-elim ∘ *2-absurd m n
    01-+-*2 Fin.zero (Fin.suc (Fin.suc ())) m n
    01-+-*2 (Fin.suc Fin.zero) Fin.zero m n = ⊥-elim ∘ *2-absurd n m ∘ ≡.sym
    01-+-*2 (Fin.suc (Fin.suc ())) Fin.zero m n
    01-+-*2 (Fin.suc Fin.zero) (Fin.suc Fin.zero) m n = *2-injective m n ∘ Nat.suc-injective
    01-+-*2 (Fin.suc Fin.zero) (Fin.suc (Fin.suc ())) m n
    01-+-*2 (Fin.suc (Fin.suc ())) (Fin.suc Fin.zero) m n
    01-+-*2 (Fin.suc (Fin.suc ())) (Fin.suc (Fin.suc j)) m n

    +-injective₂ : ∀ m n o → o + m ≡ o + n → m ≡ n
    +-injective₂ m n zero = id
    +-injective₂ m n (suc o) = +-injective₂ m n o ∘ Nat.suc-injective

    +-injective₁ : ∀ m n o → m + o ≡ n + o → m ≡ n
    +-injective₁ m n o p = +-injective₂ m n o (≡.trans (Nat.+-comm o m) (≡.trans p (Nat.+-comm n o)))

    lookupOrElse-fromDigits : ∀ {n} (i : Fin n) (xs ys : List (Fin 2)) → fromDigits xs ≡ fromDigits ys → lookupOrElse Fin.zero i xs ≡ lookupOrElse Fin.zero i ys
    lookupOrElse-fromDigits i [] [] p = ≡.refl
    lookupOrElse-fromDigits Fin.zero [] (Fin.zero ∷ ys) p = ≡.refl
    lookupOrElse-fromDigits Fin.zero [] (Fin.suc y ∷ ys) ()
    lookupOrElse-fromDigits (Fin.suc i) [] (Fin.zero ∷ ys) p = lookupOrElse-fromDigits i [] ys (*2-injective 0 _ p)
    lookupOrElse-fromDigits (Fin.suc i) [] (Fin.suc y ∷ ys) ()
    lookupOrElse-fromDigits Fin.zero (Fin.zero ∷ xs) [] p = ≡.refl
    lookupOrElse-fromDigits Fin.zero (Fin.suc x ∷ xs) [] ()
    lookupOrElse-fromDigits {Nat.suc n} Fin.zero (x ∷ xs) (y ∷ ys) p =
      let q = 01-+-*2 x y (fromDigits xs) (fromDigits ys) p
          p′ = ≡.subst (λ fdys → Fin.toℕ x + fromDigits xs * 2 ≡ Fin.toℕ y + fdys) (≡.cong₂ _*_ (≡.sym q) ≡.refl) p
          p′′ = +-injective₁ (Fin.toℕ x) (Fin.toℕ y) _ p′
      in Fin.toℕ-injective p′′
    lookupOrElse-fromDigits (Fin.suc i) (Fin.zero ∷ xs) [] p = lookupOrElse-fromDigits i xs [] (*2-injective _ _ p)
    lookupOrElse-fromDigits (Fin.suc i) (Fin.suc x ∷ xs) [] ()
    lookupOrElse-fromDigits (Fin.suc i) (x ∷ xs) (y ∷ ys) p =
      lookupOrElse-fromDigits i xs ys (01-+-*2 x y (fromDigits xs) (fromDigits ys) p)

    toDigits-fromDigits : ∀ {n} (i : Fin n) xs → lookupOrElse Fin.zero i (proj₁ (toDigits 2 (fromDigits xs))) ≡ lookupOrElse Fin.zero i xs
    toDigits-fromDigits i xs with toDigits 2 (fromDigits xs)
    toDigits-fromDigits i xs | ds , p = lookupOrElse-fromDigits i ds xs p

  asNat : LeftInverse (FiniteSet.setoid A-finiteSet ⇨ ≡.setoid Bool) (≡.setoid ℕ)
  _⟨$⟩_ (to asNat) f = fromDigits (Table.toList (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ))
  cong (to asNat) {f} p = ≡.cong fromDigits {x = Table.toList (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ)} (List.tabulate-cong λ x → ≡.cong fromBool (p A.refl))
  _⟨$⟩_ (_⟨$⟩_ (from asNat) n) x = toBool (lookupOrElse Fin.zero (A.toIx x) (proj₁ (toDigits 2 n)))
  cong (_⟨$⟩_ (from asNat) n) {x} {y} = ≡.cong (λ i → toBool (lookupOrElse Fin.zero i (proj₁ (toDigits 2 n)))) ∘ cong (to A.ontoFin)
  cong (from asNat) {n} ≡.refl = cong (_⟨$⟩_ (from asNat) n)
  left-inverse-of asNat f {x} {y} p =
    begin
      toBool (lookupOrElse Fin.zero (A.toIx x) (proj₁ (toDigits 2 (fromDigits (Table.toList (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ))))))
    ≡⟨ ≡.cong toBool (toDigits-fromDigits (A.toIx x) (Table.toList (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ))) ⟩
      toBool (lookupOrElse Fin.zero (A.toIx x) (Table.toList (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ)))
    ≡⟨ ≡.cong toBool (lookupOrElse-toList (A.toIx x) _) ⟩
      toBool (Table.lookup (Table.map (fromBool ∘ (f ⟨$⟩_)) A.enumₜ) (A.toIx x))
    ≡⟨⟩
      toBool (fromBool (f ⟨$⟩ (from A.ontoFin ⟨$⟩ (to A.ontoFin ⟨$⟩ x))))
    ≡⟨ toBool-fromBool _ ⟩
      f ⟨$⟩ (from A.ontoFin ⟨$⟩ (to A.ontoFin ⟨$⟩ x))
    ≡⟨ cong f (left-inverse-of A.ontoFin x) ⟩
      f ⟨$⟩ x
    ≡⟨ cong f p ⟩
      f ⟨$⟩ y
    ∎
    where open ≡.Reasoning


module _ where

module A where

  infix 2 c
  infix 1 d

  syntax c x   = x ↑
  syntax d x y = x ↓ y

  data D : Set where
    ● : D
    c : D → D
    d : D → D → D

module B where

  syntax d x y = x ↓ y

  data D : Set where
    d : D → D → D

open A
open B

rejected : A.D
rejected = ● ↑ ↓ ●


{-# OPTIONS --without-K #-}
open import container.core

module container.m.coalgebra {li la lb}
  (c : Container li la lb) where

open import level
open import sum
open import function as F hiding (_∘_ ; module _≅_ ; _≅_ ; iso ; ≅⇒≡)
open import equality
open import hott
------------------------------------------------------------------------------
open Container c

-- Definition 3 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
Coalg : ∀ ℓ → Set _
Coalg ℓ = Σ (I → Set ℓ) λ X → X →ⁱ F X

carrier : ∀ {ℓ} → Coalg ℓ → I → Set ℓ
carrier (X , _) = X

IsMor : ∀ {ℓ₁ ℓ₂}(𝓧 : Coalg ℓ₁)(𝓨 : Coalg ℓ₂)
      → (carrier 𝓧 →ⁱ carrier 𝓨) → Set _
IsMor (X , θ) (Y , ψ) f = ψ ∘ⁱ f ≡ imap f ∘ⁱ θ

_⇒_ : ∀ {ℓ₁ ℓ₂} → Coalg ℓ₁ → Coalg ℓ₂ → Set _
𝓧 ⇒ 𝓨 = Σ (carrier 𝓧 →ⁱ carrier 𝓨) (IsMor 𝓧 𝓨)

idf : ∀ {ℓ} → (𝓧 : Coalg ℓ) → 𝓧 ⇒ 𝓧
idf 𝓧 = (λ i x → x) , refl

_∘_ : ∀ {ℓ} → ⦃ 𝓧 𝓨 𝓩 : Coalg ℓ ⦄ → 𝓨 ⇒ 𝓩 → 𝓧 ⇒ 𝓨 → 𝓧 ⇒ 𝓩
(g , coh₁) ∘ (f , coh₂) = g ∘ⁱ f , funextⁱ (λ i x → funext-invⁱ coh₁ i (f i x)
                                   · ap (imap g i) (funext-invⁱ coh₂ i x))

private
  subst-coerce : ∀ {a b} {A : Set a} {B : A → Set b}
                 {x y : A} (p : x ≡ y) {u : B x}
    → subst B p u ≡ coerce (ap B p) u
  subst-coerce refl = refl

  app= : ∀ {a b} {A : Set a} {B : A → Set b} {f g : (x : A) → B x} → f ≡ g
    →(x : A) → f x ≡ g x
  app= p x = ap (λ u → u x) p

  app=-β : ∀ {a b} {A : Set a} {B : A → Set b} {f g : (x : A) → B x}
           (p : ∀ x → f x ≡ g x) (x : A)
    → app= (funext p) x ≡ p x
  app=-β {B = B} p x = helper (funext p) x
                         · app= (F._≅_.iso₁ strong-funext-iso p) x
    where helper : ∀ {f g : ∀ x → B x} (p : f ≡ g) x → app= p x ≡ funext-inv p x
          helper refl x = refl

  abstract
    ua : ∀ {i}{X Y : Set i} → X F.≅ Y → X ≡ Y
    ua = F.≅⇒≡

    coerce-β : ∀ {a} {X Y : Set a} → (e : X F.≅ Y)
      → ∀ x → coerce (ua e) x ≡ apply e x
    coerce-β e x = app= (uni-coherence (≅⇒≈ e)) x

  substⁱ-lemma : ∀ {ℓ} {X Y : I → Set ℓ} {f : X →ⁱ F X} {g : Y →ⁱ F Y}
                → (p : X ≡ Y)
                → (∀ i x → subst (λ Z → F Z i) p (f i x)
                              ≡ g i (subst (λ Z → Z i) p x))
    → subst (λ Z → Z →ⁱ F Z) p f ≡ g
  substⁱ-lemma refl = funextⁱ

  imap-subst : ∀ {ℓ} {X Y : I → Set ℓ} (p : X ≡ Y)
    → imap (λ i → subst (λ Z → Z i) p) ≡ (λ i → subst (λ Z → F Z i) p)
  imap-subst refl = refl

record _≅_ {ℓ} (𝓧 𝓨 : Coalg ℓ) : Set (lsuc $ ℓ ⊔ li ⊔ la ⊔ lb) where
  constructor iso
  field
    f : 𝓧 ⇒ 𝓨
    g : 𝓨 ⇒ 𝓧
    f-g : f ∘ g ≡ idf 𝓨
    g-f : g ∘ f ≡ idf 𝓧

≅⇒≡ : ∀ {ℓ} {𝓧 𝓨 : Coalg ℓ} → 𝓧 ≅ 𝓨 → 𝓧 ≡ 𝓨
≅⇒≡ {𝓧 = X , θ} {𝓨 = Y , ψ} 𝓧≅𝓨 = unapΣ (π₁≡ , π₂≡)
  where open _≅_ 𝓧≅𝓨
        X≅Y : ∀ i → X i F.≅ Y i
        X≅Y i = F.iso (proj₁ f i) (proj₁ g i)
                      (funext-invⁱ (ap proj₁ g-f) i)
                      (funext-invⁱ (ap proj₁ f-g) i)
        π₁≡ : X ≡ Y
        π₁≡ = funext λ i → ua (X≅Y i)
        π₂≡ : subst (λ Z → Z →ⁱ F Z) π₁≡ θ ≡ ψ
        π₂≡ = substⁱ-lemma π₁≡ λ i x →
                app= (lemma₂ i) _
              · sym (funext-invⁱ (proj₂ f) i x)
              · ap (ψ i) (sym (lemma₁ i x))
          where lemma₁ : ∀ i x → subst (λ Z → Z i) π₁≡ x ≡ proj₁ f i x
                lemma₁ i x = subst-coerce π₁≡
                           · ap (λ u → coerce u x) (app=-β _ i)
                           · coerce-β (X≅Y i) _
                lemma₂ : ∀ i → subst (λ Z → F Z i) π₁≡ ≡ imap (proj₁ f) i
                lemma₂ i = sym $ funext (hmap (λ i x → sym (lemma₁ i x)) i)
                                   · app= (imap-subst π₁≡) i

IsFinal : ∀ {ℓ} → Coalg ℓ → Set _
IsFinal {ℓ} 𝓧 = ∀ (𝓨 : Coalg ℓ) → contr (𝓨 ⇒ 𝓧)

Final : ∀ ℓ → Set _
Final ℓ = Σ (Coalg ℓ) IsFinal

prop-IsFinal : ∀ {ℓ} (𝓧 : Coalg ℓ) → prop (IsFinal 𝓧)
prop-IsFinal 𝓧 = h1⇒prop (Π-level (λ 𝓨 → contr-h1 _))

-- Lemma 5 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
Final-prop : ∀ {ℓ} → prop (Final ℓ)
Final-prop (𝓧 , IsFinal-𝓧) (𝓨 , IsFinal-𝓨) =
    unapΣ (𝓧≡𝓨 , prop-IsFinal 𝓨 _ _)
  where 𝓧≡𝓨 : 𝓧 ≡ 𝓨
        𝓧≡𝓨 = ≅⇒≡ $ iso (proj₁ (IsFinal-𝓨 𝓧)) (proj₁ (IsFinal-𝓧 𝓨))
                        (contr⇒prop (IsFinal-𝓨 𝓨) _ _)
                        (contr⇒prop (IsFinal-𝓧 𝓧) _ _)


-- Andreas, 2014-01-10
-- Code by Jesper Cockx and Conor McBride and folks from the Coq-club

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

-- An empty type.

data Zero : Set where

-- A unit type as W-type.

mutual
  data WOne : Set where wrap : FOne -> WOne
  FOne = Zero -> WOne

-- Type equality.

data _<->_ (X : Set) : Set -> Set₁ where
  Refl : X <-> X

-- This postulate is compatible with univalence:

postulate
  iso : WOne <-> FOne

-- But accepting that is incompatible with univalence:

auoo : WOne -> Zero
auoo (wrap f) = noo FOne iso f
  where
    noo : (X : Set) -> (WOne <-> X) -> X -> Zero
    noo .WOne Refl w = auoo w

-- Matching against Refl silently applies the conversion
-- FOne -> WOne to f.  But this conversion corresponds
-- to an application of wrap.  Thus, f, which is really
-- (wrap f), should not be considered a subterm of (wrap f)
-- by the termination checker.
-- At least, if we want to be compatible with univalence.

absurd : Zero
absurd = auoo (wrap \ ())

-- noo should fail termination check.


-- We define ZigZag-complete relations and prove that quasi equivalence relations
-- give rise to equivalences on the set quotients.
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.ZigZag.Base where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.HITs.SetQuotients
open import Cubical.HITs.PropositionalTruncation as Trunc
open import Cubical.Relation.Binary.Base

open BinaryRelation
open isEquivRel

private
 variable
  ℓ ℓ' : Level

isZigZagComplete : {A B : Type ℓ} (R : A → B → Type ℓ') → Type (ℓ-max ℓ ℓ')
isZigZagComplete R = ∀ {a b a' b'} → R a b → R a' b → R a' b' → R a b'

ZigZagRel : (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
ZigZagRel A B ℓ' = Σ[ R ∈ (A → B → Type ℓ') ] (isZigZagComplete R)

record isQuasiEquivRel {A B : Type ℓ} (R : A → B → Type ℓ') : Type (ℓ-max ℓ ℓ') where
  field
    zigzag : isZigZagComplete R
    fwd : A → B
    fwdRel : (a : A) → R a (fwd a)
    bwd : B → A
    bwdRel : (b : B) → R (bwd b) b

open isQuasiEquivRel

QuasiEquivRel : (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
QuasiEquivRel A B ℓ' =
  Σ[ R ∈ PropRel A B ℓ' ] isQuasiEquivRel (R .fst)

invQER : {A B : Type ℓ} {ℓ' : Level} → QuasiEquivRel A B ℓ' → QuasiEquivRel B A ℓ'
invQER (R , qer) .fst = invPropRel R
invQER (R , qer) .snd .zigzag aRb aRb' a'Rb' = qer .zigzag a'Rb' aRb' aRb
invQER (R , qer) .snd .fwd = qer .bwd
invQER (R , qer) .snd .fwdRel = qer .bwdRel
invQER (R , qer) .snd .bwd = qer .fwd
invQER (R , qer) .snd .bwdRel = qer .fwdRel

QER→EquivRel : {A B : Type ℓ}
  → QuasiEquivRel A B ℓ' → EquivPropRel A ℓ'
QER→EquivRel (R , sim) .fst .fst a₀ a₁ = R .fst a₀ (sim .fwd a₁)
QER→EquivRel (R , sim) .fst .snd _ _ = R .snd _ _
QER→EquivRel (R , sim) .snd .reflexive a = sim .fwdRel a
QER→EquivRel (R , sim) .snd .symmetric a₀ a₁ r =
  sim .zigzag (sim .fwdRel a₁) r (sim .fwdRel a₀)
QER→EquivRel (R , sim) .snd .transitive a₀ a₁ a₂ r s =
  sim .zigzag r (sim .fwdRel a₁) s

-- The following result is due to Carlo Angiuli
module QER→Equiv {A B : Type ℓ} (R : QuasiEquivRel A B ℓ') where

  private
    sim = R .snd
    f = sim .fwd
    g = sim .bwd

  Rᴸ = QER→EquivRel R .fst .fst
  Rᴿ = QER→EquivRel (invQER R) .fst .fst

  Thm : (A / Rᴸ) ≃ (B / Rᴿ)
  Thm = isoToEquiv (iso φ ψ η ε)
    where
    φ : _
    φ [ a ] = [ f a ]
    φ (eq/ a₀ a₁ r i) = eq/ _ _ (sim .zigzag (sim .bwdRel (f a₁)) r (sim .fwdRel a₀)) i
    φ (squash/ _ _ p q j i) = squash/ _ _ (cong φ p) (cong φ q) j i

    ψ : _
    ψ [ b ] = [ g b ]
    ψ (eq/ b₀ b₁ s i) = eq/ _ _ (sim .zigzag (sim .bwdRel b₀) s (sim .fwdRel (g b₁))) i
    ψ (squash/ _ _ p q j i) = squash/ _ _ (cong ψ p) (cong ψ q) j i

    η = elimProp (λ _ → squash/ _ _) (λ b → eq/ _ _ (sim .fwdRel (g b)))

    ε = elimProp (λ _ → squash/ _ _) (λ a → eq/ _ _ (sim .bwdRel (f a)))


import Lvl

-- TODO: Just testing how it goes with creating an axiomatic system
module Geometry.Test3 (Point : Set(Lvl.𝟎)) where

open import Functional
open import Logic.Propositional{Lvl.𝟎}
open import Logic.Predicate{Lvl.𝟎}{Lvl.𝟎}
open import Relator.Equals{Lvl.𝟎}{Lvl.𝟎} renaming (_≡_ to _≡ₚ_ ; _≢_ to _≢ₚ_)
open import Sets.PredicateSet
open import Sets.PredicateSet.Proofs
open import Structure.Relator.Equivalence{Lvl.𝟎}{Lvl.𝟎}
open import Structure.Relator.Ordering{Lvl.𝟎}{Lvl.𝟎}

-- A line of infinite length
record Line : Set(Lvl.𝟎) where
  constructor line
  field
    a : Point
    b : Point

  field
    different : (a ≢ₚ b)

-- A circle
record Circle : Set(Lvl.𝟎) where
  constructor circle
  field
    middle : Point
    outer : Point

record Theory : Set(Lvl.𝐒(Lvl.𝐒(Lvl.𝟎))) where
  -- Symbols
  field
    -- CirclesIntersectionPoint : Circle → Circle → Point → Set(Lvl.𝟎)
    _∈ᶜ_ : Point → Circle → Stmt
    _∈ˡ_ : Point → Line → Stmt

    -- circleIntersectionPoint : (a : Circle) → (b : Circle) → ⦃ _ : CircleIntersect a b ⦄ → Point

  CircleBoundary : Circle → Point → Stmt
  CircleBoundary c p = (p ∈ᶜ c) ∧ (∀{outer a : Point} → (a ∈ᶜ circle p outer) → ⊥)

  LineIntersection : Line → Line → Point → Stmt
  LineIntersection a b p = (p ∈ˡ a) ∧ (p ∈ˡ b)

  -- Axioms
  -- field
  --   circle-boundary-eq : ∀{a b} → ((_∈ᶜ a) ≡ (_∈ᶜ b)) ↔ (CircleBoundaryPoint a ≡ᵖ CircleBoundaryPoint b)
  --   circle-either : ∀{middle outer₁ outer₂} → ((_∈ᶜ circle middle outer₁) ⊆ (_∈ᶜ circle middle outer₂)) ∨ ((_∈ᶜ circle middle outer₂) ⊆ (_∈ᶜ circle middle outer₁))
    -- circleOuterIs Circle.outer

module Theorems ⦃ _ : Theory ⦄ where
  open Theory ⦃ ... ⦄

  -- perpendicularLine : CirclesIntersectionPoint

  -- middlepoint : Line → Point
  -- middlepoint(line(a)(b)) =


open import Data.Nat      using (ℕ; suc; zero; _<_; _≤_; z≤n; s≤s; _+_; _⊔_)
open import Data.Bool     using (Bool; true; false; not; _∧_)
open import Data.Sum      using (inj₁; inj₂; _⊎_; [_,_])
open import Data.Product  using (_×_; _,_; -,_; _-,-_; ∃; ∃-syntax; proj₂)
open import Data.String   using (String; _≟_; length)
open import Relation.Nullary           using (¬_; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; trans; cong₂)
open import Data.Nat.Properties hiding (_≤?_; _≟_)

open import IMP

level = ℕ

sec : vname → level
-- We can also temporarily use "sec x" to avoid the
-- automatic expansion of the definition in error messages
sec x = length x

secₐ : aexp → level
secₐ (N n) = 0
secₐ (V x) = sec x
secₐ (Plus a b) = secₐ a ⊔ secₐ b

sec₆ : bexp → level
sec₆ (Bc x) = 0
sec₆ (Not b) = sec₆ b
sec₆ (And b₁ b₂) = sec₆ b₁ ⊔ sec₆ b₂
sec₆ (Less a b) = secₐ a ⊔ secₐ b

_≡_⦅≤_⦆ : state → state → level → Set
s₁ ≡ s₂ ⦅≤ l ⦆ = ∀ x → sec x ≤ l → s₁ x ≡ s₂ x

_≡_⦅<_⦆ : state → state → level → Set
s₁ ≡ s₂ ⦅< l ⦆ = ∀ x → sec x < l → s₁ x ≡ s₂ x

non-interference-aexp : ∀ a {s₁ s₂ l}
  → s₁ ≡ s₂ ⦅≤ l ⦆
  → secₐ a ≤ l
  → aval a s₁ ≡ aval a s₂
non-interference-aexp (N x) r e = refl
non-interference-aexp (V x) r e = r x e
non-interference-aexp (Plus a b) r e =
  cong₂ (_+_) (non-interference-aexp a r (m⊔n≤o⇒m≤o _ _ e))
              (non-interference-aexp b r (m⊔n≤o⇒n≤o _ _ e))

non-interference-bexp : ∀ a {s₁ s₂ l}
  → s₁ ≡ s₂ ⦅≤ l ⦆
  → sec₆ a ≤ l
  → bval a s₁ ≡ bval a s₂
non-interference-bexp (Bc x) r e = refl
non-interference-bexp (Not a) r e = cong not (non-interference-bexp a r e)
non-interference-bexp (And a b) r e =
  cong₂ (_∧_) (non-interference-bexp a r (m⊔n≤o⇒m≤o _ _ e))
              (non-interference-bexp b r (m⊔n≤o⇒n≤o _ _ e))
non-interference-bexp (Less a b) r e =
  cong₂ (_≤?_) (non-interference-aexp a r (m⊔n≤o⇒m≤o _ _ e))
               (non-interference-aexp b r (m⊔n≤o⇒n≤o _ _ e))

data _⊢_ : level → com → Set where
  SecSkip : ∀{l}
     → l ⊢ SKIP
  SecLoc : ∀{l a x}
     → secₐ a ≤ sec x
     → l ≤ sec x
     → l ⊢ (x ::= a)
  SecSeq : ∀{l c₁ c₂}
     → l ⊢ c₁
     → l ⊢ c₂
     → l ⊢ (c₁ :: c₂)
  SecIf : ∀{b l c₁ c₂}
     → (l ⊔ sec₆ b) ⊢ c₁
     → (l ⊔ sec₆ b) ⊢ c₂
     → l ⊢ (IF b THEN c₁ ELSE c₂)
  SecWhile : ∀{b l c}
     → (l ⊔ sec₆ b) ⊢ c
     → l ⊢ (WHILE b DO c)

anti-monotonicity : ∀{l l′ c}
  → l ⊢ c
  → l′ ≤ l
  → l′ ⊢ c
anti-monotonicity SecSkip s = SecSkip
anti-monotonicity (SecLoc x x₁) s = SecLoc x (≤-trans s x₁)
anti-monotonicity (SecSeq d d₁) s = SecSeq (anti-monotonicity d s) (anti-monotonicity d₁ s)
anti-monotonicity (SecIf d d₁) s = SecIf (anti-monotonicity d (⊔-monoˡ-≤ _ s)) (anti-monotonicity d₁ (⊔-monoˡ-≤ _ s))
anti-monotonicity (SecWhile d) s = SecWhile ((anti-monotonicity d (⊔-monoˡ-≤ _ s)))

data ⦅_,_⦆⇒_ : com → state → state → Set where
  Skip : ∀{s} → ⦅ SKIP , s ⦆⇒ s
  Loc : ∀{s x a}
         → ⦅ x ::= a , s ⦆⇒ (s [ x ::= aval a s ])
  Seq : ∀{c₁ c₂ s₁ s₂ s₃}
         → ⦅ c₁ , s₁ ⦆⇒ s₂
         → ⦅ c₂ , s₂ ⦆⇒ s₃
         → ⦅ c₁ :: c₂ , s₁ ⦆⇒ s₃
  IfTrue : ∀{c₁ c₂ b s t}
         → bval b s ≡ true
         → ⦅ c₁ , s ⦆⇒ t
         → ⦅ IF b THEN c₁ ELSE c₂ , s ⦆⇒ t
  IfFalse : ∀{c₁ c₂ b s t}
         → bval b s ≡ false
         → ⦅ c₂ , s ⦆⇒ t
         → ⦅ IF b THEN c₁ ELSE c₂ , s ⦆⇒ t
  WhileFalse : ∀{c b s}
         → bval b s ≡ false
         → ⦅ WHILE b DO c , s ⦆⇒ s
  WhileTrue : ∀{c b s₁ s₂ s₃}
         → bval b s₁ ≡ true
         → ⦅ c , s₁ ⦆⇒ s₂
         → ⦅ WHILE b DO c , s₂ ⦆⇒ s₃
         → ⦅ WHILE b DO c , s₁ ⦆⇒ s₃

confinement : ∀{c s t l}
  → ⦅ c , s ⦆⇒ t
  → l ⊢ c
  → s ≡ t ⦅< l ⦆
confinement Skip SecSkip x₂ x₃ = refl
confinement (Loc {x = x₂}) (SecLoc x x₁) e r with e ≟ x₂
... | yes refl = contradiction x₁ (<⇒≱ r)
... | no  _ = refl
confinement (Seq x x₄) (SecSeq x₁ x₅) x₂ x₃ =
  trans (confinement x x₁ x₂ x₃)
        (confinement x₄ x₅ x₂ x₃)
confinement (IfTrue x x₄) (SecIf x₁ x₅) x₂ x₃ = confinement x₄ x₁ x₂ (m<n⇒m<n⊔o _ x₃)
confinement (IfFalse x x₄) (SecIf x₁ x₅) x₂ x₃ = confinement x₄ x₅ x₂ (m<n⇒m<n⊔o _ x₃)
confinement (WhileFalse x) (SecWhile x₁) x₂ x₃ = refl
confinement {l = l} (WhileTrue x x₄ x₅) (SecWhile x₁) x₂ x₃ =
   trans (confinement x₄ (anti-monotonicity x₁ (m≤m⊔n _ _)) x₂ x₃)
         (confinement x₅ (SecWhile x₁) x₂ x₃)

true≢false : ¬ (true ≡ false)
true≢false = λ ()

reversal₁ : ∀{b c s₁ s₃}
  → ⦅ WHILE b DO c , s₁ ⦆⇒ s₃
  → bval b s₁ ≡ true
  → ∃[ s₂ ] ( ⦅ c , s₁ ⦆⇒ s₂ × ⦅ WHILE b DO c , s₂ ⦆⇒ s₃)
reversal₁ (WhileFalse x) v = contradiction (trans (sym v) x) true≢false
reversal₁ (WhileTrue x e e₁) v = -, e , e₁

reversal₂ : ∀{b c s₁ s₃}
  → ⦅ WHILE b DO c , s₁ ⦆⇒ s₃
  → bval b s₁ ≡ false
  → s₁ ≡ s₃
reversal₂ (WhileFalse x) v = refl
reversal₂ (WhileTrue x r r₁) v = contradiction (trans (sym x) v) true≢false

level-cong : ∀{l l′ c} → l ≡ l′ → l ⊢ c → l′ ⊢ c
level-cong refl x = x

≤⇒<suc : ∀{a b} → a ≤ b → a < suc b
≤⇒<suc z≤n = s≤s z≤n
≤⇒<suc (s≤s r) = s≤s (≤⇒<suc r)

non-interference : ∀{c s s′ t t′ l}
  → ⦅ c , s ⦆⇒ s′
  → ⦅ c , t ⦆⇒ t′
  → 0 ⊢ c
  → s  ≡ t  ⦅≤ l ⦆
  → s′ ≡ t′ ⦅≤ l ⦆
non-interference Skip Skip z e = e
non-interference (Loc {x = x₂} {a}) Loc (SecLoc x₃ z≤n) e x x₁ with x ≟ x₂
... | yes refl = non-interference-aexp a e (≤-trans x₃ x₁)
... | no _ = e x x₁
non-interference (Seq x cs) (Seq y ct) (SecSeq z z₁) e =
  non-interference cs ct z₁ (non-interference x y z e)
non-interference {l = l} (IfTrue {b = b} x cs) (IfTrue x₁ red) (SecIf w w₁) e r r₁ =
  non-interference cs red (anti-monotonicity w z≤n) e r r₁
non-interference {l = l} (IfTrue {b = b} x cs) (IfFalse x₁ red) (SecIf w w₁) e r r₁ =
  [ (λ secb≤l →
        let wr = non-interference-bexp b e secb≤l
         in contradiction (trans (sym x) (trans wr x₁)) true≢false)
  , (λ l<secb → let oo₁ = confinement cs w
                    oo₂ = confinement red w₁
                 in trans (sym (oo₁ r (<-transʳ r₁ l<secb)))
                   (trans (e r r₁)
                          (oo₂ r (<-transʳ r₁ l<secb))))
  ]  (≤-<-connex (sec₆ b) l)
non-interference {l = l} (IfFalse x₁ red) (IfTrue {b = b} x cs) (SecIf w w₁) e r r₁ =
  [ (λ secb≤l →
        let wr = non-interference-bexp b e secb≤l
         in contradiction (trans (sym x) (trans (sym wr) x₁)) true≢false)
  , (λ l<secb → let oo₁ = confinement cs w
                    oo₂ = confinement red w₁
                 in trans (sym (oo₂ r (<-transʳ r₁ l<secb)))
                   (trans (e r r₁)
                          (oo₁ r (<-transʳ r₁ l<secb))))
  ]  (≤-<-connex (sec₆ b) l)
non-interference (IfFalse x₁ red) (IfFalse x cs) (SecIf x₇ x₈) =
  non-interference red cs (anti-monotonicity x₈ z≤n)
non-interference (WhileFalse x) (WhileFalse x₁) (SecWhile z) e = e
non-interference {l = l} (WhileFalse {b = b} r) (WhileTrue c ct ct₁) (SecWhile z) e x x₁ =
  [ (λ secb≤l →
        let wr = non-interference-bexp b e secb≤l
         in contradiction (trans (sym c) (trans (sym wr) r)) true≢false)
  , (λ l<secb →
        let simp = confinement ct z
            simp2 = confinement ct₁ (SecWhile (level-cong (sym (m≤n⇒m⊔n≡n l<secb)) z))
         in trans (e x x₁) (trans (simp x (<-transʳ x₁ l<secb)) (simp2 x (≤⇒<suc x₁))))
  ]  (≤-<-connex (sec₆ b) l)
non-interference {l = l} (WhileTrue c ct ct₁) (WhileFalse {b = b} r) (SecWhile z) e x x₁ =
  [ (λ secb≤l →
        let wr = non-interference-bexp b e secb≤l
         in contradiction (trans (sym c) (trans wr r)) true≢false)
  , (λ l<secb →
        let simp = confinement ct z
            simp2 = confinement ct₁ (SecWhile (level-cong (sym (m≤n⇒m⊔n≡n l<secb)) z))
         in trans (trans (sym (simp2 x (≤⇒<suc x₁))) (sym (simp x ((<-transʳ x₁ l<secb))))) (e x x₁))
  ]  (≤-<-connex (sec₆ b) l)
non-interference {l = l} (WhileTrue {b = b} r cs cs₁) (WhileTrue c ct ct₁) (SecWhile z) e =
  let h₁ = non-interference cs ct (anti-monotonicity z z≤n) e
      h₂ = non-interference cs₁ ct₁ (SecWhile z) h₁
   in h₂


{-# OPTIONS --without-K --safe #-}
-- Actually, we're cheating (for expediency); this is
-- Symmetric Rig, not just Rig.
open import Categories.Category

module Categories.Category.RigCategory {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Data.Fin renaming (zero to 0F; suc to sucF)
open import Data.Product using (_,_)

open import Categories.Functor renaming (id to idF)
open import Categories.Category.Monoidal
open import Categories.Category.Monoidal.Braided
open import Categories.Category.Monoidal.Symmetric
open import Categories.NaturalTransformation.NaturalIsomorphism
open import Categories.NaturalTransformation using (_∘ᵥ_; _∘ₕ_; _∘ˡ_; _∘ʳ_; NaturalTransformation)
open import Categories.Morphism C

-- Should probably split out Distributive Category out and make this be 'over' that.
record RigCategory {M⊎ M× : Monoidal C} (S⊎ : Symmetric M⊎)
   (S× : Symmetric M×) : Set (o ⊔ ℓ ⊔ e) where

  private
    module C = Category C

  open C hiding (_≈_)
  open Commutation
  module M⊎ = Monoidal M⊎
  module M× = Monoidal M×
  module S⊎ = Symmetric S⊎
  module S× = Symmetric S×
  open M⊎ renaming (_⊗₀_ to _⊕₀_; _⊗₁_ to _⊕₁_)
  open M×

  private
    0C : C.Obj
    0C = M⊎.unit
    1C : C.Obj
    1C = M×.unit

  private
    B⊗ : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
    B⊗ {X} {Y} = S×.braiding.⇒.η (X , Y)
    B⊕ : ∀ {X Y} → X ⊕₀ Y ⇒ Y ⊕₀ X
    B⊕ {X} {Y} = S⊎.braiding.⇒.η (X , Y)

  field
    annₗ : ∀ {X} → 0C ⊗₀ X ≅ 0C
    annᵣ : ∀ {X} → X ⊗₀ 0C ≅ 0C
    distribₗ : ∀ {X Y Z} → X ⊗₀ (Y ⊕₀ Z) ≅ (X ⊗₀ Y) ⊕₀ (X ⊗₀ Z)
    distribᵣ : ∀ {X Y Z} → (X ⊕₀ Y) ⊗₀ Z ≅ (X ⊗₀ Z) ⊕₀ (Y ⊗₀ Z)

  private
    λ* : ∀ {X} → 0C ⊗₀ X ⇒ 0C
    λ* {X} = _≅_.from (annₗ {X})
    ρ* : ∀ {X} → X ⊗₀ 0C ⇒ 0C
    ρ* {X} = _≅_.from (annᵣ {X})
    module dl {X} {Y} {Z} = _≅_ (distribₗ {X} {Y} {Z})
    module dr {X} {Y} {Z} = _≅_ (distribᵣ {X} {Y} {Z})
    ⊗λ⇒ = M×.unitorˡ.from
    ⊗λ⇐ = M×.unitorˡ.to
    ⊗ρ⇒ = M×.unitorʳ.from
    ⊗ρ⇐ = M×.unitorʳ.to
    ⊗α⇒ = M×.associator.from
    ⊗α⇐ = M×.associator.to
    ⊕λ⇒ = M⊎.unitorˡ.from
    ⊕λ⇐ = M⊎.unitorˡ.to
    ⊕ρ⇒ = M⊎.unitorʳ.from
    ⊕ρ⇐ = M⊎.unitorʳ.to
    ⊕α⇒ = M⊎.associator.from
    ⊕α⇐ = M⊎.associator.to

  -- need II, IX, X, XV
  -- choose I, IV, VI, XI, XIII, XIX, XXIII and (XVI, XVII)
  field
    laplazaI : ∀ {A B C} →
      [ A ⊗₀ (B ⊕₀ C) ⇒ (A ⊗₀ C) ⊕₀ (A ⊗₀ B) ]⟨
        dl.from        ⇒⟨ (A ⊗₀ B) ⊕₀ (A ⊗₀ C) ⟩
        B⊕
      ≈
        C.id ⊗₁ B⊕    ⇒⟨ A ⊗₀ (C ⊕₀ B) ⟩
        dl.from
      ⟩
    laplazaII : ∀ {A B C} →
      [ (A ⊕₀ B) ⊗₀ C ⇒ (C ⊗₀ A) ⊕₀ (C ⊗₀ B) ]⟨
        B⊗             ⇒⟨ C ⊗₀ (A ⊕₀ B) ⟩
        dl.from
      ≈
        dr.from        ⇒⟨ (A ⊗₀ C) ⊕₀ (B ⊗₀ C) ⟩
        B⊗ ⊕₁ B⊗
      ⟩
    laplazaIV : {A B C D : Obj} →
      [ (A ⊕₀ B ⊕₀ C) ⊗₀ D ⇒ ((A ⊗₀ D) ⊕₀ (B ⊗₀ D)) ⊕₀ (C ⊗₀ D) ]⟨
         dr.from            ⇒⟨ (A ⊗₀ D) ⊕₀ ((B ⊕₀ C) ⊗₀ D) ⟩
         C.id ⊕₁ dr.from   ⇒⟨ (A ⊗₀ D) ⊕₀ ((B ⊗₀ D) ⊕₀ (C ⊗₀ D)) ⟩
         ⊕α⇐
      ≈
         ⊕α⇐ ⊗₁ C.id       ⇒⟨ ((A ⊕₀ B) ⊕₀ C) ⊗₀ D ⟩
         dr.from            ⇒⟨ ((A ⊕₀ B) ⊗₀ D) ⊕₀ (C ⊗₀ D) ⟩
         dr.from ⊕₁ C.id
      ⟩

    laplazaVI : {A B C D : Obj} →
      [ A ⊗₀ B ⊗₀ (C ⊕₀ D) ⇒ ((A ⊗₀ B) ⊗₀ C) ⊕₀ ((A ⊗₀ B) ⊗₀ D) ]⟨
          C.id ⊗₁ dl.from   ⇒⟨ A ⊗₀ ((B ⊗₀ C) ⊕₀ (B ⊗₀ D)) ⟩
          dl.from            ⇒⟨ (A ⊗₀ B ⊗₀ C) ⊕₀ (A ⊗₀ B ⊗₀ D) ⟩
          ⊗α⇐ ⊕₁ ⊗α⇐
      ≈
        ⊗α⇐                ⇒⟨ (A ⊗₀ B) ⊗₀ (C ⊕₀ D) ⟩
        dl.from
      ⟩
    laplazaIX : ∀ {A B C D} → [ (A ⊕₀ B) ⊗₀ (C ⊕₀ D) ⇒ (((A ⊗₀ C) ⊕₀ (B ⊗₀ C)) ⊕₀ (A ⊗₀ D)) ⊕₀ (B ⊗₀ D) ]⟨
        dr.from                ⇒⟨ (A ⊗₀ (C ⊕₀ D)) ⊕₀ (B ⊗₀ (C ⊕₀ D)) ⟩
        dl.from ⊕₁ dl.from     ⇒⟨ ((A ⊗₀ C) ⊕₀ (A ⊗₀ D)) ⊕₀ ((B ⊗₀ C) ⊕₀ (B ⊗₀ D)) ⟩
        ⊕α⇐                    ⇒⟨ (((A ⊗₀ C) ⊕₀ (A ⊗₀ D)) ⊕₀ (B ⊗₀ C)) ⊕₀ (B ⊗₀ D) ⟩
        ⊕α⇒ ⊕₁ C.id           ⇒⟨ ((A ⊗₀ C) ⊕₀ ((A ⊗₀ D) ⊕₀ (B ⊗₀ C))) ⊕₀ (B ⊗₀ D) ⟩
        (C.id ⊕₁ B⊕) ⊕₁ C.id  ⇒⟨ ((A ⊗₀ C) ⊕₀ ((B ⊗₀ C) ⊕₀ (A ⊗₀ D))) ⊕₀ (B ⊗₀ D) ⟩
        ⊕α⇐ ⊕₁ C.id
      ≈
        dl.from                ⇒⟨ ((A ⊕₀ B) ⊗₀ C) ⊕₀ ((A ⊕₀ B) ⊗₀ D) ⟩
        dr.from ⊕₁ dr.from     ⇒⟨ ((A ⊗₀ C) ⊕₀ (B ⊗₀ C)) ⊕₀ ((A ⊗₀ D) ⊕₀ (B ⊗₀ D))  ⟩
        ⊕α⇐
      ⟩
    laplazaX : [ 0C ⊗₀ 0C ⇒ 0C ]⟨ λ* ≈ ρ* ⟩
    laplazaXI : ∀ {A B} →
      [ 0C ⊗₀ (A ⊕₀ B) ⇒ 0C ]⟨
        dl.from   ⇒⟨ (0C ⊗₀ A) ⊕₀ (0C ⊗₀ B) ⟩
        λ* ⊕₁ λ*  ⇒⟨ 0C ⊕₀ 0C ⟩
        ⊕λ⇒
      ≈
        λ*
      ⟩
    laplazaXIII : [ 0C ⊗₀ 1C ⇒ 0C ]⟨ ⊗ρ⇒ ≈ λ* ⟩
    laplazaXV : ∀ {A : Obj} →
      [ A ⊗₀ 0C ⇒ 0C ]⟨
        ρ*
      ≈
        B⊗ ⇒⟨ 0C ⊗₀ A ⟩
        λ*
      ⟩
    laplazaXVI : ∀ {A B} → [ 0C ⊗₀ (A ⊗₀ B) ⇒ 0C ]⟨
        ⊗α⇐        ⇒⟨ (0C ⊗₀ A) ⊗₀ B ⟩
        λ* ⊗₁ C.id  ⇒⟨ 0C ⊗₀ B ⟩
        λ*
      ≈
        λ*
      ⟩
    laplazaXVII : ∀ {A B} → [ A ⊗₀ (0C ⊗₀ B) ⇒ 0C ]⟨
        ⊗α⇐        ⇒⟨ (A ⊗₀ 0C) ⊗₀ B ⟩
        ρ* ⊗₁ C.id ⇒⟨ 0C ⊗₀ B ⟩
        λ*
      ≈
        C.id ⊗₁ λ* ⇒⟨ A ⊗₀ 0C ⟩
        ρ*
      ⟩
    laplazaXIX : ∀ {A B} → [ A ⊗₀ (0C ⊕₀ B) ⇒ A ⊗₀ B ]⟨
        dl.from     ⇒⟨ (A ⊗₀ 0C) ⊕₀ (A ⊗₀ B) ⟩
        ρ* ⊕₁ C.id  ⇒⟨ 0C ⊕₀ (A ⊗₀ B) ⟩
        ⊕λ⇒
      ≈
        C.id ⊗₁ ⊕λ⇒
      ⟩
    laplazaXXIII : ∀ {A B} → [ 1C ⊗₀ (A ⊕₀ B) ⇒ (A ⊕₀ B) ]⟨
        ⊗λ⇒
      ≈
        dl.from ⇒⟨ (1C ⊗₀ A) ⊕₀ (1C ⊗₀ B) ⟩
        ⊗λ⇒ ⊕₁ ⊗λ⇒
      ⟩


module AbstractData where

abstract
  data D : Set where
    c : D

  d : D
  d = c


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

open import lib.Base

module lib.Relation where

Rel : ∀ {i} (A : Type i) j → Type (lmax i (lsucc j))
Rel A j = A → A → Type j

Decidable : ∀ {i} {A : Type i} {j} → Rel A j → Type (lmax i j)
Decidable rel = ∀ a₁ a₂ → Dec (rel a₁ a₂)


{-

Definition of and facts about Smith normal form

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.IntegerMatrix.Smith.NormalForm where

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

open import Cubical.Data.Nat
  hiding   (_·_)
  renaming (_+_ to _+ℕ_ ; +-assoc to +Assocℕ)
open import Cubical.Data.Int
  hiding   (_+_ ; _·_ ; _-_ ; -_ ; addEq)
open import Cubical.Data.Int.Divisibility
open import Cubical.Data.FinData

open import Cubical.Data.Empty as Empty
open import Cubical.Data.Unit  as Unit
open import Cubical.Data.Sigma
open import Cubical.Data.List

open import Cubical.Relation.Nullary

open import Cubical.Algebra.Matrix.CommRingCoefficient
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Int
  renaming (ℤ to ℤRing)

private
  variable
    m n k : ℕ

open Coefficient  ℤRing

-- Sequence of consecutively divisible integers

_∣all_ : ℤ → List ℤ → Type
n ∣all [] = ¬ n ≡ 0
n ∣all (x ∷ ys) = n ∣ x × n ∣all ys

isProp∣all : {n : ℤ}{xs : List ℤ} → isProp (n ∣all xs)
isProp∣all {xs = []}= isPropΠ (λ _ → isProp⊥)
isProp∣all {xs = x ∷ xs} = isProp× isProp∣ isProp∣all

isConsDivs : List ℤ → Type
isConsDivs [] = Unit
isConsDivs (x ∷ xs) = x ∣all xs × isConsDivs xs

isPropIsConsDivs : (xs : List ℤ) → isProp (isConsDivs xs)
isPropIsConsDivs [] = isPropUnit
isPropIsConsDivs (x ∷ xs) = isProp× isProp∣all (isPropIsConsDivs xs)

ConsDivs : Type
ConsDivs = Σ[ xs ∈ List ℤ ] isConsDivs xs

cons : (n : ℤ)(xs : ConsDivs) → n ∣all xs .fst → ConsDivs
cons n (xs , _) _ .fst = n ∷ xs
cons n ([] , _) p .snd = p , tt
cons n (x ∷ xs , q) p .snd = p , q

-- Smith normal matrix

_+length_ : ConsDivs → ℕ → ℕ
xs +length n = length (xs .fst) +ℕ n

smithMat : (xs : List ℤ)(m n : ℕ) → Mat (length xs +ℕ m) (length xs +ℕ n)
smithMat [] _ _ = 𝟘
smithMat (x ∷ xs) _ _ = x ⊕ smithMat xs _ _

smithMat∣ :
    (a : ℤ)(xs : ConsDivs){m n : ℕ}
  → ¬ a ≡ 0
  → ((i : Fin (xs +length m))(j : Fin (xs +length n)) → a ∣ smithMat (xs .fst) m n i j)
  → a ∣all xs .fst
smithMat∣ _ ([] , _) q _ = q
smithMat∣ a (x ∷ xs , p) q h = h zero zero , smithMat∣ a (xs , p .snd) q (λ i j → h (suc i) (suc j))

smithMat⊕ :
    (a : ℤ)(xs : ConsDivs){m n : ℕ}
  → (div : a ∣all xs .fst)
  → a ⊕ smithMat (xs .fst) m n ≡ smithMat (cons a xs div .fst) m n
smithMat⊕ _ _ _ = refl

-- Matrix with smith normality

record isSmithNormal (M : Mat m n) : Type where
  field
    divs : ConsDivs
    rowNull : ℕ
    colNull : ℕ

    rowEq : divs +length rowNull ≡ m
    colEq : divs +length colNull ≡ n
    matEq : PathP (λ t → Mat (rowEq t) (colEq t)) (smithMat (divs .fst) rowNull colNull) M

open isSmithNormal

row col : {M : Mat m n} → isSmithNormal M → ℕ
row isNorm = isNorm .divs +length isNorm .rowNull
col isNorm = isNorm .divs +length isNorm .colNull

smith∣ :
    (a : ℤ){M : Mat m n}(isNorm : isSmithNormal M)
  → ¬ a ≡ 0
  → ((i : Fin m)(j : Fin n) → a ∣ M i j)
  → a ∣all isNorm . divs .fst
smith∣ a isNorm p h =
  let a∣smith = λ
        { i j →
          subst (a ∣_) (λ t → isNorm .matEq (~ t)
            (subst-filler Fin (isNorm .rowEq) i (~ t))
            (subst-filler Fin (isNorm .colEq) j (~ t))) (h _ _) }
  in  smithMat∣ _ (isNorm .divs) p a∣smith

-- Similarity to a normal form

open Sim

record Smith (M : Mat m n) : Type where
  field
    sim : Sim M
    isnormal : isSmithNormal (sim .result)

open Smith

simSmith : {M : Mat m n}(sim : Sim M) → Smith (sim .result) → Smith M
simSmith simM smith .sim      = compSim simM (smith .sim)
simSmith _    smith .isnormal = smith .isnormal

-- Simple special cases of normal matrices

isSmithNormal𝟘 : isSmithNormal (𝟘 {m = m} {n = n})
isSmithNormal𝟘 .divs = [] , tt
isSmithNormal𝟘 {m = m} .rowNull = m
isSmithNormal𝟘 {n = n} .colNull = n
isSmithNormal𝟘 .rowEq = refl
isSmithNormal𝟘 .colEq = refl
isSmithNormal𝟘 .matEq = refl

isSmithNormalEmpty : (M : Mat 0 n) → isSmithNormal M
isSmithNormalEmpty _ .divs = [] , tt
isSmithNormalEmpty _ .rowNull = 0
isSmithNormalEmpty {n = n} _ .colNull = n
isSmithNormalEmpty _ .rowEq = refl
isSmithNormalEmpty _ .colEq = refl
isSmithNormalEmpty _ .matEq = isContr→isProp isContrEmpty _ _

isSmithNormalEmptyᵗ : (M : Mat m 0) → isSmithNormal M
isSmithNormalEmptyᵗ _ .divs = [] , tt
isSmithNormalEmptyᵗ {m = m} _ .rowNull = m
isSmithNormalEmptyᵗ _ .colNull = 0
isSmithNormalEmptyᵗ _ .rowEq = refl
isSmithNormalEmptyᵗ _ .colEq = refl
isSmithNormalEmptyᵗ _ .matEq = isContr→isProp isContrEmptyᵗ _ _

smith𝟘 : Smith (𝟘 {m = m} {n = n})
smith𝟘 .sim      = idSim _
smith𝟘 .isnormal = isSmithNormal𝟘

smithEmpty : (M : Mat 0 n) → Smith M
smithEmpty _ .sim      = idSim _
smithEmpty M .isnormal = isSmithNormalEmpty M

smithEmptyᵗ : (M : Mat m 0) → Smith M
smithEmptyᵗ _ .sim      = idSim _
smithEmptyᵗ M .isnormal = isSmithNormalEmptyᵗ M


{-# OPTIONS --without-K #-}
module function.isomorphism.coherent where

open import sum
open import equality.core
open import equality.calculus
open import equality.reasoning
open import function.core
open import function.isomorphism.core
open import function.overloading
open import overloading.core

coherent : ∀ {i j} {X : Set i}{Y : Set j} → X ≅ Y → Set _
coherent f = ∀ x → ap to (iso₁ x) ≡ iso₂ (to x)
  -- this definition says that the two possible proofs that
  --     to (from (to x)) ≡ to x
  -- are equal
  where
    open _≅_ f

coherent' : ∀ {i j} {X : Set i}{Y : Set j} → X ≅ Y → Set _
coherent' f = ∀ y → ap from (iso₂ y) ≡ iso₁ (from y)
  where
    open _≅_ f

-- coherent isomorphisms
_≅'_ : ∀ {i j} → (X : Set i)(Y : Set j) → Set _
X ≅' Y = Σ (X ≅ Y) coherent

instance
  iso'-is-fun : ∀ {i j}{X : Set i}{Y : Set j}
              → Coercion (X ≅' Y) (X → Y)
  iso'-is-fun = record
    { coerce = λ isom → apply (proj₁ isom) }

  iso'-is-iso : ∀ {i j}{X : Set i}{Y : Set j}
              → Coercion (X ≅' Y) (X ≅ Y)
  iso'-is-iso = record
    { coerce = proj₁ }

-- technical lemma: substiting a fixpoint proof into itself is like
-- applying the function
lem-subst-fixpoint : ∀ {i}{X : Set i}
                     (f : X → X)(x : X)
                     (p : f x ≡ x)
                   → subst (λ x → f x ≡ x) (sym p) p
                   ≡ ap f p
lem-subst-fixpoint {i}{X} f x p = begin
    subst (λ x → f x ≡ x) (p ⁻¹) p
  ≡⟨ lem (f x) (sym p) ⟩
    ap f (sym (sym p)) · p · sym p
  ≡⟨ ap (λ z → ap f z · p · sym p)
           (double-inverse p) ⟩
    ap f p · p · sym p
  ≡⟨ associativity (ap f p) p (sym p) ⟩
    ap f p · (p · sym p)
  ≡⟨ ap (λ z → ap f p · z) (left-inverse p) ⟩
    ap f p · refl
  ≡⟨ left-unit (ap f p) ⟩
    ap f p
  ∎
  where
    open ≡-Reasoning
    lem : (y : X) (q : x ≡ y)
        → subst (λ z → f z ≡ z) q p
        ≡ ap f (sym q) · p · q
    lem .x refl = sym (left-unit p)

lem-whiskering : ∀ {i} {X : Set i}
                 (f : X → X) (H : (x : X) → f x ≡ x)
                 (x : X) → ap f (H x) ≡ H (f x)
lem-whiskering f H x = begin
    ap f (H x)
  ≡⟨ sym (lem-subst-fixpoint f x (H x)) ⟩
    subst (λ z → f z ≡ z) (sym (H x)) (H x)
  ≡⟨ ap' H (sym (H x)) ⟩
    H (f x)
  ∎
  where
    open ≡-Reasoning

lem-homotopy-nat : ∀ {i j}{X : Set i}{Y : Set j}
                   {x x' : X}{f g : X → Y}
                   (H : (x : X) → f x ≡ g x) (p : x ≡ x')
                 → H x · ap g p ≡ ap f p · H x'
lem-homotopy-nat H refl = left-unit _

co-coherence : ∀ {i j}{X : Set i}{Y : Set j}
               (isom : X ≅ Y)
             → coherent isom
             → coherent' isom
co-coherence (iso f g H K) coherence y =
  subst (λ z → ap g (K z) ≡ H (g z)) (K y) lem
  where
    open ≡-Reasoning

    lem : ap g (K (f (g y)))
        ≡ H (g (f (g y)))
    lem = begin
        ap g (K (f (g y)))
      ≡⟨ ap (ap g) (sym (coherence (g y))) ⟩
        ap g (ap f (H (g y)))
      ≡⟨ ap-hom f g _ ⟩
        ap (g ∘ f) (H (g y))
      ≡⟨ lem-whiskering (g ∘ f) H (g y) ⟩
        H (g (f (g y)))
      ∎

sym≅' : ∀ {i j}{X : Set i}{Y : Set j}
      → X ≅' Y → Y ≅' X
sym≅' (isom , γ) = sym≅ isom , co-coherence isom γ

--- Vogt's lemma. See http://ncatlab.org/nlab/show/homotopy+equivalence
vogt-lemma : ∀ {i j}{X : Set i}{Y : Set j} → (isom : X ≅ Y)
           → let open _≅_ isom
              in Σ ((y : Y) → to (from y) ≡ y) λ iso' →
                 coherent (iso to from iso₁ iso')
vogt-lemma {X = X}{Y = Y} isom = K' , γ
  where
    open _≅_ isom
      renaming (to to f ; from to g ; iso₁ to H ; iso₂ to K)

    -- Outline of the proof
    -- --------------------
    --
    -- We want to find a homotopy K' : f g → id such that f K' ≡ H f.
    --
    -- To do so, we first prove that the following diagram of
    -- homotopies:
    --
    --                     f H g f
    --          f g f g f ---------> f g f
    --              |                  |
    --     f g K f  |                  | K f
    --              |                  |
    --              v                  v
    --            f g f -------------> f
    --                       f H
    --
    -- commutes. We then observe that f appears on the right side of
    -- every element in the diagram, except the bottom row, so if we
    -- define:
    --
    --     K' = (f g K) ⁻¹ · (f H g f) · (K f)
    --
    -- we get that K' f must be equal to the bottom row, which is
    -- exactly the required coherence condition.

    open ≡-Reasoning

    -- the diagram above commutes
    lem : (x : X)
        → ap f (H (g (f x))) · K (f x)
        ≡ ap (f ∘ g) (K (f x)) · ap f (H x)
    lem x = begin
        ap f (H (g (f x))) · K (f x)
      ≡⟨ ap (λ z → ap f z · K (f x))
              (sym (lem-whiskering (g ∘ f) H x)) ⟩
        ap f (ap (g ∘ f) (H x)) · K (f x)
      ≡⟨ ap (λ z → z · K (f x))
              (ap-hom (g ∘ f) f (H x)) ⟩
        ap (f ∘ g ∘ f) (H x) · K (f x)
      ≡⟨ sym (lem-homotopy-nat (λ x → K (f x)) (H x)) ⟩
        K (f (g (f x))) · ap f (H x)
      ≡⟨ ap (λ z → z · ap f (H x))
              (sym (lem-whiskering (f ∘ g) K (f x))) ⟩
        ap (f ∘ g) (K (f x)) · ap f (H x)
      ∎

    K' : (y : Y) → f (g y) ≡ y
    K' y = ap (f ∘ g) (sym (K y))
         · ap f (H (g y))
         · K y

    iso' = iso f g H K'

    -- now we can just compute using the groupoid laws
    γ : coherent iso'
    γ x = sym $ begin
        K' (f x)
      ≡⟨ refl ⟩
        ap (f ∘ g) (sym (K (f x))) ·
        ap f (H (g (f x))) · K (f x)
      ≡⟨ associativity (ap (f ∘ g) (sym (K (f x))))
               (ap f (H (g (f x))))
               (K (f x)) ⟩
        ap (f ∘ g) (sym (K (f x))) ·
        (ap f (H (g (f x))) · K (f x))
      ≡⟨ ap (λ z → ap (f ∘ g) (sym (K (f x))) · z) (lem x) ⟩
        ap (f ∘ g) (sym (K (f x))) ·
        (ap (f ∘ g) (K (f x)) · ap f (H x))
      ≡⟨ ap (λ z → z · (ap (f ∘ g) (K (f x)) · ap f (H x)))
              (ap-inv (f ∘ g) (K (f x))) ⟩
        sym (ap (f ∘ g) (K (f x))) ·
        (ap (f ∘ g) (K (f x)) · ap f (H x))
      ≡⟨ sym (associativity (sym (ap (f ∘ g) (K (f x))))
                       (ap (f ∘ g) (K (f x)))
                       (ap f (H x))) ⟩
        ( sym (ap (f ∘ g) (K (f x))) ·
          ap (f ∘ g) (K (f x)) ) ·
        ap f (H x)
      ≡⟨ ap (λ z → z · ap f (H x))
               (right-inverse (ap (f ∘ g) (K (f x)))) ⟩
        refl · ap f (H x)
      ≡⟨ right-unit (ap f (H x)) ⟩
        ap f (H x)
      ∎

≅⇒≅' : ∀ {i j} {X : Set i}{Y : Set j} → X ≅ Y → X ≅' Y
≅⇒≅' {X = X}{Y = Y} isom = iso to from iso₁ (proj₁ v) , proj₂ v
  where
    open _≅_ isom
    open import sum
    abstract
      v : Σ ((y : Y) → to (from y) ≡ y) λ iso₂'
        → coherent (iso to from iso₁ iso₂')
      v = vogt-lemma isom


module IrrelevantModuleParameter .(A : Set) where

postulate
  a : A
-- cannot declare something of type A, since A is irrelevant


module Data.Unit.Instance where

open import Class.Monoid
open import Data.Unit.Polymorphic

instance
  Unit-Monoid : ∀ {a} → Monoid {a} ⊤
  Unit-Monoid = record { mzero = tt ; _+_ = λ _ _ -> tt }


open import Common.Prelude
open import Common.Reflect
open import Common.Equality

postulate
  trustme : ∀ {a} {A : Set a} {x y : A} → x ≡ y

magic : Term → Term
magic _ = def (quote trustme) []

id : ∀ {a} {A : Set a} → A → A
id x = x

science : Term → Term
science _ = def (quote id) []

by-magic : ∀ n → n + 4 ≡ 3
by-magic n = tactic magic

by-science : ∀ n → 0 + n ≡ n
by-science n = tactic science | refl


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Free.Evaluation (Σ : Signature) where

open import Fragment.Algebra.Free.Monad Σ
open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Free.Base Σ
open import Fragment.Algebra.Homomorphism Σ
open import Fragment.Setoid.Morphism as Morphism

open import Level using (Level)

open import Data.Empty using (⊥)
open import Data.Nat using (ℕ; suc)
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_; map)
open import Data.Vec.Relation.Binary.Pointwise.Inductive
  using (Pointwise; []; _∷_)

open import Relation.Binary using (Setoid)
import Relation.Binary.PropositionalEquality as PE

private
  variable
    a b ℓ₁ ℓ₂ : Level

module _ (A : Algebra {a} {ℓ₁}) where

  private

    open Setoid ∥ A ∥/≈
    open import Relation.Binary.Reasoning.Setoid ∥ A ∥/≈

    mutual
      map-∣eval∣ : ∀ {n} → Vec (Term ∥ A ∥) n → Vec ∥ A ∥ n
      map-∣eval∣ []       = []
      map-∣eval∣ (x ∷ xs) = ∣eval∣ x ∷ map-∣eval∣ xs

      ∣eval∣ : Term ∥ A ∥ → ∥ A ∥
      ∣eval∣ (atom x)    = x
      ∣eval∣ (term f xs) = A ⟦ f ⟧ (map-∣eval∣ xs)

    mutual
      map-∣eval∣-cong : ∀ {n} {xs ys : Vec (Term ∥ A ∥) n}
                         → Pointwise (_~_ ∥ A ∥/≈) xs ys
                         → Pointwise ≈[ A ] (map-∣eval∣ xs)
                                          (map-∣eval∣ ys)
      map-∣eval∣-cong []       = []
      map-∣eval∣-cong (p ∷ ps) = ∣eval∣-cong p ∷ map-∣eval∣-cong ps

      ∣eval∣-cong : Congruent (_~_ ∥ A ∥/≈) ≈[ A ] ∣eval∣
      ∣eval∣-cong (atom p)                 = p
      ∣eval∣-cong {x = term op _} (term p) =
        (A ⟦ op ⟧-cong) (map-∣eval∣-cong p)

    ∣eval∣⃗ : Herbrand ∥ A ∥/≈ ↝ ∥ A ∥/≈
    ∣eval∣⃗ = record { ∣_∣      = ∣eval∣
                     ; ∣_∣-cong = ∣eval∣-cong
                     }

    ∣eval∣-args≡map : ∀ {n} {xs : Vec (Term ∥ A ∥) n}
                      → Pointwise _≈_ (map-∣eval∣ xs) (map ∣eval∣ xs)
    ∣eval∣-args≡map {xs = []}     = []
    ∣eval∣-args≡map {xs = x ∷ xs} = refl ∷ ∣eval∣-args≡map

    ∣eval∣-hom : Homomorphic (Free ∥ A ∥/≈) A ∣eval∣
    ∣eval∣-hom f []       = refl
    ∣eval∣-hom f (x ∷ xs) = sym ((A ⟦ f ⟧-cong) (∣eval∣-args≡map {xs = x ∷ xs}))

  eval : Free ∥ A ∥/≈ ⟿ A
  eval = record { ∣_∣⃗    = ∣eval∣⃗
                ; ∣_∣-hom = ∣eval∣-hom
                }

fold : ∀ {A : Setoid a ℓ₁} (B : Algebra {b} {ℓ₂})
       → (A ↝ ∥ B ∥/≈) → Free A ⟿ B
fold B f = (eval B) ⊙ bind (unit · f)

Env : (A : Algebra {a} {ℓ₁}) → ℕ → Set _
Env A n = Fin n → ∥ A ∥

env : ∀ {A : Algebra {a} {ℓ₁}} {n} → (Γ : Vec ∥ A ∥ n) → Env A n
env {A = _} {suc n} (x ∷ _)  zero    = x
env {A = A} {suc n} (_ ∷ xs) (suc i) = env {A = A} xs i

module _ {n}
  {S : Setoid a ℓ₁}
  (T : Setoid b ℓ₂)
  (f : S ↝ T)
  (g : Fin n → Setoid.Carrier T)
  where

  private

    open Setoid S renaming (Carrier to A) using ()
    open Setoid T renaming (Carrier to B)

    ∣sub∣ : BT A n → B
    ∣sub∣ (sta x) = Morphism.∣ f ∣ x
    ∣sub∣ (dyn x) = g x

    ∣sub∣-cong : Congruent (_≍_ S n) _≈_ ∣sub∣
    ∣sub∣-cong (sta p) = Morphism.∣ f ∣-cong p
    ∣sub∣-cong (dyn q) = reflexive (PE.cong g q)

  sub : Atoms S n ↝ T
  sub = record { ∣_∣      = ∣sub∣
               ; ∣_∣-cong = ∣sub∣-cong
               }

module _ {n}
  {A : Setoid a ℓ₁}
  (B : Algebra {b} {ℓ₂})
  (f : A ↝ ∥ B ∥/≈)
  (g : Fin n → ∥ B ∥)
  where

  subst : Free (Atoms A n) ⟿ B
  subst = fold B (sub ∥ B ∥/≈ f g)

ignore : ∀ (A : Setoid a ℓ₁) → PE.setoid ⊥ ↝ A
ignore _ = record { ∣_∣      = λ ()
                  ; ∣_∣-cong = λ {}
                  }

inst : ∀ {n} (A : Algebra {a} {ℓ₁})
       → Env A n → F n ⟿ A
inst {n = n} A θ = subst A (ignore ∥ A ∥/≈) θ


module Category.Functor.Arr where
open import Agda.Primitive using (_⊔_)
open import Category.Functor     using (RawFunctor    ; module RawFunctor    )
open import Category.Applicative using (RawApplicative; module RawApplicative)
open import Function using (_∘_)
open import Category.Functor.Lawful
open import Relation.Binary.PropositionalEquality using (refl)

Arr : ∀ {l₁ l₂} → Set l₁ → Set l₂ → Set (l₁ ⊔ l₂)
Arr A B = A → B

arrFunctor : ∀ {l₁ l₂} {B : Set l₁} → RawFunctor (Arr {l₁} {l₂} B)
arrFunctor = record { _<$>_ = λ z z₁ x → z (z₁ x) } -- auto-found

arrLawfulFunctor : ∀ {l₁ l₂} {B : Set l₁} → LawfulFunctorImp (arrFunctor {l₁} {l₂} {B})
arrLawfulFunctor = record
  { <$>-identity = refl
  ; <$>-compose  = refl
  }

arrApplicative : ∀ {l₁} {B : Set l₁} → RawApplicative (Arr {l₁} {l₁} B)
arrApplicative = record { pure = λ z x → z ; _⊛_ = λ z z₁ x → z x (z₁ x) } -- auto-found

arrLawfulApplicative : ∀ {l₁} {B : Set l₁} → LawfulApplicativeImp (arrApplicative {l₁} {B})
arrLawfulApplicative = record
  { ⊛-identity = refl
  ; ⊛-homomorphism = refl
  ; ⊛-interchange = refl
  ; ⊛-composition = refl
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use the
-- Relation.Binary.Reasoning.Preorder module directly.
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.PreorderReasoning
         {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where

open import Relation.Binary.Reasoning.Preorder P public


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

open import Agda.Builtin.Equality

postulate @0 A : Set

@0 f : (X : Set) → A ≡ X → Set
f X refl = {!!}


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

open import Level renaming (zero to lzero ; suc to lsuc)
open import Syntax
open import Data.List using (length ; [] ; _∷_ ) renaming ( _++_ to _++L_ )
open import Data.Vec  using ([] ; _∷_  ) renaming ( _++_ to _++V_ )

open import Data.Vec.Relation.Unary.All using (All ; [] ; _∷_)
open import Data.Nat

open import Data.Product
open import Function using () renaming (case_of_ to case*_of_)

open import Size
open import Relation.Binary.PropositionalEquality

-- Sets indexed by invertible environments (that is, Θ and Ξ). This
-- actually is our semantic domain.
Dom : ∀ ℓ -> Set (lsuc ℓ)
Dom ℓ = (Θ : TyEnv) -> (Ξ : MultEnv (length Θ)) -> Set ℓ

-- A pairing operator, inspired by the Day convolution in category theory.
data _⊛_ {ℓ : Level}
         (F : Dom ℓ)
         (G : Dom ℓ)
         (Θ : TyEnv) (Ξ : MultEnv (length Θ)) : Set ℓ where
     tup : ∀ Ξ₁ Ξ₂ -> (spΞ : Ξ₁ +ₘ Ξ₂ ≡ Ξ) ->
           (fst : F Θ Ξ₁) -> (snd : G Θ Ξ₂) -> (F ⊛ G) Θ Ξ

-- mult is used for representing entries in value environments that are aware of multiplicities.
data mult {ℓ : Level} (F : Dom ℓ) : (m : Multiplicity₀) -> Dom ℓ where
  -- An entry corresponds to multiplicity zero, i.e., nothing.
  mult-zero :
    ∀ {Θ Ξ} ->
    (eq : Ξ ≡ ∅) ->
    mult F zero Θ Ξ

  -- An entry corresponds to multiplicity one, a value must be used linearly.
  mult-one :
    ∀ {Θ Ξ} ->
    (v : F Θ Ξ) -> mult F one Θ Ξ

  -- An entry corresponds to multiplicity omega; such values must be indexed by the empty invertible environment.
  mult-omega :
    ∀ {Θ Ξ} ->
    (v : F Θ ∅) -> (eq : Ξ ≡ ∅) -> mult F omega Θ Ξ

-- Values (Value), residuals (Residual) and value environments
-- (ValEnv) are mutually defined.
--
-- The sized types are used for termination checking with the presence
-- of --without-K, which weakens termination analysis for
-- with-abstractions that the original definitions used to have.

data Value (Θ : TyEnv) : MultEnv (length Θ) -> Ty zero -> {i : Size} -> Set
data Residual (Θ : TyEnv) : MultEnv (length Θ) -> Ty zero -> {i : Size} -> Set
ValEnv :
  (Γ : TyEnv) -> (Δ : MultEnv (length Γ)) -> {i : Size} ->
  (Θ : TyEnv) -> MultEnv (length Θ) -> Set

-- ValEnv Γ Δ : Dom 0 represents value environments conforms to Γ Δ.
-- Intuitively, (Θ , Ξ) of ValEnv Γ Δ Θ Ξ represents typed resources contained in
-- value environments.

ValEnv [] Δ {i}            = λ Θ Ξ -> Ξ ≡ ∅
ValEnv (A ∷ Γ) (m ∷ Δ) {i} =
  mult (V A) m ⊛ ValEnv Γ Δ {i}
  where
    V : Ty zero -> Dom 0ℓ
    V A Θ Ξ = Value Θ Ξ A {i}

-- Values
data Value Θ where
  clo :
    ∀ {Ξ Ξ' Γ' Δ' A B Ξₜ i} ->
    (m : Multiplicity) ->
    (spΞ : Ξ' +ₘ Ξₜ ≡ Ξ) ->
    (θ : ValEnv Γ' Δ' {i} Θ Ξ' ) ->
    (t : Term (A ∷ Γ') (M→M₀ m ∷ Δ') Θ Ξₜ B) ->
    Value Θ Ξ (A # m ~> B) {↑ i}

  unit :
    ∀ {Ξ i} ->
    (eq : ∅ ≡ Ξ) ->
    Value Θ Ξ tunit {↑ i}

  pair :
    ∀ {Ξ Ξ₁ Ξ₂ A B i} ->
    (spΞ : Ξ₁ +ₘ Ξ₂ ≡ Ξ) ->
    Value Θ Ξ₁ A {i} ->
    Value Θ Ξ₂ B {i} ->
    Value Θ Ξ (A ⊗ B) {↑ i}

  many :
    ∀ {Ξ Ξ₀ A i} ->
    (m : Multiplicity) ->
    (spΞ : m ×ₘ Ξ₀ ≡ Ξ) ->
    Value Θ Ξ₀ A {i} ->
    Value Θ Ξ (Many m A) {↑ i}

  inl  :
    ∀ {Ξ} {A B i} ->
    Value Θ Ξ A {i} ->
    Value Θ Ξ (A ⊕ B) {↑ i}

  inr :
    ∀ {Ξ} {A B i} ->
    Value Θ Ξ B {i} ->
    Value Θ Ξ (A ⊕ B) {↑ i}

  roll :
    ∀ {Ξ F i} ->
    Value Θ Ξ (substTy F (μ F)) {i} ->
    Value Θ Ξ (μ F) {↑ i}

  inj :
    ∀ {Ξ A B i}
    -> (eq : ∅ ≡ Ξ)
    -> (r : Residual (A ∷ []) (one ∷ ∅) (B ●) {i})
    -> Value Θ Ξ (A ↔ B) {↑ i}

  red :
    ∀ {Ξ A i} ->
    Residual Θ Ξ (A ●) {i} ->
    Value Θ Ξ (A ●) {↑ i}

-- Residuals
data Residual Θ where
  unit● :
    ∀ {i} ->
    Residual Θ ∅ (tunit ●) {↑ i}

  letunit● :
    ∀ {Ξ₀ Ξ A i} ->
    Residual Θ Ξ₀ (tunit ●) {i} ->
    Residual Θ Ξ  (A ●) {i} ->
    Residual Θ (Ξ₀ +ₘ Ξ) (A ●) {↑ i}

  pair● :
    ∀ {Ξ₁ Ξ₂ A B i} ->
    Residual Θ Ξ₁ (A ●) {i} ->
    Residual Θ Ξ₂ (B ●) {i} ->
    Residual Θ (Ξ₁ +ₘ Ξ₂) ((A ⊗ B) ●) {↑ i}

  letpair● :
    ∀ {Ξ₀ Ξ A B C i} ->
    Residual Θ Ξ₀ ((A ⊗ B) ●) {i} ->
    Residual (A ∷ B ∷ Θ) (one ∷ one ∷ Ξ) (C ●) {i} ->
    Residual Θ (Ξ₀ +ₘ Ξ) (C ●) {↑ i}

  inl● :
    ∀ {Ξ} {A B} {i} ->
    Residual Θ Ξ (A ●) {i} ->
    Residual Θ Ξ ((A ⊕ B) ●) {↑ i}

  inr● :
    ∀ {Ξ} {A B} {i} ->
    Residual Θ Ξ (B ●) {i} ->
    Residual Θ Ξ ((A ⊕ B) ●) {↑ i}

  case● :
    ∀ {Ξ₀ Ξ Ξₑ Ξₜ Γ₁ Γ₂ Δ₁ Δ₂ A B C i} ->
    Residual Θ Ξ₀ ((A ⊕ B) ●) {i} ->
    (spΞ : Ξₑ +ₘ Ξₜ ≡ Ξ) ->
    (θ₁ : ValEnv Γ₁ Δ₁ {i} Θ Ξₑ) ->
    (t₁ : Term Γ₁ Δ₁ (A ∷ Θ) (one ∷ Ξₜ) (C ●)) ->
    (θ₂ : ValEnv Γ₂ Δ₂ {i} Θ Ξₑ) ->
    (t₂ : Term Γ₂ Δ₂ (B ∷ Θ) (one ∷ Ξₜ) (C ●)) ->
    (v : Value [] ∅ (C # omega ~> tbool) {i}) ->
    Residual Θ (Ξ₀ +ₘ Ξ) (C ●) {↑ i}

  var● : ∀ {Ξ A i} ->
         (x : Θ ∋ A) -> (ok : varOk● Θ x Ξ) ->
         Residual Θ Ξ (A ●) {↑ i}

  pin : ∀ {Ξ₁ Ξ₂ A B i} ->
        Residual Θ Ξ₁ (A ●) {i} ->
        (v : Value    Θ Ξ₂ (A # omega ~> B ●) {i}) ->
        Residual Θ (Ξ₁ +ₘ Ξ₂) ((A ⊗ B) ●) {↑ i}

open ≡-Reasoning

-- A property on value environments that says discardable value environments cannot contain any resources.

discardable-has-no-resources : ∀ {Γ Δ Θ Ξ} -> ValEnv Γ Δ Θ Ξ -> All discardable Δ -> Ξ ≡ ∅
discardable-has-no-resources {[]} {Δ} θ ad = θ
discardable-has-no-resources {A ∷ Γ} {.omega ∷ Δ} (tup .∅ Ξ₂ spΞ (mult-omega v refl) snd) (omega ∷ ad) =
     begin
      _
     ≡⟨ sym spΞ ⟩
      ∅ +ₘ Ξ₂
     ≡⟨ ∅-lid Ξ₂ ⟩
      Ξ₂
     ≡⟨ discardable-has-no-resources {Γ} {Δ} snd ad ⟩
      ∅
     ∎
discardable-has-no-resources {A ∷ Γ} {.zero ∷ Δ} (tup .∅ Ξ₂ spΞ (mult-zero refl) snd) (zero ∷ ad) =
     begin
      _
     ≡⟨ sym spΞ ⟩
      ∅ +ₘ Ξ₂
     ≡⟨ ∅-lid Ξ₂ ⟩
      Ξ₂
     ≡⟨ discardable-has-no-resources {Γ} {Δ} snd ad ⟩
      ∅
     ∎

-- Looking up variables in an environment. Unlike the usual variable looking-up functions, this version
-- takes varOk Γ x Δ instead of x to ensure that the variable can be looked up. Notice
-- for example that we cannot look up variables with multiplicity zero. Also, the fact that the
-- return type is Value Θ Ξ A means that the value environment cannot contain other resources.

lookupVar : ∀ {Γ Δ Θ Ξ A} {x : Γ ∋ A} -> ValEnv Γ Δ Θ Ξ -> varOk Γ x Δ -> Value Θ Ξ A
lookupVar (tup .(∅) Ξ₂ spΞ (mult-omega v refl) snd) (there omega ok) with (trans (sym (∅-lid _)) spΞ)
... | refl = lookupVar snd ok
lookupVar (tup .∅ Ξ₂ spΞ (mult-zero refl) snd) (there zero ok) with (trans (sym (∅-lid _)) spΞ)
... | refl = lookupVar snd ok
lookupVar {Γ = A ∷ Γ} {Δ = m ∷ Δ} (tup Ξ₁ Ξ₂ spΞ fst snd) (here u ad) with discardable-has-no-resources {Γ} {Δ} snd ad
... | refl with trans (sym (∅-rid _)) spΞ
lookupVar {A ∷ Γ} {.omega ∷ Δ} (tup .∅ .∅ spΞ (mult-omega v refl) snd) (here omega ad) | refl | refl = v
lookupVar {A ∷ Γ} {.one ∷ Δ} (tup Ξ₁ .∅ spΞ (mult-one v) snd) (here one ad) | refl | refl = v

-- separateEnv separates value environments according to separation of
-- (unidirectional) type environments.

separateEnv : ∀ {Γ Θ Ξ} -> ∀ Δ₁ Δ₂ ->
              ValEnv Γ (Δ₁ +ₘ Δ₂) Θ Ξ ->
              (ValEnv Γ Δ₁ ⊛ ValEnv Γ Δ₂) Θ Ξ
separateEnv {[]} Δ₁ Δ₂ refl = tup ∅ ∅ (∅-lid ∅) refl refl
separateEnv {A ∷ Γ} (m₁ ∷ Δ₁) (m₂ ∷ Δ₂) (tup Ξ₁ Ξ₂ spΞ fst snd) with separateEnv {Γ} Δ₁ Δ₂ snd
separateEnv {A ∷ Γ} {Θ = Θ} {Ξ = Ξ} (zero ∷ Δ₁) (m₂ ∷ Δ₂) (tup Ξ₁ Ξ₂ spΞ fst snd) | tup Ξ₁' Ξ₂' spΞ₂ θ₁ θ₂ =
            tup Ξ₁' (Ξ₁ +ₘ Ξ₂') lemma (tup ∅ Ξ₁'   (∅-lid _) (mult-zero refl) θ₁)
                                             (tup Ξ₁ Ξ₂' refl      fst θ₂)
  where
    open import Algebra.Solver.CommutativeMonoid (+ₘ-commutativeMonoid (length Θ))
                renaming (_⊕_ to _⊞_)

    lemma : Ξ₁' +ₘ (Ξ₁ +ₘ Ξ₂') ≡ Ξ
    lemma =
      begin
        Ξ₁' +ₘ (Ξ₁ +ₘ Ξ₂')
      ≡⟨ solve 3 (λ x y z -> x ⊞ (y ⊞ z) ⊜ y ⊞ (x ⊞ z)) refl Ξ₁' Ξ₁ Ξ₂' ⟩
        Ξ₁ +ₘ (Ξ₁' +ₘ Ξ₂')
      ≡⟨ cong (_ +ₘ_) spΞ₂ ⟩
        Ξ₁ +ₘ Ξ₂
      ≡⟨ spΞ ⟩
        Ξ
      ∎

separateEnv {A ∷ Γ} {Ξ = Ξ} (one ∷ Δ₁) (zero ∷ Δ₂) (tup Ξ₁ Ξ₂ spΞ fst snd) | tup Ξ₁' Ξ₂' spΞ₂ θ₁ θ₂ =
  tup (Ξ₁ +ₘ Ξ₁') Ξ₂' lemma (tup Ξ₁ Ξ₁' refl fst θ₁)
                               (tup ∅   Ξ₂' (∅-lid _) (mult-zero refl) θ₂)
  where
    lemma : Ξ₁ +ₘ Ξ₁' +ₘ Ξ₂' ≡ Ξ
    lemma =
      begin
        Ξ₁ +ₘ Ξ₁' +ₘ Ξ₂'
      ≡⟨ +ₘ-assoc Ξ₁ Ξ₁' _ ⟩
        Ξ₁ +ₘ (Ξ₁' +ₘ Ξ₂')
      ≡⟨ cong (_ +ₘ_) spΞ₂ ⟩
        Ξ₁ +ₘ Ξ₂
      ≡⟨ spΞ ⟩
        Ξ
      ∎
separateEnv {A ∷ Γ} (one ∷ Δ₁) (one ∷ Δ₂) (tup .(∅) .(Ξ₁' +ₘ Ξ₂') refl (mult-omega v refl) snd) | tup Ξ₁' Ξ₂' refl θ₁ θ₂ =
  tup Ξ₁' Ξ₂' (sym (∅-lid _)) (tup ∅ Ξ₁' (∅-lid _) (mult-one v) θ₁)
                                (tup ∅ Ξ₂' (∅-lid _) (mult-one v) θ₂)
separateEnv {A ∷ Γ} (one ∷ Δ₁) (omega ∷ Δ₂) (tup .(∅) .(Ξ₁' +ₘ Ξ₂') refl (mult-omega v refl) snd) | tup Ξ₁' Ξ₂' refl θ₁ θ₂ =
  tup Ξ₁' Ξ₂' (sym (∅-lid _)) (tup ∅ Ξ₁' (∅-lid _) (mult-one v) θ₁)
                                (tup ∅ Ξ₂' (∅-lid _) (mult-omega v refl) θ₂)

separateEnv {A ∷ Γ} (omega ∷ Δ₁) (zero ∷ Δ₂) (tup .(∅) .(Ξ₁' +ₘ Ξ₂') refl (mult-omega v refl) snd) | tup Ξ₁' Ξ₂' refl θ₁ θ₂ =
  tup Ξ₁' Ξ₂' (sym (∅-lid _)) (tup ∅ Ξ₁' (∅-lid _) (mult-omega v refl) θ₁)
                                (tup ∅ Ξ₂' (∅-lid _) (mult-zero refl) θ₂)

separateEnv {A ∷ Γ} (omega ∷ Δ₁) (one ∷ Δ₂) (tup .(∅) .(Ξ₁' +ₘ Ξ₂') refl (mult-omega v refl) snd) | tup Ξ₁' Ξ₂' refl θ₁ θ₂ =
   tup Ξ₁' Ξ₂' (sym (∅-lid _)) (tup ∅ Ξ₁' (∅-lid _) (mult-omega v refl) θ₁)
                                 (tup ∅ Ξ₂' (∅-lid _) (mult-one v) θ₂)

separateEnv {A ∷ Γ} (omega ∷ Δ₁) (omega ∷ Δ₂) (tup .(∅) .(Ξ₁' +ₘ Ξ₂') refl (mult-omega v refl) snd) | tup Ξ₁' Ξ₂' refl θ₁ θ₂ =
  tup Ξ₁' Ξ₂' (sym (∅-lid _)) (tup ∅ Ξ₁' (∅-lid _) (mult-omega v refl) θ₁)
                                (tup ∅ Ξ₂' (∅-lid _) (mult-omega v refl) θ₂)

-- un×ₘ-valEnv is a counter of separateEnv for ×ₘ.

un×ₘ-valEnv : ∀ Γ {m Δ Θ Ξ} -> ValEnv Γ (m ×ₘ Δ) Θ Ξ -> ∃[ Ξ' ] (ValEnv Γ Δ Θ Ξ' × m ×ₘ Ξ' ≡ Ξ)
un×ₘ-valEnv [] {m} θ = ∅ , refl , trans (×ₘ∅ m) (sym θ)
un×ₘ-valEnv (_ ∷ Γ) {Δ = mₓ ∷ Δ} (tup Ξ₁ Ξ₂ refl fst snd) with un×ₘ-valEnv Γ snd
un×ₘ-valEnv (_ ∷ Γ) {one} {mₓ ∷ Δ} (tup Ξ₁ .(Data.Vec.map (λ y → y) Ξ') refl fst snd) | Ξ' , θ' , refl = Ξ₁ +ₘ Ξ' , tup Ξ₁ Ξ' refl fst θ' , lemma
  where
    open import Data.Vec.Properties using (map-id)

    lemma : Data.Vec.map (λ x -> x) (Ξ₁ +ₘ Ξ') ≡ Ξ₁ +ₘ Data.Vec.map (λ x -> x) Ξ'
    lemma = begin
              Data.Vec.map (λ x -> x) (Ξ₁ +ₘ Ξ')
            ≡⟨ map-id _ ⟩
              Ξ₁ +ₘ Ξ'
            ≡⟨ cong (_ +ₘ_) (sym (map-id _)) ⟩
              Ξ₁ +ₘ Data.Vec.map (λ x -> x) Ξ'
            ∎

un×ₘ-valEnv (_ ∷ Γ) {omega} {zero ∷ Δ} (tup .(∅) .(Data.Vec.map (mul₀ omega) Ξ') refl (mult-zero refl) snd) | Ξ' , θ' , refl = Ξ' , tup ∅ Ξ' (∅-lid _) (mult-zero refl) θ' , sym (∅-lid _)
un×ₘ-valEnv (_ ∷ Γ) {omega} {one ∷ Δ} (tup .(∅) .(Data.Vec.map (mul₀ omega) Ξ') refl (mult-omega v refl) snd) | Ξ' , θ' , refl = Ξ' , tup ∅ Ξ' (∅-lid _) (mult-one v) θ' , sym (∅-lid _)
un×ₘ-valEnv (_ ∷ Γ) {omega} {omega ∷ Δ} (tup .(∅) .(Data.Vec.map (mul₀ omega) Ξ') refl (mult-omega v refl) snd) | Ξ' , θ' , refl = Ξ' , tup ∅ Ξ' (∅-lid _) (mult-omega v refl) θ' , sym (∅-lid _)

-- weakenΘ-value and weakenΘ-residual are counterparts of
-- weakenΘ-term for values and residuals.

weakenΘ-value :
  ∀ {Θ Ξ Θ' Ξ' A i} ->
  compatΘ Θ Ξ Θ' Ξ' ->
  Value Θ Ξ A {i} -> Value Θ' Ξ' A
weakenΘ-residual :
  ∀ {Θ Ξ Θ' Ξ' A i} ->
  compatΘ Θ Ξ Θ' Ξ' ->
  Residual Θ Ξ A {i} -> Residual Θ' Ξ' A

weakenΘ-valEnv :
  ∀ Γ {Δ Θ Ξ Θ' Ξ' i} ->
  compatΘ Θ Ξ Θ' Ξ' ->
  ValEnv Γ Δ {i} Θ Ξ -> ValEnv Γ Δ Θ' Ξ'

weakenΘ-mult :
  ∀ {Θ Ξ Θ' Ξ' m A i} ->
  compatΘ Θ Ξ Θ' Ξ' ->
  mult (λ Θ Ξ -> Value Θ Ξ A {i}) m Θ  Ξ ->
  mult (λ Θ Ξ -> Value Θ Ξ A) m Θ' Ξ'

weakenΘ-value ext (clo {Γ' = Γ'} m refl θ t) =
  case* compatΘ-split ext of λ {
    (_ , _ , ext₁ , ext₂ , refl) ->
      clo m refl (weakenΘ-valEnv Γ' ext₁ θ)
                 (weakenΘ-term ext₂ t)
  }

weakenΘ-value ext (unit refl) =
  case* compatΘ-∅ ext of λ where
    refl -> unit refl

weakenΘ-value ext (pair refl v₁ v₂) =
  case* compatΘ-split ext of λ where
   (_ , _ , ext₁ , ext₂ , refl) ->
     pair refl (weakenΘ-value ext₁ v₁) (weakenΘ-value ext₂ v₂)

weakenΘ-value ext (many m refl v) =
  case* compatΘ-×ₘ ext of λ where
    (_ , ext' , refl) -> many m refl (weakenΘ-value ext' v)

weakenΘ-value ext (inl v) = inl (weakenΘ-value ext v)
weakenΘ-value ext (inr v) = inr (weakenΘ-value ext v)
weakenΘ-value ext (roll v) = roll (weakenΘ-value ext v)
weakenΘ-value ext (red x) = red (weakenΘ-residual ext x)
weakenΘ-value ext (inj refl r) =
  case* compatΘ-∅ ext of λ {
    refl -> inj refl (weakenΘ-residual ext-id r)
  }

weakenΘ-mult ext (mult-zero refl) =
  case* compatΘ-∅ ext  of λ {
    refl -> mult-zero refl
  }

weakenΘ-mult ext (mult-one v) = mult-one (weakenΘ-value ext v)
weakenΘ-mult ext (mult-omega v refl) =
  case* compatΘ-∅ ext of λ {
    refl -> mult-omega (weakenΘ-value ext v) refl
  }

weakenΘ-valEnv [] ext refl =
  case* compatΘ-∅ ext of λ {
    refl -> refl
  }
weakenΘ-valEnv (_ ∷ Γ) {_ ∷ Δ} ext (tup Ξ₁ Ξ₂ refl mv θ) =
  case* compatΘ-split ext of λ {
    (Ξ₁' , Ξ₂' , ext₁ , ext₂ , refl) ->
      tup Ξ₁' Ξ₂' refl (weakenΘ-mult ext₁ mv) (weakenΘ-valEnv Γ ext₂ θ)
  }

weakenΘ-residual ext unit● =
  case* compatΘ-∅ ext of λ {
    refl -> unit●
  }

weakenΘ-residual ext (letunit● r₁ r₂) =
  case* compatΘ-split ext of λ {
    (_ , _ , ext₁ , ext₂ , refl) ->
      letunit● (weakenΘ-residual ext₁ r₁)
               (weakenΘ-residual ext₂ r₂)
  }

weakenΘ-residual ext (pair● r₁ r₂) =
  case* compatΘ-split ext of λ {
    (_ , _ , ext₁ , ext₂ , refl) ->
      pair● (weakenΘ-residual ext₁ r₁)
            (weakenΘ-residual ext₂ r₂)
  }

weakenΘ-residual ext (letpair● r₁ r₂) =
  case* compatΘ-split ext of λ {
    (_ , _ , ext₁ , ext₂ , refl) ->
      letpair● (weakenΘ-residual ext₁ r₁)
               (weakenΘ-residual (compat-skip (compat-skip ext₂)) r₂)
  }

weakenΘ-residual ext (inl● r) = inl● (weakenΘ-residual ext r)
weakenΘ-residual ext (inr● r) = inr● (weakenΘ-residual ext r)
weakenΘ-residual ext (case● {Γ₁ = Γ₁} {Γ₂} r refl θ₁ t₁ θ₂ t₂ v) with compatΘ-split ext
... | _ , _ , ext₁ , ext₂ , refl
   with compatΘ-split ext₂
... | _ , _ , extₑ , extₜ , refl =
    case● (weakenΘ-residual ext₁ r)
          refl
          (weakenΘ-valEnv Γ₁ extₑ θ₁)
          (weakenΘ-term   (compat-skip extₜ) t₁)
          (weakenΘ-valEnv Γ₂ extₑ θ₂)
          (weakenΘ-term   (compat-skip extₜ) t₂)
          (weakenΘ-value  adjust∅Θ v)

weakenΘ-residual ext (var● x ok) =
  case* compatΘ-preserves-varOk● ext ok of λ {
    (x' , ok') -> var● x' ok'
  }

weakenΘ-residual ext (pin r v) =
  case* compatΘ-split ext of λ {
    (_ , _ , ext₁ , ext₂ , refl) ->
       pin (weakenΘ-residual ext₁ r)
           (weakenΘ-value ext₂ v)
  }

-- Converting a value (of multiplicty m) into an entry to be inserted to a value environment.

value-to-multM :
  ∀ {Θ m Ξ A} ->
  all-no-omega (m ×ₘ Ξ) -> Value Θ Ξ A -> mult (λ Θ' Ξ' -> Value Θ' Ξ' A) (M→M₀ m) Θ (m ×ₘ Ξ)
value-to-multM {Θ} {one} ano v = mult-one (subst (λ x -> Value Θ x _) (sym (one×ₘ _)) v )
value-to-multM {Θ} {omega} {Ξ} ano v with all-no-omega-omega×ₘ Ξ ano
... | refl = mult-omega v (×ₘ∅ _)

-- Some specialized versions of subst.

substV : ∀ {Θ Ξ Ξ' A} -> Ξ ≡ Ξ' -> Value Θ Ξ A -> Value Θ Ξ' A
substV refl v = v

substR : ∀ {Θ Ξ Ξ' A} -> Ξ ≡ Ξ' -> Residual Θ Ξ A -> Residual Θ Ξ' A
substR refl E = E


module Where where

{-
id : Set -> Set
id a = a
-}

-- x : (_ : _) -> _
x = id Set3000
  where id = \x -> x

y = False
  where data False : Set where


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

open import Equivalence
open import Types

postulate
  ua : ∀ {ℓ} {A : Set ℓ} {B : Set ℓ} → (A ≡ B) ≃ (A ≃ B)


module Proof where

open import Prelude
open import Lambda
open import Subst
open import Trans
open import Reduction
import Chain

open module C = Chain _≤_ (\x -> refl-≤) (\x y z -> trans-≤)
     renaming (_===_by_ to _<≤>_by_)

data SN {Γ : Ctx}{τ : Type}(t : Term Γ τ) : Set where
  bound : (n : Nat) ->
          ({u : Term Γ τ}(r : t ⟶β* u) -> length r ≤ n) -> SN t

SNˢ : forall {Γ Δ} -> Terms Γ Δ -> Set
SNˢ ts = All² SN ts

-- Let's prove a simple lemma
lem-SN⟶β : {Γ : Ctx}{τ : Type}{t u : Term Γ τ} ->
           SN t -> t ⟶β* u -> SN u
lem-SN⟶β {Γ}{τ}{t}{u}(bound n cap) r = bound n \r' ->
  chain> length r'
     <≤> length r + length r' by lem-≤+L (length r)
     <≤> length (r ▹◃ r')     by refl-≤' (lem-length▹◃ r r')
     <≤> n                    by cap (r ▹◃ r')
  qed

lem-SN-map : {Γ Δ : Ctx}{σ τ : Type}
             (tm : Term Γ σ -> Term Δ τ) ->
             (f  : {t u : Term Γ σ} -> t ⟶β u -> tm t ⟶β tm u)
             {t : Term Γ σ} -> SN (tm t) -> SN t
lem-SN-map tm f (bound n p) = bound n \r ->
  chain> length r
     <≤> length {R = _⟶β_} (map tm f r)
                by refl-≤' (lem-length-map tm f r)
     <≤> n      by p (map tm f r)
  qed

lem-SN•L : {Γ : Ctx}{σ τ : Type}{t : Term Γ (σ ⟶ τ)}{u : Term Γ σ} ->
          SN (t • u) -> SN t
lem-SN•L {u = u} = lem-SN-map (\v -> v • u) •⟶L

lem-SN↑ : {Γ : Ctx}(Δ : Ctx){σ : Type}{t : Term Γ σ} ->
          SN (t ↑ Δ) -> SN t
lem-SN↑ Δ = lem-SN-map (\v -> v ↑ Δ) (↑⟶β Δ)

lem-SN-x : {Γ Δ : Ctx}{σ : Type}(x : Var Γ (Δ ⇒ σ))
           {ts : Terms Γ Δ} -> SNˢ ts -> SN (var x •ˢ ts)
lem-SN-x x ∅²            = bound zero red-var
  where
    red-var : forall {u} -> (r : var x ⟶β* u) -> length r ≤ 0
    red-var ()
lem-SN-x x (_◄²_ {x = t}{xs = ts} snts snt) = {! !}
  where
    sn-xts : SN (var x •ˢ ts)
    sn-xts = lem-SN-x x snts

infix 30 ⟦_⟧ ∋_

⟦_⟧ ∋_ : (τ : Type){Γ : Ctx} -> Term Γ τ -> Set
⟦ ι     ⟧ ∋ t = SN t
⟦ σ ⟶ τ ⟧ ∋ t = forall {Δ}(u : Term (_ ++ Δ) σ) ->
                ⟦ σ ⟧ ∋ u -> ⟦ τ ⟧ ∋ t ↑ Δ • u

mutual

  lem-⟦⟧⊆SN : (σ : Type){Γ : Ctx}{t : Term Γ σ} ->
              ⟦ σ ⟧ ∋ t -> SN t
  lem-⟦⟧⊆SN ι              okt = okt
  lem-⟦⟧⊆SN (σ ⟶ τ) {Γ}{t} okt = lem-SN↑ (ε , σ) sn-t↑
    where
      ih : {Δ : Ctx}{u : Term Δ τ} -> ⟦ τ ⟧ ∋ u -> SN u
      ih = lem-⟦⟧⊆SN τ

      sn• : (Δ : Ctx)(u : Term (Γ ++ Δ) σ) -> ⟦ σ ⟧ ∋ u -> SN (t ↑ Δ • u)
      sn• Δ u h = ih (okt {Δ} u h)

      sn-t↑ : SN (wk t)
      sn-t↑ = lem-SN•L (sn• (ε , σ) vz (lem-⟦⟧ˣ σ vzero ∅²))

  lem-⟦⟧ˣ : (σ : Type){Γ Δ : Ctx}(x : Var Γ (Δ ⇒ σ)){ts : Terms Γ Δ} ->
            SNˢ ts -> ⟦ σ ⟧ ∋ var x •ˢ ts
  lem-⟦⟧ˣ ι       x snts = lem-SN-x x snts
  lem-⟦⟧ˣ (σ ⟶ τ) {Γ}{Δ} x {ts} snts = \u oku -> {! !}
    where
      snts↑ : (Δ : Ctx) -> SNˢ (ts ↑ˢ Δ)
      snts↑ Δ = {! !}

      rem : (Δ : Ctx)(u : Term (Γ ++ Δ) σ) ->
            ⟦ σ ⟧ ∋ u -> ⟦ τ ⟧ ∋ var (x ↑ˣ Δ) •ˢ ts ↑ˢ Δ • u
      rem Δ u oku = lem-⟦⟧ˣ τ (x ↑ˣ Δ) (snts↑ Δ ◄² lem-⟦⟧⊆SN σ oku)

lem-⟦⟧subst : {Γ Δ : Ctx}{τ : Type}(σ : Type)
              {t : Term (Γ , τ) (Δ ⇒ σ)}{u : Term Γ τ}{vs : Terms Γ Δ} ->
              ⟦ σ ⟧ ∋ (t / [ u ]) •ˢ vs -> ⟦ σ ⟧ ∋ (ƛ t) • u •ˢ vs
lem-⟦⟧subst ι         h = {!h !}
lem-⟦⟧subst (σ₁ ⟶ σ₂) h = {! !}