------------------------------------------------------------------------
-- Sums of binary relations
------------------------------------------------------------------------

module Relation.Binary.Sum where

open import Data.Function
open import Data.Sum as Sum
open import Data.Product
open import Data.Unit using (⊤)
open import Data.Empty
open import Relation.Nullary
open import Relation.Binary

infixr 1 _⊎-Rel_ _⊎-<_

------------------------------------------------------------------------
-- Sums of relations

-- Generalised sum.

data ⊎ʳ (P : Set) {a₁ : Set} (_∼₁_ : Rel a₁)
                  {a₂ : Set} (_∼₂_ : Rel a₂)
          : a₁ ⊎ a₂ → a₁ ⊎ a₂ → Set where
  ₁∼₂ : ∀ {x y} (p : P)         → ⊎ʳ P _∼₁_ _∼₂_ (inj₁ x) (inj₂ y)
  ₁∼₁ : ∀ {x y} (x∼₁y : x ∼₁ y) → ⊎ʳ P _∼₁_ _∼₂_ (inj₁ x) (inj₁ y)
  ₂∼₂ : ∀ {x y} (x∼₂y : x ∼₂ y) → ⊎ʳ P _∼₁_ _∼₂_ (inj₂ x) (inj₂ y)

-- Pointwise sum.

_⊎-Rel_ : ∀ {a₁} (_∼₁_ : Rel a₁) →
          ∀ {a₂} (_∼₂_ : Rel a₂) →
          Rel (a₁ ⊎ a₂)
_⊎-Rel_ = ⊎ʳ ⊥

-- All things to the left are smaller than (or equal to, depending on
-- the underlying equality) all things to the right.

_⊎-<_ : ∀ {a₁} (_∼₁_ : Rel a₁) →
        ∀ {a₂} (_∼₂_ : Rel a₂) →
        Rel (a₁ ⊎ a₂)
_⊎-<_ = ⊎ʳ ⊤

------------------------------------------------------------------------
-- Helpers

private

  ₁≁₂ : ∀ {a₁} {∼₁ : Rel a₁} →
        ∀ {a₂} {∼₂ : Rel a₂} →
        ∀ {x y} → ¬ (inj₁ x ⟨ ∼₁ ⊎-Rel ∼₂ ⟩₁ inj₂ y)
  ₁≁₂ (₁∼₂ ())

  drop-inj₁ : ∀ {a₁} {∼₁ : Rel a₁} →
              ∀ {a₂} {∼₂ : Rel a₂} →
              ∀ {P x y} → inj₁ x ⟨ ⊎ʳ P ∼₁ ∼₂ ⟩₁ inj₁ y → ∼₁ x y
  drop-inj₁ (₁∼₁ x∼y) = x∼y

  drop-inj₂ : ∀ {a₁} {∼₁ : Rel a₁} →
              ∀ {a₂} {∼₂ : Rel a₂} →
              ∀ {P x y} → inj₂ x ⟨ ⊎ʳ P ∼₁ ∼₂ ⟩₁ inj₂ y → ∼₂ x y
  drop-inj₂ (₂∼₂ x∼y) = x∼y

------------------------------------------------------------------------
-- Some properties which are preserved by the relation formers above

_⊎-reflexive_ : ∀ {a₁} {≈₁ ∼₁ : Rel a₁} → ≈₁ ⇒ ∼₁ →
                ∀ {a₂} {≈₂ ∼₂ : Rel a₂} → ≈₂ ⇒ ∼₂ →
                ∀ {P} → (≈₁ ⊎-Rel ≈₂) ⇒ (⊎ʳ P ∼₁ ∼₂)
refl₁ ⊎-reflexive refl₂ = refl
  where
  refl : (_ ⊎-Rel _) ⇒ (⊎ʳ _ _ _)
  refl (₁∼₁ x₁≈y₁) = ₁∼₁ (refl₁ x₁≈y₁)
  refl (₂∼₂ x₂≈y₂) = ₂∼₂ (refl₂ x₂≈y₂)
  refl (₁∼₂ ())

_⊎-refl_ : ∀ {a₁} {∼₁ : Rel a₁} → Reflexive ∼₁ →
           ∀ {a₂} {∼₂ : Rel a₂} → Reflexive ∼₂ →
           Reflexive (∼₁ ⊎-Rel ∼₂)
refl₁ ⊎-refl refl₂ = refl
  where
  refl : Reflexive (_ ⊎-Rel _)
  refl {x = inj₁ _} = ₁∼₁ refl₁
  refl {x = inj₂ _} = ₂∼₂ refl₂

_⊎-irreflexive_ : ∀ {a₁} {≈₁ <₁ : Rel a₁} → Irreflexive ≈₁ <₁ →
                  ∀ {a₂} {≈₂ <₂ : Rel a₂} → Irreflexive ≈₂ <₂ →
                  ∀ {P} → Irreflexive (≈₁ ⊎-Rel ≈₂) (⊎ʳ P <₁ <₂)
irrefl₁ ⊎-irreflexive irrefl₂ = irrefl
  where
  irrefl : Irreflexive (_ ⊎-Rel _) (⊎ʳ _ _ _)
  irrefl (₁∼₁ x₁≈y₁) (₁∼₁ x₁<y₁) = irrefl₁ x₁≈y₁ x₁<y₁
  irrefl (₂∼₂ x₂≈y₂) (₂∼₂ x₂<y₂) = irrefl₂ x₂≈y₂ x₂<y₂
  irrefl (₁∼₂ ())    _

_⊎-symmetric_ : ∀ {a₁} {∼₁ : Rel a₁} → Symmetric ∼₁ →
                ∀ {a₂} {∼₂ : Rel a₂} → Symmetric ∼₂ →
                Symmetric (∼₁ ⊎-Rel ∼₂)
sym₁ ⊎-symmetric sym₂ = sym
  where
  sym : Symmetric (_ ⊎-Rel _)
  sym (₁∼₁ x₁∼y₁) = ₁∼₁ (sym₁ x₁∼y₁)
  sym (₂∼₂ x₂∼y₂) = ₂∼₂ (sym₂ x₂∼y₂)
  sym (₁∼₂ ())

_⊎-transitive_ : ∀ {a₁} {∼₁ : Rel a₁} → Transitive ∼₁ →
                 ∀ {a₂} {∼₂ : Rel a₂} → Transitive ∼₂ →
                 ∀ {P} → Transitive (⊎ʳ P ∼₁ ∼₂)
trans₁ ⊎-transitive trans₂ = trans
  where
  trans : Transitive (⊎ʳ _ _ _)
  trans (₁∼₁ x∼y) (₁∼₁ y∼z) = ₁∼₁ (trans₁ x∼y y∼z)
  trans (₂∼₂ x∼y) (₂∼₂ y∼z) = ₂∼₂ (trans₂ x∼y y∼z)
  trans (₁∼₂ p)   (₂∼₂ _)     = ₁∼₂ p
  trans (₁∼₁ _)   (₁∼₂ p)     = ₁∼₂ p

_⊎-antisymmetric_ : ∀ {a₁} {≈₁ ≤₁ : Rel a₁} → Antisymmetric ≈₁ ≤₁ →
                    ∀ {a₂} {≈₂ ≤₂ : Rel a₂} → Antisymmetric ≈₂ ≤₂ →
                    ∀ {P} → Antisymmetric (≈₁ ⊎-Rel ≈₂) (⊎ʳ P ≤₁ ≤₂)
antisym₁ ⊎-antisymmetric antisym₂ = antisym
  where
  antisym : Antisymmetric (_ ⊎-Rel _) (⊎ʳ _ _ _)
  antisym (₁∼₁ x≤y) (₁∼₁ y≤x) = ₁∼₁ (antisym₁ x≤y y≤x)
  antisym (₂∼₂ x≤y) (₂∼₂ y≤x) = ₂∼₂ (antisym₂ x≤y y≤x)
  antisym (₁∼₂ _)   ()

_⊎-asymmetric_ : ∀ {a₁} {<₁ : Rel a₁} → Asymmetric <₁ →
                 ∀ {a₂} {<₂ : Rel a₂} → Asymmetric <₂ →
                 ∀ {P} → Asymmetric (⊎ʳ P <₁ <₂)
asym₁ ⊎-asymmetric asym₂ = asym
  where
  asym : Asymmetric (⊎ʳ _ _ _)
  asym (₁∼₁ x<y) (₁∼₁ y<x) = asym₁ x<y y<x
  asym (₂∼₂ x<y) (₂∼₂ y<x) = asym₂ x<y y<x
  asym (₁∼₂ _)   ()

_⊎-≈-respects₂_ : ∀ {a₁} {≈₁ ∼₁ : Rel a₁} → ∼₁ Respects₂ ≈₁ →
                  ∀ {a₂} {≈₂ ∼₂ : Rel a₂} → ∼₂ Respects₂ ≈₂ →
                  ∀ {P} → (⊎ʳ P ∼₁ ∼₂) Respects₂ (≈₁ ⊎-Rel ≈₂)
