module Type.Lemmas where

open import Context
open import Type.Core

open import Function
open import Data.Unit.Base
open import Relation.Binary.PropositionalEquality

foldlᶜ-▻-ε : ∀ {α} {A : Set α} -> (Θ : Con A) -> foldlᶜ _▻_ ε Θ ≡ Θ
foldlᶜ-▻-ε  ε      = refl
foldlᶜ-▻-ε (Γ ▻ σ) = cong (_▻ σ) (foldlᶜ-▻-ε Γ)

-- Same as `mapᶜ f (Γ ▻▻ Δ) ≡ mapᶜ f Γ ▻▻ mapᶜ f Δ`, but we fully inline the definitions,
-- because the REWRITE pragma requires that.
mapᶜ-▻▻
  : ∀ {α β} {A : Set α} {B : Set β} {f : A -> B} {Γ : Con A}
  -> ∀ Δ ->
      foldlᶜ (λ Ξ σ -> Ξ ▻ f σ) ε (foldlᶜ _▻_ Γ Δ)
    ≡ foldlᶜ _▻_ (foldlᶜ (λ Ξ σ -> Ξ ▻ f σ) ε Γ) (foldlᶜ (λ Ξ σ -> Ξ ▻ f σ) ε Δ)
mapᶜ-▻▻  ε      = refl
mapᶜ-▻▻ (Δ ▻ τ) = cong (_▻ _) (mapᶜ-▻▻ Δ)

keep-id : ∀ {α} {A : Set α} {Γ : Con A} {σ τ} -> (v : σ ∈ Γ ▻ τ) -> keep id v ≡ v
keep-id  vz    = refl
keep-id (vs v) = refl

keep-keep
  : ∀ {α} {A : Set α} {Γ Δ Ξ : Con A} {σ τ}
  -> (κ : Δ ⊆ Ξ) -> (ι : Γ ⊆ Δ) -> (v : σ ∈ Γ ▻ τ) -> keep κ (keep ι v) ≡ keep (κ ∘ ι) v
keep-keep κ ι  vz    = refl
keep-keep κ ι (vs v) = refl

dupl-keep-vs
  : ∀ {α} {A : Set α} {Γ Δ : Con A} {σ τ}
  -> (ι : Γ ⊆ Δ) -> (v : σ ∈ Γ ▻ τ) -> dupl (keep (vs_ ∘ ι) v) ≡ keep ι v
dupl-keep-vs ι  vz    = refl
dupl-keep-vs ι (vs v) = refl

inject-foldr-poly
  : ∀ {α β γ} {A : Set α} {B : Set β} {yᶠ yᵍ}
  -> (C : B -> Set γ)
  -> (h : ∀ {yʰ} -> C yʰ -> C yʰ -> C yʰ)
  -> (g : C yᶠ -> C yᵍ)
  -> (∀ {y z} -> h (g y) (g z) ≡ g (h y z))
  -> (f : A -> C yᶠ)
  -> (Γ : Con A)
  -> (z : C yᶠ)
  -> g (foldrᶜ (h ∘ f) z Γ) ≡ foldrᶜ (h ∘ g ∘ f) (g z) Γ
inject-foldr-poly C h g dist f  ε      y = refl
inject-foldr-poly C h g dist f (Γ ▻ x) y
  rewrite dist {f x} {y} = inject-foldr-poly C h g dist f Γ (h (f x) y)

inject-foldr-mono
  : ∀ {α β} {A : Set α} {B : Set β}
  -> (h : B -> B -> B)
  -> (g : B -> B)
  -> (∀ {y z} -> h (g y) (g z) ≡ g (h y z))
  -> (f : A -> B)
  -> (Γ : Con A)
  -> (y : B)
  -> g (foldrᶜ (h ∘ f) y Γ) ≡ foldrᶜ (h ∘ g ∘ f) (g y) Γ
inject-foldr-mono h g dist f Γ y = inject-foldr-poly {B = ⊤} _ h g dist f Γ y

keep-eq
  : ∀ {α} {A : Set α} {Θ Ξ : Con A} {σ} (ι κ : Θ ⊆ Ξ)
  -> (∀ {τ} -> (v : τ ∈ Θ)     -> renᵛ       ι  v ≡ renᵛ       κ  v)
  -> (∀ {τ} -> (v : τ ∈ Θ ▻ σ) -> renᵛ (keep ι) v ≡ renᵛ (keep κ) v)
keep-eq ι κ q  vz    = refl
keep-eq ι κ q (vs v) = cong vs_ (q v)

renᵗ-ext
  : ∀ {Θ Ξ σ} (ι κ : Θ ⊆ Ξ) (α : Θ ⊢ᵗ σ)
  -> (∀ {τ} -> (v : τ ∈ Θ) -> renᵛ ι v ≡ renᵛ κ v)
  -> renᵗ ι α ≡ renᵗ κ α
renᵗ-ext ι κ (Var v) q = cong  Var (q v)
renᵗ-ext ι κ (Lam β) q = cong Lam_ (renᵗ-ext (keep ι) (keep κ) β (keep-eq ι κ q))
renᵗ-ext ι κ (φ ∙ α) q = cong₂ _∙_ (renᵗ-ext ι κ φ q) (renᵗ-ext ι κ α q)
renᵗ-ext ι κ (α ⇒ β) q = cong₂ _⇒_ (renᵗ-ext ι κ α q) (renᵗ-ext ι κ β q)
renᵗ-ext ι κ (π σ β) q = cong (π σ) (renᵗ-ext (keep ι) (keep κ) β (keep-eq ι κ q))
renᵗ-ext ι κ (μ ψ α) q = cong₂ μ (renᵗ-ext ι κ ψ q) (renᵗ-ext ι κ α q)

renᵗ-keep-keep
  : ∀ {Θ Ξ Ω σ τ} (κ : Ξ ⊆ Ω) (ι : Θ ⊆ Ξ) (β : Θ ▻ σ ⊢ᵗ τ)
  -> renᵗ (keep κ ∘ keep ι) β ≡ renᵗ (keep (κ ∘ ι)) β
renᵗ-keep-keep κ ι β = renᵗ-ext (keep κ ∘ keep ι) (keep (κ ∘ ι)) β λ
  {  vz    -> refl
  ; (vs v) -> refl
  }

renᵗ-∘
  : ∀ {Θ Ξ Ω σ} (κ : Ξ ⊆ Ω) (ι : Θ ⊆ Ξ) (α : Θ ⊢ᵗ σ)
  -> renᵗ κ (renᵗ ι α) ≡ renᵗ (κ ∘ ι) α
renᵗ-∘ κ ι (Var v) = refl
renᵗ-∘ κ ι (Lam β) = cong Lam_ (trans (renᵗ-∘ (keep κ) (keep ι) β) (renᵗ-keep-keep κ ι β))
renᵗ-∘ κ ι (f ∙ α) = cong₂ _∙_ (renᵗ-∘ κ ι f) (renᵗ-∘ κ ι α)
renᵗ-∘ κ ι (α ⇒ β) = cong₂ _⇒_  (renᵗ-∘ κ ι α) (renᵗ-∘ κ ι β)
renᵗ-∘ κ ι (π σ β) = cong (π σ) (trans (renᵗ-∘ (keep κ) (keep ι) β) (renᵗ-keep-keep κ ι β))
renᵗ-∘ κ ι (μ ψ α) = cong₂ μ (renᵗ-∘ κ ι ψ) (renᵗ-∘ κ ι α)

renᵗ-keep-id
  : ∀ {Θ σ τ} (β : Θ ▻ σ ⊢ᵗ τ)
  -> renᵗ (keep id) β ≡ renᵗ id β
renᵗ-keep-id β = renᵗ-ext (keep id) id β λ
  {  vz    -> refl
  ; (vs v) -> refl
  }

renᵗ-id : ∀ {Θ σ} (α : Θ ⊢ᵗ σ) -> renᵗ id α ≡ α
renᵗ-id (Var v) = refl
renᵗ-id (Lam β) = cong Lam_ (trans (renᵗ-keep-id β) (renᵗ-id β))
renᵗ-id (φ ∙ α) = cong₂ _∙_ (renᵗ-id φ) (renᵗ-id α)
renᵗ-id (α ⇒ β) = cong₂ _⇒_ (renᵗ-id α) (renᵗ-id β)
renᵗ-id (π σ β) = cong (π σ) (trans (renᵗ-keep-id β) (renᵗ-id β))
renᵗ-id (μ ψ α) = cong₂ μ (renᵗ-id ψ) (renᵗ-id α)

module EnvironmentLemmas
    {α β} {A : Set α} {_◆_ : Con A -> A -> Set β}
    (environment : Environment _◆_) where
  open Environment environment

  keepᵉ-eq
    : ∀ {Θ Ξ : Con A} {σ} (ρ χ : Ξ ⊢ᵉ Θ)
    -> (∀ {τ} -> (v : τ ∈ Θ)     -> lookupᵉ v        ρ  ≡ lookupᵉ v        χ )
    -> (∀ {τ} -> (v : τ ∈ Θ ▻ σ) -> lookupᵉ v (keepᵉ ρ) ≡ lookupᵉ v (keepᵉ χ))
  keepᵉ-eq ρ χ q  vz    = refl
  keepᵉ-eq ρ χ q (vs v) = cong (renᵈ vs_) (q v)

module _ where
  open TypeEnv
  open EnvironmentLemmas environmentᵗ

  subᵗ-ext
    : ∀ {Θ Ξ σ} (ρ χ : Ξ ⊢ᵗᵉ Θ) (α : Θ ⊢ᵗ σ)
    -> (∀ {τ} -> (v : τ ∈ Θ) -> lookupᵉ v ρ ≡ lookupᵉ v χ)
    -> subᵗ ρ α ≡ subᵗ χ α
  subᵗ-ext ρ χ (Var v) q = q v
  subᵗ-ext ρ χ (Lam β) q = cong Lam_ (subᵗ-ext (keepᵉ ρ) (keepᵉ χ) β (keepᵉ-eq ρ χ q))
  subᵗ-ext ρ χ (φ ∙ α) q = cong₂ _∙_ (subᵗ-ext ρ χ φ q) (subᵗ-ext ρ χ α q)
  subᵗ-ext ρ χ (α ⇒ β) q = cong₂ _⇒_ (subᵗ-ext ρ χ α q) (subᵗ-ext ρ χ β q)
  subᵗ-ext ρ χ (π σ β) q = cong (π σ) (subᵗ-ext (keepᵉ ρ) (keepᵉ χ) β (keepᵉ-eq ρ χ q))
  subᵗ-ext ρ χ (μ ψ α) q = cong₂ μ (subᵗ-ext ρ χ ψ q) (subᵗ-ext ρ χ α q)

  subᵗ-keepᵉ-keep
    : ∀ {Θ Ξ Ω σ τ} (ρ : Ω ⊢ᵗᵉ Ξ) (ι : Θ ⊆ Ξ) (β : Θ ▻ σ ⊢ᵗ τ)
    -> subᵗ (keepᵉ ρ ∘ᵉ keep ι) β ≡ subᵗ (keepᵉ (ρ ∘ᵉ ι)) β
  subᵗ-keepᵉ-keep ρ ι β = subᵗ-ext (keepᵉ ρ ∘ᵉ keep ι) (keepᵉ (ρ ∘ᵉ ι)) β λ
    {  vz    -> refl
    ; (vs v) -> refl
    }

  subᵗ-renᵗ
    : ∀ {Θ Ξ Ω σ} (ρ : Ω ⊢ᵗᵉ Ξ) (ι : Θ ⊆ Ξ) (α : Θ ⊢ᵗ σ)
    -> subᵗ ρ (renᵗ ι α) ≡ subᵗ (ρ ∘ᵉ ι) α
  subᵗ-renᵗ ρ ι (Var v) = refl
  subᵗ-renᵗ ρ ι (Lam β) = cong Lam_ (trans (subᵗ-renᵗ (keepᵉ ρ) (keep ι) β) (subᵗ-keepᵉ-keep ρ ι β))
  subᵗ-renᵗ ρ ι (φ ∙ α) = cong₂ _∙_ (subᵗ-renᵗ ρ ι φ) (subᵗ-renᵗ ρ ι α)
  subᵗ-renᵗ ρ ι (α ⇒ β) = cong₂ _⇒_ (subᵗ-renᵗ ρ ι α) (subᵗ-renᵗ ρ ι β)
  subᵗ-renᵗ ρ ι (π σ β) = cong (π σ) (trans (subᵗ-renᵗ (keepᵉ ρ) (keep ι) β) (subᵗ-keepᵉ-keep ρ ι β))
  subᵗ-renᵗ ρ ι (μ ψ α) = cong₂ μ (subᵗ-renᵗ ρ ι ψ) (subᵗ-renᵗ ρ ι α)

  subᵗ-keepᵉ-idᵉ
    : ∀ {Θ σ τ} (β : Θ ▻ σ ⊢ᵗ τ)
    -> subᵗ (keepᵉ idᵉ) β ≡ subᵗ idᵉ β
  subᵗ-keepᵉ-idᵉ β = subᵗ-ext (keepᵉ idᵉ) idᵉ β λ
    {  vz    -> refl
    ; (vs v) -> refl
    }

  subᵗ-idᵉ
    : ∀ {Θ σ} (α : Θ ⊢ᵗ σ)
    -> subᵗ idᵉ α ≡ α
  subᵗ-idᵉ (Var v) = refl
  subᵗ-idᵉ (Lam β) = cong Lam_ (trans (subᵗ-keepᵉ-idᵉ β) (subᵗ-idᵉ β))
  subᵗ-idᵉ (φ ∙ α) = cong₂ _∙_ (subᵗ-idᵉ φ) (subᵗ-idᵉ α)
  subᵗ-idᵉ (α ⇒ β) = cong₂ _⇒_ (subᵗ-idᵉ α) (subᵗ-idᵉ β)
  subᵗ-idᵉ (π σ β) = cong (π σ) (trans (subᵗ-keepᵉ-idᵉ β) (subᵗ-idᵉ β))
  subᵗ-idᵉ (μ ψ α) = cong₂ μ (subᵗ-idᵉ ψ) (subᵗ-idᵉ α)

  subᵗ-keepᵉ-Var
    : ∀ {Θ Ξ σ τ} (ι : Θ ⊆ Ξ) (β : Θ ▻ σ ⊢ᵗ τ)
    -> subᵗ (keepᵉ (PackEnv (Var ∘ ι))) β ≡ subᵗ (PackEnv (Var ∘ keep ι)) β
  subᵗ-keepᵉ-Var ι β = subᵗ-ext (keepᵉ (PackEnv (Var ∘ ι))) (PackEnv (Var ∘ keep ι)) β λ
    {  vz    -> refl
    ; (vs v) -> refl
    }

  subᵗ-Var
    : ∀ {Θ Ξ σ} (ι : Θ ⊆ Ξ) (α : Θ ⊢ᵗ σ)
    -> subᵗ (PackEnv (Var ∘ ι)) α ≡ renᵗ ι α
  subᵗ-Var ι (Var v) = refl
  subᵗ-Var ι (Lam β) = cong Lam_ (trans (subᵗ-keepᵉ-Var ι β) (subᵗ-Var (keep ι) β))
  subᵗ-Var ι (φ ∙ α) = cong₂ _∙_ (subᵗ-Var ι φ) (subᵗ-Var ι α)
  subᵗ-Var ι (α ⇒ β) = cong₂ _⇒_ (subᵗ-Var ι α) (subᵗ-Var ι β)
  subᵗ-Var ι (π σ β) = cong (π σ) (trans (subᵗ-keepᵉ-Var ι β) (subᵗ-Var (keep ι) β))
  subᵗ-Var ι (μ ψ α) = cong₂ μ (subᵗ-Var ι ψ) (subᵗ-Var ι α)

inject-foldr-⇒-renᵗ
  : ∀ {Θ Ξ Ω} {f : Star Θ -> Star Ξ}
  -> ∀ Δ
  -> (ι : Ξ ⊆ Ω)
  -> (β : Star Ξ)
  -> renᵗ ι (conToTypeBy f Δ β) ≡ conToTypeBy (renᵗ ι ∘ f) Δ (renᵗ ι β)
inject-foldr-⇒-renᵗ Δ ι β = inject-foldr-poly Star _⇒_ (renᵗ ι) refl _ Δ β

inject-foldr-⇒-subᵗ
  : ∀ {Θ Ξ Ω} {f : Star Θ -> Star Ξ}
  -> ∀ Δ
  -> (ρ : Ω TypeEnv.⊢ᵉ Ξ)
  -> (β : Star Ξ)
  -> subᵗ ρ (conToTypeBy f Δ β) ≡ conToTypeBy (subᵗ ρ ∘ f) Δ (subᵗ ρ β)
inject-foldr-⇒-subᵗ Δ ρ β = inject-foldr-poly Star _⇒_ (subᵗ ρ) refl _ Δ β


open import Prelude

module Implicits.Resolution.Infinite.Resolution where

open import Coinduction
open import Data.Fin.Substitution
open import Data.List
open import Data.List.Any.Membership using (map-mono)
open import Data.List.Any
open Membership-≡

open import Implicits.Syntax
open import Implicits.Substitutions

module Coinductive where
  infixl 5 _⊢ᵣ_ _⊢_↓_

  mutual
    data _⊢_↓_ {ν} (Δ : ICtx ν) : Type ν → SimpleType ν → Set where
      i-simp : ∀ a → Δ ⊢ simpl a ↓ a
      i-iabs : ∀ {ρ₁ ρ₂ a} → ∞ (Δ ⊢ᵣ ρ₁) → Δ ⊢ ρ₂ ↓ a → Δ ⊢ ρ₁ ⇒ ρ₂ ↓ a
      i-tabs : ∀ {ρ a} b → Δ ⊢ ρ tp[/tp b ] ↓ a → Δ ⊢ ∀' ρ ↓ a

    data _⊢ᵣ_ {ν} (Δ : ICtx ν) : Type ν → Set where
      r-simp : ∀ {r τ} → (r ∈ Δ) → Δ ⊢ r ↓ τ → Δ ⊢ᵣ simpl τ
      r-iabs : ∀ {ρ₁ ρ₂} → ((ρ₁ ∷ Δ) ⊢ᵣ ρ₂) → Δ ⊢ᵣ (ρ₁ ⇒ ρ₂)
      r-tabs : ∀ {ρ} → (ictx-weaken Δ ⊢ᵣ ρ) → Δ ⊢ᵣ ∀' ρ

  mutual
    -- extending contexts is safe: it preserves the r ↓ a relation
    -- (this is not true for Oliveira's deterministic calculus)
    ⊆-r↓a : ∀ {ν} {Δ Δ' : ICtx ν} {a r} → Δ ⊢ r ↓ a → Δ ⊆ Δ' → Δ' ⊢ r ↓ a
    ⊆-r↓a (i-simp a) _ = i-simp a
    ⊆-r↓a (i-iabs x₁ x₂) f = i-iabs (♯ (⊆-Δ⊢a (♭ x₁) f)) (⊆-r↓a x₂ f)
    ⊆-r↓a (i-tabs b x₁) f = i-tabs b (⊆-r↓a x₁ f)

    -- extending contexts is safe: it preserves the ⊢ᵣ a relation
    -- (this is not true for Oliveira's deterministic calculus)
    ⊆-Δ⊢a : ∀ {ν} {Δ Δ' : ICtx ν} {a} → Δ ⊢ᵣ a → Δ ⊆ Δ' → Δ' ⊢ᵣ a
    ⊆-Δ⊢a (r-simp x₁ x₂) f = r-simp (f x₁) (⊆-r↓a x₂ f)
    ⊆-Δ⊢a (r-iabs x₁) f =
      r-iabs (⊆-Δ⊢a x₁ (λ{ (here px) → here px ; (there x₂) → there (f x₂) }))
    ⊆-Δ⊢a (r-tabs x) f = r-tabs (⊆-Δ⊢a x f')
      where
        f' = map-mono (flip TypeSubst._/_ TypeSubst.wk) f

module Inductive where
  infixl 5 _⊢ᵣ_ _⊢_↓_

  mutual
    data _⊢_↓_ {ν} (Δ : ICtx ν) : Type ν → SimpleType ν → Set where
      i-simp : ∀ a → Δ ⊢ simpl a ↓ a
      i-iabs : ∀ {ρ₁ ρ₂ a} → (Δ ⊢ᵣ ρ₁) → Δ ⊢ ρ₂ ↓ a → Δ ⊢ ρ₁ ⇒ ρ₂ ↓ a
      i-tabs : ∀ {ρ a} b → Δ ⊢ ρ tp[/tp b ] ↓ a → Δ ⊢ ∀' ρ ↓ a

    data _⊢ᵣ_ {ν} (Δ : ICtx ν) : Type ν → Set where
      r-simp : ∀ {r τ} → (r ∈ Δ) → Δ ⊢ r ↓ τ → Δ ⊢ᵣ simpl τ
      r-iabs : ∀ {ρ₁ ρ₂} → ((ρ₁ ∷ Δ) ⊢ᵣ ρ₂) → Δ ⊢ᵣ (ρ₁ ⇒ ρ₂)
      r-tabs : ∀ {ρ} → (ictx-weaken Δ ⊢ᵣ ρ) → Δ ⊢ᵣ ∀' ρ

  mutual -- extending contexts is safe: it preserves the r ↓ a relation
    -- (this is not true for Oliveira's deterministic calculus)
    ⊆-r↓a : ∀ {ν} {Δ Δ' : ICtx ν} {a r} → Δ ⊢ r ↓ a → Δ ⊆ Δ' → Δ' ⊢ r ↓ a
    ⊆-r↓a (i-simp a) _ = i-simp a
    ⊆-r↓a (i-iabs x₁ x₂) f = i-iabs (⊆-Δ⊢a x₁ f) (⊆-r↓a x₂ f)
    ⊆-r↓a (i-tabs b x₁) f = i-tabs b (⊆-r↓a x₁ f)

    -- extending contexts is safe: it preserves the ⊢ᵣ a relation
    -- (this is not true for Oliveira's deterministic calculus)
    ⊆-Δ⊢a : ∀ {ν} {Δ Δ' : ICtx ν} {a} → Δ ⊢ᵣ a → Δ ⊆ Δ' → Δ' ⊢ᵣ a
    ⊆-Δ⊢a (r-simp x₁ x₂) f = r-simp (f x₁) (⊆-r↓a x₂ f)
    ⊆-Δ⊢a (r-iabs x₁) f =
      r-iabs (⊆-Δ⊢a x₁ (λ{ (here px) → here px ; (there x₂) → there (f x₂) }))
    ⊆-Δ⊢a (r-tabs x) f = r-tabs (⊆-Δ⊢a x f')
      where
        f' = map-mono (flip TypeSubst._/_ TypeSubst.wk) f

open Inductive public


{-# OPTIONS --no-universe-polymorphism #-}

module Issue202 where

open import Common.Level
open import Imports.Test

module Test2 {ℓ : Level} (F : Foo ℓ) where

-- Test2.agda:4,31-36
-- The metavariable _1 cannot depend on ℓ because it does not depend
-- on any variables
-- when checking that the expression Foo ℓ has type _1

-- The code is accepted if universe polymorphism is turned on in
-- Test2.agda.


module Prelude.Equality.Unsafe where

open import Prelude.Equality
open import Prelude.Empty
open import Prelude.Erased

open import Agda.Builtin.TrustMe

-- unsafeEqual {x = x} {y = y} evaluates to refl if x and y are
-- definitionally equal.
unsafeEqual : ∀ {a} {A : Set a} {x y : A} → x ≡ y
unsafeEqual = primTrustMe

{-# DISPLAY primTrustMe = [erased] #-}

-- Used in decidable equality for primitive types (String, Char and Float)
unsafeNotEqual : ∀ {a} {A : Set a} {x y : A} → ¬ (x ≡ y)
unsafeNotEqual _ = erase-⊥ trustme
  where postulate trustme : ⊥

-- Erase an equality proof. Throws away the actual proof
-- and replaces it by unsafeEqual.
eraseEquality : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≡ y
eraseEquality _ = unsafeEqual

unsafeCoerce : ∀ {a} {A : Set a} {B : Set a} → A → B
unsafeCoerce {A = A} {B} x with unsafeEqual {x = A} {y = B}
unsafeCoerce x | refl = x


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

module Data.Product.NAry where

open import Data.Sigma
open import Prelude hiding (⊤; tt)
open import Data.Unit.UniversePolymorphic
open import Path.Reasoning

private
  variable
    n : ℕ
    ℓ : Level

Levels : ℕ → Type
Levels zero = ⊤
Levels (suc n) = Level × Levels n

private
  variable
    ls : Levels n

max-level : Levels n → Level
max-level {zero} _ = ℓzero
max-level {suc n} (x , xs) =
  x ℓ⊔ max-level xs

Types : ∀ n → (ls : Levels n) → Type (ℓsuc (max-level ls))
Types zero ls = ⊤
Types (suc n) (l , ls) = Type l × Types n ls

⦅_⦆⁺ :  Types (suc n) ls →
        Type (max-level ls)
⦅_⦆⁺ {n = zero } (X , Xs) = X
⦅_⦆⁺ {n = suc n} (X , Xs) = X × ⦅ Xs ⦆⁺

⦅_⦆ :  Types n ls →
       Type (max-level ls)
⦅_⦆ {n = zero} _ = ⊤
⦅_⦆ {n = suc n} = ⦅_⦆⁺ {n = n}

map-types : (fn : ∀ {ℓ} → Type ℓ → Type ℓ) → ∀ {n ls} → Types n ls → Types n ls
map-types fn {zero} xs = xs
map-types fn {suc n} (x , xs) = fn x , map-types fn xs

data ArgForm : Type where expl impl inst : ArgForm

infixr 0 _[_]→_
_[_]→_ : Type a → ArgForm → Type b → Type (a ℓ⊔ b)
A [ expl  ]→ B =         A    → B
A [ impl  ]→ B = {  _ :  A }  → B
A [ inst  ]→ B = ⦃  _ :  A ⦄  → B

[_$] : ∀ form → (A [ form ]→ B) ⇔ (A → B)
[ expl $] .fun f = f
[ impl $] .fun f x = f {x}
[ inst $] .fun f x = f ⦃ x ⦄
[ expl $] .inv f = f
[ impl $] .inv f {x} = f x
[ inst $] .inv f ⦃ x ⦄ = f x
[ expl $] .leftInv f = refl
[ impl $] .leftInv f = refl
[ inst $] .leftInv f = refl
[ expl $] .rightInv f = refl
[ impl $] .rightInv f = refl
[ inst $] .rightInv f = refl

infixr 0 pi-arr
pi-arr : (A : Type a) → ArgForm → (A → Type b) → Type (a ℓ⊔ b)
pi-arr A expl B = (x : A) → B x
pi-arr A impl B = {x : A} → B x
pi-arr A inst B = ⦃ x : A ⦄ → B x

syntax pi-arr a f (λ x → b ) = x ⦂ a Π[ f ]→ b
Π[_$] : ∀ {B : A → Type b} fr → (x ⦂ A Π[ fr ]→ B x) ⇔ ((x : A) → B x)
Π[ expl $] .fun f = f
Π[ impl $] .fun f x = f {x}
Π[ inst $] .fun f x = f ⦃ x ⦄
Π[ expl $] .inv f x = f x
Π[ impl $] .inv f {x} = f x
Π[ inst $] .inv f ⦃ x ⦄ = f x
Π[ expl $] .leftInv f = refl
Π[ impl $] .leftInv f = refl
Π[ inst $] .leftInv f = refl
Π[ expl $] .rightInv f = refl
Π[ impl $] .rightInv f = refl
Π[ inst $] .rightInv f = refl

infixr 0 ⦅_⦆[_]→_
⦅_⦆[_]→_ : Types n ls → ArgForm → Type ℓ → Type (max-level ls ℓ⊔ ℓ)
⦅_⦆[_]→_ {n = zero}  Xs fr Y = Y
⦅_⦆[_]→_ {n = suc n} (X , Xs) fr Y = X [ fr ]→ ⦅ Xs ⦆[ fr ]→ Y

infixr 0 pi-arrs-plus
pi-arrs-plus :
  (Xs : Types (suc n) ls) →
  ArgForm →
  (y : ⦅ Xs ⦆⁺ → Type ℓ) →
  Type (max-level ls ℓ⊔ ℓ)
pi-arrs-plus {n = zero   } (X , Xs) fr Y = x ⦂ X Π[ fr ]→ Y x
pi-arrs-plus {n = suc n  } (X , Xs) fr Y =
  x ⦂ X Π[ fr ]→ xs ⦂⦅ Xs ⦆⁺Π[ fr ]→ Y (x , xs)

syntax pi-arrs-plus Xs fr (λ xs → Y) = xs ⦂⦅ Xs ⦆⁺Π[ fr ]→ Y

pi-arrs : ∀ {n ls ℓ} → (Xs : Types n ls) → ArgForm → (y : ⦅ Xs ⦆ → Type ℓ) → Type (max-level ls ℓ⊔ ℓ)
pi-arrs {n = zero} xs fr Y = Y tt
pi-arrs {n = suc n} = pi-arrs-plus
syntax pi-arrs Xs fr (λ xs → Y) = xs ⦂⦅ Xs ⦆Π[ fr ]→ Y

[_^_$]⁺↓ : ∀ n {ls ℓ} f {Xs : Types (suc n) ls} {y : Type ℓ} → (⦅ Xs ⦆⁺ → y) → ⦅ Xs ⦆[ f ]→ y
[ zero  ^ fr $]⁺↓ f = [ fr $] .inv f
[ suc n ^ fr $]⁺↓ f = [ fr $] .inv ([ n ^ fr $]⁺↓ ∘ (f ∘_) ∘ _,_)

[_^_$]↓ : ∀ n {ls ℓ} f {xs : Types n ls} {y : Type ℓ} → (⦅ xs ⦆ → y) → ⦅ xs ⦆[ f ]→ y
[ zero  ^ fr $]↓ f = f tt
[ suc n ^ fr $]↓ f = [ n ^ fr $]⁺↓ f

[_^_$]⁺↑ : ∀ n {ls ℓ} f {xs : Types (suc n) ls} {y : Type ℓ} → (⦅ xs ⦆[ f ]→ y) → (⦅ xs ⦆⁺ → y)
[ zero  ^ fr $]⁺↑ f = [ fr $] .fun f
[ suc n ^ fr $]⁺↑ f = uncurry ([ n ^ fr $]⁺↑ ∘ [ fr $] .fun f)

[_^_$]↑ : ∀ n {ls ℓ} f {xs : Types n ls} {y : Type ℓ} → (⦅ xs ⦆[ f ]→ y) → (⦅ xs ⦆ → y)
[ zero ^ fr  $]↑ f _ = f
[ suc n ^ fr $]↑ f = [ n ^ fr $]⁺↑ f

leftInvCurry⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : Type ℓ}
              → (f : ⦅ Xs ⦆[ fr ]→ Y ) → [ n ^ fr $]⁺↓ ([ n ^ fr $]⁺↑ f) ≡ f
leftInvCurry⁺ zero fr f = [ fr $] .leftInv f
leftInvCurry⁺ (suc n) fr f =
  [ fr $] .inv ([ n ^ fr $]⁺↓ ∘ [ n ^ fr $]⁺↑ ∘ [ fr $] .fun f) ≡⟨ cong (λ r → [ fr $] .inv (r ∘ [ fr $] .fun f)) (funExt (leftInvCurry⁺ n fr)) ⟩
  [ fr $] .inv ([ fr $] .fun f) ≡⟨ [ fr $] .leftInv f ⟩
  f ∎

leftInvCurry : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : Type ℓ}
             → (f : ⦅ Xs ⦆[ fr ]→ Y ) → [ n ^ fr $]↓ ([ n ^ fr $]↑ f) ≡ f
leftInvCurry zero fr f = refl
leftInvCurry (suc n) fr f = leftInvCurry⁺ n fr f

rightInvCurry⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : Type ℓ} (f : ⦅ Xs ⦆ → Y)
              → [ n ^ fr $]⁺↑ ([ n ^ fr $]⁺↓ f) ≡ f
rightInvCurry⁺ zero fr f = [ fr $] .rightInv f
rightInvCurry⁺ (suc n) fr f =
  uncurry ([ n ^ fr $]⁺↑ ∘ [ fr $] .fun ([ fr $] .inv ([ n ^ fr $]⁺↓ ∘ ((f ∘_) ∘ _,_)))) ≡⟨ cong (λ h → uncurry ([ n ^ fr $]⁺↑ ∘ h)) ([ fr $] .rightInv _) ⟩
  uncurry ([ n ^ fr $]⁺↑ ∘ [ n ^ fr $]⁺↓ ∘ ((f ∘_) ∘ _,_)) ≡⟨ cong (λ r → uncurry (r ∘ ((f ∘_) ∘ _,_))) (funExt (rightInvCurry⁺ n fr)) ⟩
  f ∎

rightInvCurry : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : Type ℓ} (f : ⦅ Xs ⦆ → Y)
              → [ n ^ fr $]↑ ([ n ^ fr $]↓ f) ≡ f
rightInvCurry zero fr f = refl
rightInvCurry (suc n) fr f = rightInvCurry⁺ n fr f

[_^_$] : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : Type ℓ}
       → (⦅ Xs ⦆[ fr ]→ Y) ⇔ (⦅ Xs ⦆ → Y)
[ n ^ fr $] .fun = [ n ^ fr $]↑
[ n ^ fr $] .inv = [ n ^ fr $]↓
[ n ^ fr $] .leftInv  = leftInvCurry n fr
[ n ^ fr $] .rightInv = rightInvCurry n fr

↓Π[_^_$]⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : ⦅ Xs ⦆ → Type ℓ} → ((xs : ⦅ Xs ⦆) → Y xs) → xs ⦂⦅ Xs ⦆⁺Π[ fr ]→ Y xs
↓Π[ zero ^ fr  $]⁺ f = Π[ fr $] .inv f
↓Π[ suc n ^ fr $]⁺ f = Π[ fr $] .inv (↓Π[ n ^ fr $]⁺ ∘ (f ∘_) ∘ _,_)

↓Π[_^_$] : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : ⦅ Xs ⦆ → Type ℓ} → ((xs : ⦅ Xs ⦆) → Y xs) → xs ⦂⦅ Xs ⦆Π[ fr ]→ Y xs
↓Π[ zero ^ fr $] f = f tt
↓Π[ suc n ^ fr $] f = ↓Π[ n ^ fr $]⁺ f

↑Π[_^_$]⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : ⦅ Xs ⦆ → Type ℓ} → (xs ⦂⦅ Xs ⦆⁺Π[ fr ]→ Y xs) → ((xs : ⦅ Xs ⦆) → Y xs)
↑Π[ zero ^ fr  $]⁺ f = Π[ fr $] .fun f
↑Π[ suc n ^ fr $]⁺ f = uncurry (↑Π[ n ^ fr $]⁺ ∘ Π[ fr $] .fun f)

↑Π[_^_$] : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : ⦅ Xs ⦆ → Type ℓ} → (xs ⦂⦅ Xs ⦆Π[ fr ]→ Y xs) → ((xs : ⦅ Xs ⦆) → Y xs)
↑Π[ zero ^ fr  $] f _ = f
↑Π[ suc n ^ fr $] f = ↑Π[ n ^ fr $]⁺ f

leftInvCurryΠ⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : ⦅ Xs ⦆ → Type ℓ}
              → (f : xs ⦂⦅ Xs ⦆⁺Π[ fr ]→ Y xs) → ↓Π[ n ^ fr $]⁺ (↑Π[ n ^ fr $]⁺ f) ≡ f
leftInvCurryΠ⁺ zero fr f = Π[ fr $] .leftInv f
leftInvCurryΠ⁺ (suc n) fr f =
  Π[ fr $] .inv (↓Π[ n ^ fr $]⁺ ∘ ↑Π[ n ^ fr $]⁺ ∘ Π[ fr $] .fun f)  ≡⟨ cong (Π[ fr $] .inv ∘ flip _∘_ (Π[ fr $] .fun f)) (λ i x → leftInvCurryΠ⁺ n fr x i) ⟩
  Π[ fr $] .inv (Π[ fr $] .fun f) ≡⟨ Π[ fr $] .leftInv f ⟩
  f ∎

leftInvCurryΠ : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : ⦅ Xs ⦆ → Type ℓ}
              → (f : xs ⦂⦅ Xs ⦆Π[ fr ]→ Y xs) → ↓Π[ n ^ fr $] (↑Π[ n ^ fr $] f) ≡ f
leftInvCurryΠ zero fr f = refl
leftInvCurryΠ (suc n) fr f = leftInvCurryΠ⁺ n fr f

rightInvCurryΠ⁺ : ∀ n {ls ℓ} fr {Xs : Types (suc n) ls} {Y : ⦅ Xs ⦆ → Type ℓ} (f : (xs : ⦅ Xs ⦆) → Y xs)
               → ↑Π[ n ^ fr $]⁺ (↓Π[ n ^ fr $]⁺ f) ≡ f
rightInvCurryΠ⁺ zero fr f = Π[ fr $] .rightInv f
rightInvCurryΠ⁺ (suc n) fr f =
  uncurry (↑Π[ n ^ fr $]⁺ ∘ (Π[ fr $] .fun (Π[ fr $] .inv (↓Π[ n ^ fr $]⁺ ∘ (f ∘_) ∘ _,_)))) ≡⟨ cong (λ h → uncurry (↑Π[ n ^ fr $]⁺ ∘ h)) (Π[ fr $] .rightInv _) ⟩
  uncurry (↑Π[ n ^ fr $]⁺ ∘ ↓Π[ n ^ fr $]⁺ ∘ (f ∘_) ∘ _,_) ≡⟨ cong (uncurry ∘ flip _∘_ ((f ∘_) ∘ _,_)) (λ i x → rightInvCurryΠ⁺ n fr x i) ⟩
  f ∎

rightInvCurryΠ : ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : ⦅ Xs ⦆ → Type ℓ} (f : (xs : ⦅ Xs ⦆) → Y xs)
               → ↑Π[ n ^ fr $] (↓Π[ n ^ fr $] f) ≡ f