_⊎-≈-respects₂_ {≈₁ = ≈₁} {∼₁ = ∼₁} resp₁
                {≈₂ = ≈₂} {∼₂ = ∼₂} resp₂ {P} =
  (λ {_ _ _} → resp¹) ,
  (λ {_ _ _} → resp²)
  where
  resp¹ : ∀ {x} → ((⊎ʳ P ∼₁ ∼₂) x) Respects (≈₁ ⊎-Rel ≈₂)
  resp¹ (₁∼₁ y≈y') (₁∼₁ x∼y) = ₁∼₁ (proj₁ resp₁ y≈y' x∼y)
  resp¹ (₂∼₂ y≈y') (₂∼₂ x∼y) = ₂∼₂ (proj₁ resp₂ y≈y' x∼y)
  resp¹ (₂∼₂ y≈y') (₁∼₂ p)   = (₁∼₂ p)
  resp¹ (₁∼₂ ())   _

  resp² :  ∀ {y}
        → (flip₁ (⊎ʳ P ∼₁ ∼₂) y) Respects (≈₁ ⊎-Rel ≈₂)
  resp² (₁∼₁ x≈x') (₁∼₁ x∼y) = ₁∼₁ (proj₂ resp₁ x≈x' x∼y)
  resp² (₂∼₂ x≈x') (₂∼₂ x∼y) = ₂∼₂ (proj₂ resp₂ x≈x' x∼y)
  resp² (₁∼₁ x≈x') (₁∼₂ p)   = (₁∼₂ p)
  resp² (₁∼₂ ())   _

_⊎-substitutive_ : ∀ {a₁} {∼₁ : Rel a₁} → Substitutive ∼₁ →
                   ∀ {a₂} {∼₂ : Rel a₂} → Substitutive ∼₂ →
                   Substitutive (∼₁ ⊎-Rel ∼₂)
subst₁ ⊎-substitutive subst₂ = subst
  where
  subst : Substitutive (_ ⊎-Rel _)
  subst P (₁∼₁ x∼y) Px = subst₁ (λ z → P (inj₁ z)) x∼y Px
  subst P (₂∼₂ x∼y) Px = subst₂ (λ z → P (inj₂ z)) x∼y Px
  subst P (₁∼₂ ())  Px

⊎-decidable : ∀ {a₁} {∼₁ : Rel a₁} → Decidable ∼₁ →
              ∀ {a₂} {∼₂ : Rel a₂} → Decidable ∼₂ →
              ∀ {P} → (∀ {x y} → Dec (inj₁ x ⟨ ⊎ʳ P ∼₁ ∼₂ ⟩₁ inj₂ y)) →
              Decidable (⊎ʳ P ∼₁ ∼₂)
⊎-decidable {∼₁ = ∼₁} dec₁ {∼₂ = ∼₂} dec₂ {P} dec₁₂ = dec
  where
  dec : Decidable (⊎ʳ P ∼₁ ∼₂)
  dec (inj₁ x) (inj₁ y) with dec₁ x y
  ...                   | yes x∼y = yes (₁∼₁ x∼y)
  ...                   | no  x≁y = no (x≁y ∘ drop-inj₁)
  dec (inj₂ x) (inj₂ y) with dec₂ x y
  ...                   | yes x∼y = yes (₂∼₂ x∼y)
  ...                   | no  x≁y = no (x≁y ∘ drop-inj₂)
  dec (inj₁ x) (inj₂ y) = dec₁₂
  dec (inj₂ x) (inj₁ y) = no (λ())

_⊎-<-total_ : ∀ {a₁} {≤₁ : Rel a₁} → Total ≤₁ →
              ∀ {a₂} {≤₂ : Rel a₂} → Total ≤₂ →
              Total (≤₁ ⊎-< ≤₂)
total₁ ⊎-<-total total₂ = total
  where
  total : Total (_ ⊎-< _)
  total (inj₁ x) (inj₁ y) = Sum.map ₁∼₁ ₁∼₁ $ total₁ x y
  total (inj₂ x) (inj₂ y) = Sum.map ₂∼₂ ₂∼₂ $ total₂ x y
  total (inj₁ x) (inj₂ y) = inj₁ (₁∼₂ _)
  total (inj₂ x) (inj₁ y) = inj₂ (₁∼₂ _)

_⊎-<-trichotomous_ : ∀ {a₁} {≈₁ <₁ : Rel a₁} → Trichotomous ≈₁ <₁ →
                     ∀ {a₂} {≈₂ <₂ : Rel a₂} → Trichotomous ≈₂ <₂ →
                     Trichotomous (≈₁ ⊎-Rel ≈₂) (<₁ ⊎-< <₂)
_⊎-<-trichotomous_ {≈₁ = ≈₁} {<₁ = <₁} tri₁
                   {≈₂ = ≈₂} {<₂ = <₂} tri₂ = tri
  where
  tri : Trichotomous (≈₁ ⊎-Rel ≈₂) (<₁ ⊎-< <₂)
  tri (inj₁ x) (inj₂ y) = tri< (₁∼₂ _) ₁≁₂ (λ())
  tri (inj₂ x) (inj₁ y) = tri> (λ()) (λ()) (₁∼₂ _)
  tri (inj₁ x) (inj₁ y) with tri₁ x y
  ...                   | tri< x<y x≉y x≯y =
    tri< (₁∼₁ x<y)        (x≉y ∘ drop-inj₁) (x≯y ∘ drop-inj₁)
  ...                   | tri≈ x≮y x≈y x≯y =
    tri≈ (x≮y ∘ drop-inj₁) (₁∼₁ x≈y)    (x≯y ∘ drop-inj₁)
  ...                   | tri> x≮y x≉y x>y =
    tri> (x≮y ∘ drop-inj₁) (x≉y ∘ drop-inj₁) (₁∼₁ x>y)
  tri (inj₂ x) (inj₂ y) with tri₂ x y
  ...                   | tri< x<y x≉y x≯y =
    tri< (₂∼₂ x<y)        (x≉y ∘ drop-inj₂) (x≯y ∘ drop-inj₂)
  ...                   | tri≈ x≮y x≈y x≯y =
    tri≈ (x≮y ∘ drop-inj₂) (₂∼₂ x≈y)    (x≯y ∘ drop-inj₂)
  ...                   | tri> x≮y x≉y x>y =
    tri> (x≮y ∘ drop-inj₂) (x≉y ∘ drop-inj₂) (₂∼₂ x>y)

------------------------------------------------------------------------
-- Some collections of properties which are preserved

_⊎-isEquivalence_ : ∀ {a₁} {≈₁ : Rel a₁} → IsEquivalence ≈₁ →
                    ∀ {a₂} {≈₂ : Rel a₂} → IsEquivalence ≈₂ →
                    IsEquivalence (≈₁ ⊎-Rel ≈₂)
eq₁ ⊎-isEquivalence eq₂ = record
  { refl  = refl  eq₁ ⊎-refl        refl  eq₂
  ; sym   = sym   eq₁ ⊎-symmetric   sym   eq₂
  ; trans = trans eq₁ ⊎-transitive  trans eq₂
  }
  where open IsEquivalence

_⊎-isPreorder_ : ∀ {a₁} {≈₁ ∼₁ : Rel a₁} → IsPreorder ≈₁ ∼₁ →
                 ∀ {a₂} {≈₂ ∼₂ : Rel a₂} → IsPreorder ≈₂ ∼₂ →
                 ∀ {P} → IsPreorder (≈₁ ⊎-Rel ≈₂) (⊎ʳ P ∼₁ ∼₂)
pre₁ ⊎-isPreorder pre₂ = record
  { isEquivalence = isEquivalence pre₁ ⊎-isEquivalence
                    isEquivalence pre₂
  ; reflexive     = reflexive pre₁ ⊎-reflexive   reflexive pre₂
  ; trans         = trans     pre₁ ⊎-transitive  trans     pre₂
  ; ∼-resp-≈      = ∼-resp-≈  pre₁ ⊎-≈-respects₂ ∼-resp-≈  pre₂
  }
  where open IsPreorder

_⊎-isDecEquivalence_ : ∀ {a₁} {≈₁ : Rel a₁} → IsDecEquivalence ≈₁ →
                       ∀ {a₂} {≈₂ : Rel a₂} → IsDecEquivalence ≈₂ →
                       IsDecEquivalence (≈₁ ⊎-Rel ≈₂)
eq₁ ⊎-isDecEquivalence eq₂ = record
  { isEquivalence = isEquivalence eq₁ ⊎-isEquivalence
                    isEquivalence eq₂
  ; _≟_           = ⊎-decidable (_≟_ eq₁) (_≟_ eq₂) (no ₁≁₂)
  }
  where open IsDecEquivalence

_⊎-isPartialOrder_ : ∀ {a₁} {≈₁ ≤₁ : Rel a₁} → IsPartialOrder ≈₁ ≤₁ →
                     ∀ {a₂} {≈₂ ≤₂ : Rel a₂} → IsPartialOrder ≈₂ ≤₂ →
                     ∀ {P} → IsPartialOrder (≈₁ ⊎-Rel ≈₂) (⊎ʳ P ≤₁ ≤₂)
po₁ ⊎-isPartialOrder po₂ = record
  { isPreorder = isPreorder po₁ ⊎-isPreorder    isPreorder po₂
  ; antisym    = antisym    po₁ ⊎-antisymmetric antisym    po₂
  }
  where open IsPartialOrder

_⊎-isStrictPartialOrder_ :
  ∀ {a₁} {≈₁ <₁ : Rel a₁} → IsStrictPartialOrder ≈₁ <₁ →
  ∀ {a₂} {≈₂ <₂ : Rel a₂} → IsStrictPartialOrder ≈₂ <₂ →
  ∀ {P} → IsStrictPartialOrder (≈₁ ⊎-Rel ≈₂) (⊎ʳ P <₁ <₂)
spo₁ ⊎-isStrictPartialOrder spo₂ = record
  { isEquivalence = isEquivalence spo₁ ⊎-isEquivalence
                    isEquivalence spo₂
  ; irrefl        = irrefl   spo₁ ⊎-irreflexive irrefl   spo₂
  ; trans         = trans    spo₁ ⊎-transitive  trans    spo₂
  ; <-resp-≈      = <-resp-≈ spo₁ ⊎-≈-respects₂ <-resp-≈ spo₂
  }
  where open IsStrictPartialOrder

_⊎-<-isTotalOrder_ : ∀ {a₁} {≈₁ ≤₁ : Rel a₁} → IsTotalOrder ≈₁ ≤₁ →
                     ∀ {a₂} {≈₂ ≤₂ : Rel a₂} → IsTotalOrder ≈₂ ≤₂ →
                     IsTotalOrder (≈₁ ⊎-Rel ≈₂) (≤₁ ⊎-< ≤₂)
to₁ ⊎-<-isTotalOrder to₂ = record
  { isPartialOrder = isPartialOrder to₁ ⊎-isPartialOrder
                     isPartialOrder to₂
  ; total          = total to₁ ⊎-<-total total to₂
  }
  where open IsTotalOrder

_⊎-<-isDecTotalOrder_ :
  ∀ {a₁} {≈₁ ≤₁ : Rel a₁} → IsDecTotalOrder ≈₁ ≤₁ →
  ∀ {a₂} {≈₂ ≤₂ : Rel a₂} → IsDecTotalOrder ≈₂ ≤₂ →
  IsDecTotalOrder (≈₁ ⊎-Rel ≈₂) (≤₁ ⊎-< ≤₂)
to₁ ⊎-<-isDecTotalOrder to₂ = record
  { isTotalOrder = isTotalOrder to₁ ⊎-<-isTotalOrder isTotalOrder to₂
  ; _≟_          = ⊎-decidable (_≟_  to₁) (_≟_  to₂) (no ₁≁₂)
  ; _≤?_         = ⊎-decidable (_≤?_ to₁) (_≤?_ to₂) (yes (₁∼₂ _))
  }
  where open IsDecTotalOrder

------------------------------------------------------------------------
-- The game can be taken even further...

_⊎-setoid_ : Setoid → Setoid → Setoid
s₁ ⊎-setoid s₂ = record
  { isEquivalence = isEquivalence s₁ ⊎-isEquivalence isEquivalence s₂
  } where open Setoid

_⊎-preorder_ : Preorder → Preorder → Preorder
p₁ ⊎-preorder p₂ = record
  { _∼_          = _∼_        p₁ ⊎-Rel        _∼_        p₂
  ; isPreorder   = isPreorder p₁ ⊎-isPreorder isPreorder p₂
  } where open Preorder

_⊎-decSetoid_ : DecSetoid → DecSetoid → DecSetoid
ds₁ ⊎-decSetoid ds₂ = record
  { isDecEquivalence = isDecEquivalence ds₁ ⊎-isDecEquivalence
                       isDecEquivalence ds₂
  } where open DecSetoid

_⊎-poset_ : Poset → Poset → Poset
po₁ ⊎-poset po₂ = record
  { _≤_            = _≤_ po₁ ⊎-Rel _≤_ po₂
  ; isPartialOrder = isPartialOrder po₁ ⊎-isPartialOrder
                     isPartialOrder po₂
  } where open Poset

_⊎-<-poset_ : Poset → Poset → Poset
po₁ ⊎-<-poset po₂ = record
  { _≤_            = _≤_ po₁ ⊎-< _≤_ po₂
  ; isPartialOrder = isPartialOrder po₁ ⊎-isPartialOrder
                     isPartialOrder po₂
  } where open Poset

_⊎-<-strictPartialOrder_ :
  StrictPartialOrder → StrictPartialOrder → StrictPartialOrder
spo₁ ⊎-<-strictPartialOrder spo₂ = record
  { _<_                  = _<_ spo₁ ⊎-< _<_ spo₂
  ; isStrictPartialOrder = isStrictPartialOrder spo₁
                             ⊎-isStrictPartialOrder
                           isStrictPartialOrder spo₂
  } where open StrictPartialOrder

_⊎-<-totalOrder_ : TotalOrder → TotalOrder → TotalOrder
to₁ ⊎-<-totalOrder to₂ = record
  { isTotalOrder = isTotalOrder to₁ ⊎-<-isTotalOrder isTotalOrder to₂
  } where open TotalOrder

_⊎-<-decTotalOrder_ : DecTotalOrder → DecTotalOrder → DecTotalOrder
to₁ ⊎-<-decTotalOrder to₂ = record
  { isDecTotalOrder = isDecTotalOrder to₁ ⊎-<-isDecTotalOrder
                      isDecTotalOrder to₂
  } where open DecTotalOrder


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.UnivariateList.Poly1-1Poly where

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

open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec renaming ( [] to <> ; _∷_ to _::_)
open import Cubical.Data.Vec.OperationsNat

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Polynomials.UnivariateList.Base renaming (Poly to Poly:)
open import Cubical.Algebra.Polynomials.UnivariateList.Properties
open import Cubical.Algebra.CommRing.Instances.Polynomials.UnivariatePolyList
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly

private variable
  ℓ : Level

module Equiv-Poly1-Poly:
  (Acr@(A , Astr) : CommRing ℓ) where

  private
    PA = PolyCommRing Acr 1
    PAstr = snd PA
    PA: = UnivariatePolyList Acr
    PA:str = snd PA:

  open PolyMod Acr using (ElimProp)
  open PolyModTheory Acr
    using ( prod-Xn ; prod-Xn-sum ; prod-Xn-∷ ; prod-Xn-prod)
    renaming
    (prod-Xn-0P to prod-Xn-0P:)

  open CommRingStr
  open RingTheory

-- Notation P, Q, R... for Poly 1
-- x, y, w... for Poly:
-- a,b,c... for A

-----------------------------------------------------------------------------
-- direct

  trad-base : (v : Vec ℕ 1) → A → Poly: Acr
  trad-base (n :: <>) a = prod-Xn n (a ∷ [])

  trad-base-neutral : (v : Vec ℕ 1) → trad-base v (0r Astr) ≡ []
  trad-base-neutral (n :: <>) = cong (prod-Xn n) drop0 ∙ prod-Xn-0P: n

  trad-base-add : (v : Vec ℕ 1) → (a b : A) → _+_ PA:str (trad-base v a) (trad-base v b) ≡ trad-base v (_+_ Astr a b)
  trad-base-add (n :: <>) a b = prod-Xn-sum n (a ∷ []) (b ∷ [])

  Poly1→Poly: : Poly Acr 1 → Poly: Acr
  Poly1→Poly: = DS-Rec-Set.f _ _ _ _ (is-set PA:str)
                 []
                 trad-base
                 (_+_ PA:str)
                 (+Assoc PA:str)
                 (+IdR PA:str)
                 (+Comm PA:str)
                 trad-base-neutral
                 trad-base-add

  Poly1→Poly:-pres+ : (P Q : Poly Acr 1) → Poly1→Poly: (_+_ PAstr P Q) ≡ _+_ PA:str (Poly1→Poly: P) (Poly1→Poly: Q)
  Poly1→Poly:-pres+ P Q = refl

-----------------------------------------------------------------------------
-- converse

  Poly:→Poly1-int : (n : ℕ) → Poly: Acr → Poly Acr 1
  Poly:→Poly1-int n [] = 0r PAstr
  Poly:→Poly1-int n (a ∷ x) = _+_ PAstr (base (n :: <>) a) (Poly:→Poly1-int (suc n) x)
  Poly:→Poly1-int n (drop0 i) = ((cong (λ X → _+_ PAstr X (0r PAstr)) (base-neutral (n :: <>))) ∙ (+IdR PAstr _)) i

  Poly:→Poly1 : Poly: Acr → Poly Acr 1
  Poly:→Poly1 x = Poly:→Poly1-int 0 x

  Poly:→Poly1-int-pres+ : (x y : Poly: Acr) → (n : ℕ) →
                              Poly:→Poly1-int n (_+_ PA:str x y) ≡ _+_ PAstr (Poly:→Poly1-int n x) (Poly:→Poly1-int n y)
  Poly:→Poly1-int-pres+ = ElimProp _
                           (λ y n → cong (Poly:→Poly1-int n) (+IdL PA:str y) ∙ sym (+IdL PAstr _))
                           (λ a x ind-x → ElimProp _
                                           (λ n → sym (+IdR PAstr (Poly:→Poly1-int n (a ∷ x))))
                                           (λ b y ind-y n → sym (+ShufflePairs (CommRing→Ring PA) _ _ _ _
                                                                ∙ cong₂ (_+_ PAstr) (base-add _ _ _) (sym (ind-x y (suc n)))))
                                           (isPropΠ (λ _ → is-set PAstr _ _)))
                           (isPropΠ2 (λ _ _ → is-set PAstr _ _))

  Poly:→Poly1-pres+ : (x y : Poly: Acr) → Poly:→Poly1 (_+_ PA:str x y) ≡ _+_ PAstr (Poly:→Poly1 x) (Poly:→Poly1 y)
  Poly:→Poly1-pres+ x y = Poly:→Poly1-int-pres+ x y 0

-----------------------------------------------------------------------------
-- section

  e-sect-int : (x : Poly: Acr) → (n : ℕ) → Poly1→Poly: (Poly:→Poly1-int n x) ≡ prod-Xn n x
  e-sect-int = ElimProp _
               (λ n → sym (prod-Xn-0P: n))
               (λ a x ind-x n → cong (λ X → _+_ PA:str (prod-Xn n (a ∷ [])) X) (ind-x (suc n))
                                 ∙ prod-Xn-∷ n a x)
               (isPropΠ (λ _ → is-set PA:str _ _))

  e-sect : (x : Poly: Acr) → Poly1→Poly: (Poly:→Poly1 x) ≡ x
  e-sect x = e-sect-int x 0

-----------------------------------------------------------------------------
-- retraction

  idde : (m n : ℕ) → (a : A) → Poly:→Poly1-int n (prod-Xn m (a ∷ [])) ≡ base ((n +n m) :: <>) a
  idde zero n a = +IdR PAstr (base (n :: <>) a)
                  ∙ cong (λ X → base (X :: <>) a) (sym (+-zero n))
  idde (suc m) n a = cong (λ X → _+_ PAstr X (Poly:→Poly1-int (suc n) (prod-Xn m (a ∷ [])))) (base-neutral (n :: <>))
                     ∙ +IdL PAstr (Poly:→Poly1-int (suc n) (prod-Xn m (a ∷ [])))
                     ∙ idde m (suc n) a
                     ∙ cong (λ X → base (X :: <>) a) (sym (+-suc n m))

  idde-v : (v : Vec ℕ 1) → (a : A) → Poly:→Poly1-int 0 (trad-base v a) ≡ base v a
  idde-v (n :: <>) a = (idde n 0 a)

  e-retr : (P : Poly Acr 1) → Poly:→Poly1 (Poly1→Poly: P) ≡ P
  e-retr = DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
           refl
           (λ v a → idde-v v a)
           λ {P Q} ind-P ind-Q → cong Poly:→Poly1 (Poly1→Poly:-pres+ P Q)
                                 ∙ Poly:→Poly1-pres+ (Poly1→Poly: P) (Poly1→Poly: Q)
                                 ∙ cong₂ (_+_ PAstr) ind-P ind-Q

-----------------------------------------------------------------------------
-- Ring morphism

  Poly1→Poly:-pres1 : Poly1→Poly: (1r PAstr) ≡ 1r PA:str
  Poly1→Poly:-pres1 = refl

  trad-base-prod : (v v' : Vec ℕ 1) → (a a' : A) → trad-base (v +n-vec v') (Astr ._·_ a a') ≡
                                                      _·_ PA:str (trad-base v a) (trad-base v' a')
  trad-base-prod (k :: <>) (l :: <>) a a' = sym ((prod-Xn-prod k l [ a ]  [ a' ]) ∙ cong (λ X → prod-Xn (k +n l) [ X ]) (+IdR Astr _))

  Poly1→Poly:-pres· : (P Q : Poly Acr 1) → Poly1→Poly: (_·_ PAstr P Q) ≡ _·_ PA:str (Poly1→Poly: P) (Poly1→Poly: Q)
  Poly1→Poly:-pres· = DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ λ _ → is-set PA:str _ _)
                        (λ Q → refl)
                        (λ v a → DS-Ind-Prop.f _ _ _ _ (λ _ → is-set PA:str _ _)
                                  (sym (0RightAnnihilates (CommRing→Ring PA:) _))
                                  (λ v' a' → trad-base-prod v v' a a')
                                  λ {U V} ind-U ind-V → (cong₂ (_+_ PA:str) ind-U ind-V)
                                                          ∙ sym (·DistR+ PA:str _ _ _))
                        λ {U V} ind-U ind-V Q → (cong₂ (_+_ PA:str) (ind-U Q) (ind-V Q))
                                                 ∙ sym (·DistL+ PA:str _ _ _)

-----------------------------------------------------------------------------
-- Ring Equivalences

module _ (Acr : CommRing ℓ) where

  open Equiv-Poly1-Poly: Acr

  CRE-Poly1-Poly: : CommRingEquiv (PolyCommRing Acr 1) (UnivariatePolyList Acr)
  fst CRE-Poly1-Poly: = isoToEquiv is
    where
    is : Iso _ _
    Iso.fun is = Poly1→Poly:
    Iso.inv is = Poly:→Poly1
    Iso.rightInv is = e-sect
    Iso.leftInv is = e-retr
  snd CRE-Poly1-Poly: = makeIsRingHom
                        Poly1→Poly:-pres1
                        Poly1→Poly:-pres+
                        Poly1→Poly:-pres·


{-# OPTIONS --safe #-}
module JVM.Syntax.Values where

open import Data.Bool
open import Data.Integer.Base
open import Relation.Unary
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax

open import JVM.Types

data Const : Ty → Set where
  null : ∀ {c} → Const (ref c)
  num  : ℤ     → Const int
  bool : Bool  → Const boolean


module Data.Either.Multi where

open import Data
open import Data.Either
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Data.Tuple.RaiseTypeᵣ
open import Data.Tuple.RaiseTypeᵣ.Functions
open import Data.Tuple using (_⨯_ ; _,_)
open import Function.Multi
open import Function.Multi.Functions
import      Lvl
import      Lvl.MultiFunctions as Lvl
open import Numeral.Finite
open import Numeral.Natural
open import Type

Alt : (n : ℕ) → ∀{ℓ𝓈} → TypesOfTypes{n}(ℓ𝓈) ⇉ Type{Lvl.⨆(ℓ𝓈)}
Alt(n) = binaryTypeRelator₊(n)(_‖_)(Empty)

pattern alt₀   x = _‖_.Left x
pattern alt₁   x = _‖_.Right(alt₀ x)
pattern alt₂   x = _‖_.Right(alt₁ x)
pattern alt₃   x = _‖_.Right(alt₂ x)
pattern alt₄   x = _‖_.Right(alt₃ x)
pattern alt₅   x = _‖_.Right(alt₄ x)
pattern alt₆   x = _‖_.Right(alt₅ x)
pattern alt₇   x = _‖_.Right(alt₆ x)
pattern alt₈   x = _‖_.Right(alt₇ x)
pattern alt₉   x = _‖_.Right(alt₈ x)
pattern alt₁,₂ x = _‖_.Right(x)
pattern alt₂,₃ x = _‖_.Right(alt₁,₂ x)
pattern alt₃,₄ x = _‖_.Right(alt₂,₃ x)
pattern alt₄,₅ x = _‖_.Right(alt₃,₄ x)
pattern alt₅,₆ x = _‖_.Right(alt₄,₅ x)
pattern alt₆,₇ x = _‖_.Right(alt₅,₆ x)
pattern alt₇,₈ x = _‖_.Right(alt₆,₇ x)
pattern alt₈,₉ x = _‖_.Right(alt₇,₈ x)

{-
-- TODO: Move or generalize uncurry
uncurryTypes : (n : ℕ) → ∀{ℓ𝓈}{ℓ}{B : Type{ℓ}} → (TypesOfTypes{𝐒(n)}(ℓ𝓈) ⇉ B) → (Types(ℓ𝓈) → B)
uncurryTypes(𝟎)    f          = f
uncurryTypes(𝐒(n)) f (x , xs) = uncurryTypes(n) (f(x)) xs

-- TODO: Problem with the type. Not normalizing correctly
alt : ∀{n}{ℓ𝓈}{As : Types(ℓ𝓈)} → (i : 𝕟(𝐒(n))) → (index i As) → uncurryTypes(n) (Alt(𝐒(n)){ℓ𝓈}) As
alt {0}       𝟎     x = x
alt {1}       𝟎     x = Left  x
alt {1}       (𝐒 𝟎) x = Right x
alt {𝐒(𝐒(n))} 𝟎     x = {!Left x!}
alt {𝐒(𝐒(n))} (𝐒 i) x = {!Right(alt {𝐒(n)} i x)!}
-}


data D : Set → Set1 where
  c : (A B : Set) → D (A → B)

test : (X : Set) → D X → Set
test .(A → B) (c A B) = A

-- this should crash Epic as long as A is considered forced in constructor c


open import Level using () renaming (zero to ℓ₀)
open import Relation.Binary using (DecSetoid)

module Bidir (A : DecSetoid ℓ₀ ℓ₀) where

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)
import Level
import Category.Monad
import Category.Functor
open import Data.Maybe using (Maybe ; nothing ; just ; maybe′ ; drop-just) renaming (setoid to MaybeSetoid ; Eq to MaybeEq)
open Category.Monad.RawMonad {Level.zero} Data.Maybe.monad using (_>>=_)
open Category.Functor.RawFunctor {Level.zero} Data.Maybe.functor using (_<$>_)
open import Data.List using (List)
open import Data.List.All using (All)
open import Data.Vec using (Vec ; [] ; _∷_ ; toList ; map ; allFin) renaming (lookup to lookupVec)
open import Data.Vec.Equality using () renaming (module Equality to VecEq)
open import Data.Vec.Properties using (lookup∘tabulate ; map-cong ; map-∘ ; map-lookup-allFin)
open import Data.Product using (∃ ; _×_ ; _,_ ; proj₁ ; proj₂)
open import Function using (id ; _∘_ ; flip)
open import Relation.Binary.Core using (refl ; _≡_)
open import Relation.Binary.Indexed using (_at_) renaming (Setoid to ISetoid)
open import Relation.Binary.PropositionalEquality using (cong ; sym ; inspect ; [_] ; trans ; cong₂ ; decSetoid ; module ≡-Reasoning) renaming (setoid to EqSetoid)
open import Relation.Binary using (Setoid ; module Setoid ; module DecSetoid)
import Relation.Binary.EqReasoning as EqR

open import Structures using (Functor ; IsFunctor ; Shaped ; module Shaped)
open import Instances using (MaybeFunctor ; ShapedISetoid)
import GetTypes
open GetTypes.PartialShapeShape using (Get ; module Get)
open import Generic using (mapMV ; mapMV-cong ; mapMV-purity ; sequenceV ; VecISetoid ; just-injective)
open import FinMap
import CheckInsert
open CheckInsert A
import BFF
open BFF.PartialShapeBFF A using (assoc ; enumerate ; denumerate ; bff)
open Setoid using () renaming (_≈_ to _∋_≈_)
open module A = DecSetoid A using (Carrier) renaming (_≟_ to deq)

lemma-1 : {m n : ℕ} → (f : Fin n → Carrier) → (is : Vec (Fin n) m) → assoc is (map f is) ≡ just (restrict f is)
lemma-1 f []        = refl
lemma-1 f (i ∷ is′) = begin
  (assoc is′ (map f is′) >>= checkInsert i (f i))
    ≡⟨ cong (λ m → m >>= checkInsert i (f i)) (lemma-1 f is′) ⟩
  checkInsert i (f i) (restrict f is′)
    ≡⟨ lemma-checkInsert-restrict f i is′ ⟩
  just (restrict f (i ∷ is′)) ∎
  where open ≡-Reasoning