rightInvCurryΠ zero fr f = refl
rightInvCurryΠ (suc n) fr f = rightInvCurryΠ⁺ n fr f

Π[_^_$] :  ∀ n {ls ℓ} fr {Xs : Types n ls} {Y : ⦅ Xs ⦆ → Type ℓ} →
           (xs ⦂⦅ Xs ⦆Π[ fr ]→ Y xs) ⇔ ((xs : ⦅ Xs ⦆) → Y xs)
Π[ n ^ fr $] .fun = ↑Π[ n ^ fr $]
Π[ n ^ fr $] .inv = ↓Π[ n ^ fr $]
Π[ n ^ fr $] .leftInv  = leftInvCurryΠ n fr
Π[ n ^ fr $] .rightInv = rightInvCurryΠ n fr


{-# OPTIONS --cubical --no-import-sorts --safe #-}

-- The Category of Elements

open import Cubical.Categories.Category

module Cubical.Categories.Constructions.Elements {ℓ ℓ'} {C : Precategory ℓ ℓ'} where

open import Cubical.Categories.Instances.Sets
open import Cubical.Categories.Functor
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma

import Cubical.Categories.Morphism as Morphism
import Cubical.Categories.Constructions.Slice as Slice

-- some issues
-- * always need to specify objects during composition because can't infer isSet
open Precategory
open Functor

getIsSet : ∀ {ℓS} {C : Precategory ℓ ℓ'} (F : Functor C (SET ℓS)) → (c : C .ob) → isSet (fst (F ⟅ c ⟆))
getIsSet F c = snd (F ⟅ c ⟆)

infix 50 ∫_
∫_ : ∀ {ℓS} → Functor C (SET ℓS) → Precategory (ℓ-max ℓ ℓS) (ℓ-max ℓ' ℓS)
-- objects are (c , x) pairs where c ∈ C and x ∈ F c
(∫ F) .ob = Σ[ c ∈ C .ob ] fst (F ⟅ c ⟆)
-- morphisms are f : c → c' which take x to x'
(∫ F) .Hom[_,_] (c , x) (c' , x')  = Σ[ f ∈ C [ c , c' ] ] x' ≡ (F ⟪ f ⟫) x
(∫ F) .id (c , x) = C .id c , sym (funExt⁻ (F .F-id) x ∙ refl)
(∫ F) ._⋆_ {c , x} {c₁ , x₁} {c₂ , x₂} (f , p) (g , q)
  = (f ⋆⟨ C ⟩ g) , (x₂
            ≡⟨ q ⟩
              (F ⟪ g ⟫) x₁         -- basically expanding out function composition
            ≡⟨ cong (F ⟪ g ⟫) p ⟩
              (F ⟪ g ⟫) ((F ⟪ f ⟫) x)
            ≡⟨ funExt⁻ (sym (F .F-seq _ _)) _ ⟩
              (F ⟪ f ⋆⟨ C ⟩ g ⟫) x
            ∎)
(∫ F) .⋆IdL o@{c , x} o1@{c' , x'} f'@(f , p) i
  = (cIdL i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS' x' ((F ⟪ a ⟫) x)) p' p cIdL i
    where
      isS = getIsSet F c
      isS' = getIsSet F c'
      cIdL = C .⋆IdL f

      -- proof from composition with id
      p' : x' ≡ (F ⟪ C .id c ⋆⟨ C ⟩ f ⟫) x
      p' = snd ((∫ F) ._⋆_ ((∫ F) .id o) f')
(∫ F) .⋆IdR o@{c , x} o1@{c' , x'} f'@(f , p) i
    = (cIdR i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS' x' ((F ⟪ a ⟫) x)) p' p cIdR i
      where
        cIdR = C .⋆IdR f
        isS' = getIsSet F c'

        p' : x' ≡ (F ⟪ f ⋆⟨ C ⟩ C .id c' ⟫) x
        p' = snd ((∫ F) ._⋆_ f' ((∫ F) .id o1))
(∫ F) .⋆Assoc o@{c , x} o1@{c₁ , x₁} o2@{c₂ , x₂} o3@{c₃ , x₃} f'@(f , p) g'@(g , q) h'@(h , r) i
  = (cAssoc i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS₃ x₃ ((F ⟪ a ⟫) x)) p1 p2 cAssoc i
    where
      cAssoc = C .⋆Assoc f g h
      isS₃ = getIsSet F c₃

      p1 : x₃ ≡ (F ⟪ (f ⋆⟨ C ⟩ g) ⋆⟨ C ⟩ h ⟫) x
      p1 = snd ((∫ F) ._⋆_ ((∫ F) ._⋆_ {o} {o1} {o2} f' g') h')

      p2 : x₃ ≡ (F ⟪ f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ h) ⟫) x
      p2 = snd ((∫ F) ._⋆_ f' ((∫ F) ._⋆_ {o1} {o2} {o3} g' h'))

-- same thing but for presheaves
∫ᴾ_ : ∀ {ℓS} → Functor (C ^op) (SET ℓS) → Precategory (ℓ-max ℓ ℓS) (ℓ-max ℓ' ℓS)
-- objects are (c , x) pairs where c ∈ C and x ∈ F c
(∫ᴾ F) .ob = Σ[ c ∈ C .ob ] fst (F ⟅ c ⟆)
-- morphisms are f : c → c' which take x to x'
(∫ᴾ F) .Hom[_,_] (c , x) (c' , x')  = Σ[ f ∈ C [ c , c' ] ] x ≡ (F ⟪ f ⟫) x'
(∫ᴾ F) .id (c , x) = C .id c , sym (funExt⁻ (F .F-id) x ∙ refl)
(∫ᴾ F) ._⋆_ {c , x} {c₁ , x₁} {c₂ , x₂} (f , p) (g , q)
  = (f ⋆⟨ C ⟩ g) , (x
            ≡⟨ p ⟩
              (F ⟪ f ⟫) x₁         -- basically expanding out function composition
            ≡⟨ cong (F ⟪ f ⟫) q ⟩
              (F ⟪ f ⟫) ((F ⟪ g ⟫) x₂)
            ≡⟨ funExt⁻ (sym (F .F-seq _ _)) _ ⟩
              (F ⟪ f ⋆⟨ C ⟩ g ⟫) x₂
            ∎)
(∫ᴾ F) .⋆IdL o@{c , x} o1@{c' , x'} f'@(f , p) i
  = (cIdL i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS x ((F ⟪ a ⟫) x')) p' p cIdL i
    where
      isS = getIsSet F c
      isS' = getIsSet F c'
      cIdL = C .⋆IdL f

      -- proof from composition with id
      p' : x ≡ (F ⟪ C .id c ⋆⟨ C ⟩ f ⟫) x'
      p' = snd ((∫ᴾ F) ._⋆_ ((∫ᴾ F) .id o) f')
(∫ᴾ F) .⋆IdR o@{c , x} o1@{c' , x'} f'@(f , p) i
    = (cIdR i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS x ((F ⟪ a ⟫) x')) p' p cIdR i
      where
        cIdR = C .⋆IdR f
        isS = getIsSet F c

        p' : x ≡ (F ⟪ f ⋆⟨ C ⟩ C .id c' ⟫) x'
        p' = snd ((∫ᴾ F) ._⋆_ f' ((∫ᴾ F) .id o1))
(∫ᴾ F) .⋆Assoc o@{c , x} o1@{c₁ , x₁} o2@{c₂ , x₂} o3@{c₃ , x₃} f'@(f , p) g'@(g , q) h'@(h , r) i
  = (cAssoc i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS x ((F ⟪ a ⟫) x₃)) p1 p2 cAssoc i
    where
      cAssoc = C .⋆Assoc f g h
      isS = getIsSet F c

      p1 : x ≡ (F ⟪ (f ⋆⟨ C ⟩ g) ⋆⟨ C ⟩ h ⟫) x₃
      p1 = snd ((∫ᴾ F) ._⋆_ ((∫ᴾ F) ._⋆_ {o} {o1} {o2} f' g') h')

      p2 : x ≡ (F ⟪ f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ h) ⟫) x₃
      p2 = snd ((∫ᴾ F) ._⋆_ f' ((∫ᴾ F) ._⋆_ {o1} {o2} {o3} g' h'))

-- helpful results

module _ {ℓS} {F : Functor (C ^op) (SET ℓS)} where

  -- morphisms are equal as long as the morphisms in C are equals
  ∫ᴾhomEq : ∀ {o1 o1' o2 o2'} (f : (∫ᴾ F) [ o1 , o2 ]) (g : (∫ᴾ F) [ o1' , o2' ])
          → (p : o1 ≡ o1') (q : o2 ≡ o2')
          → (eqInC : PathP (λ i → C [ fst (p i) , fst (q i) ]) (fst f) (fst g))
          → PathP (λ i → (∫ᴾ F) [ p i , q i ]) f g
  ∫ᴾhomEq (f , eqf) (g , eqg) p q eqInC
    = ΣPathP (eqInC
              , isOfHLevel→isOfHLevelDep 1 {A = Σ[ (o1 , o2) ∈ (∫ᴾ F) .ob × (∫ᴾ F) .ob ] (C [ fst o1 , fst o2 ])}
                                          {B = λ ((o1 , o2) , f) → snd o1 ≡ (F ⟪ f ⟫) (snd o2)}
                                          (λ ((o1 , o2) , f) → snd (F ⟅ (fst o1) ⟆) (snd o1) ((F ⟪ f ⟫) (snd o2)))
                                          eqf
                                          eqg
                                          λ i → ((p i , q i) , eqInC i))


module CompilingCoinduction where

open import Common.Coinduction
open import Common.Char
open import Common.String

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}

postulate
  IO : Set → Set

{-# COMPILED_TYPE IO IO #-}
{-# BUILTIN IO IO #-}

{-# IMPORT Data.Text.IO #-}

postulate
  putStrLn : ∞ String → IO Unit

{-# COMPILED putStrLn Data.Text.IO.putStrLn #-}
{-# COMPILED_UHC putStrLn (UHC.Agda.Builtins.primPutStrLn) #-}
{-# COMPILED_JS putStrLn function(x) { return function(cb) { process.stdout.write(x(0) + "\n"); cb(0); }; } #-}

main = putStrLn (♯ "a")


------------------------------------------------------------------------
-- The Agda standard library
--
-- Floats
------------------------------------------------------------------------

module Data.Float where

open import Data.Bool hiding (_≟_)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
open import Relation.Binary.PropositionalEquality.TrustMe
open import Data.String using (String)

postulate
  Float : Set

{-# BUILTIN FLOAT Float #-}

primitive
  primFloatEquality : Float → Float → Bool
  primShowFloat     : Float → String

show : Float → String
show = primShowFloat

_≟_ : (x y : Float) → Dec (x ≡ y)
x ≟ y with primFloatEquality x y
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _


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

open import Relation.Binary.PropositionalEquality using (_≢_; _≡_; refl; sym; subst; cong; trans)
open import Function using (_∘_)
open import Relation.Nullary using (yes; no)

import Data.Empty as Empty
import Data.Product as Product
import Data.Product.Properties as Productₚ
import Data.Nat as Nat
import Data.Vec as Vec
import Data.Vec.Properties as Vecₚ
import Data.Fin as Fin
import Data.Fin.Properties as Finₚ
import Data.Vec.Relation.Unary.All as All

open Empty using (⊥-elim)
open Nat using (ℕ; zero; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Fin using (Fin ; zero ; suc)
open Product using (Σ-syntax; _×_; _,_; proj₁; proj₂)

import PiCalculus.Syntax
open PiCalculus.Syntax.Scoped
open import PiCalculus.Semantics
open import PiCalculus.Semantics.Properties
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.Exchange (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω
open import PiCalculus.LinearTypeSystem.ContextLemmas Ω

private
  variable
    n : ℕ
    i j : Fin n
    idx : Idx
    idxs : Idxs n
    P Q : Scoped n

⊢-unused : {γ : PreCtx n} {Γ Θ : Ctx idxs}
         → (i : Fin n)
         → Unused i P
         → γ ； Γ ⊢ P ▹ Θ
         → All.lookup i Γ ≡ All.lookup i Θ
⊢-unused i uP 𝟘 = refl
⊢-unused i uP (ν t m μ ⊢P) = ⊢-unused (suc i) uP ⊢P
⊢-unused i (i≢x , uP) ((_ , x) ⦅⦆ ⊢P) = trans
  (∋-lookup-≢ x i i≢x)
  (⊢-unused (suc i) uP ⊢P)
⊢-unused i (i≢x , i≢y , uP) ((_ , x) ⟨ _ , y ⟩ ⊢P) = trans (trans
  (∋-lookup-≢ x i i≢x)
  (∋-lookup-≢ y i i≢y))
  (⊢-unused i uP ⊢P)
⊢-unused i (uP , uQ) (⊢P ∥ ⊢Q) = trans
  (⊢-unused i uP ⊢P)
  (⊢-unused i uQ ⊢Q)

module _ {a} {A : Set a} where
  exchangeᵥ : (i : Fin n) → Vec A (suc n) → Vec A (suc n)
  exchangeᵥ zero (xs -, y -, x) = xs -, x -, y
  exchangeᵥ (suc i) (xs -, y -, x) = exchangeᵥ i (xs -, y) -, x

  exchangeₐ : ∀ {b} {P : A → Set b} (i : Fin n) {xs : Vec A (suc n)} → All P xs → All P (exchangeᵥ i xs)
  exchangeₐ zero (xs -, y -, x) = xs -, x -, y
  exchangeₐ (suc i) (xs -, y -, x) = exchangeₐ i (xs -, y) -, x

-- TODO: rewrite this crap
∋-exchange : {γ : PreCtx (suc n)} {idxs : Idxs (suc n)} {Γ Θ : Ctx idxs} {t : Type} {x : Usage idx ²}
       → (i : Fin n)
       → γ ； Γ ∋[ j ] t ； x ▹ Θ
       → exchangeᵥ i γ ； exchangeₐ i Γ ∋[ exchangeFin i j ] t ； x ▹ exchangeₐ i Θ
∋-exchange {γ = _ -, _ -, _} {idxs = _ -, _ -, _} {Γ = _ -, _ -, _} zero (zero , zero xyz) = (suc zero , suc (zero xyz))
∋-exchange {γ = _ -, _ -, _} zero (suc zero , suc (zero xyz)) = zero , zero xyz
∋-exchange {γ = _ -, _ -, _} zero (suc (suc t) , suc (suc x)) = suc (suc t) , suc (suc x)
∋-exchange {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc i) (zero , zero xyz) = zero , zero xyz
∋-exchange {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc zero) (suc zero , suc (zero xyz)) = suc (suc zero) , suc (suc (zero xyz))
∋-exchange {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc (suc i)) (suc zero , suc (zero xyz)) = suc zero , suc (zero xyz)
∋-exchange {j = suc (suc j)} {γ = γ -, _} {Γ = Γ -, _} (suc i) (suc (suc t) , suc (suc x)) with Fin.inject₁ i Finₚ.≟ suc j
∋-exchange {j = suc (suc j)} {γ = γ -, _} {Γ = Γ -, _} (suc zero) (suc (suc t) , suc (suc x)) | yes ()
∋-exchange {j = suc (suc ._)} {γ = γ -, _} {Γ = Γ -, _} {Θ = Θ -, _} (suc (suc i)) (suc st@(suc t) , suc sx@(suc x)) | yes refl =
  let s' = subst (λ ● → exchangeᵥ (suc i) γ ； exchangeₐ (suc i) Γ ∋[ ● ] _ ； _ ▹ exchangeₐ (suc i) Θ)
                 (sym (trans (cong suc (sym (trans (exchangeFin-injectˡ i) (cong suc (sym (Finₚ.lower₁-inject₁′ i _))))))
                 (exchangeFin-suc i (Fin.inject₁ i)))) (∋-exchange (suc i) (st , sx))
  in there s'
∋-exchange {j = suc (suc j)} {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc i) (suc st@(suc t) , suc sx@(suc x)) | no ¬p with i Finₚ.≟ j
∋-exchange {j = suc (suc j)} {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc i) (suc st@(suc t) , suc sx@(suc x)) | no ¬p | yes refl rewrite sym (exchangeFin-injectʳ i) = there (∋-exchange i (st , sx))
∋-exchange {j = suc (suc j)} {γ = _ -, _ -, _ -, _} {Γ = _ -, _ -, _ -, _} (suc i) (suc st@(suc t) , suc sx@(suc x)) | no ¬p | no ¬q rewrite sym (exchangeFin-neq i j ¬q ¬p) = there (∋-exchange i (st , sx))

⊢-exchange : {γ : PreCtx (suc n)} {Γ Θ : Ctx idxs}
       → (i : Fin n)
       → γ ； Γ ⊢ P ▹ Θ
       → exchangeᵥ i γ ； exchangeₐ i Γ ⊢ exchange i P ▹ exchangeₐ i Θ
⊢-exchange {γ = _ -, _ -, _} {Γ = _ -, _ -, _} {Θ = _ -, _ -, _} i 𝟘 = 𝟘
⊢-exchange {γ = _ -, _ -, _} {Γ = _ -, _ -, _} {Θ = _ -, _ -, _} i (ν t m μ ⊢P) = ν t m μ (⊢-exchange (suc i) ⊢P)
⊢-exchange {γ = _ -, _ -, _} {Γ = _ -, _ -, _} {Θ = _ -, _ -, _} i (_⦅⦆_ {Ξ = _ -, _ -, _} x ⊢P) = ∋-exchange i x ⦅⦆ ⊢-exchange (suc i) ⊢P
⊢-exchange {γ = _ -, _ -, _} {Γ = _ -, _ -, _} {Θ = _ -, _ -, _} i (x ⟨ y ⟩ ⊢P) = ∋-exchange i x ⟨ ∋-exchange i y ⟩ (⊢-exchange i ⊢P)
⊢-exchange {γ = _ -, _ -, _} {Γ = _ -, _ -, _} {Θ = _ -, _ -, _} i (⊢P ∥ ⊢Q) = ⊢-exchange i ⊢P ∥ ⊢-exchange i ⊢Q


{-# OPTIONS --cubical --no-import-sorts --safe  #-}
module Cubical.HITs.GroupoidQuotients where

open import Cubical.HITs.GroupoidQuotients.Base public
open import Cubical.HITs.GroupoidQuotients.Properties public


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.S3 where

open import Cubical.HITs.S3.Base public

-- open import Cubical.HITs.S3.Properties public


{-# OPTIONS --type-in-type #-}

Ty% : Set
Ty% =
   (Ty%         : Set)
   (nat top bot  : Ty%)
   (arr prod sum : Ty% → Ty% → Ty%)
 → Ty%

nat% : Ty%; nat% = λ _ nat% _ _ _ _ _ → nat%
top% : Ty%; top% = λ _ _ top% _ _ _ _ → top%
bot% : Ty%; bot% = λ _ _ _ bot% _ _ _ → bot%

arr% : Ty% → Ty% → Ty%; arr%
 = λ A B Ty% nat% top% bot% arr% prod sum →
     arr% (A Ty% nat% top% bot% arr% prod sum) (B Ty% nat% top% bot% arr% prod sum)

prod% : Ty% → Ty% → Ty%; prod%
 = λ A B Ty% nat% top% bot% arr% prod% sum →
     prod% (A Ty% nat% top% bot% arr% prod% sum) (B Ty% nat% top% bot% arr% prod% sum)

sum% : Ty% → Ty% → Ty%; sum%
 = λ A B Ty% nat% top% bot% arr% prod% sum% →
     sum% (A Ty% nat% top% bot% arr% prod% sum%) (B Ty% nat% top% bot% arr% prod% sum%)

Con% : Set; Con%
 = (Con% : Set)
   (nil  : Con%)
   (snoc : Con% → Ty% → Con%)
 → Con%

nil% : Con%; nil%
 = λ Con% nil% snoc → nil%

snoc% : Con% → Ty% → Con%; snoc%
 = λ Γ A Con% nil% snoc% → snoc% (Γ Con% nil% snoc%) A

Var% : Con% → Ty% → Set; Var%
 = λ Γ A →
   (Var% : Con% → Ty% → Set)
   (vz  : ∀ Γ A → Var% (snoc% Γ A) A)
   (vs  : ∀ Γ B A → Var% Γ A → Var% (snoc% Γ B) A)
 → Var% Γ A

vz% : ∀{Γ A} → Var% (snoc% Γ A) A; vz%
 = λ Var% vz% vs → vz% _ _

vs% : ∀{Γ B A} → Var% Γ A → Var% (snoc% Γ B) A; vs%
 = λ x Var% vz% vs% → vs% _ _ _ (x Var% vz% vs%)

Tm% : Con% → Ty% → Set; Tm%
 = λ Γ A →
   (Tm%  : Con% → Ty% → Set)
   (var   : ∀ Γ A      → Var% Γ A → Tm% Γ A)
   (lam   : ∀ Γ A B    → Tm% (snoc% Γ A) B → Tm% Γ (arr% A B))
   (app   : ∀ Γ A B    → Tm% Γ (arr% A B) → Tm% Γ A → Tm% Γ B)
   (tt    : ∀ Γ        → Tm% Γ top%)
   (pair  : ∀ Γ A B    → Tm% Γ A → Tm% Γ B → Tm% Γ (prod% A B))
   (fst   : ∀ Γ A B    → Tm% Γ (prod% A B) → Tm% Γ A)
   (snd   : ∀ Γ A B    → Tm% Γ (prod% A B) → Tm% Γ B)
   (left  : ∀ Γ A B    → Tm% Γ A → Tm% Γ (sum% A B))
   (right : ∀ Γ A B    → Tm% Γ B → Tm% Γ (sum% A B))
   (case  : ∀ Γ A B C  → Tm% Γ (sum% A B) → Tm% Γ (arr% A C) → Tm% Γ (arr% B C) → Tm% Γ C)
   (zero  : ∀ Γ        → Tm% Γ nat%)
   (suc   : ∀ Γ        → Tm% Γ nat% → Tm% Γ nat%)
   (rec   : ∀ Γ A      → Tm% Γ nat% → Tm% Γ (arr% nat% (arr% A A)) → Tm% Γ A → Tm% Γ A)
 → Tm% Γ A

var% : ∀{Γ A} → Var% Γ A → Tm% Γ A; var%
 = λ x Tm% var% lam app tt pair fst snd left right case zero suc rec →
     var% _ _ x

lam% : ∀{Γ A B} → Tm% (snoc% Γ A) B → Tm% Γ (arr% A B); lam%
 = λ t Tm% var% lam% app tt pair fst snd left right case zero suc rec →
     lam% _ _ _ (t Tm% var% lam% app tt pair fst snd left right case zero suc rec)

app% : ∀{Γ A B} → Tm% Γ (arr% A B) → Tm% Γ A → Tm% Γ B; app%
 = λ t u Tm% var% lam% app% tt pair fst snd left right case zero suc rec →
     app% _ _ _ (t Tm% var% lam% app% tt pair fst snd left right case zero suc rec)
         (u Tm% var% lam% app% tt pair fst snd left right case zero suc rec)

tt% : ∀{Γ} → Tm% Γ top%; tt%
 = λ Tm% var% lam% app% tt% pair fst snd left right case zero suc rec → tt% _

pair% : ∀{Γ A B} → Tm% Γ A → Tm% Γ B → Tm% Γ (prod% A B); pair%
 = λ t u Tm% var% lam% app% tt% pair% fst snd left right case zero suc rec →
     pair% _ _ _ (t Tm% var% lam% app% tt% pair% fst snd left right case zero suc rec)
          (u Tm% var% lam% app% tt% pair% fst snd left right case zero suc rec)

fst% : ∀{Γ A B} → Tm% Γ (prod% A B) → Tm% Γ A; fst%
 = λ t Tm% var% lam% app% tt% pair% fst% snd left right case zero suc rec →
     fst% _ _ _ (t Tm% var% lam% app% tt% pair% fst% snd left right case zero suc rec)

snd% : ∀{Γ A B} → Tm% Γ (prod% A B) → Tm% Γ B; snd%
 = λ t Tm% var% lam% app% tt% pair% fst% snd% left right case zero suc rec →
     snd% _ _ _ (t Tm% var% lam% app% tt% pair% fst% snd% left right case zero suc rec)

left% : ∀{Γ A B} → Tm% Γ A → Tm% Γ (sum% A B); left%
 = λ t Tm% var% lam% app% tt% pair% fst% snd% left% right case zero suc rec →
     left% _ _ _ (t Tm% var% lam% app% tt% pair% fst% snd% left% right case zero suc rec)

right% : ∀{Γ A B} → Tm% Γ B → Tm% Γ (sum% A B); right%
 = λ t Tm% var% lam% app% tt% pair% fst% snd% left% right% case zero suc rec →
     right% _ _ _ (t Tm% var% lam% app% tt% pair% fst% snd% left% right% case zero suc rec)

case% : ∀{Γ A B C} → Tm% Γ (sum% A B) → Tm% Γ (arr% A C) → Tm% Γ (arr% B C) → Tm% Γ C; case%
 = λ t u v Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero suc rec →
     case% _ _ _ _
           (t Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero suc rec)
           (u Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero suc rec)
           (v Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero suc rec)

zero%  : ∀{Γ} → Tm% Γ nat%; zero%
 = λ Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc rec → zero% _

suc% : ∀{Γ} → Tm% Γ nat% → Tm% Γ nat%; suc%
 = λ t Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec →
   suc% _ (t Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec)

rec% : ∀{Γ A} → Tm% Γ nat% → Tm% Γ (arr% nat% (arr% A A)) → Tm% Γ A → Tm% Γ A; rec%
 = λ t u v Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec% →
     rec% _ _
          (t Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec%)
          (u Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec%)
          (v Tm% var% lam% app% tt% pair% fst% snd% left% right% case% zero% suc% rec%)

v0% : ∀{Γ A} → Tm% (snoc% Γ A) A; v0%
 = var% vz%

v1% : ∀{Γ A B} → Tm% (snoc% (snoc% Γ A) B) A; v1%
 = var% (vs% vz%)

v2% : ∀{Γ A B C} → Tm% (snoc% (snoc% (snoc% Γ A) B) C) A; v2%
 = var% (vs% (vs% vz%))

v3% : ∀{Γ A B C D} → Tm% (snoc% (snoc% (snoc% (snoc% Γ A) B) C) D) A; v3%
 = var% (vs% (vs% (vs% vz%)))

tbool% : Ty%; tbool%
 = sum% top% top%

true% : ∀{Γ} → Tm% Γ tbool%; true%
 = left% tt%

tfalse% : ∀{Γ} → Tm% Γ tbool%; tfalse%
 = right% tt%

ifthenelse% : ∀{Γ A} → Tm% Γ (arr% tbool% (arr% A (arr% A A))); ifthenelse%
 = lam% (lam% (lam% (case% v2% (lam% v2%) (lam% v1%))))

times4% : ∀{Γ A} → Tm% Γ (arr% (arr% A A) (arr% A A)); times4%
  = lam% (lam% (app% v1% (app% v1% (app% v1% (app% v1% v0%)))))

add% : ∀{Γ} → Tm% Γ (arr% nat% (arr% nat% nat%)); add%
 = lam% (rec% v0%
       (lam% (lam% (lam% (suc% (app% v1% v0%)))))
       (lam% v0%))

mul% : ∀{Γ} → Tm% Γ (arr% nat% (arr% nat% nat%)); mul%
 = lam% (rec% v0%
       (lam% (lam% (lam% (app% (app% add% (app% v1% v0%)) v0%))))
       (lam% zero%))

fact% : ∀{Γ} → Tm% Γ (arr% nat% nat%); fact%
 = lam% (rec% v0% (lam% (lam% (app% (app% mul% (suc% v1%)) v0%)))
        (suc% zero%))


module M where

Foo : Set
Foo = Set


{-# OPTIONS --safe #-}

open import Generics.Prelude hiding (lookup)
open import Generics.Telescope
open import Generics.Desc
open import Generics.All
open import Generics.HasDesc
import Generics.Helpers as Helpers

module Generics.Constructions.Elim {P I ℓ} {A : Indexed P I ℓ} where

module _ (H : HasDesc A) (open HasDesc H)
         {p c} (Pr : Pred′ I (λ i → A′ (p , i) → Set c))
         where

  private
    variable
      V : ExTele P
      i : ⟦ I ⟧tel p
      v : ⟦ V ⟧tel p

  Pr′ : A′ (p , i) → Set c
  Pr′ {i} = unpred′ I _ Pr i

  --------------------------
  -- Types of methods

  levelElimIndArg levelElimCon : ConDesc P V I → Level

  levelElimIndArg (var x) = c
  levelElimIndArg (π {ℓ} i S C) = ℓ ⊔ levelElimIndArg C
  levelElimIndArg (A ⊗ B) = levelElimIndArg A ⊔ levelElimIndArg B

  levelElimCon (var x) = c
  levelElimCon (π {ℓ′} i S C) = ℓ′ ⊔ levelElimCon C
  levelElimCon (A ⊗ B) = levelIndArg A ℓ ⊔ levelElimIndArg A ⊔ levelElimCon B

  MethodIndArg : (C : ConDesc P V I)
               → ⟦ C ⟧IndArg A′ (p , v)
               → Set (levelElimIndArg C)
  MethodIndArg (var x    ) X = Pr′ X
  MethodIndArg (π ia S C) X = Π< ia > (S _) (MethodIndArg C ∘ app< ia > X)
  MethodIndArg (A ⊗ B) (mA , mB) = MethodIndArg A mA × MethodIndArg B mB

  MethodCon : (C : ConDesc P V I)
            → (∀ {i} → ⟦ C ⟧Con A′ (p , v , i) → Set c)
            → Set (levelElimCon C)
  MethodCon (var x) f = f refl
  MethodCon (π ia S C) f = Π< ia > (S _) (λ s → MethodCon C (f ∘ (s ,_)))
  MethodCon (A ⊗ B) f = {g  : ⟦ A ⟧IndArg A′ (p , _)}
                        (Pg : MethodIndArg A g)
                      → MethodCon B (f ∘ (g ,_))

  Methods : ∀ k → Set (levelElimCon (lookupCon D k))
  Methods k = MethodCon (lookupCon D k) λ x → Pr′ (constr (k , x))

  --------------------------
  -- Eliminator

  module _ (methods : Els Methods) where

    elimData-wf
      : (x : ⟦ D ⟧Data A′ (p , i))
      → AllDataω Acc D x
      → Pr′ (constr x)

    elim-wf : (x : A′ (p , i)) → Acc x → Pr′ x
    elim-wf x (acc a) = subst Pr′ (constr∘split x) (elimData-wf (split x) a)

    elimData-wf (k , x) a
      = elimCon (lookupCon D k) (methods k) x a
      where
        elimIndArg
          : (C : ConDesc P V I)
          → (x : ⟦ C ⟧IndArg A′ (p , v))
          → AllIndArgω Acc C x
          → MethodIndArg C x
        elimIndArg (var _) x a = elim-wf x a
        elimIndArg (π ia S C) x a = fun< ia > (λ s → elimIndArg C (app< ia > x s) (a s))
        elimIndArg (A ⊗ B) (xa , xb) (aa , ab)
          = elimIndArg A xa aa
          , elimIndArg B xb ab

        elimCon
          : (C   : ConDesc P V I)
            {mk  : ∀ {i} → ⟦ C ⟧Con A′ (p , v , i) → ⟦ D ⟧Data A′ (p , i)}
            (mot : MethodCon C (λ x → Pr′ (constr (mk x))))
            (x   : ⟦ C ⟧Con A′ (p , v , i))
          → AllConω Acc C x
          → Pr′ (constr (mk x))
        elimCon (var _) mot refl a = mot
        elimCon (π ia _ C) mot (s , x) a = elimCon C (app< ia > mot s) x a
        elimCon (A ⊗ B) mot (xa , xb) (aa , ab)
          = elimCon B (mot (elimIndArg A xa aa)) xb ab

    elim′ : (x : A′ (p , i)) → Pr′ x
    elim′ x = elim-wf x (wf x)

  deriveElim : Arrows Methods (Pred′ I λ i → (x : A′ (p , i)) → Pr′ x)
  deriveElim = curryₙ (λ m → pred′ I _ λ i → elim′ m)

elim : ∀ ⦃ H : HasDesc A ⦄ (open HasDesc H) {p c} (Pr : Pred′ I (λ i → A′ (p , i) → Set c))
     → Arrows (Methods H Pr) (Pred′ I λ i → (x : A′ (p , i)) → Pr′ H Pr x)
elim ⦃ H ⦄ Pr = deriveElim H Pr


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

module Cubical.Data.Strict2Group.Explicit.Path where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Group.Base
open import Cubical.Data.Strict2Group.Explicit.Base
open import Cubical.Data.Strict2Group.Explicit.Notation

S2G : (ℓ : Level) → Type (ℓ-suc ℓ)
S2G ℓ = Strict2GroupExp ℓ

S2GΣBase : (ℓ : Level) → Type (ℓ-suc ℓ)
S2GΣBase ℓ =
  Σ[ C₀ ∈ Group ℓ ]
  Σ[ C₁ ∈ Group ℓ ]
  Σ[ s ∈ morph C₁ C₀ ]
  Σ[ t ∈ morph C₁ C₀ ]
  Σ[ i ∈ morph C₀ C₁ ]
     ((g f : Group.type C₁) → s .fst g ≡ t .fst f → Group.type C₁) -- ∘

S2GΣRest : {ℓ : Level} → (S2GΣBase ℓ) → Type ℓ
S2GΣRest (C₀ , C₁ , s , t , i , ∘)
  = Σ[ si ∈ ((x : TC₀) → src (id x) ≡ x) ]
    Σ[ ti ∈ ((x : TC₀) → tar (id x) ≡ x) ]
    Σ[ s∘ ∈ ((g f : TC₁) → (coh : CohCond g f) → src (∘ g f coh) ≡ src f) ]
    Σ[ t∘ ∈ ((g f : TC₁) → (coh : CohCond g f) → tar (∘ g f coh) ≡ tar g) ]
    Σ[ isMorph∘ ∈ ({g f g' f' : TC₁} (c : CohCond g f) (c' : CohCond g' f') → ∘ (g ∙₁ g') (f ∙₁ f') (∙c c c') ≡ (∘ g f c) ∙₁ (∘ g' f' c')) ]
    Σ[ assoc∘ ∈ ({h g f : TC₁} → (c1 : CohCond g f) → (c2 : CohCond h g) → ∘ (∘ h g c2) f  ((s∘ h g c2) ∙ c1) ≡ ∘ h (∘ g f c1) (c2 ∙ (sym (t∘ g f c1)))) ]
    Σ[ lUnit∘ ∈ ((f : TC₁) → ∘ (id (tar f)) f (si (tar f)) ≡ f) ]
    ((f : TC₁) → ∘ f (id (src f)) (sym (ti (src f))) ≡ f) -- rUnit∘
    where open S2GBaseNotation C₀ C₁ s t i ∘

S2GΣ : (ℓ : Level) → Type (ℓ-suc ℓ)
S2GΣ ℓ = Σ[ X ∈ S2GΣBase ℓ ] (S2GΣRest X)

S2GΣ→S2G : {ℓ : Level} → S2GΣ ℓ → S2G ℓ
S2GΣ→S2G ((C₀ , C₁ , s , t , i , ∘) , (si , ti , s∘ , t∘ , isMorph∘ , assoc∘ , lUnit∘ , rUnit∘)) = strict2groupexp C₀ C₁ s t i ∘ si ti s∘ t∘ isMorph∘ assoc∘ lUnit∘ rUnit∘

-- Σ-type of data needed to define the type of PathPs between the base data for an S2G
S2GΣBase≡ : {ℓ : Level} → (SB SB' : S2GΣBase ℓ) → Type (ℓ-suc ℓ)
S2GΣBase≡
  (C₀ , C₁ , s , t , i , ∘ )
  (C₀' , C₁' , s' , t' , i' , ∘')
  = Σ[ p-C₀ ∈ (C₀ ≡ C₀') ]
    Σ[ p-C₁ ∈ (C₁ ≡ C₁') ]
    Σ[ p-s ∈ (PathP (λ j → morph (p-C₁ j) (p-C₀ j)) s s') ]
    Σ[ p-t ∈ (PathP (λ j → morph (p-C₁ j) (p-C₀ j)) t t') ]
    Σ[ p-i ∈ (PathP (λ j → morph (p-C₀ j) (p-C₁ j)) i i') ]
      (PathP (λ j → (g f : Group.type (p-C₁ j)) → (fst (p-s j)) g ≡ (fst (p-t j)) f → Group.type (p-C₁ j)) ∘ ∘') -- p∘

S2GΣRest≡ : {ℓ : Level} {SB SB' : S2GΣBase ℓ} (SR : S2GΣRest {ℓ = ℓ} SB) (SR' : S2GΣRest {ℓ = ℓ} SB') (pSB : S2GΣBase≡ {ℓ = ℓ} SB SB') → Type ℓ
S2GΣRest≡ {ℓ}
  {C₀ , C₁ , s , t , i , ∘}
  {C₀' , C₁' , s' , t' , i' , ∘'}
  (si , ti , s∘ , t∘ , isMorph∘ , assoc∘ , lUnit∘ , rUnit∘)
  (si' , ti' , s∘' , t∘' , isMorph∘' , assoc∘' , lUnit∘' , rUnit∘')
  (p-C₀ , p-C₁ , p-s , p-t , p-i , p∘)
  = Σ[ p-si ∈ (PathP (λ j → (x : Group.type (p-C₀ j)) → ((p-s j) .fst) (((p-i j) .fst) x) ≡ x) si si') ]
    Σ[ p-ti ∈ (PathP (λ j → (x : Group.type (p-C₀ j)) → ((p-t j) .fst) (((p-i j) .fst) x) ≡ x) ti ti') ]
    Σ[ p-s∘ ∈ (PathP (λ j → (g f : Group.type (p-C₁ j)) → (coh : (p-s j) .fst g ≡ (p-t j) .fst f) → (p-s j) .fst ((p∘ j) g f coh) ≡ (p-s j) .fst f) s∘ s∘') ]
    Σ[ p-t∘ ∈ (PathP (λ j → (g f : Group.type (p-C₁ j)) → (coh : (p-s j) .fst g ≡ (p-t j) .fst f) → (p-t j) .fst ((p∘ j) g f coh) ≡ (p-t j) .fst g) t∘ t∘') ]
    Σ[ p-isMorph∘ ∈ PathP
       (λ j → {g f g' f' : TC₁j j}
         (coh1 : CohCondj j g f)
         (coh2 : CohCondj j g' f')
           → (p∘ j) (∙₁j j g g') (∙₁j j f f') (∙cj j coh1 coh2) ≡ ∙₁j j (p∘ j g f coh1) (p∘ j g' f' coh2))
        isMorph∘ isMorph∘' ]
    Σ[ p-assococ∘ ∈ (PathP
       (λ j → {h g f : TC₁j j}
         (coh1 : CohCondj j g f)
         (coh2 : CohCondj j h g)
          → (p∘ j (p∘ j h g coh2) f (p-s∘ j h g coh2 ∙ coh1)) ≡ (p∘ j h (p∘ j g f coh1) (coh2 ∙ (sym (p-t∘ j g f coh1)))))
        assoc∘ assoc∘') ]
    Σ[ p-lUnit∘ ∈ (PathP
       (λ j → (f : TC₁j j)
         → p∘ j (idj j (tarj j f)) f (p-si j (tarj j f)) ≡ f)
       lUnit∘ lUnit∘') ]
        (PathP (λ j → (f : TC₁j j)
          → p∘ j f (idj j (srcj j f)) (sym (p-ti j (srcj j f))) ≡ f)
        rUnit∘ rUnit∘') -- p-rUnit∘
    where
      TC₁j = λ (j : I) → Group.type (p-C₁ j)
      TC₀j = λ (j : I) → Group.type (p-C₀ j)

      CohCondj : (j : I) (g f : TC₁j j) → Type ℓ
      CohCondj j g f = (p-s j) .fst g ≡ (p-t j) .fst f

      ∙₁j = λ (j : I) → isGroup.comp (Group.groupStruc (p-C₁ j))
      ∙₀j = λ (j : I) → isGroup.comp (Group.groupStruc (p-C₀ j))

      idj = λ (j : I) → fst (p-i j)
      srcj = λ (j : I) → fst (p-s j)
      tarj = λ (j : I) → fst (p-t j)
      src∙₁j = λ (j : I) → snd (p-s j)
      tar∙₁j = λ (j : I) → snd (p-t j)

      ∙cj : (j : I) → {g f g' f' : TC₁j j} → (c1 : CohCondj j g f) → (c2 : CohCondj j g' f') → (p-s j) .fst (∙₁j j g g') ≡ (p-t j) .fst (∙₁j j f f')
      ∙cj j {g} {f} {g'} {f'} c1 c2 =
        src∙₁j j g g' ∙
        cong (λ z → ∙₀j j z (srcj j g')) c1 ∙
        cong (λ z → ∙₀j j (tarj j f) z) c2 ∙
        sym (tar∙₁j j f f')

S2GR≡ : {ℓ : Level}
  {SB SB' : S2GΣBase ℓ} {SR : S2GΣRest {ℓ = ℓ} SB} {SR' : S2GΣRest {ℓ = ℓ} SB'}
  {pSB : S2GΣBase≡ {ℓ = ℓ} SB SB'} (pSR : S2GΣRest≡ {ℓ = ℓ} {SB = SB} {SB' = SB'} SR SR' pSB)
  → S2GΣ→S2G (SB , SR) ≡ S2GΣ→S2G (SB' , SR')
S2GR≡ {ℓ}
  {C₀ , C₁ , s , t , i , ∘} -- SB
  {C₀' , C₁' , s' , t' , i' , ∘'} --SB'
  {si , ti , s∘ , t∘} -- SR
  {si' , ti' , s∘' , t∘'} -- SR'
  {p-C₀ , p-C₁ , p-s , p-t , p-i , p∘} -- pSB
  (p-si , p-ti , p-s∘ , p-t∘ , p-isMorph∘ , p-assococ∘ , p-lUnit∘ , p-rUnit∘) j
  = strict2groupexp (p-C₀ j) (p-C₁ j) (p-s j) (p-t j) (p-i j) (p∘ j) (p-si j) (p-ti j) (p-s∘ j) (p-t∘ j) (p-isMorph∘ j) (p-assococ∘ j) (p-lUnit∘ j) (p-rUnit∘ j)


module Cats.Category.Cat.Facts.Terminal where

open import Cats.Category
open import Cats.Category.Cat using (Cat)
open import Cats.Category.One using (One)

instance
  hasTerminal : ∀ lo la l≈ → HasTerminal (Cat lo la l≈)
  hasTerminal lo la l≈ = record
      { One = One lo la l≈
      ; isTerminal = _
      }


-- This file is the source Agda file
-- Edit this file not Common.hs
-- The warning below will be written to Common.hs

{- Description : Property based testing Name Utilities

This file contains various naming related utilities used for
generating Zerepoch Core types and terms.

-}

module ZerepochCore.Generators.NEAT.Common where

-- warning to be written to Haskell file:
{-# FOREIGN AGDA2HS
{-
!!! THIS FILE IS GENERATED FROM Common.agda
!!! DO NOT EDIT THIS FILE. EDIT Common.agda
!!! AND THEN RUN agda2hs ON IT.
-}
#-}

{-# FOREIGN AGDA2HS

{-# LANGUAGE EmptyCase           #-}
{-# LANGUAGE EmptyDataDeriving   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Enumerable
import qualified Data.Stream               as Stream
import qualified Data.Text                 as Text
import           ZerepochCore.Name  (Name, TyName (..))
import           ZerepochCore.Quote (MonadQuote (..), freshName)
#-}
-- * Enumerating deBruijn indices

-- empty type
data Z : Set where

{-# COMPILE AGDA2HS Z deriving (Eq, Ord, Show) #-}

-- maybe type
data S (n : Set) : Set where
  FZ : S n
  FS : n → S n

{-# COMPILE AGDA2HS S deriving (Eq, Ord, Show, Functor) #-}

{-# FOREIGN AGDA2HS
instance Enumerable Z where
  enumerate = datatype []

instance Enumerable n => Enumerable (S n) where
  enumerate = share $ aconcat
    [ c0 FZ
    , c1 FS
    ]

-- |Absurd for the zero type.
fromZ :: Z -> a
fromZ i = case i of {}

-- * Namespaces

data NameState n = NameState { nameOf :: n -> Name, freshNameStrings :: Stream.Stream Text.Text }

newtype TyNameState n = TyNameState (NameState n)

tynameOf :: TyNameState n -> n -> TyName
tynameOf (TyNameState NameState{..}) i = TyName (nameOf i)

-- |Create an empty name state from a stream of text names.
emptyNameState :: Stream.Stream Text.Text -> NameState Z
emptyNameState strs = NameState { nameOf = fromZ, freshNameStrings = strs }

-- |Extend name state with a fresh name.
extNameState
  :: (MonadQuote m)
  => NameState n
  -> m (NameState (S n))
extNameState NameState{..} = liftQuote $ do
  let str = Stream.head freshNameStrings
      freshNameStrings' = Stream.tail freshNameStrings
  name <- freshName str
  let nameOf' FZ     = name
      nameOf' (FS i) = nameOf i
  return NameState { nameOf = nameOf', freshNameStrings = freshNameStrings' }

-- |Create an empty name state from a stream of text names.
emptyTyNameState :: Stream.Stream Text.Text -> TyNameState Z
emptyTyNameState strs = TyNameState (emptyNameState strs)

-- |Extend type name state with a fresh type name.
extTyNameState
  :: (MonadQuote m)
  => TyNameState n
  -> m (TyNameState (S n))
extTyNameState (TyNameState nameState) =
  TyNameState <$> extNameState nameState

-- |Create a stream of names |x0, x1, x2, ...| from a prefix |"x"|
mkTextNameStream :: Text.Text -> Stream.Stream Text.Text
mkTextNameStream prefix =
  Stream.map
    (\n -> prefix <> Text.pack (show n))
    (Stream.iterate (+1) (0 :: Integer))
#-}


open import Level using (_⊔_)
open import Function using (_$_)
open import Algebra using (CommutativeRing)

module AKS.Modular.Equivalence {c ℓ} (R : CommutativeRing c ℓ) where

open CommutativeRing R using (0#; 1#; _+_; _*_; -_; _-_)
  renaming (Carrier to C)
open CommutativeRing R using (+-cong; +-congˡ; +-congʳ; +-identityʳ; +-assoc; +-comm)
open CommutativeRing R using (-‿inverseʳ; -‿inverseˡ; -‿cong)
open CommutativeRing R using (zeroˡ; distribʳ; distribˡ; *-congˡ; *-assoc; *-comm)
open CommutativeRing R using (_≈_; isEquivalence; setoid; ring)
  renaming (refl to ≈-refl; sym to ≈-sym)
open import Relation.Binary.Reasoning.Setoid setoid
open import Algebra.Properties.Ring ring using (-‿distribˡ-*; -‿+-comm; -‿involutive; -0#≈0#)

infix 4 _≈_[mod_]
record _≈_[mod_] (x : C) (y : C) (n : C) : Set (c ⊔ ℓ) where
  constructor modulo
  field
    k : C
    x-y≈k*n : x - y ≈ k * n

refl : ∀ {x} {y} {n} → x ≈ y → x ≈ y [mod n ]
refl {x} {y} {n} x≈y = modulo 0# $ begin
  x - y  ≈⟨ +-congˡ (-‿cong (≈-sym x≈y)) ⟩
  x - x  ≈⟨ -‿inverseʳ x ⟩
  0#     ≈⟨ ≈-sym (zeroˡ n) ⟩
  0# * n ∎

sym : ∀ {x y} {n} → x ≈ y [mod n ] → y ≈ x [mod n ]
sym {x} {y} {n} (modulo k x-y≈k*n) = modulo (- k) $ begin
  y - x       ≈⟨ +-congʳ (≈-sym (-‿involutive y)) ⟩
  - (- y) - x ≈⟨ -‿+-comm (- y) x ⟩
  - (- y + x) ≈⟨ -‿cong (+-comm (- y) x) ⟩
  - (x - y)   ≈⟨ -‿cong x-y≈k*n ⟩
  - (k * n)   ≈⟨ -‿distribˡ-* k n ⟩
  - k * n     ∎

trans : ∀ {x y z} {n} → x ≈ y [mod n ] → y ≈ z [mod n ] → x ≈ z [mod n ]
trans {x} {y} {z} {n} (modulo k₁ x-y≈k₁*n) (modulo k₂ y-z≈k₂*n) = modulo (k₁ + k₂) $ begin
  x - z               ≈⟨ +-congʳ (≈-sym (+-identityʳ x)) ⟩
  x + 0# - z          ≈⟨ +-congʳ (+-congˡ (≈-sym (-‿inverseˡ y))) ⟩
  x + (- y + y) - z   ≈⟨ +-congʳ (≈-sym (+-assoc x (- y) y)) ⟩
  (x - y) + y - z     ≈⟨ +-assoc (x - y) y (- z) ⟩
  (x - y) + (y - z)   ≈⟨ +-cong x-y≈k₁*n y-z≈k₂*n ⟩
  (k₁ * n) + (k₂ * n) ≈⟨ ≈-sym (distribʳ n k₁ k₂) ⟩
  (k₁ + k₂) * n   ∎

+-compat : ∀ {a₁ a₂ b₁ b₂} {n} → a₁ ≈ b₁ [mod n ] → a₂ ≈ b₂ [mod n ] → a₁ + a₂ ≈ b₁ + b₂ [mod n ]
+-compat {a₁} {a₂} {b₁} {b₂} {n} (modulo k₁ a₁-b₁≈k₁*n) (modulo k₂ a₂-b₂≈k₂*n) = modulo (k₁ + k₂) $ begin
  a₁ + a₂ - (b₁ + b₂)     ≈⟨ +-assoc a₁ a₂ (- (b₁ + b₂)) ⟩
  a₁ + (a₂ - (b₁ + b₂))   ≈⟨ +-congˡ (+-congˡ (≈-sym (-‿+-comm b₁ b₂))) ⟩
  a₁ + (a₂ + (- b₁ - b₂)) ≈⟨ +-congˡ (≈-sym (+-assoc a₂ (- b₁) (- b₂))) ⟩
  a₁ + (a₂ - b₁ - b₂)     ≈⟨ +-congˡ (+-congʳ (+-comm a₂ (- b₁))) ⟩
  a₁ + (- b₁ + a₂ - b₂)   ≈⟨ +-congˡ (+-assoc (- b₁) a₂ (- b₂)) ⟩
  a₁ + (- b₁ + (a₂ - b₂)) ≈⟨ ≈-sym (+-assoc a₁ (- b₁) (a₂ - b₂)) ⟩
  (a₁ - b₁) + (a₂ - b₂)   ≈⟨ +-cong a₁-b₁≈k₁*n a₂-b₂≈k₂*n ⟩
  (k₁ * n) + (k₂ * n)     ≈⟨ ≈-sym (distribʳ n k₁ k₂) ⟩
  (k₁ + k₂) * n           ∎

*-compat : ∀ {a₁ a₂ b₁ b₂} {n} → a₁ ≈ b₁ [mod n ] → a₂ ≈ b₂ [mod n ] → a₁ * a₂ ≈ b₁ * b₂ [mod n ]
*-compat {a₁} {a₂} {b₁} {b₂} {n} (modulo k₁ a₁-b₁≈k₁*n) (modulo k₂ a₂-b₂≈k₂*n) = modulo (a₂ * k₁ + b₁ * k₂) $ begin
  a₁ * a₂ - b₁ * b₂                                 ≈⟨ +-congˡ (-‿cong (*-comm b₁ b₂)) ⟩
  a₁ * a₂ - b₂ * b₁                                 ≈⟨ +-congʳ (≈-sym (+-identityʳ (a₁ * a₂))) ⟩
  a₁ * a₂ + 0# - b₂ * b₁                            ≈⟨ +-congʳ (+-congˡ lemma) ⟩
  a₁ * a₂ + (- (b₁ * a₂) + a₂ * b₁) - b₂ * b₁       ≈⟨ +-congʳ (≈-sym (+-assoc (a₁ * a₂) (- (b₁ * a₂)) (a₂ * b₁))) ⟩
  a₁ * a₂ - b₁ * a₂ + a₂ * b₁ - b₂ * b₁             ≈⟨ +-assoc (a₁ * a₂ - b₁ * a₂) (a₂ * b₁) (- (b₂ * b₁)) ⟩
  (a₁ * a₂ - b₁ * a₂) + (a₂ * b₁ - b₂ * b₁)         ≈⟨ +-cong (+-congˡ (-‿distribˡ-* b₁ a₂)) (+-congˡ (-‿distribˡ-* b₂ b₁)) ⟩
  (a₁ * a₂ + (- b₁) * a₂) + (a₂ * b₁ + (- b₂) * b₁) ≈⟨ +-cong (≈-sym (distribʳ a₂ a₁ (- b₁))) (≈-sym (distribʳ b₁ a₂ (- b₂))) ⟩
  (a₁ - b₁) * a₂ + (a₂ - b₂) * b₁                   ≈⟨ +-cong (*-comm (a₁ - b₁) a₂) (*-comm (a₂ - b₂) b₁) ⟩
  a₂ * (a₁ - b₁) + b₁ * (a₂ - b₂)                   ≈⟨ +-cong (*-congˡ a₁-b₁≈k₁*n) (*-congˡ a₂-b₂≈k₂*n) ⟩
  a₂ * (k₁ * n) + b₁ * (k₂ * n)                     ≈⟨ +-cong (≈-sym (*-assoc a₂ k₁ n)) (≈-sym (*-assoc b₁ k₂ n)) ⟩
  a₂ * k₁ * n + b₁ * k₂ * n                         ≈⟨ ≈-sym (distribʳ n (a₂ * k₁) (b₁ * k₂)) ⟩
  (a₂ * k₁ + b₁ * k₂) * n                           ∎
  where
  lemma : 0# ≈ - (b₁ * a₂) + a₂ * b₁
  lemma = begin
    0# ≈⟨ ≈-sym (-‿inverseˡ (b₁ * a₂)) ⟩
    - (b₁ * a₂) + b₁ * a₂ ≈⟨ +-congˡ (*-comm b₁ a₂) ⟩
    - (b₁ * a₂) + a₂ * b₁ ∎

n*x≈0 : ∀ {x} {n} → n * x ≈ 0# [mod n ]
n*x≈0 {x} {n} = modulo x $ begin
  n * x - 0# ≈⟨ +-congˡ -0#≈0# ⟩
  n * x + 0# ≈⟨ +-identityʳ (n * x) ⟩
  n * x      ≈⟨ *-comm n x ⟩
  x * n      ∎


open import Nat
open import Prelude
open import dynamics-core
open import contexts
open import htype-decidable
open import lemmas-matching
open import lemmas-consistency
open import disjointness
open import typed-elaboration

module elaborability where

  mutual
    elaborability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          holes-unique e →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    elaborability-synth HUNum SNum = _ , _ , ESNum
    elaborability-synth (HUPlus hu1 hu2 hd) (SPlus wt1 wt2)
      with elaborability-ana hu1 wt1 | elaborability-ana hu2 wt2
    ... | _ , _ , _ , D1 | _ , _ , _ , D2 =
      _ , _ , ESPlus hd (elab-ana-disjoint hd D1 D2) D1 D2
    elaborability-synth (HUAsc hu) (SAsc wt)
      with elaborability-ana hu wt
    ... | _ , _ , _ , D = _ , _ , ESAsc D
    elaborability-synth HUVar (SVar x) = _ , _ , ESVar x
    elaborability-synth (HULam2 hu) (SLam apt wt)
      with elaborability-synth hu wt
    ... | _ , _ , D = _ , _ , ESLam apt D
    elaborability-synth (HUAp hu1 hu2 hd) (SAp wt1 m wt2)
      with elaborability-ana hu1 (ASubsume wt1 (~sym (▸arr-consist m))) |
           elaborability-ana hu2 wt2
    ... | _ , _ , _ , D1 | _ , _ , _ , D2 =
      _ , _ , ESAp hd (elab-ana-disjoint hd D1 D2) wt1 m D1 D2
    elaborability-synth (HUPair hu1 hu2 hd) (SPair wt1 wt2)
      with elaborability-synth hu1 wt1 | elaborability-synth hu2 wt2
    ... | _ , _ , D1 | _ , _ ,  D2 = _ , _ , ESPair hd (elab-synth-disjoint hd D1 D2) D1 D2
    elaborability-synth (HUFst hu) (SFst wt m)
      with elaborability-ana hu (ASubsume wt (~sym (▸prod-consist m)))
    ... | _ , _ , _ , D = _ , _ , ESFst wt m D
    elaborability-synth (HUSnd hu) (SSnd wt m)
      with elaborability-ana hu (ASubsume wt (~sym (▸prod-consist m)))
    ... | _ , _ , _ , D = _ , _ , ESSnd wt m D
    elaborability-synth HUHole SEHole = _ , _ , ESEHole
    elaborability-synth (HUNEHole hu hnn) (SNEHole wt)
      with elaborability-synth hu wt
    ... | _ , _ , D = _ , _ , ESNEHole (elab-new-disjoint-synth hnn D) D

    elaborability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                        holes-unique e →
                        Γ ⊢ e <= τ →
                        Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                          (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    elaborability-ana {e = e} hu (ASubsume wt con)
      with elaborability-synth hu wt
    elaborability-ana {e = N x} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = e ·+ e₁} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = e ·: x} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = X x} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = ·λ x ·[ x₁ ] e} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = e ∘ e₁} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = ⟨ e , e₁ ⟩} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = fst e} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = snd e} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) wt' con
    elaborability-ana {e = ⦇-⦈[ u ]} hu (ASubsume wt con)
      | _ , _ , wt' = _ , _ , _ , EAEHole
    elaborability-ana {e = ⦇⌜ e ⌟⦈[ u ]} (HUNEHole hu hnn) (ASubsume (SNEHole wt) con)
      | _ , _ , ESNEHole apt wt' with elaborability-synth hu wt
    ... | _ , _ , wt'' = _ , _ , _ , EANEHole (elab-new-disjoint-synth hnn wt'') wt''
    elaborability-ana (HULam1 hu) (ALam apt m wt)
      with elaborability-ana hu wt
    ... | _ , _ , _ , wt' = _ , _ , _ , EALam apt m wt'
    elaborability-ana (HUInl hu) (AInl m wt)
      with elaborability-ana hu wt
    ... | _ , _ , _ , wt' = _ , _ , _ , EAInl m wt'
    elaborability-ana (HUInr hu) (AInr m wt)
      with elaborability-ana hu wt
    ... | _ , _ , _ , wt' = _ , _ , _ , EAInr m wt'
    elaborability-ana (HUCase hu hu1 hu2 hd1 hd2 hd12) (ACase apt1 apt2 m wt wt1 wt2)
      with elaborability-synth hu wt | elaborability-ana hu1 wt1 | elaborability-ana hu2 wt2
    ... | _ , _ , wt' | _ , _ , _ , wt1' | _ , _ , _ , wt2' =
      _ , _ , _ , EACase hd1 hd2 hd12 (elab-synth-ana-disjoint hd1 wt' wt1')
                                      (elab-synth-ana-disjoint hd2 wt' wt2')
                                      (elab-ana-disjoint hd12 wt1' wt2')
                                      apt1 apt2 wt' m wt1' wt2'


module Data.Signed where

open import Data.Bit using
  (Bit
  ; b0
  ; b1
  ; Bits-num
  ; Bits-neg
  ; Overflowing
  ; _overflow:_
  ; result
  ; carry
  ; WithCarry
  ; _with-carry:_
  ; toBool
  ; tryToFinₙ
  ; !ₙ
  ; _⊕_
  ; _↔_
  ) renaming
  ( _+_ to bit+
  ; _-_ to bit-
  ; ! to bit!
  ; _&_ to bit&
  ; _~|_ to bit|
  ; _^_ to bit^
  ; _>>_ to bit>>
  ; _<<_ to bit<<
  )
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; suc; zero) renaming (_≤_ to ℕ≤)
open import Data.Vec using (Vec; _∷_; []; head; tail; replicate)
open import Data.Nat.Literal using (Number)
open import Data.Int.Literal using (Negative)
open import Data.Maybe using (just; nothing)
open import Data.Empty using (⊥)

infixl 8 _-_ _+_
infixl 7 _<<_ _>>_
infixl 6 _&_
infixl 5 _^_
infixl 4 _~|_

record Signed (n : ℕ) : Set where
  constructor mk-int
  field
    bits : Vec Bit n

open Signed public

instance
  Signed-num : {m : ℕ} → Number (Signed m)
  Signed-num {zero} .Number.Constraint = Number.Constraint (Bits-num {zero})
  Signed-num {suc m} .Number.Constraint = Number.Constraint (Bits-num {m})
  Signed-num {zero} .Number.fromNat zero ⦃ p ⦄ = mk-int [] where
  Signed-num {zero} .Number.fromNat (suc _) ⦃ ℕ≤.s≤s () ⦄
  Signed-num {suc m} .Number.fromNat n ⦃ p ⦄ = mk-int (mk-bits p) where
    mk-bits : Number.Constraint (Bits-num {m}) n → Vec Bit (suc m)
    mk-bits p = b0 ∷ Number.fromNat Bits-num n ⦃ p ⦄

instance
  Signed-neg : {m : ℕ} → Negative (Signed (suc m))
  Signed-neg {m} .Negative.Constraint = Negative.Constraint (Bits-neg {m})
  Signed-neg {m} .Negative.fromNeg n ⦃ p ⦄ = mk-int bitVec where
    bitVec : Vec Bit (suc m)
    bitVec = Negative.fromNeg (Bits-neg {m}) n ⦃ p ⦄

_+_ : {n : ℕ} → Signed n → Signed n → Overflowing (Signed n)
p + q = mk-int (result sum) overflow: toBool overflow where
  sum = bit+ (bits p) (bits q)
  last-carry : {n : ℕ} → Vec Bit n → Bit
  last-carry [] = b0
  last-carry (b ∷ _) = b
  overflow = head (carry sum) ⊕ last-carry (tail (carry sum))

_-_ : {n : ℕ} → Signed n → Signed n → Overflowing (Signed n)
p - q = mk-int (result sub) overflow: toBool overflow where
  sub = bit- (bits p) (bits q)
  last-carry : {n : ℕ} → Vec Bit n → Bit
  last-carry [] = b0
  last-carry (b ∷ _) = b
  overflow = head (carry sub) ↔ last-carry (tail (carry sub))

rotr : {n : ℕ} → Signed n → Signed n → WithCarry (Signed n) (Signed n)
rotr {n} (mk-int ps) (mk-int qs) = new-result with-carry: new-carry where
  shifted : WithCarry (Vec Bit n) (Vec Bit n)
  shifted with tryToFinₙ qs
  ...        | just i  = bit>> ps i
  ...        | nothing = replicate b0 with-carry: ps
  new-result : Signed n
  new-result = mk-int (result shifted)
  new-carry : Signed n
  new-carry = mk-int (carry shifted)

rotl : {n : ℕ} → Signed n → Signed n → WithCarry (Signed n) (Signed n)
rotl {n} (mk-int ps) (mk-int qs) = new-result with-carry: new-carry where
  shifted : WithCarry (Vec Bit n) (Vec Bit n)
  shifted with tryToFinₙ qs
  ...        | just i  = bit<< ps i
  ...        | nothing = replicate b0 with-carry: ps
  new-result : Signed n
  new-result = mk-int (result shifted)
  new-carry : Signed n
  new-carry = mk-int (carry shifted)

_>>_ : {n : ℕ} → Signed n → Signed n → Signed n
ps >> qs = result (rotr ps qs)

_<<_ : {n : ℕ} → Signed n → Signed n → Signed n
ps << qs = result (rotl ps qs)

arotr : {n : ℕ} → Signed n → Signed n → WithCarry (Signed n) (Signed n)
arotr {n} (mk-int []) _ = mk-int [] with-carry: mk-int []
arotr {suc n} (mk-int (p ∷ ps)) (mk-int qs) = new-result with-carry: new-carry
  where
    shifted : WithCarry (Vec Bit n) (Vec Bit n)
    shifted with tryToFinₙ qs
    ...        | just i  = bit>> ps i
    ...        | nothing = replicate b0 with-carry: ps
    new-result : Signed (suc n)
    new-result = mk-int (p ∷ result shifted)
    new-carry : Signed (suc n)
    new-carry = mk-int (b0 ∷ carry shifted)

arotl : {n : ℕ} → Signed n → Signed n → WithCarry (Signed n) (Signed n)
arotl {n} (mk-int []) _ = mk-int [] with-carry: mk-int []
arotl {suc n} (mk-int (p ∷ ps)) (mk-int qs) = new-result with-carry: new-carry
  where
    shifted : WithCarry (Vec Bit n) (Vec Bit n)
    shifted with tryToFinₙ qs
    ...        | just i  = bit<< ps i
    ...        | nothing = replicate b0 with-carry: ps
    new-result : Signed (suc n)
    new-result = mk-int (p ∷ result shifted)
    new-carry : Signed (suc n)
    new-carry = mk-int (b0 ∷ carry shifted)

_a>>_ : {n : ℕ} → Signed n → Signed n → Signed n
ps a>> qs = result (rotr ps qs)

_a<<_ : {n : ℕ} → Signed n → Signed n → Signed n
ps a<< qs = result (rotl ps qs)

! : {n : ℕ} → Signed n → Signed n
! (mk-int ps) = mk-int (!ₙ ps)

_&_ : {n : ℕ} → Signed n → Signed n → Signed n
(mk-int ps) & (mk-int qs) = mk-int (bit& ps qs)

_~|_ : {n : ℕ} → Signed n → Signed n → Signed n
(mk-int ps) ~| (mk-int qs) = mk-int (bit| ps qs)

_^_ : {n : ℕ} → Signed n → Signed n → Signed n
(mk-int ps) ^ (mk-int qs) = mk-int (bit^ ps qs)


module REMatch where

open import Data.Char
import Data.Nat
--open import Data.List
open import Data.Bool

open import Data.Product

import Algebra
import Algebra.FunctionProperties

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Data.List
open import Data.List.Properties

open import Data.Sum

open import Data.List.NonEmpty

--open List-solver renaming (nil to :[]; _⊕_ to _:++_; _⊜_ to _:≡_; solve to listSolve; prove to listProve)

open import Algebra
import Algebra.FunctionProperties as FunProp

open import Data.Maybe

open import Data.Nat

open import RETypes

import Relation.Binary.Reflection as Ref

import Data.Bool.Properties

listDivisions : List Char -> List (List Char × List Char)
listDivisions [] = ( [] , []) ∷ []
listDivisions (h ∷ t) = ([] , h ∷ t ) ∷ (Data.List.map (λ p -> ( (h ∷ proj₁ p) , proj₂ p )) (listDivisions t) )

elementMatches : {A : Set} (f : A -> Bool) -> List A -> Bool
elementMatches f [] = false
elementMatches f (h ∷ t) = (f h) ∨ elementMatches f t

{-
mutual

  starMatch : {n : Null?} -> (RE n) -> List Char -> List Char -> (List Char -> Bool) -> Bool
  starMatch (r *) s1 (sh ∷ st) k =  (acc r (s1 ++ Data.List.[ sh ]) null ∧ acc ( r *) st k )  ∨ starMatch (r *) (s1 ++ Data.List.[ sh ]) st k
  starMatch (r *) s1 [] k = false
  starMatch _ _ _ _ = false
-}

{-# TERMINATING #-}
acc :  {n : Null?} -> RE n -> List Char -> (List Char -> Bool) -> Bool
acc ε s k = k s
acc ∅ _ _ = false
acc (Lit _) [] _ = false
acc (Lit c) (sFirst ∷ sRest) k with (c Data.Char.≟ sFirst)
... | yes pf  = (k sRest)
... | no _  = false
acc (r₁ + r₂) s k = (acc r₁ s k) ∨ (acc r₂ s k)
acc (r₁ · r₂) s k = acc r₁ s (λ s' -> acc r₂ s' k)
acc (r *) [] k = (k [])
acc (r *) (ch ∷ ct) k =
  let
    cs = ch ∷ ct
  in k cs ∨ acc r cs (\cs' -> acc (r *) cs' k)
  --acc r cs (\cs' -> acc (r) cs' k)
  --acc (r *) (sFirst ∷ sRest) k =  starMatch r (sFirst ∷ [] ) sRest k

accept : {n : Null?} -> RE n -> List Char -> Bool
accept r s = acc r s null

concatPreservesNonNull : {s1 : List Char}
  -> {s2 : List Char}
  -> (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s1 ≡ h ∷ t) )
  -> (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s1 ++ s2 ≡ h ∷ t) )
concatPreservesNonNull {s1} {s2 = []} (sh , st , pf) =
  let
    concatPf : s1 ++ [] ≡ s1
    concatPf = (solve (suc zero) (λ x → x ⊕ nil , x) (λ {x} → refl)) s1 --Should be easy, I might have already proved something similar,
    --This is probably a good place to try the List prover stuff
  in sh , st , trans concatPf pf
  where open List-solver
concatPreservesNonNull {s1} {s2 = x ∷ s2} (sh , st , pf) =
  let
    --subProof : (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s1 ++ s2 ≡ h ∷ t) )
    (h , t , subProof) = concatPreservesNonNull {s1} {s2} (sh , st , pf)
    p2 : ((sh ∷ st) ++ s2 ≡ h ∷ t)
    p2 = subst (λ x₁ → x₁ ++ s2 ≡ h ∷ t) pf subProof
  in sh , (st ++ (x ∷ s2)) , cong (λ x₁ → x₁ ++ x ∷ s2) pf

concatPreservesNonNull2 : {s1 : List Char}
  -> {s2 : List Char}
  -> (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s2 ≡ h ∷ t) )
  -> (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s1 ++ s2 ≡ h ∷ t) )
concatPreservesNonNull2 {[]} (sh , st , pf) = sh , st , pf
concatPreservesNonNull2 {x ∷ s1} {s2} (sh , st , pf) = x , s1 ++ s2 , refl

open ≡-Reasoning

nullCorrect : (r : RE NonNull) -> (s : List Char ) -> (REMatch s r)
  -> (∃ λ (h : Char) -> ∃ λ (t : List Char) -> (s ≡ h ∷ t) )
nullCorrect .(Lit c) .(c ∷ []) (LitMatch c) = c , [] , refl
nullCorrect ._ s (LeftPlusMatch {nb = BothNullB} {r1 = r1} r2 match) = nullCorrect r1 s match
nullCorrect ._ s (RightPlusMatch {nb = BothNullB} r1 {r2 = r2} match) = nullCorrect r2 s match
nullCorrect .(r1 · r2) s (ConcatMatch {nt = LeftNullT} {s1 = s1} {s2 = s2} {spf = spf} {r1 = r1} {r2 = r2}  match1 match2) =
  let
    sh , st , subPf = concatPreservesNonNull2 {s1 = s1} {s2 = s2} (nullCorrect r2 s2 match2)
  in sh , st , trans (sym spf) subPf   --subH , subT , ?
nullCorrect ._ s (ConcatMatch {nt = BothNonNullT} {s1 = s1} {s2 = s2} {spf = spf} {r1 = r1} {r2 = r2} match1 match2) =
  let
    sh , st , subPf = concatPreservesNonNull2 {s1 = s1} {s2 = s2} (nullCorrect r2 s2 match2)
  in sh , st , trans (sym spf) subPf
nullCorrect ._ s (ConcatMatch {nt = RightNullT} {s1 = s1} {s2 = s2} {spf = spf} {r1 = r1} {r2 = r2} match1 match2) =
  let
    sh , st , subPf = concatPreservesNonNull {s1 = s1} {s2 = s2} (nullCorrect r1 s1 match1)
  in sh , st , trans (sym spf) subPf  -- concatPreservesNonNull (nullCorrect r1 s1 match1)

--Taken from http://gelisam.blogspot.ca/2010/10/equality-is-useless-transmutation.html
--Can probably be done with more complicated existing stuff, but this is easier
mySubst : {X : Set}
       → (P : X → Set)
       → (x y : X)
       → x ≡ y
       → P x
       → P y
mySubst P v .v refl p = p

orLemma1 : {x : Bool} {y : Bool} -> (y ≡ true) -> (y ∨ x) ≡ true
orLemma1 {x} {true} pf = refl
orLemma1 {x} {false} ()

andElim1 : {x : Bool} {y : Bool} -> (x ∧ y) ≡ true -> (x ≡ true)
andElim1 {true} pf = refl
andElim1 {false} ()

--TODO Pattern match on and first
andElim2 : {x : Bool} {y : Bool} -> (x ∧ y) ≡ true -> (y ≡ true)
andElim2 {y = true} pf = refl
andElim2 {true} {false} ()
andElim2 {false} {false} ()

andCombine : {x : Bool} {y : Bool} -> x ≡ true -> y ≡ true -> (x ∧ y) ≡ true
andCombine {true} pfx pfy = pfy
andCombine {false} ()

{-
orCommut : {x : Bool} {y : Bool} -> (y ∨ x) ≡ (x ∨ y)
orCommut {true} {true} = refl
orCommut {false} {true} = refl
orCommut {true} {false} = refl
orCommut {false} {false} = refl
-}

orLemma2 : {x : Bool} {y : Bool} -> (y ≡ true) -> (x ∨ y) ≡ true
orLemma2 {true} {true} pf = refl
orLemma2 {false} {true} pf = refl
orLemma2 {true} {false} pf = refl
orLemma2 {false} {false} ()

orCases : {x : Bool} {y : Bool} -> (x ∨ y ≡ true) -> (x ≡ true) ⊎ (y ≡ true)
orCases {true} y = inj₁ refl
orCases {false} y = inj₂ y

listRightIdent : { x : List Char} -> (x ++ []) ≡ x
listRightIdent {[]} = refl
listRightIdent {x ∷ x₁} = cong (_∷_ x) (listRightIdent {x₁})

listAssoc : {x y z : List Char} -> (x ++ y) ++ z ≡ x ++ (y ++ z)
listAssoc {[]} = λ {y} {z} → refl
listAssoc {xh ∷ xt} {y} {z} = cong (_∷_ xh) (listAssoc {xt} {y} {z})

maybeHead : List Char -> Maybe Char
maybeHead [] = nothing
maybeHead (x ∷ _) = just x

fakeTail : List Char -> List Char
fakeTail [] = []
fakeTail (_ ∷ t) = t

myFromJust : Maybe Char -> Char
myFromJust (just x) = x
myFromJust (nothing) = 'a'

sameHead : {a : Char}{b : Char}{l1 : List Char}{l2 : List Char} -> ((a ∷ l1) ≡ (b ∷ l2)) -> (a ≡ b)
sameHead {a} {b} {l1} {l2} pf =
  let
    maybeSameHead : (just a) ≡ (just b)
    maybeSameHead = cong (maybeHead) pf
  in cong myFromJust maybeSameHead

sameTail : {a : Char}{b : Char}{l1 : List Char}{l2 : List Char} -> ((a ∷ l1) ≡ (b ∷ l2)) -> (l1 ≡ l2)
sameTail {a} {b} {l1} {l2} pf = cong fakeTail pf

emptyMiddleList : {c : Char}{s1 s2 : List Char} -> (c ∷ s1 ≡ (c ∷ []) ++ s2 ) -> s1 ≡ s2
emptyMiddleList {c} {s1} {s2} spf =

  let
    p0 : (s1 ≡ [] ++ s2 )
    p0 = cong fakeTail spf
    p1 : [] ++ s2 ≡ s2
    p1 = refl
  in trans p0 p1

accCorrect :
  {n : Null? }
  (r : RE n)
  (s : List Char) (s1 : List Char) (s2 : List Char)
  (k : (List Char -> Bool))
  -> ( (s1 ++ s2) ≡ s)
  -> (REMatch s1 r)
  -> (k s2 ≡ true)
  -> (acc r s k ≡ true )
--accCorrect ∅ [] [] [] k _ () kproof
accCorrect ε  [] ._ []  k _ EmptyMatch kproof = kproof
accCorrect (Lit .c) (c1 ∷ srest ) (.c ∷ []) s2 k stringProof (LitMatch c) kproof with (c Data.Char.≟ c1)
... | yes eqPf =   let
    sameHeads : c ≡ c1
    sameHeads = sameHead stringProof
    p0 : c Data.List.∷ srest ≡ c1 Data.List.∷ srest
    p0 = cong (λ x → x ∷ srest) sameHeads

    flipProof : (c1 ∷ srest ) ≡ (c ∷ []) ++ s2
    flipProof = sym stringProof
    cFlip : (c ∷ srest ) ≡ (c ∷ []) ++ s2
    cFlip = trans p0 flipProof
    restProof : srest ≡ s2
    restProof = emptyMiddleList cFlip

    primEq : (Dec (c ≡ c1))
    primEq = yes sameHeads

    pf3 = cong (λ theChar -> acc (Lit c) (c ∷ srest) k ) sameHeads

  in trans (cong k restProof) kproof
accCorrect (Lit .c) (c1 ∷ srest ) (.c ∷ []) s2 k stringProof (LitMatch c) () | no pf

{-
  let
    sameHeads = sameHead stringProof
    primEq : (Dec (c ≡ c1))
    primEq = yes sameHeads
    pf3 = cong (λ theChar -> acc (Lit c) (c ∷ srest) k ) sameHeads
    restProof : srest ≡ s2
    restProof = {!!}
  in cong k restProof
-}
accCorrect (.r1 · .r2 ) s .s1 s2  k  split1 (ConcatMatch {_} {_} {n3} {nt} {s1'} {s2'} {s1} {spf'} {r1} {r2} subMatch1 subMatch2) kproof  =
  let
           --s1 = s1' ++ s2'
           split2 : (s1' ++ s2') ≡ s1
           split2 = spf' --refl
           split3 : (s1' ++ s2') ++ s2 ≡ s1 ++ s2
           split3 = cong (λ x -> x ++ s2) split2
           split4 : s1' ++ s2' ++ s2 ≡ (s1' ++ s2') ++ s2
           split4 =  sym (listAssoc {s1'} {s2'} {s2})
           transChain : s1' ++ s2' ++ s2 ≡ s
           transChain = trans split4 (trans split3 split1)
  in accCorrect r1 s s1' (s2' ++ s2) (\cs -> acc r2 cs k) transChain
    subMatch1 (accCorrect r2 (s2' ++ s2) s2' s2 k refl subMatch2 kproof)
accCorrect (.r1 + .r2 ) s .s1 s2  k
  splitProof (LeftPlusMatch {_} {_} {n3} {nb} {s1} {r1} (r2) subMatch) kproof  =
   orLemma1 (accCorrect r1 s s1 s2 k splitProof subMatch kproof )
accCorrect (.r1 + .r2) s .s1 s2  k
  splitProof (RightPlusMatch {_} {_} {n3} {nb} {s1} (r1) {r2} subMatch) kproof  =
    let subCorrect = accCorrect r2 s s1 s2 k splitProof subMatch kproof
    in orLemma2 {acc r1 s k} {acc r2 s k} subCorrect
accCorrect (.r *) [] ._ [] k _ (EmptyStarMatch {r}) kproof = kproof

accCorrect {MaybeNull} (.r *) (sh ∷ st ) .s1 s2  k  split1 (StarMatch {c1} {s1t'} {s2'} {s1} {spf} {r} subMatch1 subMatch2) kproof  =
  let
           s = (sh ∷ st )
           s1' = (c1 ∷ s1t')

           split2 : (s1' ++ s2') ≡ s1
           split2 = spf
           split3 : (s1' ++ s2') ++ s2 ≡ s1 ++ s2
           split3 = cong (λ x -> x ++ s2) split2
           split4 : s1' ++ s2' ++ s2 ≡ (s1' ++ s2') ++ s2
           split4 =  sym (listAssoc {s1'} {s2'} {s2})
           transChain : s1' ++ s2' ++ s2 ≡ s
           transChain = trans split4 (trans split3 split1)
           sub2' : REMatch {MaybeNull} s2' (r *)
           sub2' = subMatch2
           subCorrect : acc (r *) (s2' ++ s2) k ≡ true
           subCorrect = accCorrect (r *) (s2' ++ s2) s2' s2 k refl subMatch2 kproof
           rightCorrect : acc r s (\cs' -> acc (r *) cs' k) ≡ true
           rightCorrect = accCorrect r s s1' (s2' ++ s2) (λ cs → acc (r *) cs k) transChain subMatch1 subCorrect
           orCorrect : (k s ∨ acc r s (\cs' -> acc (r *) cs' k) ) ≡ true
           orCorrect = orLemma2 {x = k s} rightCorrect
  --TODO pass in x and y explicitly
  in orCorrect --accCorrect r s s1' (s2' ++ s2) (\cs -> acc (r *) cs k) transChain
    --subMatch1 (accCorrect (r *) (s2' ++ s2) s2' s2 k refl subMatch2 kproof)

accCorrect (r *) (sh ∷ st) [] s2 k sp1 _ kproof =
  let
    s = sh ∷ st
    sp2 : s2 ≡ s
    sp2 = sp1
    kproof2 : k s ≡ k s2
    kproof2 = cong k (sym sp1)
    kproof3 : k s ≡ true
    kproof3 = trans kproof2 kproof
    --orProof : (k s ∨ starMatch r [] s k) ≡ true
    orProof = orLemma1 kproof3
  in orProof
 --accCorrect r s s1' (s2' ++ s2) (\cs -> acc (r *) cs k) transChain
    --subMatch1 (accCorrect (r *) (s2' ++ s2) s2' s2 k refl subMatch2 kproof)
--accCorrect  (.r *) s ._ s2 k sp1 (StarMatch {s1'} {s1''} {r} sub1 sub2) kproof = ?
accCorrect ∅ _ _ _ _ _ ()
accCorrect ε (_ ∷ _ ) _ _ _ () _
accCorrect _ [] (_ ∷ _ ) _ _ () _ _
accCorrect _ [] _ (_ ∷ _ ) _ () _ _
accCorrect (Lit _) [] _ _ _ () _ _
accCorrect {._} (_* _) [] [] [] _ _
             (StarMatch {_} {_} {_} {._} {()} {._} _ _) _
--accCorrect _ _ _ _ _ _ _ _ = {!!} --This case should disappear when I finish star

boolExclMiddle : {x : Bool} { y : Bool } -> (x ∨ y ≡ true ) -> (x ≡ false) -> (y ≡ true)
boolExclMiddle {true} p1 ()
boolExclMiddle {false} p1 p2 = p1

{-# TERMINATING #-}
accComplete :
  {n : Null?}
  (r : RE n)
  (s : List Char)
  (k : (List Char -> Bool))
  -> (acc r s k ≡ true)
  -> ∃ (λ s1 -> ∃ (λ s2 -> (s1 ++ s2 ≡ s) × ( k s2 ≡ true) × (REMatch s1 r ) ) )
accComplete ε [] k pf =  [] , [] , refl , pf , EmptyMatch
accComplete ε s k pf = [] , s , refl , pf , EmptyMatch
accComplete (Lit c) (c1 ∷ srest) k accProof with (c Data.Char.≟ c1)
...| yes eqProof =
    let
      charsEqual : c ≡ c1
      charsEqual = eqProof
    in  Data.List.[ c ] , srest , cong (λ x → x ∷ srest) charsEqual , accProof , LitMatch c
accComplete (Lit c) (c1 ∷ srest) k () | no _
accComplete (_·_ {n1} {n2} r1  r2) s k pf =
  let
    sub1 : acc r1 s (λ s' -> acc r2 s' k) ≡ true
    sub1 = pf
    s11 , s2' , psub1 , psub2 , match1  = accComplete r1 s (λ s' -> acc r2 s' k) pf
    s12 , s2 , p1 , p2 , match2 = accComplete r2 s2' k psub2
    localAssoc :  s11 ++ (s12 ++ s2) ≡ (s11 ++ s12) ++ s2
    localAssoc = sym (listAssoc {s11} {s12} {s2})
    subProof1 : s11 ++ s2' ≡ s11 ++ (s12 ++ s2)
    subProof1 = sym ( cong (λ x -> s11 ++ x) p1 )
    subProof2 : s11 ++ s2' ≡ (s11 ++ s12) ++ s2
    subProof2 = trans subProof1 localAssoc
    stringProof = trans (sym subProof2) psub1
  in (s11 ++ s12 ) , s2 , stringProof , p2 , (ConcatMatch {spf = refl} match1 match2)

accComplete (r1 + r2) s k accProof with (orCases accProof)
...  | inj₁ leftTrue  =
  let
    s1 , s2 , p1 , p2 , match = accComplete r1 s k leftTrue
  in s1 , s2 , p1 , p2 , LeftPlusMatch r2 match
...  | inj₂ rightTrue  = let
    s1 , s2 , p1 , p2 , match = accComplete r2 s k rightTrue
  in s1 , s2 , p1 , p2 , RightPlusMatch r1 match
accComplete (r *) [] k pf =  [] , [] , refl , pf , EmptyStarMatch
accComplete {MaybeNull} (r *) (sh ∷ st) k accProof with (orCases accProof)
... | inj₁ leftTrue  =  [] , (sh ∷ st) , refl , leftTrue , EmptyStarMatch
... | inj₂ rightTrue  =
  let
    rTest : RE NonNull
    rTest = r
    s = sh ∷ st
    sub1 : acc r s (λ s' -> acc (r *) s' k) ≡ true
    sub1 = rightTrue
    s11 , s2' , psub1 , psub2 , match1  = accComplete r s (λ s' -> acc (r *) s' k) rightTrue
    s12 , s2 , p1 , p2 , match2 = accComplete (r *) s2' k psub2
    localAssoc :  s11 ++ (s12 ++ s2) ≡ (s11 ++ s12) ++ s2
    localAssoc = sym (listAssoc {s11} {s12} {s2})
    subProof1 : s11 ++ s2' ≡ s11 ++ (s12 ++ s2)
    subProof1 = sym ( cong (λ x -> s11 ++ x) p1 )
    subProof2 : s11 ++ s2' ≡ (s11 ++ s12) ++ s2
    subProof2 = trans subProof1 localAssoc
    stringProof = trans (sym subProof2) psub1

    s11h , s11t , nnpf = nullCorrect r s11 match1
    nonNullPf : s11 ≡ s11h ∷ s11t
    nonNullPf = nnpf

    m1 : REMatch (s11h ∷ s11t) r
    m1 = mySubst (λ str → REMatch str r) s11 (s11h ∷ s11t) (nonNullPf) match1
    m2 : REMatch s12 (r *)
    m2 = match2
    newSpf : (s11h ∷ s11t) ++ s2' ≡ s11 ++ s2'
    newSpf = {!!}
    --ourMatch : REMatch (s11 ++ s12) (r *)
    ourMatch = StarMatch {spf = newSpf} {r = rTest} m1 ? --m2
  in (s11 ++ s12 ) , s2 , stringProof , p2 , {!!} --ourMatch
accComplete ∅ _ _ ()
accComplete (Lit _) [] _ ()

acceptCorrect :
  {n : Null? }
  (r : RE n)
  (s : List Char)
  -> (REMatch s r)
  -> (accept r s ≡ true )
acceptCorrect r s match = accCorrect r s s [] null listRightIdent match refl

nullEq : {x : List Char} -> (null x ≡ true ) -> (x ≡ [])
nullEq {[]} pf = refl
nullEq {x ∷ x₁} ()

substMatch : {n : Null?}{r : RE n}{s s1 : List Char} -> s1 ≡ s -> REMatch s1 r -> REMatch s r
substMatch refl m = m

acceptComplete :
  {n : Null? }
  (r : RE n)
  (s : List Char)
  -> (accept r s ≡ true )
  -> REMatch s r
acceptComplete r s pf =
  let
    s1 , s2 , sproof , ks2Proof , match = accComplete r s null pf
    s2Null : s2 ≡ []
    s2Null = nullEq ks2Proof
    sp3 : s1 ++ s2 ≡ s1 ++ []
    sp3 = cong (λ x -> s1 ++ x) s2Null
    sp4 : s1 ++ s2 ≡ s1
    sp4 = trans sp3 listRightIdent
    sp5 : s1 ≡ s
    sp5 = sym (trans (sym sproof) sp4)
  in substMatch sp5 match --match


------------------------------------------------------------------------
-- Various equality checkers (some complete, all sound)
------------------------------------------------------------------------

import Axiom.Extensionality.Propositional as E
import Level
open import Data.Universe

-- The code makes use of the assumption that propositional equality of
-- functions is extensional.

module README.DependentlyTyped.Equality-checker
  (Uni₀ : Universe Level.zero Level.zero)
  (ext : E.Extensionality Level.zero Level.zero)
  where

open import Category.Monad
open import Data.Maybe
import Data.Maybe.Categorical as Maybe
open import Data.Product
open import Function hiding (_∋_) renaming (const to k)
import README.DependentlyTyped.NBE as NBE; open NBE Uni₀ ext
import README.DependentlyTyped.NormalForm as NF; open NF Uni₀
import README.DependentlyTyped.Term as Term; open Term Uni₀
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary as Dec using (Dec; yes)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product

open P.≡-Reasoning
open RawMonadZero (Maybe.monadZero {f = Level.zero})

-- Decides if two "atomic type proofs" are equal.

infix 4 _≟-atomic-type_

_≟-atomic-type_ :
  ∀ {Γ σ} (σ′₁ σ′₂ : Γ ⊢ σ atomic-type) → Dec (σ′₁ ≡ σ′₂)
⋆  ≟-atomic-type ⋆  = yes P.refl
el ≟-atomic-type el = yes P.refl

mutual

  private

    -- A helper lemma.

    helper-lemma :
      ∀ {Γ₁ sp₁₁ sp₂₁ σ₁}
        (t₁₁ : Γ₁ ⊢ π sp₁₁ sp₂₁ , σ₁ ⟨ ne ⟩) (t₂₁ : Γ₁ ⊢ fst σ₁ ⟨ no ⟩)
        {Γ₂ sp₁₂ sp₂₂ σ₂}
        (t₁₂ : Γ₂ ⊢ π sp₁₂ sp₂₂ , σ₂ ⟨ ne ⟩) (t₂₂ : Γ₂ ⊢ fst σ₂ ⟨ no ⟩) →
      t₁₁ · t₂₁ ≅-⊢n t₁₂ · t₂₂ → t₁₁ ≅-⊢n t₁₂ × t₂₁ ≅-⊢n t₂₂
    helper-lemma _ _ ._ ._ P.refl = P.refl , P.refl

  -- Decides if two neutral terms are identical. Note that the terms
  -- must have the same context, but they do not need to have the same
  -- type.

  infix 4 _≟-⊢ne_

  _≟-⊢ne_ : ∀ {Γ σ₁} (t₁ : Γ ⊢ σ₁ ⟨ ne ⟩)
                {σ₂} (t₂ : Γ ⊢ σ₂ ⟨ ne ⟩) →
            Dec (t₁ ≅-⊢n t₂)
  var x₁ ≟-⊢ne var x₂ = Dec.map′ var-n-cong helper (x₁ ≟-∋ x₂)
    where
    helper : ∀ {Γ₁ σ₁} {x₁ : Γ₁ ∋ σ₁}
               {Γ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} →
             var x₁ ≅-⊢n var x₂ → x₁ ≅-∋ x₂
    helper P.refl = P.refl

  t₁₁ · t₂₁ ≟-⊢ne t₁₂ · t₂₂ with t₁₁ ≟-⊢ne t₁₂
  ... | Dec.no neq = Dec.no (neq ∘ proj₁ ∘ helper-lemma _ t₂₁ _ t₂₂)
  ... | yes eq     = Dec.map′
    (·n-cong eq)
    (proj₂ ∘ helper-lemma t₁₁ _ t₁₂ _)
    (t₂₁ ≟-⊢no t₂₂ [ fst-cong $ indexed-type-cong $ helper eq ])
    where
    helper : ∀ {Γ₁ σ₁} {t₁ : Γ₁ ⊢ σ₁ ⟨ ne ⟩}
               {Γ₂ σ₂} {t₂ : Γ₂ ⊢ σ₂ ⟨ ne ⟩} →
             t₁ ≅-⊢n t₂ → σ₁ ≅-Type σ₂
    helper P.refl = P.refl

  var _ ≟-⊢ne _ · _ = Dec.no λ ()
  _ · _ ≟-⊢ne var _ = Dec.no λ ()

  -- Decides if two normal forms are identical. Note that the terms
  -- must have the same type.

  infix 4 _≟-⊢no_[_]

  _≟-⊢no_[_] : ∀ {Γ₁ σ₁} (t₁ : Γ₁ ⊢ σ₁ ⟨ no ⟩)
                 {Γ₂ σ₂} (t₂ : Γ₂ ⊢ σ₂ ⟨ no ⟩) →
              σ₁ ≅-Type σ₂ → Dec (t₁ ≅-⊢n t₂)
  ne σ′₁ t₁ ≟-⊢no ne σ′₂ t₂ [ P.refl ] = ne≟ne σ′₁ σ′₂ (t₁ ≟-⊢ne t₂)
    where
    ne≟ne : ∀ {Γ σ} {t₁ t₂ : Γ ⊢ σ ⟨ ne ⟩}
            (σ′₁ : Γ ⊢ σ atomic-type) (σ′₂ : Γ ⊢ σ atomic-type) →
            Dec (t₁ ≅-⊢n t₂) → Dec (ne σ′₁ t₁ ≅-⊢n ne σ′₂ t₂)
    ne≟ne ⋆  ⋆  (yes P.refl) = yes P.refl
    ne≟ne el el (yes P.refl) = yes P.refl
    ne≟ne _  _  (Dec.no neq) = Dec.no (neq ∘ helper)
      where
      helper :
        ∀ {Γ₁ σ₁ σ′₁} {t₁ : Γ₁ ⊢ σ₁ ⟨ ne ⟩}
          {Γ₂ σ₂ σ′₂} {t₂ : Γ₂ ⊢ σ₂ ⟨ ne ⟩} →
        ne σ′₁ t₁ ≅-⊢n ne σ′₂ t₂ → t₁ ≅-⊢n t₂
      helper P.refl = P.refl

  ƛ t₁ ≟-⊢no ƛ t₂ [ eq ] =
    Dec.map′ ƛn-cong helper
             (t₁ ≟-⊢no t₂ [ snd-cong $ indexed-type-cong eq ])
    where
    helper :
      ∀ {Γ₁ σ₁ τ₁} {t₁ : Γ₁ ▻ σ₁ ⊢ τ₁ ⟨ no ⟩}
        {Γ₂ σ₂ τ₂} {t₂ : Γ₂ ▻ σ₂ ⊢ τ₂ ⟨ no ⟩} →
      ƛ t₁ ≅-⊢n ƛ t₂ → t₁ ≅-⊢n t₂
    helper P.refl = P.refl

  ne _ _ ≟-⊢no ƛ _    [ _ ] = Dec.no λ ()
  ƛ _    ≟-⊢no ne _ _ [ _ ] = Dec.no λ ()

-- Tries to prove that two terms have the same semantics. The terms
-- must have the same type.

⟦_⟧≟⟦_⟧ : ∀ {Γ σ} (t₁ t₂ : Γ ⊢ σ) →
          Maybe (⟦ t₁ ⟧ ≅-Value ⟦ t₂ ⟧)
⟦ t₁ ⟧≟⟦ t₂ ⟧ with normalise t₁ ≟-⊢no normalise t₂ [ P.refl ]
... | Dec.no _ = ∅
... | yes eq   = return (begin
  [ ⟦ t₁ ⟧            ]  ≡⟨ normalise-lemma t₁ ⟩
  [ ⟦ normalise t₁ ⟧n ]  ≡⟨ ⟦⟧n-cong eq ⟩
  [ ⟦ normalise t₂ ⟧n ]  ≡⟨ P.sym $ normalise-lemma t₂ ⟩
  [ ⟦ t₂ ⟧            ]  ∎)

-- Tries to prove that two semantic types are equal, given
-- corresponding syntactic types. The types must have the same
-- context.

infix 4 _≟-Type_

_≟-Type_ : ∀ {Γ σ₁} (σ₁′ : Γ ⊢ σ₁ type)
               {σ₂} (σ₂′ : Γ ⊢ σ₂ type) →
           Maybe (σ₁ ≅-Type σ₂)
⋆ ≟-Type ⋆ = return P.refl

el t₁ ≟-Type el t₂ = helper <$> ⟦ t₁ ⟧≟⟦ t₂ ⟧
  where
  helper : ∀ {Γ₁} {v₁ : Value Γ₁ (⋆ , _)}
             {Γ₂} {v₂ : Value Γ₂ (⋆ , _)} →
           v₁ ≅-Value v₂ → (el , v₁) ≅-Type (el , v₂)
  helper P.refl = P.refl
π σ′₁ τ′₁ ≟-Type π σ′₂ τ′₂ = helper τ′₁ τ′₂ =<< σ′₁ ≟-Type σ′₂
  where
  helper :
    ∀ {Γ₁ σ₁ τ₁} (τ′₁ : Γ₁ ▻ σ₁ ⊢ τ₁ type)
      {Γ₂ σ₂ τ₂} (τ′₂ : Γ₂ ▻ σ₂ ⊢ τ₂ type) →
    σ₁ ≅-Type σ₂ → Maybe (Type-π σ₁ τ₁ ≅-Type Type-π σ₂ τ₂)
  helper τ′₁ τ′₂ P.refl = Type-π-cong <$> (τ′₁ ≟-Type τ′₂)

_ ≟-Type _ = ∅


-- Andreas, 2017-04-13, issue #2494, reported by identicalsnowflake
-- Consecutive hidden record fields confused the implicit argument insertion
-- due to lack of names in NamedArg.

-- {-# OPTIONS -v tc.lhs:30 #-}
-- {-# OPTIONS -v tc.term.args:100 #-}

postulate
  Red Blue : Set

record Colors : Set where
  field
    {{red}}  : Red
    {{blue}} : Blue

f : Colors → Red
f record { blue = blue } = blue


open import FRP.JS.Delay using ( Delay )

module FRP.JS.Time.Core where

record Time : Set where
  constructor epoch
  field toDelay : Delay

{-# COMPILED_JS Time function(x,v) { return v.epoch(x); } #-}
{-# COMPILED_JS epoch function(d) { return d; } #-}


module Issue2959.M (_ : Set₁) where

record R : Set₁ where
  field
    A : Set


module aux where

open import Data.Nat
open import Level renaming (zero to lzero)
open import Data.Fin
open import Data.Fin.Properties
open import Data.Fin.Subset renaming (∣_∣ to ∣_∣ˢ)
open import Data.Fin.Subset.Properties
open import Data.Vec
open import Data.Bool
open import Data.Bool.Properties
open import Data.Product
open import Data.Sum
open import Relation.Unary hiding (_∈_ ; _⊆_)
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Nullary.Sum
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open import Data.Empty renaming (⊥ to ⊥')

postulate
  ext : {A : Set}{B : A → Set}{f : (x : A) → B x} {g : (x : A) → B x} →
    (∀ x → f x ≡ g x) → f ≡ g

sum-eq : {A B : Set} {x y : A} → (inj₁{B = B} x) ≡ (inj₁{B = B} y) → x ≡ y
sum-eq {A} {B} {x} {.x} refl = refl

in-subset-eq : {n : ℕ} {x : Fin n} {s : Subset n} → (l l' : x ∈ s) → l ≡ l'
in-subset-eq {.(ℕ.suc _)} {.zero} here here = refl
in-subset-eq {.(ℕ.suc _)} {.(Fin.suc _)} (there l) (there l') = cong there (in-subset-eq l l')

dec-manipulate : {n : ℕ} {A : Set} → (dec : (a a' : A) → Dec (a ≡ a')) → ((a a' : A ⊎ Fin 1) → Dec (a ≡ a'))
dec-manipulate {n} {A} dec (inj₁ x) (inj₁ x₁)
  with dec x x₁
...  | yes p = yes (cong inj₁ p)
...  | no ¬p = no λ x₂ → contradiction (sum-eq x₂) ¬p
dec-manipulate {n} {A} dec (inj₁ x) (inj₂ y) = no λ ()
dec-manipulate {n} {A} dec (inj₂ y) (inj₁ x) = no λ ()
dec-manipulate {n} {A} dec (inj₂ zero) (inj₂ zero) = yes (cong inj₂ refl)

f-manipulate : {n : ℕ} {A : Set} {s : Subset n} → ((l : Fin n) → l ∈ s → A) → (Fin n → (A ⊎ Fin 1))
f-manipulate {n} {A} {s} f l
  with l ∈? s
...  | yes p = inj₁ (f l p)
...  | no ¬p = inj₂ zero

f-equal : {n : ℕ} {A : Set} {dec : (a a' : A) → Dec (a ≡ a')} → (f f' : (l : Fin n) → A) → Dec (f ≡ f')
f-equal {n} {A} {dec} f f'
  with all?{n} λ x → dec (f x) (f' x)
...  | yes p = yes (ext p)
...  | no ¬p = no λ x → contradiction (cong-app x) ¬p

f-manipulate-eq⇒f-eq : {n : ℕ} {A : Set} {s : Subset n} {f f' : (l : Fin n) → l ∈ s → A} → (f-manipulate f) ≡ (f-manipulate f') → f ≡ f'
f-manipulate-eq⇒f-eq {n} {A} {s} {f} {f'} eq
  with (cong-app eq)
...  | eq' = ext (λ x → ext (ϱ x))
     where ϱ : (l : Fin n) → (i : l ∈ s) → f l i ≡ f' l i
           ϱ l i
             with (eq' l)
           ...  | eq''
                with l ∈? s
           ...     | yes p rewrite (in-subset-eq i p) = sum-eq eq''
           ...     | no ¬p = contradiction i ¬p

f-eq⇒f-manipulate-eq : {n : ℕ} {A : Set} {s : Subset n} {f f' : (l : Fin n) → l ∈ s → A} → f ≡ f' → (f-manipulate f) ≡ (f-manipulate f')
f-eq⇒f-manipulate-eq {n} {A} {s} {f} {f'} eq
  with (cong-app eq)
...  | eq' = ext (λ x → ϱ x)
     where ϱ : (l : Fin n) → (f-manipulate f l) ≡ (f-manipulate f' l)
           ϱ l
             with (eq' l)
           ...  | eq''
                 with l ∈? s
           ...      | yes p = cong inj₁ ((cong-app eq'') p)
           ...      | no ¬p = refl

_≡ᶠ?_ : {n : ℕ} {s : Subset n} {A : Set} {dec : (a a' : A) → Dec (a ≡ a')} (f f' : (l : Fin n) → s Data.Vec.[ l ]= inside → A) → Dec (f ≡ f')
_≡ᶠ?_ {n} {s} {A} {dec} f f'
  with (f-equal{dec = dec-manipulate{n} dec} (f-manipulate f) (f-manipulate f'))
...     | yes p = yes (f-manipulate-eq⇒f-eq p)
...     | no ¬p = no (contraposition f-eq⇒f-manipulate-eq ¬p)

x∷xs≡y∷ys⇒x≡y : {n : ℕ} {xs ys : Subset n} {x y : Bool} → (x ∷ xs) ≡ (y ∷ ys) → x ≡ y
x∷xs≡y∷ys⇒x≡y {n} {xs} {.xs} {x} {.x} refl = refl

x∷xs≡y∷ys⇒xs≡ys : {n : ℕ} {xs ys : Subset n} {x y : Bool} → (x ∷ xs) ≡ (y ∷ ys) → xs ≡ ys
x∷xs≡y∷ys⇒xs≡ys {n} {xs} {.xs} {x} {.x} refl = refl

_≡ˢ?_ : {n : ℕ} → (s s' : Subset n) → Dec (s ≡ s')
_≡ˢ?_ {zero} [] [] = yes refl
_≡ˢ?_ {suc n} (x ∷ s) (x₁ ∷ s')
  with _≡ˢ?_ {n} s s' | x Data.Bool.Properties.≟ x₁
...  | yes p | yes p' rewrite p | p' = yes refl
...  | yes p | no ¬p' rewrite p = no λ x₂ → contradiction (x∷xs≡y∷ys⇒x≡y x₂) ¬p'
...  | no ¬p | _ = no (λ x₂ → contradiction (x∷xs≡y∷ys⇒xs≡ys x₂) ¬p)

empty-subset-outside : {n : ℕ} → (x : Fin n) → ¬ (⊥ [ x ]= inside)
empty-subset-outside {.(ℕ.suc _)} zero ()
empty-subset-outside {.(ℕ.suc _)} (Fin.suc x) (there ins) = empty-subset-outside x ins

x∈[l]⇒x≡l : {n : ℕ} {x l : Fin n} → x ∈ ⁅ l ⁆ → x ≡ l
x∈[l]⇒x≡l {.(ℕ.suc _)} {zero} {zero} ins = refl
x∈[l]⇒x≡l {.(ℕ.suc _)} {Fin.suc x} {zero} (there ins) = contradiction ins (empty-subset-outside x)
x∈[l]⇒x≡l {.(ℕ.suc _)} {Fin.suc x} {Fin.suc l} (there ins) = cong Fin.suc (x∈[l]⇒x≡l ins)

l∈L⇒[l]⊆L : {n : ℕ} {l : Fin n} {L : Subset n} → l ∈ L → ⁅ l ⁆ ⊆ L
l∈L⇒[l]⊆L {n} {l} {L} ins x rewrite (x∈[l]⇒x≡l x) = ins

[l]⊆L⇒l∈L : {n : ℕ} {l : Fin n} {L : Subset n} → ⁅ l ⁆ ⊆ L → l ∈ L
[l]⊆L⇒l∈L {n} {l} {L} sub = sub (x∈⁅x⁆ l)