lemma-lookupM-checkInserted : {n : ℕ} → (i : Fin n) → (x : Carrier) → (h : FinMapMaybe n Carrier) → {h' : FinMapMaybe n Carrier} → checkInsert i x h ≡ just h' → MaybeSetoid A.setoid ∋ lookupM i h' ≈ just x
lemma-lookupM-checkInserted i x h p with checkInsert i x h | insertionresult i x h
lemma-lookupM-checkInserted i x h refl | ._ | same x' x≈x' pl = begin
  lookupM i h
    ≡⟨ pl ⟩
  just x'
    ≈⟨ MaybeEq.just (Setoid.sym A.setoid x≈x') ⟩
  just x ∎
  where open EqR (MaybeSetoid A.setoid)
lemma-lookupM-checkInserted i x h refl | ._ | new _ = Setoid.reflexive (MaybeSetoid A.setoid) (lemma-lookupM-insert i x h)
lemma-lookupM-checkInserted i x h () | ._ | wrong _ _ _

_in-domain-of_ : {m n : ℕ} {A : Set} → (is : Vec (Fin m) n) → (FinMapMaybe m A) → Set
_in-domain-of_ is h = All (λ i → ∃ λ x → lookupM i h ≡ just x) (toList is)

lemma-assoc-domain : {m n : ℕ} → (is : Vec (Fin n) m) → (xs : Vec Carrier m) → {h : FinMapMaybe n Carrier} → assoc is xs ≡ just h → is in-domain-of h
lemma-assoc-domain []         []         ph = Data.List.All.[]
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') ph with assoc is' xs' | inspect (assoc is') xs'
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') () | nothing | [ ph' ]
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') ph | just h' | [ ph' ] with checkInsert i' x' h' | inspect (checkInsert i' x') h' | insertionresult i' x' h'
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') refl | just h | [ ph' ] | ._ | _ | same x _ pl = All._∷_ (x , pl) (lemma-assoc-domain is' xs' ph')
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') refl | just h' | [ ph' ] | ._ | [ cI≡ ] | new _ = All._∷_
  (x' , lemma-lookupM-insert i' x' h')
  (Data.List.All.map
    (λ {i} p → proj₁ p , lemma-lookupM-checkInsert i i' h' (proj₂ p) x' cI≡)
    (lemma-assoc-domain is' xs' ph'))
lemma-assoc-domain (i' ∷ is') (x' ∷ xs') () | just h' | [ ph' ] | ._ | _ | wrong _ _ _

lemma-map-lookupM-assoc : {m : ℕ} → (i : Fin m) → (x : Carrier) → (h : FinMapMaybe m Carrier) → {h' : FinMapMaybe m Carrier} → checkInsert i x h ≡ just h' → {n : ℕ} → (js : Vec (Fin m) n) → js in-domain-of h → map (flip lookupM h') js ≡ map (flip lookupM h) js
lemma-map-lookupM-assoc i x h ph [] pj = refl
lemma-map-lookupM-assoc i x h ph (j ∷ js) (Data.List.All._∷_ (x' , pl) pj) = cong₂ _∷_
  (trans (lemma-lookupM-checkInsert j i h pl x ph) (sym pl))
  (lemma-map-lookupM-assoc i x h ph js pj)

lemma-2 : {m n : ℕ} → (is : Vec (Fin n) m) → (v : Vec Carrier m) → (h : FinMapMaybe n Carrier) → assoc is v ≡ just h → VecISetoid (MaybeSetoid A.setoid) at _ ∋ map (flip lookupM h) is ≈ map just v
lemma-2 []       []       h p = ISetoid.refl (VecISetoid (MaybeSetoid A.setoid))
lemma-2 (i ∷ is) (x ∷ xs) h p with assoc is xs | inspect (assoc is) xs
lemma-2 (i ∷ is) (x ∷ xs) h () | nothing | _
lemma-2 (i ∷ is) (x ∷ xs) h p | just h' | [ ir ] = begin
  lookupM i h ∷ map (flip lookupM h) is
    ≈⟨ VecEq._∷-cong_ (lemma-lookupM-checkInserted i x h' p) (ISetoid.refl (VecISetoid (MaybeSetoid A.setoid))) ⟩
  just x ∷ map (flip lookupM h) is
    ≡⟨  cong (_∷_ (just x)) (lemma-map-lookupM-assoc i x h' p is (lemma-assoc-domain is xs ir)) ⟩
  just x ∷ map (flip lookupM h') is
    ≈⟨ VecEq._∷-cong_ (Setoid.refl (MaybeSetoid A.setoid)) (lemma-2 is xs h' ir) ⟩
  just x ∷ map just xs ∎
  where open EqR (VecISetoid (MaybeSetoid A.setoid) at _)

lemma-fmap-denumerate-enumerate : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → {α : Set} {s : S} → (c : C α s) → Shaped.fmap ShapeT (denumerate ShapeT c) (enumerate ShapeT s) ≡ c
lemma-fmap-denumerate-enumerate {S} {C} ShapeT {s = s} c = begin
  fmap (denumerate ShapeT c) (fill s (allFin (arity s)))
    ≡⟨ fill-fmap (denumerate ShapeT c) s (allFin (arity s)) ⟩
  fill s (map (flip lookupVec (content c)) (allFin (arity s)))
    ≡⟨ cong (fill s) (map-lookup-allFin (content c)) ⟩
  fill s (content c)
    ≡⟨ content-fill c ⟩
  c ∎
  where open ≡-Reasoning
        open Shaped ShapeT

theorem-1 : (G : Get) → {i : Get.I G} → (s : Get.SourceContainer G Carrier (Get.gl₁ G i)) → bff G i s (Get.get G s) ≡ just (Get.fmapS G just s)
theorem-1 G {i} s = begin
  bff G i s (get s)
    ≡⟨ cong (bff G i s ∘ get) (sym (lemma-fmap-denumerate-enumerate SourceShapeT s)) ⟩
  bff G i s (get (fmapS f t))
    ≡⟨ cong (bff G i s) (free-theorem f t) ⟩
  bff G i s (fmapV f (get t))
    ≡⟨ refl ⟩
  h′↦r <$> (h↦h′ <$> (assoc (Shaped.content ViewShapeT (get t)) (Shaped.content ViewShapeT (fmapV f (get t)))))
    ≡⟨ cong (_<$>_ h′↦r ∘ _<$>_ h↦h′ ∘ assoc (Shaped.content ViewShapeT (get t))) (Shaped.fmap-content ViewShapeT f (get t)) ⟩
  h′↦r <$> (h↦h′ <$> (assoc (Shaped.content ViewShapeT (get t)) (map f (Shaped.content ViewShapeT (get t)))))
    ≡⟨ cong (_<$>_ h′↦r ∘ _<$>_ h↦h′) (lemma-1 f (Shaped.content ViewShapeT (get t))) ⟩
  (Maybe.just ∘ h′↦r ∘ h↦h′) (restrict f (Shaped.content ViewShapeT (get t)))
    ≡⟨ cong just (begin
      h′↦r (union (restrict f (Shaped.content ViewShapeT (get t))) (reshape g′ (Shaped.arity SourceShapeT (gl₁ i))))
        ≡⟨ cong (h′↦r ∘ union (restrict f (Shaped.content ViewShapeT (get t)))) (lemma-reshape-id g′) ⟩
      h′↦r (union (restrict f (Shaped.content ViewShapeT (get t))) g′)
        ≡⟨ cong h′↦r (lemma-disjoint-union f (Shaped.content ViewShapeT (get t))) ⟩
      h′↦r (fromFunc f)
        ≡⟨ refl ⟩
      fmapS (flip lookupM (fromFunc f)) t
        ≡⟨ IsFunctor.cong (Shaped.isFunctor SourceShapeT (gl₁ i)) (lemma-lookupM-fromFunc f) t ⟩
      fmapS (Maybe.just ∘ f) t
        ≡⟨ IsFunctor.composition (Shaped.isFunctor SourceShapeT (gl₁ i)) just f t ⟩
      fmapS just (fmapS f t)
        ≡⟨ cong (fmapS just) (lemma-fmap-denumerate-enumerate SourceShapeT s) ⟩
      fmapS just s ∎) ⟩ _ ∎
    where open ≡-Reasoning
          open Get G
          t    = enumerate SourceShapeT (gl₁ i)
          f    = denumerate SourceShapeT s
          g′   = delete-many (Shaped.content ViewShapeT (get t)) (fromFunc f)
          h↦h′ = flip union (reshape g′ (Shaped.arity SourceShapeT (gl₁ i)))
          h′↦r = (λ f′ → fmapS f′ t) ∘ flip lookupM

lemma-<$>-just : {A B : Set} {f : A → B} {b : B} (ma : Maybe A) → f <$> ma ≡ just b → ∃ λ a → ma ≡ just a
lemma-<$>-just (just x) f<$>ma≡just-b = x , refl
lemma-<$>-just nothing  ()

lemma-union-not-used : {n : ℕ} → {A : Set} → (h h′ : FinMapMaybe n A) → (i : Fin n) → ∃ (λ x → lookupM i h ≡ just x) → lookupM i (union h h′) ≡ lookupM i h
lemma-union-not-used h h′ i (x , px) = begin
  lookupM i (union h h′)
    ≡⟨ lookup∘tabulate (λ j → maybe′ just (lookupM j h′) (lookupM j h)) i ⟩
  maybe′ just (lookupM i h′) (lookupM i h)
    ≡⟨ cong (maybe′ just (lookupM i h′)) px ⟩
  maybe′ just (lookupM i h′) (just x)
    ≡⟨ sym px ⟩
  lookupM i h ∎
  where open ≡-Reasoning

lemma->>=-just : {A B : Set} (ma : Maybe A) {f : A → Maybe B} {b : B} → (ma >>= f) ≡ just b → ∃ λ a → ma ≡ just a
lemma->>=-just (just a) p = a , refl
lemma->>=-just nothing  ()

lemma-just-sequenceV : {A : Set} {n : ℕ} → (v : Vec A n) → sequenceV (map just v) ≡ just v
lemma-just-sequenceV []       = refl
lemma-just-sequenceV (x ∷ xs) = cong (_<$>_ (_∷_ x)) (lemma-just-sequenceV xs)

lemma-just-sequence : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → {A : Set} {s : S} → (c : C A s) → Shaped.sequence ShapeT (Shaped.fmap ShapeT just c) ≡ just c
lemma-just-sequence ShapeT {s = s} c = begin
  fill s <$> sequenceV (content (fmap just c))
    ≡⟨ cong (_<$>_ (fill s) ∘ sequenceV) (fmap-content just c) ⟩
  fill s <$> sequenceV (map just (content c))
    ≡⟨ cong (_<$>_ (fill s)) (lemma-just-sequenceV (content c)) ⟩
  fill s <$> just (content c)
    ≡⟨ cong just (content-fill c) ⟩
  just c ∎
  where open ≡-Reasoning
        open Shaped ShapeT

lemma-sequenceV-successful : {A : Set} {n : ℕ} → (v : Vec (Maybe A) n) → {r : Vec A n} → sequenceV v ≡ just r → v ≡ map just r
lemma-sequenceV-successful []             {r = []}       p = refl
lemma-sequenceV-successful (just x ∷ xs)                 p with sequenceV xs | inspect sequenceV xs
lemma-sequenceV-successful (just x ∷ xs)                 () | nothing | _
lemma-sequenceV-successful (just x ∷ xs)  {r = .x ∷ .ys} refl  | just ys | [ p′ ] = cong (_∷_ (just x)) (lemma-sequenceV-successful xs p′)
lemma-sequenceV-successful (nothing ∷ xs)                ()

lemma-sequence-successful : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → {A : Set} {s : S} → (c : C (Maybe A) s) → {r : C A s} → Shaped.sequence ShapeT c ≡ just r → c ≡ Shaped.fmap ShapeT just r
lemma-sequence-successful ShapeT {s = s} c {r} p = just-injective (sym (begin
  fill s <$> (map just <$> (content <$> just r))
    ≡⟨ cong (_<$>_ (fill s) ∘ _<$>_ (map just)) (begin
      content <$> just r
        ≡⟨ cong (_<$>_ content) (sym p) ⟩
      content <$> (fill s <$> sequenceV (content c))
        ≡⟨ sym (Functor.composition MaybeFunctor content (fill s) (sequenceV (content c))) ⟩
      content ∘ fill s <$> sequenceV (content c)
        ≡⟨ Functor.cong MaybeFunctor (fill-content s) (sequenceV (content c)) ⟩
      id <$> sequenceV (content c)
        ≡⟨ Functor.identity MaybeFunctor (sequenceV (content c)) ⟩
      sequenceV (content c)
        ≡⟨ cong sequenceV (lemma-sequenceV-successful (content c) (proj₂ wp)) ⟩
      sequenceV (map just (proj₁ wp))
        ≡⟨ lemma-just-sequenceV (proj₁ wp) ⟩
      just (proj₁ (lemma-<$>-just (sequenceV (content c)) p)) ∎) ⟩
  fill s <$> (map just <$> just (proj₁ (lemma-<$>-just (sequenceV (content c)) p)))
    ≡⟨ cong (_<$>_ (fill s) ∘ just) (sym (lemma-sequenceV-successful (content c) (proj₂ wp))) ⟩
  fill s <$> just (content c)
    ≡⟨ cong just (content-fill c) ⟩
  just c ∎))
  where open ≡-Reasoning
        open Shaped ShapeT
        wp = lemma-<$>-just (sequenceV (content c)) p

module _ (G : Get) where
  open ≡-Reasoning
  open Get G
  open Shaped SourceShapeT using () renaming (sequence to sequenceSource)
  open Shaped ViewShapeT using () renaming (sequence to sequenceView)

  lemma-get-sequence : {A : Set} → {i : I} {v : SourceContainer (Maybe A) (gl₁ i)} {r : SourceContainer A (gl₁ i)} → sequenceSource v ≡ just r → get <$> sequenceSource v ≡ sequenceView (get v)
  lemma-get-sequence {v = v} {r = r} p = begin
    get <$> sequenceSource v
      ≡⟨ cong (_<$>_ get ∘ sequenceSource) (lemma-sequence-successful SourceShapeT v p) ⟩
    get <$> sequenceSource (fmapS just r)
      ≡⟨ cong (_<$>_ get) (lemma-just-sequence SourceShapeT r) ⟩
    get <$> just r
      ≡⟨ sym (lemma-just-sequence ViewShapeT (get r)) ⟩
    sequenceView (fmapV just (get r))
      ≡⟨ cong sequenceView (sym (free-theorem just r)) ⟩
    sequenceView (get (fmapS just r))
      ≡⟨ cong (sequenceView ∘ get) (sym (lemma-sequence-successful SourceShapeT v p)) ⟩
    sequenceView (get v) ∎

sequenceV-cong : {S : Setoid ℓ₀ ℓ₀} {n : ℕ} {m₁ m₂ : Setoid.Carrier (VecISetoid (MaybeSetoid S) at n)} → VecISetoid (MaybeSetoid S) at _ ∋ m₁ ≈ m₂ → MaybeSetoid (VecISetoid S at n) ∋ sequenceV m₁ ≈ sequenceV m₂
sequenceV-cong {S}                                       VecEq.[]-cong = Setoid.refl (MaybeSetoid (VecISetoid S at _))
sequenceV-cong {S} {m₁ = just x ∷ xs} {m₂ = just y ∷ ys} (VecEq._∷-cong_ (just x≈y) xs≈ys) with sequenceV xs | sequenceV ys | sequenceV-cong xs≈ys
sequenceV-cong {S} {m₁ = just x ∷ xs} {m₂ = just y ∷ ys} (VecEq._∷-cong_ (just x≈y) xs≈ys) | just sxs | just sys | just p = MaybeEq.just (VecEq._∷-cong_ x≈y p)
sequenceV-cong {S} {m₁ = just x ∷ xs} {m₂ = just y ∷ ys} (VecEq._∷-cong_ (just x≈y) xs≈ys) | nothing | just sys | ()
sequenceV-cong {S} {m₁ = just x ∷ xs} {m₂ = just y ∷ ys} (VecEq._∷-cong_ (just x≈y) xs≈ys) | just sxs | nothing | ()
sequenceV-cong {S} {m₁ = just x ∷ xs} {m₂ = just y ∷ ys} (VecEq._∷-cong_ (just x≈y) xs≈ys) | nothing | nothing | nothing = Setoid.refl (MaybeSetoid (VecISetoid S at _))
sequenceV-cong {S}                                       (VecEq._∷-cong_ nothing xs≈ys) = Setoid.refl (MaybeSetoid (VecISetoid S at _))

sequence-cong : {S : Set} {C : Set → S → Set} → (ShapeT : Shaped S C) → (α : Setoid ℓ₀ ℓ₀) → {s : S} {x y : C (Maybe (Setoid.Carrier α)) s} → ShapedISetoid (EqSetoid S) ShapeT (MaybeSetoid α) at _ ∋ x ≈ y → MaybeSetoid (ShapedISetoid (EqSetoid S) ShapeT α at _) ∋ Shaped.sequence ShapeT x ≈ Shaped.sequence ShapeT y
sequence-cong ShapeT α {x = x} {y = y} (shape≈ , content≈) with sequenceV (Shaped.content ShapeT x) | sequenceV (Shaped.content ShapeT y) | sequenceV-cong content≈
sequence-cong ShapeT α {s} (shape≈ , content≈) | .(just x) | .(just y) | just {x} {y} x≈y = just (refl , (begin
  content (fill s x)
    ≡⟨ fill-content s x ⟩
  x
    ≈⟨ x≈y ⟩
  y
    ≡⟨ sym (fill-content s y) ⟩
  content (fill s y) ∎))
  where open EqR (VecISetoid α at _)
        open Shaped ShapeT
sequence-cong ShapeT α (shape≈ , content≈) | .nothing  | .nothing  | nothing = nothing

module _ (G : Get) where
  open Get G
  open Shaped SourceShapeT using () renaming (arity to arityS)
  open Shaped ViewShapeT using () renaming (content to contentV)

  theorem-2 : {i : I} → (j : I) → (s : SourceContainer Carrier (gl₁ i)) → (v : ViewContainer Carrier (gl₂ j)) → (u : SourceContainer (Maybe Carrier) (gl₁ j)) → bff G j s v ≡ just u → ShapedISetoid (EqSetoid _) ViewShapeT (MaybeSetoid A.setoid) at _ ∋ get u ≈ Get.fmapV G just v
  theorem-2 {i} j s v u p with lemma-<$>-just ((flip union (reshape (delete-many (contentV (get (enumerate SourceShapeT (gl₁ i)))) (fromFunc (denumerate SourceShapeT s))) (arityS (gl₁ j)))) <$> assoc (contentV (get (enumerate SourceShapeT (gl₁ j)))) (contentV v)) p
  theorem-2 {i} j s v u p | h′ , ph′ with lemma-<$>-just (assoc (contentV (get (enumerate SourceShapeT (gl₁ j)))) (contentV v)) ph′
  theorem-2 {i} j s v u p | h′ , ph′ | h , ph = refl , (begin
    contentV (get u)
      ≡⟨ cong contentV (just-injective (trans (cong (_<$>_ get) (sym p))
                                              (cong (_<$>_ get ∘ _<$>_ h′↦r ∘ _<$>_ h↦h′) ph))) ⟩
    contentV (get (h′↦r (h↦h′ h)))
      ≡⟨ refl ⟩
    contentV (get (fmapS (flip lookupM (h↦h′ h)) t))
      ≡⟨ cong contentV (free-theorem (flip lookupM (h↦h′ h)) t) ⟩
    contentV (fmapV (flip lookupM (h↦h′ h)) (get t))
      ≡⟨ Shaped.fmap-content ViewShapeT (flip lookupM (h↦h′ h)) (get t) ⟩
    map (flip lookupM (h↦h′ h)) (contentV (get t))
      ≡⟨ lemma-exchange-maps (lemma-union-not-used h (reshape g′ (arityS (gl₁ j)))) (lemma-assoc-domain (contentV (get t)) (contentV v) ph) ⟩
    map (flip lookupM h) (contentV (get t))
      ≈⟨ lemma-2 (contentV (get t)) (contentV v) h ph ⟩
    map just (contentV v)
      ≡⟨ sym (Shaped.fmap-content ViewShapeT just v) ⟩
    contentV (fmapV just v) ∎)
      where open EqR (VecISetoid (MaybeSetoid A.setoid) at _)
            s′   = enumerate SourceShapeT (gl₁ i)
            g    = fromFunc (denumerate SourceShapeT s)
            g′   = delete-many (contentV (get s′)) g
            t    = enumerate SourceShapeT (gl₁ j)
            h↦h′ = flip union (reshape g′ (arityS (gl₁ j)))
            h′↦r = (λ f → fmapS f t) ∘ flip lookupM

module _ (G : Get) where
  open Get G

  theorem-2′ : {i : I} → (j : I) → (s : SourceContainer Carrier (gl₁ i)) → (v : ViewContainer Carrier (gl₂ j)) → (u : SourceContainer Carrier (gl₁ j)) → bff G j s v ≡ just (Get.fmapS G just u) → ShapedISetoid (EqSetoid _) ViewShapeT A.setoid at _ ∋ get u ≈ v
  theorem-2′ j s v u p = drop-just (begin
    get <$> just u
      ≡⟨ cong (_<$>_ get) (sym (lemma-just-sequence SourceShapeT u)) ⟩
    get <$> Shaped.sequence SourceShapeT (fmapS just u)
      ≡⟨ lemma-get-sequence G (lemma-just-sequence SourceShapeT u) ⟩
    Shaped.sequence ViewShapeT (get (fmapS just u))
      ≈⟨ sequence-cong ViewShapeT A.setoid (theorem-2 G j s v (fmapS just u) p) ⟩
    Shaped.sequence ViewShapeT (fmapV just v)
      ≡⟨ lemma-just-sequence ViewShapeT v ⟩
    just v ∎)
    where open EqR (MaybeSetoid (ShapedISetoid (EqSetoid _) ViewShapeT A.setoid at _))


module Types where

import Level
open import Data.Unit as Unit renaming (tt to ∗)
open import Data.List as List
open import Categories.Category using (Category)
open import Function

open import Relation.Binary.PropositionalEquality as PE hiding ([_]; subst)
open import Relation.Binary using (module IsEquivalence; Setoid; module Setoid)
open ≡-Reasoning

Kind = ⊤
import Common.Context Kind as Context
open import Common.Context Kind
  using (Ctx; Var; zero; ctx-cat; ctx-bin-coproducts; _≅V_; ≅V-setoid; Vrefl; Vsym; Vtrans)
  renaming (succ to succ′)
open import Categories.Object.BinaryCoproducts ctx-cat
open BinaryCoproducts ctx-bin-coproducts

postulate
  η-≡ : {A : Set} {B : A → Set}
         {f₁ : (x : A) → B x}{f₂ : (y : A) → B y} →
         ((x : A) → f₁ x ≡ f₂ x) → f₁ ≡ f₂

TyCtx = Ctx
TyVar : Ctx → Set
TyVar Γ = Var Γ ∗
succ : ∀{Γ} (x : TyVar Γ) → TyVar (∗ ∷ Γ)
succ = Context.succ ∗

open Categories.Category.Category ctx-cat
  renaming ( _⇒_ to _▹_
           ; _≡_ to _≈_
           ; _∘_ to _●_
           ; id  to ctx-id
           )

-- | Type syntax
data Type (Γ : TyCtx) : Set where
  var  : (x : TyVar Γ)                     → Type Γ
  _⊕_  : (t₁ : Type Γ)       (t₂ : Type Γ) → Type Γ
  μ    : (t : Type (_ ∷ Γ))                → Type Γ
  _⊗_  : (t₁ : Type Γ)       (t₂ : Type Γ) → Type Γ
  _⇒_  : (t₁ : Type [])      (t₂ : Type Γ) → Type Γ
  ν    : (t : Type (_ ∷ Γ))                → Type Γ

-- | Congruence for types
data _≅T_  {Γ Γ' : Ctx} : Type Γ → Type Γ' → Set where
  var  : ∀{x : TyVar Γ} {x' : TyVar Γ'} → (x ≅V x') → var x ≅T var x'
  _⊕_  : ∀{t₁ t₂ : Type Γ} {t₁' t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⊕ t₂) ≅T (t₁' ⊕ t₂')
  _⊗_  : ∀{t₁ t₂ : Type Γ} {t₁' t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⊗ t₂) ≅T (t₁' ⊗ t₂')
  μ    : ∀{t : Type (∗ ∷ Γ)} {t' : Type (∗ ∷ Γ')} →
         (t ≅T t') →
         (μ t) ≅T (μ t')
  _⇒_  : ∀{t₁ t₁' : Type []} {t₂ : Type Γ} {t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⇒ t₂) ≅T (t₁' ⇒ t₂')
  ν    : ∀{t : Type (∗ ∷ Γ)} {t' : Type (∗ ∷ Γ')} →
         (t ≅T t') →
         (ν t) ≅T (ν t')

Trefl : ∀ {Γ : Ctx} {t : Type Γ} → t ≅T t
Trefl {t = var x}   = var e.refl
  where
    module s = Setoid
    module e = IsEquivalence (s.isEquivalence ≅V-setoid)
Trefl {t = t₁ ⊕ t₂} = Trefl ⊕ Trefl
Trefl {t = μ t}     = μ Trefl
Trefl {t = t ⊗ t₁}  = Trefl ⊗ Trefl
Trefl {t = t ⇒ t₁}  = Trefl ⇒ Trefl
Trefl {t = ν t}     = ν Trefl

Tsym : ∀ {Γ Γ' : Ctx} {t : Type Γ} {t' : Type Γ'} → t ≅T t' → t' ≅T t
Tsym (var u)   = var (Vsym u)
Tsym (u₁ ⊕ u₂) = Tsym u₁ ⊕ Tsym u₂
Tsym (u₁ ⊗ u₂) = Tsym u₁ ⊗ Tsym u₂
Tsym (μ u)     = μ (Tsym u)
Tsym (u₁ ⇒ u₂) = Tsym u₁ ⇒ Tsym u₂
Tsym (ν u)     = ν (Tsym u)

Ttrans : ∀ {Γ₁ Γ₂ Γ₃ : Ctx} {t₁ : Type Γ₁} {t₂ : Type Γ₂} {t₃ : Type Γ₃} →
         t₁ ≅T t₂ → t₂ ≅T t₃ → t₁ ≅T t₃
Ttrans (var u₁) (var u₂)   = var (Vtrans u₁ u₂)
Ttrans (u₁ ⊕ u₂) (u₃ ⊕ u₄) = Ttrans u₁ u₃ ⊕ Ttrans u₂ u₄
Ttrans (u₁ ⊗ u₂) (u₃ ⊗ u₄) = Ttrans u₁ u₃ ⊗ Ttrans u₂ u₄
Ttrans (μ u₁) (μ u₂)       = μ (Ttrans u₁ u₂)
Ttrans (u₁ ⇒ u₂) (u₃ ⇒ u₄) = Ttrans u₁ u₃ ⇒ Ttrans u₂ u₄
Ttrans (ν u₁) (ν u₂)       = ν (Ttrans u₁ u₂)

≡→≅T : ∀ {Γ : Ctx} {t₁ t₂ : Type Γ} →
       t₁ ≡ t₂ → t₁ ≅T t₂
≡→≅T {Γ} {t₁} {.t₁} refl = Trefl

-- Note: makes the equality homogeneous in Γ
≅T-setoid : ∀ {Γ} → Setoid _ _
≅T-setoid {Γ} = record
  { Carrier = Type Γ
  ; _≈_ = _≅T_
  ; isEquivalence = record
    { refl = Trefl ; sym = Tsym ; trans = Ttrans }
  }

import Relation.Binary.EqReasoning as EqR

module ≅T-Reasoning where
  module _ {Γ : Ctx} where
    open EqR (≅T-setoid {Γ}) public
      hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _≅T⟨_⟩_; begin_ to beginT_; _∎ to _∎T)

-- | Variable renaming in types
rename : {Γ Δ : TyCtx} → (ρ : Γ ▹ Δ) → Type Γ → Type Δ
rename         ρ (var x)   = var (ρ ∗ x)
rename         ρ (t₁ ⊕ t₂) = rename ρ t₁ ⊕ rename ρ t₂
rename {Γ} {Δ} ρ (μ t)     = μ (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ctx-id {[ ∗ ]} ⧻ ρ
rename         ρ (t₁ ⊗ t₂) = rename ρ t₁ ⊗ rename ρ t₂
rename         ρ (t₁ ⇒ t₂) = t₁ ⇒ rename ρ t₂
rename {Γ} {Δ} ρ (ν t)     = ν (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ctx-id {[ ∗ ]} ⧻ ρ

-------------------------
---- Generating structure on contexts (derived from renaming)

weaken : {Γ : TyCtx} (Δ : TyCtx) → Type Γ -> Type (Δ ∐ Γ)
weaken {Γ} Δ = rename {Γ} {Δ ∐ Γ} (i₂ {Δ} {Γ})

exchange : (Γ Δ : TyCtx) → Type (Γ ∐ Δ) -> Type (Δ ∐ Γ)
exchange Γ Δ = rename [ i₂ {Δ} {Γ} , i₁ {Δ} {Γ} ]

contract : {Γ : TyCtx} → Type (Γ ∐ Γ) -> Type Γ
contract = rename [ ctx-id , ctx-id ]

-- weaken-id-empty-ctx : (Δ : TyCtx) (t : GType) → weaken {[]} Δ t ≡ t
-- weaken-id-empty-ctx = ?

Subst : TyCtx → TyCtx → Set
Subst Γ Δ = TyVar Γ → Type Δ

id-subst : ∀{Γ : TyCtx} → Subst Γ Γ
id-subst x = var x

extend : ∀{Γ Δ : TyCtx} → Subst Γ Δ → Type Δ → (Subst (∗ ∷ Γ) Δ)
extend σ a zero        = a
extend σ _ (succ′ _ x) = σ x

single-subst : ∀{Γ : TyCtx} → Type Γ → (Subst (∗ ∷ Γ) Γ)
single-subst a zero        = a
single-subst _ (succ′ _ x) = var x

lift : ∀{Γ Δ} → Subst Γ Δ → Subst (∗ ∷ Γ) (∗ ∷ Δ)
lift σ = extend (weaken [ ∗ ] ∘ σ) (var zero)

-- | Simultaneous substitution
subst : {Γ Δ : TyCtx} → (σ : Subst Γ Δ) → Type Γ → Type Δ
subst         σ (var x)   = σ x
subst         σ (t₁ ⊕ t₂) = subst σ t₁ ⊕ subst σ t₂
subst {Γ} {Δ} σ (μ t)     = μ (subst (lift σ) t)
subst         σ (t₁ ⊗ t₂) = subst σ t₁ ⊗ subst σ t₂
subst         σ (t₁ ⇒ t₂) = t₁ ⇒ subst σ t₂
subst {Γ} {Δ} σ (ν t)     = ν (subst (lift σ) t)

subst₀ : {Γ : TyCtx} → Type Γ → Type (∗ ∷ Γ) → Type Γ
subst₀ {Γ} a = subst (extend id-subst a)

rename′ : {Γ Δ : TyCtx} → (ρ : Γ ▹ Δ) → Type Γ → Type Δ
rename′ ρ = subst (var ∘ (ρ ∗))

-- | Ground type
GType = Type []

-- | Unfold lfp
unfold-μ : (Type [ ∗ ]) → GType
unfold-μ a = subst₀ (μ a) a

-- | Unfold gfp
unfold-ν : (Type [ ∗ ]) → GType
unfold-ν a = subst₀ (ν a) a

--------------------------------------------------
---- Examples

unit' : GType
unit' = ν (var zero)

Nat : Type []
Nat = μ ((weaken [ ∗ ] unit') ⊕ x)
  where x = var zero

Str-Fun : {Γ : TyCtx} → Type Γ → Type (∗ ∷ Γ)
Str-Fun a = (weaken [ ∗ ] a ⊗ x)
  where x = var zero

Str : {Γ : TyCtx} → Type Γ → Type Γ
Str a = ν (Str-Fun a)

postulate
  lem :  ∀ {Γ : Ctx} (a : Type Γ) (σ : Subst Γ Γ) →
         lift (extend σ a) ≡ extend (lift σ) (weaken [ ∗ ] a)
  lem2 : ∀ {Γ : Ctx} →
         ctx-id {[ ∗ ]} ⧻ i₂ {[ ∗ ]} {Γ} ≡ i₂ {[ ∗ ]} {∗ ∷ Γ}
{-
lem {Γ} b σ =
  begin
    lift (extend σ b)
  ≡⟨ refl ⟩
    extend (weaken [ ∗ ] ∘ (extend σ b)) (var zero)
  ≡⟨ {!!} ⟩
    extend (extend (weaken [ ∗ ] ∘ σ) (var zero))
           (rename {Γ} {[ ∗ ] ∐ Γ} (i₂ {[ ∗ ]} {Γ}) b)
  ≡⟨ refl ⟩
    extend (extend (weaken [ ∗ ] ∘ σ) (var zero)) (weaken [ ∗ ] b)
  ≡⟨ refl ⟩
    extend (lift σ) (weaken [ ∗ ] b)
  ∎
-}

lem3 : ∀ {Γ : Ctx} (a : Type (∗ ∷ Γ)) →
       rename (ctx-id {[ ∗ ]} ⧻ i₂ {[ ∗ ]} {Γ}) a ≡ weaken [ ∗ ] a
lem3 {Γ} a =
     begin
        rename (ctx-id {[ ∗ ]} ⧻ i₂ {[ ∗ ]} {Γ}) a
      ≡⟨ cong (λ x → rename x a) lem2 ⟩
        rename {(∗ ∷ Γ)} {∗ ∷ ∗ ∷ Γ} (i₂ {[ ∗ ]}) a
      ≡⟨ refl ⟩
        rename {(∗ ∷ Γ)} {[ ∗ ] ∐ (∗ ∷ Γ)} (i₂ {[ ∗ ]}) a
      ≡⟨ refl ⟩
        weaken [ ∗ ] a
      ∎

lemma : ∀ {Γ : Ctx} {a b : Type Γ} {σ : Subst Γ Γ} →
        subst (extend σ b) (weaken [ ∗ ] a) ≅T subst σ a
lemma {a = var x}   = Trefl
lemma {a = a₁ ⊕ a₂} = lemma {a = a₁} ⊕ lemma {a = a₂}
lemma {Γ} {μ a} {b} {σ} = μ r
  where
    σ' : Subst (∗ ∷ Γ) (∗ ∷ Γ)
    σ' = lift σ
    b' : Type (∗ ∷ Γ)
    b' = weaken [ ∗ ] b
    a' = rename (ctx-id {[ ∗ ]} ⧻ i₂ {[ ∗ ]} {Γ}) a
    x : subst (extend σ' b') a' ≅T subst σ' a
    x = Ttrans
        (≡→≅T (cong (λ y → subst (extend σ' b') y) (lem3 a)))
        (lemma {∗ ∷ Γ} {a} {b'} {σ'})
    r : subst (lift (extend σ b)) a' ≅T subst (lift σ) a
    r = Ttrans (≡→≅T (cong (λ y → subst y a') (lem b σ))) x
lemma {a = a₁ ⊗ a₂} = lemma {a = a₁} ⊗ lemma {a = a₂}
lemma {a = a₁ ⇒ a₂} = Trefl ⇒ lemma {a = a₂}
lemma {Γ} {ν a} {b} {σ} = ν r
  where
    σ' : Subst (∗ ∷ Γ) (∗ ∷ Γ)
    σ' = lift σ
    b' : Type (∗ ∷ Γ)
    b' = weaken [ ∗ ] b
    a' = rename (ctx-id {[ ∗ ]} ⧻ i₂ {[ ∗ ]} {Γ}) a
    x : subst (extend σ' b') a' ≅T subst σ' a
    x = Ttrans
        (≡→≅T (cong (λ y → subst (extend σ' b') y) (lem3 a)))
        (lemma {∗ ∷ Γ} {a} {b'} {σ'})
    r : subst (lift (extend σ b)) a' ≅T subst (lift σ) a
    r = Ttrans (≡→≅T (cong (λ y → subst y a') (lem b σ))) x

lift-id-is-id-ext : ∀ {Γ : Ctx} (x : TyVar (∗ ∷ Γ)) →
                    (lift (id-subst {Γ})) x ≡ id-subst x
lift-id-is-id-ext zero        = refl
lift-id-is-id-ext (succ′ ∗ x) = refl

lift-id-is-id : ∀ {Γ : Ctx} → lift (id-subst {Γ}) ≡ id-subst
lift-id-is-id = η-≡ lift-id-is-id-ext

id-subst-id : ∀ {Γ : Ctx} {a : Type Γ} →
              subst id-subst a ≅T a
id-subst-id {a = var x}  = var Vrefl
id-subst-id {a = a ⊕ a₁} = id-subst-id ⊕ id-subst-id
id-subst-id {a = μ a}    =
  μ (Ttrans (≡→≅T (cong (λ u → subst u a) lift-id-is-id)) id-subst-id)
id-subst-id {a = a ⊗ a₁} = id-subst-id ⊗ id-subst-id
id-subst-id {a = a ⇒ a₁} = Trefl ⇒ id-subst-id
id-subst-id {a = ν a}    =
  ν (Ttrans (≡→≅T (cong (λ u → subst u a) lift-id-is-id)) id-subst-id)

lemma₂ : ∀ {Γ : Ctx} {a b : Type Γ} →
        subst (extend id-subst b) (weaken [ ∗ ] a) ≅T a
lemma₂ {Γ} {a} {b} = Ttrans (lemma {Γ} {a} {b} {σ = id-subst}) id-subst-id

unfold-str : ∀{a : Type []} → (unfold-ν (Str-Fun a)) ≅T (a ⊗ Str a)
unfold-str {a} = lemma₂ ⊗ Trefl

LFair : {Γ : TyCtx} → Type Γ → Type Γ → Type Γ
LFair a b = ν (μ ((w a ⊗ x) ⊕ (w b ⊗ y)))
  where
    x = var zero
    y = var (succ zero)
    Δ = ∗ ∷ [ ∗ ]
    w = weaken Δ


{-# OPTIONS --universe-polymorphism #-}
module Categories.Functor.Equivalence.Strong where

open import Level
open import Relation.Binary using (IsEquivalence)
open import Relation.Nullary using (¬_)
open import Data.Product using (Σ; ∃; _,_; proj₁; proj₂)
open import Function using () renaming (_∘_ to _∙_)

open import Categories.Category
open import Categories.Functor hiding (equiv)
open import Categories.Functor.Properties
import Categories.Morphisms as Morphisms

record StrongEquivalence {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F : Functor C D) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    .full : Full F
    .faithful : Faithful F
    eso : EssentiallySurjective F

record StronglyEquivalent {o ℓ e o′ ℓ′ e′} (C : Category o ℓ e) (D : Category o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    C⇒D : Functor C D
    strong-equivalence : StrongEquivalence C⇒D
  open StrongEquivalence strong-equivalence public

refl : ∀ {o ℓ e} {C : Category o ℓ e} → StronglyEquivalent C C
refl {C = C} = record
  { C⇒D = id
  ; strong-equivalence = record
    { full = λ {X Y} → my-full X Y
    ; faithful = λ _ _ eq → eq
    ; eso = λ d → d , (record { f = C.id; g = C.id; iso = record { isoˡ = C.identityˡ; isoʳ = C.identityˡ } })
    }
  }
  where
  module C = Category C
  open C hiding (id)
  .my-full : ∀ X Y → ¬ Σ (X ⇒ Y) (λ f → ¬ ∃ (λ g → C [ g ≡ f ]))
  my-full X Y (f , elim) = elim (f , Equiv.refl)

sym : ∀ {o ℓ e o′ ℓ′ e′} → {C : Category o ℓ e} {D : Category o′ ℓ′ e′} → StronglyEquivalent C D → StronglyEquivalent D C
sym {C = C} {D = D} Op = record
  { C⇒D = record
    { F₀ = λ d → proj₁ (Op.eso d)
    ; F₁ = λ f → {!rev (proj₂ (Op.eso _)) ∘ f ∘ ?!}
    ; identity = {!!}
    ; homomorphism = {!!}
    ; F-resp-≡ = {!!}
    }
  ; strong-equivalence = record
    { full = {!!}
    ; faithful = {!!}
    ; eso = {!!}
    }
  }
  where
  module Op = StronglyEquivalent Op
  open Op using () renaming (C⇒D to F)
  open Functor F
  open Morphisms._≅_ C renaming (f to fwd; g to rev)

trans : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂ o₃ ℓ₃ e₃} {C₁ : Category o₁ ℓ₁ e₁} {C₂ : Category o₂ ℓ₂ e₂} {C₃ : Category o₃ ℓ₃ e₃} → StronglyEquivalent C₁ C₂ → StronglyEquivalent C₂ C₃ → StronglyEquivalent C₁ C₃
trans {C₁ = C₁} {C₂} {C₃} C₁⇒C₂ C₂⇒C₃ = record
  { C⇒D = G ∘ F
  ; strong-equivalence = record
    { full = λ {X Y} → my-full X Y
    ; faithful = λ f g → C₁⇒C₂.faithful _ _ ∙ C₂⇒C₃.faithful _ _
    ; eso = my-eso }
  }
  where
  module C₁⇒C₂ = StronglyEquivalent C₁⇒C₂
  module C₂⇒C₃ = StronglyEquivalent C₂⇒C₃
  open C₁⇒C₂ using () renaming (C⇒D to F)
  open C₂⇒C₃ using () renaming (C⇒D to G)
  module F = Functor F
  open F using (F₀; F₁)
  module G = Functor G
  open G using () renaming (F₀ to G₀; F₁ to G₁)
  module E = Category.Equiv C₃
  open Morphisms C₃
  .my-full : ∀ X Y → ¬ ∃ (λ f → ¬ ∃ (λ (g : C₁ [ X , Y ]) → C₃ [ G₁ (F₁ g) ≡ f ]))
  my-full X Y (f , elim) = C₂⇒C₃.full (f , lemma)
    where
    lemma : ¬ ∃ (λ h → C₃ [ G₁ h ≡ f ])
    lemma (h , G₁h≡f) = C₁⇒C₂.full (h , lemma₂)
      where
      lemma₂ : ¬ ∃ (λ g → C₂ [ F₁ g ≡ h ])
      lemma₂ (g , F₁g≡h) = elim (g , E.trans (G.F-resp-≡ F₁g≡h) G₁h≡f)
  my-eso : ∀ c₃ → ∃ (λ c₁ → G₀ (F₀ c₁) ≅ c₃)
  my-eso c₃ with C₂⇒C₃.eso c₃
  my-eso c₃ | c₂ , ff₃ with C₁⇒C₂.eso c₂
  my-eso c₃ | c₂ , ff₃ | c₁ , ff₂ = c₁ , (ff₃ ⓘ resp-≅ ff₂)
    where open FunctorsAlways G

equiv : ∀ {o ℓ e} → IsEquivalence (StronglyEquivalent {o} {ℓ} {e})
equiv = record
  { refl = refl
  ; sym = sym
  ; trans = trans
  }


module Prelude.Product where

open import Agda.Primitive
open import Agda.Builtin.Sigma public
open import Prelude.Function
open import Prelude.Equality
open import Prelude.Decidable
open import Prelude.Ord

instance
  ipair : ∀ {a b} {A : Set a} {B : A → Set b} {{x : A}} {{y : B x}} → Σ A B
  ipair {{x}} {{y}} = x , y

infixr 3 _×_
_×_ : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
A × B = Σ A (λ _ → B)

_,′_ : ∀ {a b} {A : Set a} {B : Set b} → A → B → A × B
_,′_ = _,_

uncurry : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c} →
            (∀ x (y : B x) → C x y) → (p : Σ A B) → C (fst p) (snd p)
uncurry f (x , y) = f x y

uncurry′ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : Set c} →
            (∀ x → B x → C) → Σ A B → C
uncurry′ f (x , y) = f x y

curry : ∀ {a b c} {A : Set a} {B : A → Set b} {C : Σ A B → Set c} →
          (∀ p → C p) → ∀ x (y : B x) → C (x , y)
curry f x y = f (x , y)

infixr 3 _***_ _***′_ _&&&_
_***_ : ∀ {a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂} {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
          (f : A₁ → A₂) → (∀ {x} → B₁ x → B₂ (f x)) → Σ A₁ B₁ → Σ A₂ B₂
(f *** g) (x , y) = f x , g y

_***′_ : ∀ {a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂} {B₁ : Set b₁} {B₂ : Set b₂} →
          (A₁ → A₂) → (B₁ → B₂) → A₁ × B₁ → A₂ × B₂
(f ***′ g) (x , y) = f x , g y

_&&&_ : ∀ {c a b} {C : Set c} {A : Set a} {B : A → Set b}
          (f : C → A) → (∀ x → B (f x)) → C → Σ A B
(f &&& g) x = f x , g x

first : ∀ {a₁ a₂ b} {A₁ : Set a₁} {A₂ : Set a₂} {B : Set b} →
          (A₁ → A₂) → A₁ × B → A₂ × B
first f = f *** id

second : ∀ {a b₁ b₂} {A : Set a} {B₁ : A → Set b₁} {B₂ : A → Set b₂} →
           (∀ {x} → B₁ x → B₂ x) → Σ A B₁ → Σ A B₂
second f = id *** f

-- Eq instance --

sigma-inj-fst : ∀ {a b} {A : Set a} {B : A → Set b} {x : A} {y : B x}
                 {x₁ : A} {y₁ : B x₁} →
               (x , y) ≡ (x₁ , y₁) → x ≡ x₁
sigma-inj-fst refl = refl

sigma-inj-snd : ∀ {a b} {A : Set a} {B : A → Set b} {x : A} {y y₁ : B x} →
               _≡_ {A = Σ A B} (x , y) (x , y₁) → y ≡ y₁
sigma-inj-snd refl = refl

instance
  EqSigma : ∀ {a b} {A : Set a} {B : A → Set b} {{EqA : Eq A}} {{EqB : ∀ {x} → Eq (B x)}} → Eq (Σ A B)
  _==_ {{EqSigma}} (x , y) (x₁ , y₁) with x == x₁
  _==_ {{EqSigma}} (x , y) (x₁ , y₁) | no  neq  = no λ eq → neq (sigma-inj-fst eq)
  _==_ {{EqSigma}} (x , y) (.x , y₁) | yes refl with y == y₁
  _==_ {{EqSigma}} (x , y) (.x , y₁) | yes refl | no neq = no λ eq → neq (sigma-inj-snd eq)
  _==_ {{EqSigma}} (x , y) (.x , .y) | yes refl | yes refl = yes refl

-- Ord instance --

data LexiographicOrder {a b} {A : Set a} {B : A → Set b}
                       (_<A_ : A → A → Set a) (_<B_ : ∀ {x} → B x → B x → Set b) :
                       Σ A B → Σ A B → Set (a ⊔ b) where
  fst< : ∀ {x₁ x₂} {y₁ : B x₁} {y₂ : B x₂} → x₁ <A x₂ → LexiographicOrder _<A_ _<B_ (x₁ , y₁) (x₂ , y₂)
  snd< : ∀ {x} {y₁ y₂ : B x} → y₁ <B y₂ → LexiographicOrder _<A_ _<B_ (x , y₁) (x , y₂)

module _ {a b} {A : Set a} {B : A → Set b} {{OrdA : Ord A}} {{OrdB : ∀ {x} → Ord (B x)}} where
  private
    cmpSigma : (x y : Σ A B) → Comparison (LexiographicOrder _<_ _<_) x y
    cmpSigma (x , y)  (x₁ , y₁)  with compare x x₁
    cmpSigma (x , y)  (x₁ , y₁)  | less x<x₁    = less    (fst< x<x₁)
    cmpSigma (x , y)  (x₁ , y₁)  | greater x₁<x = greater (fst< x₁<x)
    cmpSigma (x , y)  (.x , y₁)  | equal refl with compare y y₁
    cmpSigma (x₁ , y) (.x₁ , y₁) | equal refl | less y<y₁    = less    (snd< y<y₁)
    cmpSigma (x₁ , y) (.x₁ , y₁) | equal refl | greater y₁<y = greater (snd< y₁<y)
    cmpSigma (x₁ , y) (.x₁ , .y) | equal refl | equal refl   = equal refl

    from-eq : (x y : Σ A B) → x ≡ y → LexiographicOrder _<_ _≤_ x y
    from-eq (x , y) (.x , .y) refl = snd< (eq-to-leq (refl {x = y}))

    from-lt : (x y : Σ A B) → LexiographicOrder _<_ _<_ x y → LexiographicOrder _<_ _≤_ x y
    from-lt (x₁ , y₁) (x₂ , y₂) (fst< lt) = fst< lt
    from-lt (x  , y₁) (.x , y₂) (snd< lt) = snd< (lt-to-leq {x = y₁} lt)

    from-leq : (x y : Σ A B) → LexiographicOrder _<_ _≤_ x y → LessEq (LexiographicOrder _<_ _<_) x y
    from-leq (a , b) (a₁ , b₁) (fst< a<a₁) = less (fst< a<a₁)
    from-leq (a , b) (.a , b₁) (snd< b≤b₁) with leq-to-lteq {{OrdB}} b≤b₁
    ... | less b<b₁  = less (snd< b<b₁)
    ... | equal b=b₁ = equal ((a ,_) $≡ b=b₁)

  instance
    OrdSigma : Ord (Σ A B)
    Ord._<_         OrdSigma = _
    Ord._≤_         OrdSigma = LexiographicOrder _<_ _≤_
    Ord.compare     OrdSigma = cmpSigma
    Ord.eq-to-leq   OrdSigma = from-eq _ _
    Ord.lt-to-leq   OrdSigma = from-lt _ _
    Ord.leq-to-lteq OrdSigma = from-leq _ _

module _ {a b} {A : Set a} {B : A → Set b} {{OrdA : Ord/Laws A}} {{OrdB : ∀ {x} → Ord/Laws (B x)}} where

    OrdLawsSigma : Ord/Laws (Σ A B)
    Ord/Laws.super OrdLawsSigma = OrdSigma {{OrdB = OrdB .Ord/Laws.super}}
    less-antirefl {{OrdLawsSigma}} (fst< lt)                    = less-antirefl {A = A} lt
    less-antirefl {{OrdLawsSigma}} (snd< {x = x} lt)            = less-antirefl {A = B x} lt
    less-trans    {{OrdLawsSigma}} (fst<         lt) (fst< lt₁) = fst< (less-trans {A = A} lt lt₁)
    less-trans    {{OrdLawsSigma}} (fst<         lt) (snd< lt₁) = fst< lt
    less-trans    {{OrdLawsSigma}} (snd<         lt) (fst< lt₁) = fst< lt₁
    less-trans    {{OrdLawsSigma}} (snd< {x = x} lt) (snd< lt₁) = snd< (less-trans {A = B x} lt lt₁)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Many properties which hold for `∼` also hold for `flip ∼`. Unlike
-- the module `Relation.Binary.Construct.Converse` this module flips
-- both the relation and the underlying equality.
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.Construct.Flip where

open import Function
open import Data.Product

------------------------------------------------------------------------
-- Properties

module _ {a ℓ} {A : Set a} (∼ : Rel A ℓ) where

  reflexive : Reflexive ∼ → Reflexive (flip ∼)
  reflexive refl = refl

  symmetric : Symmetric ∼ → Symmetric (flip ∼)
  symmetric sym = sym

  transitive : Transitive ∼ → Transitive (flip ∼)
  transitive trans = flip trans

  asymmetric : Asymmetric ∼ → Asymmetric (flip ∼)
  asymmetric asym = asym

  total : Total ∼ → Total (flip ∼)
  total total x y = total y x

  respects : ∀ {p} (P : A → Set p) → Symmetric ∼ →
             P Respects ∼ → P Respects flip ∼
  respects _ sym resp ∼ = resp (sym ∼)

  max : ∀ {⊥} → Minimum ∼ ⊥ → Maximum (flip ∼) ⊥
  max min = min

  min : ∀ {⊤} → Maximum ∼ ⊤ → Minimum (flip ∼) ⊤
  min max = max

module _ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
         (≈ : REL A B ℓ₁) (∼ : REL A B ℓ₂) where

  implies : ≈ ⇒ ∼ → flip ≈ ⇒ flip ∼
  implies impl = impl

  irreflexive : Irreflexive ≈ ∼ → Irreflexive (flip ≈) (flip ∼)
  irreflexive irrefl = irrefl

module _ {a ℓ₁ ℓ₂} {A : Set a} (≈ : Rel A ℓ₁) (∼ : Rel A ℓ₂) where

  antisymmetric : Antisymmetric ≈ ∼ → Antisymmetric (flip ≈) (flip ∼)
  antisymmetric antisym = antisym

  trichotomous : Trichotomous ≈ ∼ → Trichotomous (flip ≈) (flip ∼)
  trichotomous compare x y = compare y x

module _ {a ℓ₁ ℓ₂} {A : Set a} (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) where

  respects₂ : Symmetric ∼₂ → ∼₁ Respects₂ ∼₂ → flip ∼₁ Respects₂ flip ∼₂
  respects₂ sym (resp₁ , resp₂) = (resp₂ ∘ sym , resp₁ ∘ sym)

module _ {a b ℓ} {A : Set a} {B : Set b} (∼ : REL A B ℓ) where

  decidable : Decidable ∼ → Decidable (flip ∼)
  decidable dec x y = dec y x

module _ {a ℓ} {A : Set a} {≈ : Rel A ℓ} where

  isEquivalence : IsEquivalence ≈ → IsEquivalence (flip ≈)
  isEquivalence eq = record
    { refl  = reflexive  ≈ Eq.refl
    ; sym   = symmetric  ≈ Eq.sym
    ; trans = transitive ≈ Eq.trans
    }
    where module Eq = IsEquivalence eq

  isDecEquivalence : IsDecEquivalence ≈ → IsDecEquivalence (flip ≈)
  isDecEquivalence dec = record
    { isEquivalence = isEquivalence Dec.isEquivalence
    ; _≟_           = decidable ≈ Dec._≟_
    }
    where module Dec = IsDecEquivalence dec

------------------------------------------------------------------------
-- Structures

module _ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {∼ : Rel A ℓ₂} where

  isPreorder : IsPreorder ≈ ∼ → IsPreorder (flip ≈) (flip ∼)
  isPreorder O = record
    { isEquivalence = isEquivalence O.isEquivalence
    ; reflexive     = implies ≈ ∼ O.reflexive
    ; trans         = transitive ∼ O.trans
    }
    where module O = IsPreorder O

  isPartialOrder : IsPartialOrder ≈ ∼ → IsPartialOrder (flip ≈) (flip ∼)
  isPartialOrder O = record
    { isPreorder = isPreorder O.isPreorder
    ; antisym    = antisymmetric ≈ ∼ O.antisym
    }
    where module O = IsPartialOrder O

  isTotalOrder : IsTotalOrder ≈ ∼ → IsTotalOrder (flip ≈) (flip ∼)
  isTotalOrder O = record
    { isPartialOrder = isPartialOrder O.isPartialOrder
    ; total          = total ∼ O.total
    }
    where module O = IsTotalOrder O

  isDecTotalOrder : IsDecTotalOrder ≈ ∼ → IsDecTotalOrder (flip ≈) (flip ∼)
  isDecTotalOrder O = record
    { isTotalOrder = isTotalOrder O.isTotalOrder
    ; _≟_          = decidable ≈ O._≟_
    ; _≤?_         = decidable ∼ O._≤?_
    }
    where module O = IsDecTotalOrder O

  isStrictPartialOrder : IsStrictPartialOrder ≈ ∼ →
                         IsStrictPartialOrder (flip ≈) (flip ∼)
  isStrictPartialOrder O = record
    { isEquivalence = isEquivalence O.isEquivalence
    ; irrefl        = irreflexive ≈ ∼ O.irrefl
    ; trans         = transitive ∼ O.trans
    ; <-resp-≈      = respects₂ ∼ ≈ O.Eq.sym O.<-resp-≈
    }
    where module O = IsStrictPartialOrder O

  isStrictTotalOrder : IsStrictTotalOrder ≈ ∼ →
                       IsStrictTotalOrder (flip ≈) (flip ∼)
  isStrictTotalOrder O = record
    { isEquivalence = isEquivalence O.isEquivalence
    ; trans         = transitive ∼ O.trans
    ; compare       = trichotomous ≈ ∼ O.compare
    } where module O = IsStrictTotalOrder O

module _ {a ℓ} where

  setoid : Setoid a ℓ → Setoid a ℓ
  setoid S = record
    { _≈_           = flip S._≈_
    ; isEquivalence = isEquivalence S.isEquivalence
    }
    where module S = Setoid S

  decSetoid : DecSetoid a ℓ → DecSetoid a ℓ
  decSetoid S = record
    { _≈_              = flip S._≈_
    ; isDecEquivalence = isDecEquivalence S.isDecEquivalence
    }
    where module S = DecSetoid S

module _ {a ℓ₁ ℓ₂} where

  preorder : Preorder a ℓ₁ ℓ₂ → Preorder a ℓ₁ ℓ₂
  preorder O = record
    { isPreorder = isPreorder O.isPreorder
    }
    where module O = Preorder O

  poset : Poset a ℓ₁ ℓ₂ → Poset a ℓ₁ ℓ₂
  poset O = record
    { isPartialOrder = isPartialOrder O.isPartialOrder
    }
    where module O = Poset O

  totalOrder : TotalOrder a ℓ₁ ℓ₂ → TotalOrder a ℓ₁ ℓ₂
  totalOrder O = record
    { isTotalOrder = isTotalOrder O.isTotalOrder
    }
    where module O = TotalOrder O

  decTotalOrder : DecTotalOrder a ℓ₁ ℓ₂ → DecTotalOrder a ℓ₁ ℓ₂
  decTotalOrder O = record
    { isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
    }
    where module O = DecTotalOrder O

  strictPartialOrder : StrictPartialOrder a ℓ₁ ℓ₂ →
                       StrictPartialOrder a ℓ₁ ℓ₂
  strictPartialOrder O = record
    { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
    }
    where module O = StrictPartialOrder O

  strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂ →
                     StrictTotalOrder a ℓ₁ ℓ₂
  strictTotalOrder O = record
    { isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
    }
    where module O = StrictTotalOrder O


------------------------------------------------------------------------
-- A parametrised specification of "natrec", along with a proof that
-- the specification is propositional (assuming extensionality)
------------------------------------------------------------------------

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

open import Equality
open import Prelude hiding (ℕ; zero; suc)

-- The module is parametrised by equality and some type that is closed
-- under "zero" and "suc".

module Nat.Eliminator
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive)
  (ℕ : Type) (zero : ℕ) (suc : ℕ → ℕ)
  where

open import Bijection eq using (_↔_)
open Derived-definitions-and-properties eq
import Equivalence eq as Eq
open import Function-universe eq hiding (_∘_)
open import H-level eq as H-level
open import H-level.Closure eq
open import Surjection eq using (_↠_)

-- Specification of natrec.

Natrec : (ℓ : Level) → Type (lsuc ℓ)
Natrec ℓ =
  (P : ℕ → Type ℓ) (z : P zero) (s : ∀ n → P n → P (suc n)) →
  ∃ λ (natrec : ∀ n → P n) →
    natrec zero ≡ z
      ×
    ∀ n → natrec (suc n) ≡ s n (natrec n)

-- This specification is propositional (assuming extensionality).
--
-- Note that the proof uses some lemmas that are defined by recursion
-- on natural numbers. I suspect that it would be easy (although
-- perhaps somewhat tedious) to avoid such recursion.
--
-- I got the idea for this result from Christian Sattler, who
-- mentioned the work of Awodey, Gambino and Sojakova: in "Inductive
-- types in homotopy type theory" they prove something similar for a
-- non-dependent eliminator.

Natrec-propositional :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) ℓ →
  Is-proposition (Natrec ℓ)
Natrec-propositional {ℓ} ext₊ =
  [inhabited⇒+]⇒+ 0 λ natrec₀ →
  Π-closure ext₊ 1 λ P →
  Π-closure ext₌ 1 λ z →
  Π-closure ext₌ 1 λ s →
  H-level.respects-surjection (∃-cong (lemma natrec₀ P z s)) 1
    (mono₁ 0 (singleton-contractible _))
  where
  ext₌ : Extensionality ℓ ℓ
  ext₌ = lower-extensionality _ lzero ext₊

  ext₀ : Extensionality lzero ℓ
  ext₀ = lower-extensionality _ lzero ext₊

  ext : Extensionality lzero ℓ
  ext = Eq.good-ext ext₀

  lemma :
    (natrec₀ : Natrec ℓ)
    (P : ℕ → Type ℓ) (z : P zero) (s : ∀ n → P n → P (suc n))
    (natrec : ∀ n → P n) →

    natrec ≡ proj₁ (natrec₀ P z s)

      ↠

    (natrec zero ≡ z
       ×
     ∀ n → natrec (suc n) ≡ s n (natrec n))

  lemma natrec₀ P z s natrec = record
    { logical-equivalence = record
      { to   = λ eq →
                   (natrec zero      ≡⟨ cong (_$ zero) eq ⟩
                    rec₀ P z s zero  ≡⟨ nz₀ P z s ⟩∎
                    z                ∎)
                 , λ n →
                     natrec (suc n)      ≡⟨ cong (_$ suc n) eq ⟩
                     rec₀ P z s (suc n)  ≡⟨ ns₀ P z s n ⟩
                     s n (rec₀ P z s n)  ≡⟨ sym $ cong (s n) $ cong (_$ n) eq ⟩∎
                     s n (natrec n)      ∎
      ; from = λ { (nz , ns) → apply-ext ext $
                     lower ∘
                     rec₀ (λ n → ↑ ℓ (natrec n ≡ rec₀ P z s n))
                       (lift (
                          natrec zero      ≡⟨ nz ⟩
                          z                ≡⟨ sym $ nz₀ P z s ⟩∎
                          rec₀ P z s zero  ∎))
                       (λ n ih → lift (
                          natrec (suc n)      ≡⟨ ns n ⟩
                          s n (natrec n)      ≡⟨ cong (s n) (lower ih) ⟩
                          s n (rec₀ P z s n)  ≡⟨ sym $ ns₀ P z s n ⟩∎
                          rec₀ P z s (suc n)  ∎))
                 }
      }
    ; right-inverse-of = λ { (nz , ns) →
          let f = lower ∘
                  rec₀ _
                    (lift (trans nz (sym $ nz₀ P z s)))
                    (λ n ih →
                       lift (trans (ns n)
                               (trans (cong (s n) (lower ih))
                                  (sym $ ns₀ P z s n)))) in

          _↔_.to ≡×≡↔≡
            ( (trans (cong (_$ zero) (apply-ext ext f)) (nz₀ P z s)  ≡⟨ cong (flip trans (nz₀ P z s)) $ Eq.cong-good-ext ext₀ f ⟩
               trans (f zero) (nz₀ P z s)                            ≡⟨ cong (flip trans (nz₀ P z s) ∘ lower) $ nz₀ _ _ _ ⟩
               trans (trans nz (sym $ nz₀ P z s)) (nz₀ P z s)        ≡⟨ trans-[trans-sym]- _ (nz₀ P z s) ⟩∎
               nz                                                    ∎)

            , apply-ext ext λ n →
                trans
                  (cong (_$ suc n) (apply-ext ext f))
                  (trans (ns₀ P z s n)
                     (sym $ cong (s n) $ cong (_$ n) (apply-ext ext f)))     ≡⟨ cong₂ (λ p q → trans p (trans (ns₀ P z s n) (sym $ cong (s n) q)))
                                                                                (Eq.cong-good-ext ext₀ f) (Eq.cong-good-ext ext₀ f) ⟩
                trans
                  (f (suc n))
                  (trans (ns₀ P z s n) (sym $ cong (s n) (f n)))             ≡⟨ cong (flip trans (trans _ (sym $ cong (s n) (f n))) ∘ lower) $
                                                                                ns₀ _ _ _ _ ⟩
                trans
                  (trans (ns n)
                     (trans (cong (s n) (f n))
                        (sym $ ns₀ P z s n)))
                  (trans (ns₀ P z s n) (sym $ cong (s n) (f n)))             ≡⟨ cong (flip trans (trans _ (sym $ cong (s n) (f n)))) $
                                                                                sym $ trans-assoc _ _ (sym $ ns₀ P z s n) ⟩
                trans
                  (trans (trans (ns n) (cong (s n) (f n)))
                     (sym $ ns₀ P z s n))
                  (trans (ns₀ P z s n) (sym $ cong (s n) (f n)))             ≡⟨ sym $ trans-assoc _ _ (sym $ cong (s n) (f n)) ⟩

                trans
                  (trans (trans (trans (ns n) (cong (s n) (f n)))
                            (sym $ ns₀ P z s n))
                     (ns₀ P z s n))
                  (sym $ cong (s n) (f n))                                   ≡⟨ cong (flip trans (sym $ cong (s n) (f n))) $
                                                                                trans-[trans-sym]- _ (ns₀ P z s n) ⟩
                trans
                  (trans (ns n) (cong (s n) (f n)))
                  (sym $ cong (s n) (f n))                                   ≡⟨ trans-[trans]-sym _ (cong (s n) (f n)) ⟩∎

                ns n                                                         ∎
            )
        }
    }
    where
    rec₀ : (P : ℕ → Type ℓ) (z : P zero) (s : ∀ n → P n → P (suc n)) →
           ∀ n → P n
    rec₀ P z s = proj₁ (natrec₀ P z s)

    nz₀ : (P : ℕ → Type ℓ) (z : P zero) (s : ∀ n → P n → P (suc n)) →
          rec₀ P z s zero ≡ z
    nz₀ P z s = proj₁ (proj₂ (natrec₀ P z s))

    ns₀ : (P : ℕ → Type ℓ) (z : P zero) (s : ∀ n → P n → P (suc n)) →
          ∀ n → rec₀ P z s (suc n) ≡ s n (rec₀ P z s n)
    ns₀ P z s = proj₂ (proj₂ (natrec₀ P z s))


-- Jesper, 2018-12-04, Issue #3431 reported by François Thiré on the
-- Agda mailing list
-- (https://lists.chalmers.se/pipermail/agda/2018/010686.html)

-- The instance of the Reduce typeclass for pairs did not have an
-- implementation for reduceB' (only reduce'), which made it default
-- to the standard implementation and forget the blocking tags.

{-# OPTIONS --rewriting #-}

open import Agda.Primitive
open import Agda.Builtin.Equality
{-# BUILTIN REWRITE _≡_ #-}

0ℓ : Level
0ℓ = lzero

1ℓ : Level
1ℓ = lsuc lzero

record Lift {a} ℓ (A : Set a) : Set (a ⊔ ℓ) where
  constructor lift
  field lower : A

postulate
  prod  : {ℓ ℓ′ : Level} → (A : Set ℓ) → (B : Set ℓ′) → Set (ℓ ⊔ ℓ′)

  p : Set 1ℓ → Set 1ℓ
  q : Set 1ℓ → Set 1ℓ
  f : ∀ (c : Set 0ℓ) → p (Lift 1ℓ c) → q (Lift 1ℓ c)
  g : ∀ (a : Set 1ℓ) → ∀ (b : Set 1ℓ) → p (prod a b)
  a : Set 0ℓ
  b : Set 0ℓ

  canL : {ℓ ℓ′ ℓ″ : Level} → (A : Set ℓ) → (B : Set ℓ′)  → (prod (Lift ℓ″ A) B) ≡ Lift (ℓ″ ⊔ ℓ′) (prod A B)
  canR : {ℓ ℓ′ ℓ″ : Level} → (A : Set ℓ) → (B : Set ℓ′)  → (prod A (Lift ℓ″ B)) ≡ Lift (ℓ ⊔ ℓ″) (prod A B)
  canT : {ℓ ℓ′ ℓ″ : Level} → (A : Set ℓ) → Lift ℓ″ (Lift ℓ′ A) ≡ Lift (ℓ″ ⊔ ℓ′) A

{-# REWRITE canL #-}
{-# REWRITE canR #-}
{-# REWRITE canT #-}

ali : q (Lift 1ℓ (prod a b))
ali = f (prod a b) (g (Lift 1ℓ {!!}) (Lift 1ℓ b))

-- WAS: Set₁ != Set
-- SHOULD: succeed (with unsolved metas and constraints)


-- TODO: use StrictTotalOrder for QName representation

module Syntax (QName : Set) where

open import Data.Nat.Base
open import Data.Nat.Properties using (+-suc; +-identityʳ)
open import Data.List.Base hiding (_∷ʳ_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym; trans)

-- Well-scoped de Bruijn indices
-- n is the length of the context

data Var : ℕ → Set where
  vzero : ∀{n} → Var (suc n)
  vsuc  : ∀{n} (x : Var n) → Var (suc n)

-- Example: in context x,y,z (so n = 3)
-- x  is  vsuc (vsuc vzero) : Var 3
-- y  is      vsuc vzero  : Var 3
-- z  is         vzero  : Var 3

-- Qualified names

DRName   = QName  -- datatype / record name
FuncName = QName  -- function name
ProjName = QName  -- projection name (overloaded)
ConsName = QName  -- datatype / record constructor name (overloaded)

-- Data or record constructors

data ConHead : Set where
  dataCon : DRName → ConHead
  recCon  : DRName → (fs : List ProjName) → ConHead

-- Sorts are Set₀, Set₁, ...

data Sort : Set where
  uni : (ℓ : ℕ) → Sort

-- In the following definition of well-scoped syntax,
-- n is always the length of the context.

mutual

  data Term (n : ℕ) : Set where
    var : (x : Var n) (es : Elims n) → Term n
    def : (f : FuncName) (es : Elims n) → Term n
    con : (c : ConHead) (vs : Args n) → Term n     -- Fully applied
    lam : (v : Term (suc n)) → Term n
    -- Types
    dat  : (d : DRName) (vs : Args n) → Term n     -- Fully applied
    sort : (s : Sort) → Term n
    pi   : (u : Term n) (v : Term (suc n)) → Term n

  data Elim (n : ℕ) : Set where
    apply : (u : Term n)   → Elim n
    proj  : (π : ProjName) → Elim n

  Elims : (n : ℕ) → Set
  Elims n = List (Elim n)

  Args : (n : ℕ) → Set
  Args n = List (Term n)

-- Example: (A : Set) (x : A) → A
-- is represented by

exTyId : Term 0
exTyId = pi (sort (uni 0)) (pi (var vzero []) (var (vsuc vzero) []))

-- Looking up a field in a field-value collection

-- TODO: Do we want to ensure |fs| = |vs| ?
data LookupField {a} {A : Set a} : (fs : List ProjName) (vs : List A) (f : ProjName) (v : A) → Set where

  here : ∀{f fs v vs}
    → LookupField (f ∷ fs) (v ∷ vs) f v

  there : ∀{f f' fs v v' vs}
    → LookupField fs vs f v
    → LookupField (f' ∷ fs) (v' ∷ vs) f v

-- Renamings represented as functions

Renaming : (Γ Δ : ℕ) → Set
Renaming Γ Δ = Var Δ → Var Γ

weak : ∀{Γ} → Renaming (suc Γ) Γ
weak x = vsuc x

-- If    Γ   ⊢ ρ         : Δ
-- then  Γ,x ⊢ liftRen ρ : Δ,x.

liftRen : ∀{Γ Δ} → Renaming Γ Δ → Renaming (suc Γ) (suc Δ)
liftRen ρ vzero    = vzero
liftRen ρ (vsuc x) = vsuc (ρ x)

-- We need sized types to show termination of rename.
{-# TERMINATING #-}

mutual
  rename : ∀{Γ Δ} (ρ : Renaming Γ Δ) (t : Term Δ) → Term Γ
  rename ρ (var x es) = var (ρ x) (map (renameElim ρ) es)
  rename ρ (def f es) = def f (map (renameElim ρ) es)
  rename ρ (con c vs) = con c (map (rename ρ) vs)
  rename ρ (lam t)    = lam (rename (liftRen ρ) t)
  rename ρ (dat d vs) = dat d (map (rename ρ) vs)
  rename ρ (sort s)   = sort s
  rename ρ (pi u v)   = pi (rename ρ u) (rename (liftRen ρ) v)

  renameElim : ∀{Γ Δ} (ρ : Renaming Γ Δ) (e : Elim Δ) → Elim Γ
  renameElim ρ (apply u) = apply (rename ρ u)
  renameElim ρ (proj π)  = proj π

-- Substitutions represented as functions

-- σ : Subst Γ Δ  applies to a term living in context Δ
-- and turns it into a term living in context Γ

Substitution : (Γ Δ : ℕ) → Set
Substitution Γ Δ = Var Δ → Term Γ

liftSub : ∀{Γ Δ} (σ : Substitution Γ Δ) → Substitution (suc Γ) (suc Δ)
liftSub σ vzero    = var vzero []
liftSub σ (vsuc x) = rename weak (σ x)

-- Substitute for the last variable (vzero)

sg : ∀{Γ} (u : Term Γ) → Substitution Γ (suc Γ)
sg {Γ} u vzero    = u
sg {Γ} u (vsuc x) = var x []

data All₂ {A B : Set} (R : A → B → Set) : List A → List B → Set where
  nil  : All₂ R [] []
  cons : ∀{x y xs ys}
    → R x y
    → All₂ R xs ys
    → All₂ R (x ∷ xs) (y ∷ ys)

mutual

  data Apply {Γ} : (t : Term Γ) (es : Elims Γ) (v : Term Γ) → Set where

    empty : ∀{t}
      → Apply t [] t

    var : ∀{x es es'}
      → Apply (var x es) es' (var x (es ++ es'))

    def : ∀{f es es'}
      → Apply (def f es) es' (def f (es ++ es'))

    proj : ∀{ c πs vs π es u v}
      → LookupField πs vs π u
      → Apply u es v
      → Apply (con (recCon c πs) vs) (proj π ∷ es) v

    lam : ∀{t t' u v es}
      → SubstTerm (sg u) t t'
      → Apply t' es v
      → Apply (lam t) (apply u ∷ es) v

  data SubstTerm {Γ Δ} (σ : Substitution Γ Δ) : Term Δ → Term Γ → Set where

    var : ∀{x : Var Δ} {es : Elims Δ} {v : Term Γ} {es' : Elims Γ}
      → All₂ (SubstElim σ) es es'
      → Apply (σ x) es' v
      → SubstTerm σ (var x es) v

    def : ∀{f : FuncName} {es : Elims Δ} {es' : Elims Γ}
      → All₂ (SubstElim σ) es es'
      → SubstTerm σ (def f es) (def f es')

    con : ∀{c : ConHead} {vs : Args Δ} {vs' : Args Γ}
      → All₂ (SubstTerm σ) vs vs'
      → SubstTerm σ (con c vs) (con c vs')

    lam : ∀{v : Term (suc Δ)} {v'}
      → SubstTerm (liftSub σ) v v'
      → SubstTerm σ (lam v) (lam v')

    dat : ∀{d : DRName} {vs : Args Δ} {vs' : Args Γ}
      → All₂ (SubstTerm σ) vs vs'
      → SubstTerm σ (dat d vs) (dat d vs')

    pi : ∀{U V U' V'}
      → SubstTerm σ U U'
      → SubstTerm (liftSub σ) V V'
      → SubstTerm σ (pi U V) (pi U' V')

    sort : ∀{s : Sort}
      → SubstTerm σ (sort s) (sort s)

  data SubstElim {Γ Δ} (σ : Substitution Γ Δ) : Elim Δ → Elim Γ → Set where

    apply : ∀{u u'}
      → SubstTerm σ u u'
      → SubstElim σ (apply u) (apply u')

    proj : ∀{π}
      → SubstElim σ (proj π) (proj π)

data FunctionApply {Γ} : (T : Term Γ) (us : Args Γ) (U : Term Γ) → Set where

  empty : ∀{T}
    → FunctionApply T [] T

  pi : ∀{u us T U V V'}
    → SubstTerm (sg u) V V'
    → FunctionApply V' us T
    → FunctionApply (pi U V) (u ∷ us) T

-- n is the length of the context
data Context : (n : ℕ) → Set where
  []   : Context zero
  _∷ʳ_ : ∀{n} → Context n → Term n → Context (suc n)

-- n is the size of the outer context; m is the size of the telescope
data Telescope (n : ℕ) : (m : ℕ) →  Set where
  []  : Telescope n zero
  _∷_ : ∀{m} → Term n → Telescope (suc n) m → Telescope n (suc m)

telescopeSize : ∀{n m} → Telescope n m → ℕ
telescopeSize {m = m} _ = m

suc-move : (m n : ℕ) → m + suc n ≡ suc m + n
suc-move zero    n = refl
suc-move (suc m) n = cong suc (+-suc m n)

-- Add a telescope to a compatible outer context.
addToContext : ∀{n m}  → Context n → Telescope n m → Context (n + m)
addToContext {n}            Γ []                rewrite +-identityʳ n = Γ
addToContext {n} {.(suc m)} Γ (_∷_ {m = m} x t) rewrite suc-move n m       = addToContext (Γ ∷ʳ x) t

expandTelescope : ∀ {n m} → Telescope n m → Term (n + m) → Term n
expandTelescope {n} [] T rewrite +-identityʳ n = T
expandTelescope {n} {suc m} (U ∷ Δ) T rewrite suc-move n m =
  pi U (expandTelescope Δ T)

data Pattern (n : ℕ) : Set where
  pvariable      : Var n → Pattern n
  pconstructor   : ConsName → List (Pattern n) → Pattern n
  pinaccesssible : Term n → Pattern n

data Copattern (n : ℕ) : Set where
  capply : Pattern n → Copattern n
  cproj  : ProjName  → Copattern n

record ConsDeclaration (n : ℕ) : Set where
  constructor mkConsDeclaration
  field
    consName : ConsName
    consType : Term n

record ProjDeclaration (n : ℕ) : Set where
  constructor mkProjDeclaration
  field
    projName : ProjName
    projType : Term n

record DataSignature : Set where
  constructor mkDataSignature
  field
    name         : DRName
    {numParams}  : ℕ
    {numIndices} : ℕ
    params       : Telescope zero      numParams
    indices      : Telescope numParams numIndices
    dsort        : Sort

record DataDefinition : Set where
  field
    name         : DRName
    {numParams}  : ℕ
    params       : Telescope zero numParams
    constructors : List (ConsDeclaration numParams)

record RecordSignature : Set where
  constructor mkRecordSignature
  field
    name        : DRName
    {numParams} : ℕ
    params      : Telescope zero numParams
    dsort       : Sort

record RecordDefinition : Set where
  field
    name         : DRName
    {numParams}  : ℕ
    params       : Telescope zero numParams
    fconstructor : ConsName
    fields       : List (ProjDeclaration numParams)

-- TODO: Update spec
record FuncClause : Set where
   field
     ctxSize : ℕ
     ctx   : Context ctxSize
     name  : FuncName
     spine : List (Copattern ctxSize)
     rhs   : Term ctxSize

-- TODO: How to represent pattern variables?
data Declaration : Set where
  typeSignature    : FuncName → Term zero → Declaration
  functionClause   : FuncClause → Declaration
  dataSignature    : DataSignature    → Declaration
  dataDefinition   : DataDefinition   → Declaration
  recordSignature  : RecordSignature  → Declaration
  recordDefinition : RecordDefinition → Declaration

-- TODO: Update signature declarations
data SignatureDeclaration : Set where
  dataSig     : (D : DataSignature) → List (ConsDeclaration (DataSignature.numParams D)) →
                SignatureDeclaration
  recordSig   : (R : RecordSignature) → ConsDeclaration (RecordSignature.numParams R) →
                List (ProjDeclaration (RecordSignature.numParams R)) → SignatureDeclaration
  functionSig : FuncName → Term zero → List FuncClause → SignatureDeclaration

Signature : Set
Signature = List SignatureDeclaration

data LookupSig : Signature → SignatureDeclaration → Set where

  here : ∀{sd sds}
    → LookupSig (sd ∷ sds) sd

  there : ∀{sd sd' sds}
    → LookupSig sds sd
    → LookupSig (sd' ∷ sds) sd

data LookupCons : ∀{m} → List (ConsDeclaration m) → ConsName → Term m → Set where

  here : ∀{c m} {T : Term m} {cs : List (ConsDeclaration m)}
    → LookupCons {m} (mkConsDeclaration c T ∷ cs) c T

  there : ∀{c c' m} {T : Term m} {T' : Term m} {cs : List (ConsDeclaration m)}
    → LookupCons cs c T
    → LookupCons (mkConsDeclaration c' T' ∷ cs) c T

data LookupProj : ∀{m} → List (ProjDeclaration m) → ProjName → Term m → Set where

  here : ∀{π m} {T : Term m} {πs : List (ProjDeclaration m)}
    → LookupProj (mkProjDeclaration π T ∷ πs) π T

  there : ∀ {π π' m} {πs : List (ProjDeclaration m)} {T : Term m} {T' : Term m}
    → LookupProj πs π T
    → LookupProj (mkProjDeclaration π' T' ∷ πs) π T

data SigLookup : ∀{m} → Signature → QName → Term m → Set where
  func : ∀{Σ f T cls} → LookupSig Σ (functionSig f T cls) → SigLookup Σ f T
  dat : ∀{Σ D m m' s cs} {Δ : Telescope zero m} {Δ' : Telescope m m'} →
        LookupSig Σ (dataSig (mkDataSignature D {m} {m'} Δ Δ' s) cs) →
        SigLookup Σ D (expandTelescope Δ (expandTelescope Δ' (sort s)))
  con : ∀{Σ D m m' s cs c T} {Δ : Telescope zero m} {Δ' : Telescope m m'} →
        LookupSig Σ (dataSig (mkDataSignature D {m} {m'} Δ Δ' s) cs) →
        LookupCons cs c T →
        SigLookup Σ c (expandTelescope Δ T)
  rec : ∀{Σ R m s c ps} {Δ : Telescope zero m} →
        LookupSig Σ (recordSig (mkRecordSignature R Δ s) c ps) →
        SigLookup Σ R (expandTelescope Δ (sort s))
  rcon : ∀{Σ R m s c T πs} {Δ : Telescope zero m} →
         LookupSig Σ (recordSig (mkRecordSignature R Δ s) (mkConsDeclaration c T) πs) →
         SigLookup Σ c (expandTelescope Δ T)
  rproj : ∀{Σ R m s c π T πs} {Δ : Telescope zero m} →
          LookupSig Σ (recordSig (mkRecordSignature R Δ s) (mkConsDeclaration c T) πs) →
          LookupProj πs π T →
          SigLookup Σ π (expandTelescope Δ T)


module Relation.Ternary.Separation.Monad where

open import Level
open import Data.Product
open import Function using (_∘_; case_of_)
open import Relation.Unary
open import Relation.Unary.PredicateTransformer hiding (_⊔_)
open import Relation.Binary.PropositionalEquality
open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Morphisms

module Monads
  {a b} {A : Set a}  {B : Set b} {{r}} {u}
  {{as : IsUnitalSep {C = A} r u}}
  {{rb : RawSep B}}
  {{jm : Morphism A B}}
  {{bs : IsUnitalSep rb (Morphism.j jm u)}}
  where

  open Morphism jm

  RawMonad : ∀ {i} (I : Set i) → (ℓ : Level) → Set _
  RawMonad I ℓ = (i j : I) → PT A B ℓ ℓ

  {- strong indexed monads on predicates over PRSAs, relative to the functor induced by the PRSA morphism j -}
  record Monad {i} (I : Set i) ℓ (M : RawMonad I ℓ) : Set (a ⊔ b ⊔ suc ℓ ⊔ i) where
    field
      return : ∀ {P i₁}         → ∀[ P ⇒ⱼ M i₁ i₁ P ]
      bind   : ∀ {P i₁ i₂ i₃ Q} → ∀[ (P ─✴ⱼ M i₂ i₃ Q) ⇒ (M i₁ i₂ P ─✴ M i₁ i₃ Q) ]

    _=<<_ : ∀ {P Q i₁ i₂ i₃} → ∀[ P ⇒ⱼ M i₂ i₃ Q ] → ∀[ M i₁ i₂ P ⇒ M i₁ i₃ Q ]
    f =<< mp = app (bind (wand λ where px σ → case ⊎-id⁻ˡ σ of λ where refl → f px)) mp ⊎-idˡ

    _>>=_ : ∀ {Φ} {P Q i₁ i₂ i₃} → M i₁ i₂ P Φ → ∀[ P ⇒ⱼ M i₂ i₃ Q ] → M i₁ i₃ Q Φ
    mp >>= f = f =<< mp

    mapM′ : ∀ {P Q i₁ i₂} → ∀[ (P ─✴ Q) ⇒ⱼ (M i₁ i₂ P ─✴ M i₁ i₂ Q) ]
    mapM′ f = bind (wand λ where
      px σ →
         case j-⊎⁻ σ of λ where
           (_ , refl , σ') → return (app f px σ'))

    mapM : ∀ {Φ} {P Q i₁ i₂} → M i₁ i₂ P Φ → ∀[ P ⇒ Q ] → M i₁ i₂ Q Φ
    mapM mp f = mp >>= (return ∘ f)

  open Monad ⦃...⦄ public

  -- having the internal bind is enough to get strength
  module _ {i} {I : Set i} {i₁ i₂} {P} {M} {{ _ : Monad I a M }} where
    str  : ∀ {Q : Pred A a} → M i₁ i₂ P Φ₁ → Φ₁ ⊎ j Φ₂ ≣ Φ → Q Φ₂ → M i₁ i₂ (P ✴ Q) Φ
    str mp σ qx = app (bind (wand λ where
      px σ' → case j-⊎⁻ σ' of λ where
        (_ , refl , σ'') → return (px ×⟨ ⊎-comm σ'' ⟩ qx))
      ) mp (⊎-comm σ)

    typed-str : ∀ {Φ₁ Φ₂ Φ} (Q) → M i₁ i₂ P Φ₁ → Φ₁ ⊎ j Φ₂ ≣ Φ → Q Φ₂ → M i₁ i₂ (P ✴ Q) Φ
    typed-str Q mp σ qx = str {Q = Q} mp σ qx

    syntax str mp σ qx = mp &⟨ σ ⟩ qx
    syntax typed-str Q mp σ qx = mp &⟨ Q ∥ σ ⟩ qx

    _&_ : ∀ {Q} → M i₁ i₂ P ε → ∀[ Q ⇒ⱼ M i₁ i₂ (P ✴ Q) ]
    mp & q = mp &⟨ ⊎-idˡ ⟩ q


module Categories.Families where

open import Library
open import Categories

open Cat

Fam : Set → Cat
Fam I = record {
  Obj  = I → Set;
  Hom  = λ A B → ∀ {i} → A i → B i;
  iden = id;
  comp = λ f g → f ∘ g;
  idl  = refl;
  idr  = refl;
  ass  = refl}


module ProofRep where

import Prelude
import Logic.Relations
import Logic.Identity
import Data.Nat
import Data.Nat.Properties

open Prelude
open Data.Nat hiding (_==_; _≡_)
open Data.Nat.Properties
open Logic.Relations

module Foo (Var : Set) where

  data _==_ : (x y : Var) -> Set where
    cRefl  : {x : Var} -> x == x
    cSym   : {x y : Var} -> y == x -> x == y
    cTrans : {x y z : Var} -> x == z -> z == y -> x == y
    cAxiom : {x y : Var} -> x == y

  data Axioms {A : Set}(_≈_ : Rel A)([_] : Var -> A) : Set where
    noAxioms   : Axioms _≈_ [_]
    anAxiom    : (x y : Var) -> [ x ] ≈ [ y ] -> Axioms _≈_ [_]
    manyAxioms : Axioms _≈_ [_] -> Axioms _≈_ [_] -> Axioms _≈_ [_]

  refl : {x : Var} -> x == x
  refl = cRefl

  sym : {x y : Var} -> x == y -> y == x
  sym (cRefl xy)     = cRefl (Var.sym xy)
  sym  cAxiom        = cSym cAxiom
  sym (cSym p)       = p
  sym (cTrans z p q) = cTrans z (sym q) (sym p)

  trans : {x y z : Var} -> x == y -> y == z -> x == z
  trans {x}{y}{z} (cRefl xy) q     = Var.subst (\w -> w == z) (Var.sym xy) q
  trans {x}{y}{z} p (cRefl yz)     = Var.subst (\w -> x == w) yz p
  trans {x}{y}{z} (cTrans w p q) r = cTrans w p (trans q r)
  trans           p q              = cTrans _ p q


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Constraints( x : X) where
  open X(x)

  data Strata : Set where
    Flat : Strata
    Extended : Strata

  data Implication (knot : Set → Set)(n : Set) : Set where
    ∃_·_⊃_ : (v : ℕ) → QConstraint n → knot (n ⨁ v) → Implication knot n

  {- SYNTAX -}
  data Constraint (n : Set) : Strata → Set where
    QC : ∀ {x} → QConstraint n → Constraint n x
    Imp : Implication (λ n → Constraint n Flat) n → Constraint n Flat
    Imp′ : QConstraint n → Constraint n Extended → Constraint n Extended
    _∧′_ : ∀ {x} → Constraint n x → Constraint n x → Constraint n x
    Ⅎ_ : Constraint (Ⓢ n) Extended → Constraint n Extended

  ε′ : ∀ {n}{x} → Constraint n x
  ε′ = QC ε

  _∼′_ : ∀ {n}{x} → Type n → Type n → Constraint n x
  τ₁ ∼′ τ₂ = QC (τ₁ ∼ τ₂)

  Ⅎ′_·_ : {n : Set}(v : ℕ) → Constraint (n ⨁ v) Extended → Constraint n Extended
  Ⅎ′ (suc n) · c = Ⅎ (Ⅎ′ n · c)
  Ⅎ′ zero · c = c

  infixl 6 Ⅎ′_·_
{-
  toAE : {n : Set}{s : Strata} → Constraint n s → Constraint n Extended
  toAE (QC x) = QC x
  toAE (a ∧′ b) = toAE a ∧′ toAE b
  toAE (Imp (∃ n · Q ⊃ C)) = Imp (∃ n · Q ⊃ toAE C)
  toAE (Ⅎ c) = Ⅎ c
-}
  infixl 6 Ⅎ_

  infixl 7 _∧′_

  {- INSTANCES -}
  private
    pn-is-functor = λ {n} → Monad.is-functor (PlusN-is-monad {n})
    module PlusN-f n = Functor (Monad.is-functor (PlusN-is-monad {n}))
    module Ⓢ-f = Functor Ⓢ-is-functor
    module Type-f = Functor (type-is-functor)
    module QC-f = Functor (qconstraint-is-functor)

  private
    fmap-c : ∀ {s}{a b} → (a → b) → Constraint a s → Constraint b s
    fmap-c f (QC x) = QC (QC-f.map f x)
    fmap-c f (C₁ ∧′ C₂) = (fmap-c f C₁) ∧′ (fmap-c f C₂)
    fmap-c f (Imp′ Q C) = Imp′ (QC-f.map f Q) (fmap-c f C)
    fmap-c f (Imp (∃ n · Q ⊃ C)) = Imp (∃ n · (QC-f.map f Q) ⊃ (fmap-c (pn.map f) C))
      where module pn = PlusN-f n
    fmap-c f (Ⅎ C) = Ⅎ (fmap-c (Ⓢ-f.map f) C)
    fmap-c-id : ∀{s}{A : Set} {f : A → A} → isIdentity f → isIdentity (fmap-c {s} f)
    fmap-c-id {f = f} isid {QC x       } = cong QC (QC-f.identity isid)
    fmap-c-id {f = f} isid {Imp′ Q C   } = cong₂ Imp′ (QC-f.identity isid) (fmap-c-id isid)
    fmap-c-id {f = f} isid {Imp(∃ n · Q ⊃ C)} = cong Imp
                                                     (cong₂ (∃_·_⊃_ n)
                                                            (QC-f.identity isid)
                                                            (fmap-c-id (pn.identity isid)))
        where module pn = PlusN-f n
    fmap-c-id {f = f} isid {C₁ ∧′ C₂} = cong₂ _∧′_ (fmap-c-id isid) (fmap-c-id isid)
    fmap-c-id {f = f} isid {Ⅎ C    }  = cong Ⅎ_ (fmap-c-id (Ⓢ-f.identity isid))
    fmap-c-comp : {s : Strata}{A B C : Set} {f : A → B} {g : B → C} {x : Constraint A s}
                → fmap-c (g ∘ f) x ≡ fmap-c g (fmap-c f x)
    fmap-c-comp {x = QC x} = cong QC QC-f.composite
    fmap-c-comp {x = Imp′ Q C} = cong₂ Imp′ (QC-f.composite) (fmap-c-comp)
    fmap-c-comp {x = C₁ ∧′ C₂} = cong₂ _∧′_ (fmap-c-comp {x = C₁}) (fmap-c-comp {x = C₂})
    fmap-c-comp {x = Ⅎ C} = cong Ⅎ_ (combine-composite′ ⦃ Ⓢ-is-functor ⦄ fmap-c fmap-c-comp)
    fmap-c-comp {x = Imp(∃ n · Q ⊃ C)} = cong Imp
                                              (cong₂ (∃_·_⊃_ n) QC-f.composite
                                                     (combine-composite′ ⦃ pn-is-functor {n}⦄
                                                                         fmap-c fmap-c-comp))
      where module pn = PlusN-f n

  constraint-is-functor : ∀ {s : Strata} → Functor (λ n → Constraint n s)
  constraint-is-functor = record { map = fmap-c
                                 ; identity = fmap-c-id
                                 ; composite = fmap-c-comp
                                 }


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for standard evaluation with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Denotation.Value where

open import Nehemiah.Syntax.Type public
open import Nehemiah.Change.Type public
open import Base.Denotation.Notation public

open import Structure.Bag.Nehemiah
open import Data.Integer

import Parametric.Denotation.Value Base as Value

⟦_⟧Base : Value.Structure
⟦ base-int ⟧Base = ℤ
⟦ base-bag ⟧Base = Bag

open Value.Structure ⟦_⟧Base public


{-# OPTIONS --safe #-}
module Cubical.Algebra.AbGroup.Instances.Unit where

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

open import Cubical.Data.Unit renaming (Unit* to UnitType)

open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Group.Instances.Unit using (UnitGroup)
open import Cubical.Algebra.Group.Base using (GroupStr)

private
  variable
    ℓ : Level

open AbGroupStr
open IsAbGroup

UnitAbGroup : AbGroup ℓ
fst UnitAbGroup = UnitType
0g (snd UnitAbGroup) = tt*
_+_ (snd UnitAbGroup) = λ _ _ → tt*
- snd UnitAbGroup = λ _ → tt*
isGroup (isAbGroup (snd UnitAbGroup)) = GroupStr.isGroup (snd UnitGroup)
+Comm (isAbGroup (snd UnitAbGroup)) = λ _ _ → refl