module Sigma.Renaming.Vec where

open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Fin as Fin using (Fin; zero; suc)

open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)

open import Data.Vec as V using (Vec; []; _∷_; map; _[_]≔_)
  renaming (head to headᵥ; tail to tailᵥ; lookup to lookupᵥ; insert to insertᵥ; remove to removeᵥ; updateAt to updateAtᵥ)
open import Data.HVec as HV using (HVec; []; _∷_)
  renaming (head to headₕ; tail to tailₕ; lookup to lookupₕ; insert to insertₕ; remove to removeₕ; updateAt to updateAtₕ)

open import Function as Fun using (_∘_)

open import Sigma.Renaming.Base as R using (Ren)
  renaming (id to idᵣ; ↑ to ↑ᵣ; _⇑ to _⇑ᵣ)

open import Relation.Binary.PropositionalEquality as Eq
  using (_≡_; refl; sym; trans; cong; cong₂; cong-app; subst)
open Eq.≡-Reasoning

-- ------------------------------------------------------------------------
-- Vectored Renaming Shape

-- A renaming ρ : 𝕀ᵐ → 𝕀ⁿ is defined by a *shape*, denoted m ↦ n.
--
-- Similarly, a vectored renaming ρs = [ρ₁ ; ...; ρₖ] : [𝕀ᵐ₁ → 𝕀ⁿ₁, ...; 𝕀ᵐₖ → 𝕀ⁿₖ]
-- is defined by a vector of renaming shapes, denoted [m₁ ↦ n₁; ...; mₖ ↦ nₖ]

module Shape where

  open import Data.Vec using (lookup; replicate; _[_]%=_; _[_]≔_)

  -- TODO: Implement shape for renaming?

  Shape : ℕ → Set
  Shape n = Vec (ℕ × ℕ) n

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

  pattern _↦_ m n = ⟨ m , n ⟩

  shape : ∀ { n } → Shape n → Fin n → ℕ × ℕ
  shape = lookup

  dom : ∀ { n } → Shape n → Fin n → ℕ
  dom s = proj₁ ∘ (shape s)

  rng : ∀ { n } → Shape n → Fin n → ℕ
  rng s = proj₂ ∘ (shape s)

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

  id : ∀ { m } → ℕ → Shape m
  id n = replicate (n ↦ n)

  ↑ : ∀ { m } → ℕ → Fin m → Shape m
  ↑ n i = id n [ i ]≔ n ↦ (1 + n)

  -- TODO: This may become a pain, used a hack to use := instead of
  -- %=
  infix 10 _⇑_
  _⇑_ : ∀ { n } → Shape n → Fin n → Shape n
  s ⇑ i = s [ i ]≔ ⇑ (lookup s i)
    where
      ⇑ : ℕ × ℕ → ℕ × ℕ
      ⇑ (m ↦ n) = (1 + m) ↦ (1 + n)

open Shape using (Shape; _↦_) renaming (id to idₛ; ↑ to ↑ₛ; _⇑_ to _⇑ₛ_)

-- TODO: Move this when implementing shapes on renamings?
-- IDEA: Call it an interpretation of a shape
-- use the nice brackets ;)

⦅_⦆ : ℕ × ℕ → Set
⦅ m ↦ n ⦆ = Ren m n

-- ------------------------------------------------------------------------
-- Vectored Renaming

-- A vectored renaming ρs = [ρ₁ ; ...; ρₖ] : [𝕀ᵐ₁ → 𝕀ⁿ₁, ...; 𝕀ᵐₖ → 𝕀ⁿₖ]
-- defined by it's shape: [m₁ ↦ n₁; ...; mₖ ↦ nₖ]
-- It is implemented as a hetrogenous vector.

VRen : ∀ n → Shape n → Set
VRen n shape = HVec n (map ⦅_⦆ shape)

length : ∀ { n S } → VRen n S → ℕ
length { n = n } _ = n

shape : ∀ { n S } → VRen n S → Shape n
shape { S = shape } _ = shape

-- ------------------------------------------------------------------------
-- Basic operations (ported from HVec)

-- Anonymous module containing properties about
-- Data.Vec's map composed w/ other operations
module _ { ℓ₁ ℓ₂ } { A : Set ℓ₁ } { B : Set ℓ₂ } where
  open import Data.Vec using (head; tail; insert; remove)

  private
    variable
      m n k : ℕ

  open import Data.Vec.Properties using (lookup-map; map-[]≔) public

  unfold-map : (f : A → B) (x : A) (xs : Vec A n)
    → map f (x ∷ xs) ≡ f x ∷ map f xs
  unfold-map f x [] = refl
  unfold-map f x (_ ∷ xs) = refl

  unfold-remove : (x : A) (xs : Vec A (1 + n)) (i : Fin (1 + n))
    → remove (x ∷ xs) (suc i) ≡ x ∷ remove xs i
  unfold-remove x (_ ∷ xs) zero = refl
  unfold-remove x (y ∷ xs) (suc i) = refl

  head-map : (f : A → B) (xs : Vec A (1 + n))
    → head (map f xs) ≡ f (head xs)
  head-map f (x ∷ xs) = refl

  tail-map : (f : A → B) (xs : Vec A (1 + n))
    → tail (map f xs) ≡ map f (tail xs)
  tail-map f (x ∷ xs) = refl

  insert-map : (f : A → B) (x : A) (xs : Vec A n) (i : Fin (1 + n))
    → insert (map f xs) i (f x) ≡ map f (insert xs i x)
  insert-map f x xs zero = refl
  insert-map f x (_ ∷ xs) (suc i) rewrite insert-map f x xs i = refl

  remove-map : (f : A → B) (xs : Vec A (1 + n)) (i : Fin (1 + n))
    → remove (map f xs) i ≡ map f (remove xs i)
  remove-map f (_ ∷ xs) zero = refl
  remove-map f (x ∷ y ∷ xs) (suc i) rewrite remove-map f (y ∷ xs) i = refl

module _ where

  private
    variable
      m n k : ℕ
      S : Shape m

  head : VRen (1 + m) S → ⦅ headᵥ S ⦆
  head ρs rewrite sym (head-map ⦅_⦆ (shape ρs)) = headₕ ρs

  tail : VRen (1 + m) S → VRen m (tailᵥ S)
  tail ρs rewrite sym (tail-map ⦅_⦆ (shape ρs)) = tailₕ ρs

  lookup : VRen m S → (i : Fin m) → ⦅ lookupᵥ S i ⦆
  lookup ρs i rewrite sym (lookup-map i ⦅_⦆ (shape ρs)) = lookupₕ ρs i

  insert : VRen m S → (i : Fin (1 + m)) → Ren n k → VRen (1 + m) (insertᵥ S i (n ↦ k))
  insert { n = n } { k = k } ρs i ρ rewrite sym (insert-map ⦅_⦆ (n ↦ k) (shape ρs) i) = insertₕ ρs i ρ

  remove : VRen (1 + m) S → (i : Fin (1 + m)) → VRen m (removeᵥ S i)
  remove ρs i rewrite sym (remove-map ⦅_⦆ (shape ρs) i) = removeₕ ρs i

  updateAt : (i : Fin m) → (⦅ lookupᵥ S i ⦆ → Ren n k) → VRen m S → VRen m (S [ i ]≔ n ↦ k)
  updateAt { n = n } { k = k } i f ρs rewrite map-[]≔ ⦅_⦆ (shape ρs) i { x = n ↦ k } = updateAtₕ i f' ρs
    where
      f' : lookupᵥ (map ⦅_⦆ (shape ρs)) i → Ren n k
      f' rewrite lookup-map i ⦅_⦆ (shape ρs) = f

  infixl 6 _[_]$=_

  _[_]$=_ : VRen m S → (i : Fin m) → (⦅ lookupᵥ S i ⦆ → Ren n k) → VRen m (S [ i ]≔ n ↦ k)
  ρs [ i ]$= f = updateAt i f ρs

  infixl 6 _[_]&=_

  _[_]&=_ : VRen m S → (i : Fin m) → Ren n k → VRen m (S [ i ]≔ n ↦ k)
  ρs [ i ]&= ρ = ρs [ i ]$= Fun.const ρ

-- ------------------------------------------------------------------------
-- Primitives

id : ∀ m { n } → VRen m (idₛ n)
id zero = []
id (suc m) = idᵣ ∷ id m

↑ : ∀ m { n } → (i : Fin m) → VRen m (↑ₛ n i)
↑ m i = (id m) [ i ]&= ↑ᵣ

_⇑_ : ∀ { n S } → VRen n S → (i : Fin n) → VRen n (S ⇑ₛ i)
ρs ⇑ i = ρs [ i ]$= (_⇑ᵣ)

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


module MutualBlockInLet where

postulate
  A : Set
  a : A

test = let abstract
             x = a
             y = x
       in y


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

open import HoTT

module cw.cohomology.GridPtdMap {i j k}
  {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (f : X ⊙→ Y) (g : Y ⊙→ Z) where

  open import cw.cohomology.GridMap (fst f) (fst g) public

  Y/X = ⊙Cofiber f
  Z/X = ⊙Cofiber (g ⊙∘ f)
  Z/Y = ⊙Cofiber g

  Y/X-to-Z/X : Y/X ⊙→ Z/X
  Y/X-to-Z/X = B/A-to-C/A , idp

  Z/X-to-Z/Y : Z/X ⊙→ Z/Y
  Z/X-to-Z/Y = C/A-to-C/B , idp


open import Nat
open import Prelude
open import core
open import contexts
open import lemmas-consistency
open import lemmas-disjointness
open import weakening

module typed-elaboration where
  mutual
    typed-elaboration-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-elaboration-synth ESConst = TAConst
    typed-elaboration-synth (ESVar x₁) = TAVar x₁
    typed-elaboration-synth (ESLam x₁ ex) = TALam x₁ (typed-elaboration-synth ex)
    typed-elaboration-synth (ESAp {Δ1 = Δ1} _ d x₁ x₂ x₃ x₄)
      with typed-elaboration-ana x₃ | typed-elaboration-ana x₄
    ... | con1 , ih1 | con2 , ih2  = TAAp (TACast (weaken-ta-Δ1 d ih1) con1) (TACast (weaken-ta-Δ2 {Δ1 = Δ1} d ih2) con2)
    typed-elaboration-synth (ESEHole {Γ = Γ} {u = u})  = TAEHole (ctx-top ∅ u (Γ , ⦇-⦈) refl)(STAId (λ x τ z → z))
    typed-elaboration-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} (d1 , d2) ex)
      with typed-elaboration-synth ex
    ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇-⦈)} (ctx-top Δ u (Γ , ⦇-⦈) (d2 u (lem-domsingle _ _))) (weaken-ta-Δ1 (d1 , d2) ih1)(STAId (λ x τ₁ z → z))
    typed-elaboration-synth (ESAsc x)
      with typed-elaboration-ana x
    ... | con , ih = TACast ih con

    typed-elaboration-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')
    typed-elaboration-ana (EALam x₁ MAHole ex)
      with typed-elaboration-ana ex
    ... | con , D = TCHole1 , TALam x₁ D
    typed-elaboration-ana (EALam x₁ MAArr ex)
      with typed-elaboration-ana ex
    ... | con , D = TCArr TCRefl con , TALam x₁ D
    typed-elaboration-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-elaboration-synth x₂
    typed-elaboration-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (ctx-top ∅ u (Γ , _) refl) (STAId (λ x τ z → z))
    typed-elaboration-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ} (d1 , d2) x)
      with typed-elaboration-synth x
    ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (ctx-top Δ u (Γ , τ) (d2 u (lem-domsingle _ _)) ) (weaken-ta-Δ1 (d1 , d2) ih1) (STAId (λ x₁ τ₁ z → z))


{-# OPTIONS --no-positivity-check #-}
{-# OPTIONS --no-termination-check #-}

module UniDB.Examples.Free where

open import UniDB
open import Function
open import Relation.Binary.PropositionalEquality
import Level

-- Interpret a value of the morphism representation Ξ as
-- a morphism between S and T.
Int : (Ξ : MOR) (S T : STX) → Set
Int Ξ S T = (γ₁ γ₂ : Dom) (ξ : Ξ γ₁ γ₂) → S γ₁ → T γ₂

-- Combine two types and their interpretations to an
-- intepretation of an outer composition.
IntPair : (Ξ Ζ : MOR) (S T U : STX) →
  (intΞ : Int Ξ S T) (intΖ : Int Ζ T U) →
  Int (Pair Ξ Ζ) S U
IntPair Ξ Ζ S T U intΞ intΖ _ _ (ξ ⊗ ζ) = intΖ _ _ ζ ∘ intΞ _ _ ξ

-- Predicate: The interpretation of an identity morphism is
-- indeed an identity.
IntIdm : (Ξ : MOR) (T : STX) {{idmΞ : Idm Ξ}} (intΞ : Int Ξ T T) → Set
IntIdm Ξ T intΞ = (γ : Dom) (t : T γ) → intΞ _ _ (idm {Ξ} γ) t ≡ t

-- Pointwise equality between two differently represented morphisms.
_∣_⊢_≃_ :
  {Ξ Ζ : MOR} {S T : STX} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  (intΞ : Int Ξ S T) (intΖ : Int Ζ S T)
  {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂) → Set
intΞ ∣ intΖ ⊢ ξ ≃ ζ = ∀ s → intΞ _ _ ξ s ≡ intΖ _ _ ζ s

-- Equality at arbitrary depths
data _∣_⊢_≅_
  {Ξ Ζ : MOR} {S T : STX} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  (intΞ : Int Ξ S T) (intΖ : Int Ζ S T) :
  {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂) → Set where
  ≃-to-≅ :
    {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂)
    (δ : Dom) (eq≃ : (δ' : Dom) → intΞ ∣ intΖ ⊢ (ξ ↑ δ') ≃ (ζ ↑ δ')) →
    intΞ ∣ intΖ ⊢ (ξ ↑ δ) ≅ (ζ ↑ δ)

-- ≅ can always be pushed under binders
int≅-↑₁ :
  {Ξ Ζ : MOR} {S T : STX} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  {intΞ : Int Ξ S T} {intΖ : Int Ζ S T}
  {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} →
  intΞ ∣ intΖ ⊢ ξ ≅ ζ →
  intΞ ∣ intΖ ⊢ (ξ ↑₁) ≅ (ζ ↑₁)
int≅-↑₁ (≃-to-≅ ξ ζ δ eq≃) rewrite sym (↑-suc ξ δ) | sym (↑-suc ζ δ) =
  ≃-to-≅ ξ ζ (suc δ) eq≃

int≅-↑ :
  {Ξ Ζ : MOR} {S T : STX} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  {intΞ : Int Ξ S T} {intΖ : Int Ζ S T}
  {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} →
  intΞ ∣ intΖ ⊢ ξ ≅ ζ →
  (δ : Dom) → intΞ ∣ intΖ ⊢ (ξ ↑ δ) ≅ (ζ ↑ δ)
int≅-↑ {ξ = ξ} {ζ} eq zero    rewrite ↑-zero ξ  | ↑-zero ζ  = eq
int≅-↑ {ξ = ξ} {ζ} eq (suc δ) rewrite ↑-suc ξ δ | ↑-suc ζ δ = int≅-↑₁ (int≅-↑ eq δ)

lk≅ :
  {Ξ Ζ : MOR} {S T : STX} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  {intΞ : Int Ξ S T} {intΖ : Int Ζ S T}
  {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} →
  intΞ ∣ intΖ ⊢ ξ ≅ ζ →
  ∀ s → intΞ _ _ ξ s ≡ intΖ _ _ ζ s
lk≅ (≃-to-≅ ξ ζ δ eq≃) s = eq≃ δ s

record Functor (F : STX → STX) : Set₁ where
  field
    fmap :
      (Ξ : MOR) (S T : STX) {{up : Up Ξ}} (intΞ : Int Ξ S T) →
      (γ₁ γ₂ : Dom) (ξ : Ξ γ₁ γ₂) → F S γ₁ → F T γ₂
    fmap-idm :
      (Ξ : MOR) (T : STX) {{upΞ : Up Ξ}} {{idmΞ : Idm Ξ}}
      (intΞ : Int Ξ T T) (intIdmΞ : IntIdm Ξ T intΞ)
      (γ : Dom) (ft : F T γ) →
      fmap Ξ T T intΞ _ _ (idm {Ξ} γ) ft ≡ ft
    fmap-⊗ :
      (Ξ Ζ : MOR) (S T U : STX) {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
      (intΞ : Int Ξ S T) (intΖ : Int Ζ T U)
      (γ₁ γ₂ γ₃ : Dom) (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) (fs : F S γ₁) →
      fmap (Pair Ξ Ζ) S U (IntPair Ξ Ζ S T U intΞ intΖ) _ _ (ξ ⊗ ζ) fs ≡
      fmap Ζ T U intΖ _ _ ζ (fmap Ξ S T intΞ _ _ ξ fs)
    fmap-≅ :
      (Ξ Ζ : MOR) (S T : STX) {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
      (intΞ : Int Ξ S T) (intΖ : Int Ζ S T)
      (γ₁ γ₂ : Dom) (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂) →
      intΞ ∣ intΖ ⊢ ξ ≅ ζ  →
      fmap Ξ S T intΞ ∣ fmap Ζ S T intΖ ⊢ ξ ≅ ζ
open Functor {{...}}

--------------------------------------------------------------------------------
-- Freely generated functor

data Free (F : STX → STX) (V : STX) (γ : Dom) : Set where
  var  : (i : V γ) → Free F V γ
  free : F (Free F V) γ → Free F V γ

bind :
  (F : STX → STX) {{functorF : Functor F}}
  (V W : STX) (Ξ : MOR) {{upΞ : Up Ξ}}
  (intΞ : (γ₁ γ₂ : Dom) → Ξ γ₁ γ₂ → V γ₁ → Free F W γ₂) →
  (γ₁ γ₂ : Dom) → Free F V γ₁ → Ξ γ₁ γ₂ → Free F W γ₂
bind F V W Ξ intΞ γ₁ γ₂ (var v)    ξ = intΞ γ₁ γ₂ ξ v
bind F V W Ξ intΞ γ₁ γ₂ (free ffv) ξ =
  free (fmap {F} Ξ (Free F V) (Free F W)
          (λ γ₃ γ₄ ξ' x' → bind F V W Ξ intΞ γ₃ γ₄ x' ξ' )
          γ₁ γ₂ ξ ffv)

--------------------------------------------------------------------------------
-- Functor instance for Free F

postulate
  ext : Extensionality Level.zero Level.zero

fmap-intpair :
  (F : STX → STX) {{_ : Functor F}}
  (Ξ Ζ : MOR) (S T U : STX) {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  (intΞ : Int Ξ S T) (intΖ : Int Ζ T U) →
  fmap {F} (Pair Ξ Ζ) S U (IntPair Ξ Ζ S T U intΞ intΖ) ≡
  IntPair Ξ Ζ (F S) (F T) (F U) (fmap {F} Ξ S T intΞ) (fmap {F} Ζ T U intΖ)
fmap-intpair F Ξ Ζ S T U intΞ intΖ =
  ext λ γ₁ → ext λ γ₃ → ext λ { (_⊗_ {._} {γ₂} ξ ζ) → ext λ fs →
    fmap-⊗ {F} Ξ Ζ S T U intΞ intΖ γ₁ γ₂ γ₃ ξ ζ fs }

instance
  iFunctorFree : {F : STX → STX} {{functorF : Functor F}} →
    Functor (Free F)
  fmap {{iFunctorFree {F}}} Ξ S T intΞ _ _ ξ (var s) = var (intΞ _ _ ξ s)
  fmap {{iFunctorFree {F}}} Ξ S T intΞ _ _ ξ (free x) =
    free (fmap Ξ (Free F S) (Free F T) (fmap Ξ S T intΞ) _ _ ξ x)
  fmap-idm {{iFunctorFree {F}}} Ξ T intΞ intIdmΞ _ (var t)    = cong var (intIdmΞ _ t)
  fmap-idm {{iFunctorFree {F}}} Ξ T intΞ intIdmΞ _ (free fft) = cong free
    (fmap-idm {F} Ξ (Free F T) (fmap Ξ T T intΞ) (fmap-idm {Free F} Ξ T intΞ intIdmΞ) _ fft)
  fmap-⊗ {{iFunctorFree {F}}} Ξ Ζ S T U intΞ intΖ _ _ _ ξ ζ (var i) = cong var refl
  fmap-⊗ {{iFunctorFree {F}}} Ξ Ζ S T U intΞ intΖ _ _ _ ξ ζ (free x) = cong free (begin
    fmap (Pair Ξ Ζ) (Free F S) (Free F U) (fmap (Pair Ξ Ζ) S U (IntPair Ξ Ζ S T U intΞ intΖ)) _ _ (ξ ⊗ ζ) x
      ≡⟨ cong
           (λ (int : Int (Pair Ξ Ζ) (Free F S) (Free F U)) →
              fmap (Pair Ξ Ζ) (Free F S) (Free F U) int _ _ (ξ ⊗ ζ) x)
           (fmap-intpair (Free F) Ξ Ζ S T U intΞ intΖ)
       ⟩
    fmap (Pair Ξ Ζ) (Free F S) (Free F U) (IntPair Ξ Ζ (Free F S) (Free F T) (Free F U) (fmap Ξ S T intΞ) (fmap Ζ T U intΖ)) _ _ (ξ ⊗ ζ) x
      ≡⟨ fmap-⊗ {F} Ξ Ζ (Free F S) (Free F T) (Free F U) (fmap Ξ S T intΞ) (fmap Ζ T U intΖ) _ _ _ ξ ζ x ⟩
    fmap Ζ (Free F T) (Free F U) (fmap Ζ T U intΖ) _ _ ζ (fmap Ξ (Free F S) (Free F T) (fmap Ξ S T intΞ) _ _ ξ x)
      ∎)
  fmap-≅ {{iFunctorFree {F}}} Ξ Ζ S T intΞ intΖ _ _ _ _ eq = {!!}

--------------------------------------------------------------------------------
-- Specialiation to monads relative on Ix

module _ {F : STX → STX} {{functorF : Functor F}} where
  instance
    iVrFree : Vr (Free F Ix)
    vr     {{iVrFree}}      = var
    vr-inj {{iVrFree}} refl = refl

    iApFree : Ap (Free F Ix) (Free F Ix)
    ap {{iApFree}} {Ξ} ξ x = bind F Ix Ix Ξ (λ _ _ → lk) _ _ x ξ

    iApVrFree : ApVr (Free F Ix)
    ap-vr {{iApVrFree}} ξ i = refl

    -- After proving these three properties the relative monad laws
    -- can be derived from the library.
    iApIdmFree : ApIdm (Free F Ix) (Free F Ix)
    ap-idm {{iApIdmFree}} {Ξ} x = {!!}

    iApPairFree : ApPair (Free F Ix) (Free F Ix)
    ap-pair {{iApPairFree}} ξ ζ x = {!!}

    iApRelFree : ApRel (Free F Ix) (Free F Ix)
    ap-rel≅ {{iApRelFree}} eq x = {!!}


module Formalization.ClassicalPropositionalLogic.Semantics.Proofs where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Either as Either using (_‖_ ; Left ; Right)
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Formalization.ClassicalPropositionalLogic.Semantics
open import Functional
open import Logic.Classical     as Logic using (Classical)
import      Logic.Propositional as Logic
import      Logic.Predicate     as Logic
open import Relator.Equals
open import Relator.Equals.Proofs
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇]) renaming (•_ to singleton ; _≡_ to _≡ₛ_)
open import Type

private variable ℓₚ ℓ : Lvl.Level
private variable P : Type{ℓₚ}
private variable 𝔐 : Model(P)
private variable Γ Γ₁ Γ₂ : Formulas(P){ℓ}
private variable φ ψ : Formula(P)

[⊧₊]-antimonotone : (Γ₁ ⊆ Γ₂) → ((_⊧₊ Γ₁) ⊇ (_⊧₊ Γ₂))
[⊧₊]-antimonotone Γ₁Γ₂ 𝔐Γ₂ Γ₁γ = 𝔐Γ₂ (Γ₁Γ₂ Γ₁γ)

[⊧₊]-strengthen : (𝔐 ⊧₊ Γ₁) → (𝔐 ⊧₊ Γ₂) → (𝔐 ⊧₊ (Γ₁ ∪ Γ₂))
[⊧₊]-strengthen 𝔐Γ₁ 𝔐Γ₂ Γ₁Γ₂γ = Logic.[∨]-elim 𝔐Γ₁ 𝔐Γ₂ Γ₁Γ₂γ

[⊧₊]-of-[∪]ₗ : (𝔐 ⊧₊ (Γ₁ ∪ Γ₂)) → (𝔐 ⊧₊ Γ₁)
[⊧₊]-of-[∪]ₗ 𝔐Γ₁Γ₂ 𝔐Γ₁ = 𝔐Γ₁Γ₂ (Left 𝔐Γ₁)

[⊧₊]-of-[∪]ᵣ : (𝔐 ⊧₊ (Γ₁ ∪ Γ₂)) → (𝔐 ⊧₊ Γ₂)
[⊧₊]-of-[∪]ᵣ 𝔐Γ₁Γ₂ 𝔐Γ₂ = 𝔐Γ₁Γ₂ (Right 𝔐Γ₂)

[⊧]-to-[⊧₊] : (𝔐 ⊧ φ) Logic.↔ (𝔐 ⊧₊ singleton(φ))
[⊧]-to-[⊧₊] = Logic.[↔]-intro (_$ [≡]-intro) (\𝔐φ φγ → [≡]-substitutionᵣ φγ 𝔐φ)

[⊧]-contradiction : (𝔐 ⊧ φ) → (𝔐 ⊧ (¬ φ)) → (𝔐 ⊧ ⊥)
[⊧]-contradiction = apply

[⊨]-monotone : (Γ₁ ⊆ Γ₂) → ((Γ₁ ⊨_) ⊆ (Γ₂ ⊨_))
[⊨]-monotone Γ₁Γ₂ Γ₁φ 𝔐Γ₂ = Γ₁φ (Γ₁γ ↦ 𝔐Γ₂ (Γ₁Γ₂ Γ₁γ))

[⊨]-functionₗ : (Γ₁ ≡ₛ Γ₂) → ((Γ₁ ⊨_) ≡ₛ (Γ₂ ⊨_))
[⊨]-functionₗ {Γ₁ = Γ₁}{Γ₂ = Γ₂} Γ₁Γ₂ {φ} = Logic.[↔]-intro ([⊨]-monotone{Γ₁ = Γ₂}{Γ₂ = Γ₁}(\{x} → [≡]-to-[⊇] (Γ₁Γ₂{x}) {x}){φ}) ([⊨]-monotone{Γ₁ = Γ₁}{Γ₂ = Γ₂}(\{x} → [≡]-to-[⊆] (Γ₁Γ₂{x}) {x}){φ})

[⊨]-weaken : (Γ₁ ⊨ φ) → ((Γ₁ ∪ Γ₂) ⊨ φ)
[⊨]-weaken Γ₁φ 𝔐Γ₁Γ₂ = Γ₁φ (Γ₁γ ↦ 𝔐Γ₁Γ₂ (Left Γ₁γ))

[⊨]-validity : (∀{Γ : Formulas(P){ℓ}} → (Γ ⊨ φ)) Logic.↔ Valid(φ)
[⊨]-validity = Logic.[↔]-intro (λ r → const r) (λ l → l{∅} empty)

[⊨]-contradiction : (Γ ⊨ φ) → (Γ ⊨ (¬ φ)) → (Γ ⊨ ⊥)
[⊨]-contradiction Γφ Γ¬φ 𝔐Γ = Γ¬φ 𝔐Γ (Γφ 𝔐Γ)

[⊨]-unsatisfiability : (Γ ⊨ ⊥) Logic.↔ Unsatisfiable(Γ)
[⊨]-unsatisfiability {Γ = Γ} = Logic.[↔]-intro l r where
  l : (Γ ⊨ ⊥) ← Unsatisfiable(Γ)
  l unsatΓ {𝔐} 𝔐Γ = unsatΓ (Logic.[∃]-intro 𝔐 ⦃ 𝔐Γ ⦄)

  r : (Γ ⊨ ⊥) → Unsatisfiable(Γ)
  r Γ⊥ (Logic.[∃]-intro 𝔐 ⦃ 𝔐Γ ⦄) = Γ⊥ 𝔐Γ

[⊨][¬]-intro : ((Γ ∪ singleton(φ)) ⊨ ⊥) Logic.↔ (Γ ⊨ (¬ φ))
[⊨][¬]-intro {Γ = Γ}{φ = φ} = Logic.[↔]-intro l r where
  l : ((Γ ∪ singleton(φ)) ⊨ ⊥) ← (Γ ⊨ (¬ φ))
  l Γ¬φ 𝔐Γφ = Γ¬φ (𝔐Γφ ∘ Left) (𝔐Γφ (Right [≡]-intro))

  r : ((Γ ∪ singleton(φ)) ⊨ ⊥) → (Γ ⊨ (¬ φ))
  r Γφ⊥ 𝔐Γ 𝔐φ = Γφ⊥ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton(φ)} 𝔐Γ (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] 𝔐φ))

[∅]-satisfiable : Satisfiable{P = P}{ℓ = ℓ}(∅)
[∅]-satisfiable = Logic.[∃]-intro (const(𝑇)) ⦃ \{_}() ⦄

module _ ⦃ classical : ∀{ℓ} → Logic.∀ₗ(Classical{ℓ}) ⦄ where
  [⊧]-of-[¬¬] : (𝔐 ⊧ ¬(¬ φ)) → (𝔐 ⊧ φ)
  [⊧]-of-[¬¬] {𝔐 = 𝔐}{φ = φ} = Logic.[¬¬]-elim

  [⊨]-entailment-unsatisfiability : (Γ ⊨ φ) Logic.↔ Unsatisfiable(Γ ∪ singleton(¬ φ))
  [⊨]-entailment-unsatisfiability {Γ = Γ}{φ = φ} = Logic.[↔]-intro l r where
    l : (Γ ⊨ φ) ← Unsatisfiable(Γ ∪ singleton(¬ φ))
    l r {𝔐} 𝔐Γ = [⊧]-of-[¬¬] {𝔐 = 𝔐}{φ = φ} (𝔐¬φ ↦ r (Logic.[∃]-intro 𝔐 ⦃ Logic.[∨]-elim 𝔐Γ (\{[≡]-intro → 𝔐¬φ}) ⦄))

    r : (Γ ⊨ φ) → Unsatisfiable(Γ ∪ singleton(¬ φ))
    r l (Logic.[∃]-intro 𝔐 ⦃ sat ⦄) = [⊧]-contradiction {φ = φ} 𝔐φ 𝔐¬φ where
      𝔐φ  = l([⊧₊]-of-[∪]ₗ {Γ₁ = Γ} sat)
      𝔐¬φ = Logic.[↔]-to-[←] [⊧]-to-[⊧₊] ([⊧₊]-of-[∪]ᵣ {Γ₁ = Γ} sat)

  [⊨][⟶]-intro : ((Γ ∪ singleton(φ)) ⊨ ψ) Logic.↔ (Γ ⊨ (φ ⟶ ψ))
  [⊨][⟶]-intro {Γ = Γ}{φ = φ}{ψ = ψ} = Logic.[↔]-intro l r where
    l : (Γ ⊨ (φ ⟶ ψ)) → ((Γ ∪ singleton(φ)) ⊨ ψ)
    l φψ {𝔐 = 𝔐} 𝔐Γφ = Logic.[∨]-elim (¬φ ↦ Logic.[⊥]-elim(¬φ 𝔐φ)) id (φψ 𝔐Γ) where
      𝔐Γ : 𝔐 ⊧₊ Γ
      𝔐Γ {γ} Γγ = 𝔐Γφ {γ} (Logic.[∨]-introₗ Γγ)

      𝔐φ : 𝔐 ⊧ φ
      𝔐φ = 𝔐Γφ {φ} (Logic.[∨]-introᵣ [≡]-intro)

    r : ((Γ ∪ singleton(φ)) ⊨ ψ) → (Γ ⊨ (φ ⟶ ψ))
    r Γφψ {𝔐 = 𝔐} 𝔐Γ with Logic.excluded-middle(𝔐 ⊧ φ)
    ... | Logic.[∨]-introₗ 𝔐φ  = Logic.[∨]-introᵣ (Γφψ(Logic.[∨]-elim 𝔐Γ \{[≡]-intro → 𝔐φ}))
    ... | Logic.[∨]-introᵣ ¬𝔐φ = Logic.[∨]-introₗ ¬𝔐φ


------------------------------------------------------------------------
-- The extensional sublist relation over decidable setoid equality.
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.List.Relation.Binary.Subset.DecSetoid
  {c ℓ} (S : DecSetoid c ℓ) where

-- import Data.List.Relation.Binary.Permutation.Setoid as SetoidPerm
-- import Data.List.Relation.Binary.Subset.Setoid as SetoidSubset
-- import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
--   as HeterogeneousProperties
open import Level using (_⊔_)

-- open DecSetoid S
-- open SetoidSubset setoid public
-- open DecSetoidEquality S

open Relation.Binary using (Rel)
open import Data.List using (List)

------------------------------------------------------------------------
-- Subset relation

module _ where
  open import Function using (_∘_)
  open import Data.List
  open import Data.List.Membership.DecSetoid S using (_∈_; _∈?_)
  open import Relation.Nullary
  open import Data.List.Relation.Unary.Any public
  open import Data.List.Relation.Unary.Any.Properties using (¬Any[])

  open DecSetoid S

  infix 4 _⊆_ _⊈_
  _⊆_ : Rel (List Carrier) (c ⊔ ℓ)
  xs ⊆ ys = ∀ x → x ∈ xs → x ∈ ys

  _⊈_ : Rel (List Carrier) (c ⊔ ℓ)
  xs ⊈ ys = ¬ xs ⊆ ys

  -- lemma
  ∈-cong : ∀ {xs x y} → x ≈ y → x ∈ xs → y ∈ xs
  ∈-cong x≈y (here P) = here (trans (sym x≈y) P)
  ∈-cong x≈y (there P) = there (∈-cong x≈y P)

  ∉[] : ∀ {x xs} → ¬ x ∷ xs ⊆ []
  ∉[] {x} {xs} P = ¬Any[] (∈-cong {[]} {x} {x} refl (P x (here refl)))

  ⊆-refl : ∀ {xs} → xs ⊆ xs
  ⊆-refl  x P = P

  ∷-mono : ∀ {xs ys x y} → x ≈ y → xs ⊆ ys → x ∷ xs ⊆ y ∷ ys
  ∷-mono x≈y P x (here Q) = here (trans Q x≈y)
  ∷-mono x≈y P x (there Q) = there (P x Q)

  ⊆-swap : ∀ {xs x y} → x ∷ y ∷ xs ⊆ y ∷ x ∷ xs
  ⊆-swap x (here P) = there (here P)
  ⊆-swap x (there (here P)) = here P
  ⊆-swap x (there (there P)) = there (there P)

  infix 4 _⊆?_
  _⊆?_ : Decidable _⊆_
  [] ⊆? ys = yes (λ x ())
  x ∷ xs ⊆? [] = no ∉[]
  x ∷ xs ⊆? y ∷ ys with x ∈? y ∷ ys
  x ∷ xs ⊆? y ∷ ys | yes P with xs ⊆? y ∷ ys
  ... | yes Q = yes λ where x (here R) → ∈-cong (sym R) P
                            x (there R) → Q x R
  ... | no ¬Q = no λ R → ¬Q λ x S → R x (there S)
  x ∷ xs ⊆? y ∷ ys | no ¬P = no λ Q → ¬P (Q x (here refl))

------------------------------------------------------------------------
-- Equivalence relation

module _ where
  open DecSetoid S
  open import Data.Product
  open import Data.List
  open import Relation.Binary.Construct.Intersection
  open import Function.Base using (flip)
  infix 4 _≋_
  _≋_ : Rel (List Carrier) (c ⊔ ℓ)
  _≋_ = _⊆_ ∩ flip _⊆_
  {-# DISPLAY _⊆_ ∩ flip _⊆_ = _≋_ #-}

  ∷-cong : ∀ {xs ys x y} → x ≈ y → xs ≋ ys → x ∷ xs ≋ y ∷ ys
  ∷-cong x≈y (xs⊆ys , ys⊆xs) = ∷-mono x≈y xs⊆ys , ∷-mono (sym x≈y) ys⊆xs

  ≋-swap : ∀ {xs x y} → x ∷ y ∷ xs ≋ y ∷ x ∷ xs
  ≋-swap = ⊆-swap , ⊆-swap

  open import Data.List.Relation.Binary.Permutation.Homogeneous
  open import Relation.Nullary
  open import Relation.Nullary.Decidable

  infix 4 _≋?_
  _≋?_ : Decidable _≋_
  _≋?_ = decidable _⊆?_ (flip _⊆?_)

------------------------------------------------------------------------
-- Relational properties

module _ where
  open import Data.Product

  ≋-isEquivalence : IsEquivalence _≋_
  ≋-isEquivalence = record
    { refl = (λ x z → z) , (λ x z → z)
    ; sym = λ where (P , Q) → Q , P
    ; trans = λ where (P , Q) (S , T) → (λ x U → S x (P x U)) , λ x V → Q x (T x V)
    }

  -- shorthands
  ≋-refl : Reflexive _≋_
  ≋-refl = IsEquivalence.refl ≋-isEquivalence

  ≋-sym : Symmetric _≋_
  ≋-sym = IsEquivalence.sym ≋-isEquivalence

  ≋-trans : Transitive _≋_
  ≋-trans = IsEquivalence.trans ≋-isEquivalence

  ⊆-IsPreorder : IsPreorder _≋_ _⊆_
  ⊆-IsPreorder = record
    { isEquivalence = ≋-isEquivalence
    ; reflexive = λ where (P , Q) x R → P x R
    ; trans = λ P Q x R → Q x (P x R)
    }

  ⊆-Antisymmetric : Antisymmetric _≋_ _⊆_
  ⊆-Antisymmetric P Q = P , Q

  ⊆-isPartialOrder : IsPartialOrder _≋_ _⊆_
  ⊆-isPartialOrder = record
    { isPreorder = ⊆-IsPreorder
    ; antisym = ⊆-Antisymmetric }

  ⊆-isDecPartialOrder : IsDecPartialOrder _≋_ _⊆_
  ⊆-isDecPartialOrder = record
    { isPartialOrder = ⊆-isPartialOrder
    ; _≟_            = _≋?_
    ; _≤?_           = _⊆?_
    }

------------------------------------------------------------------------
-- Bundles

poset : Poset _ _ _
poset = record
  { Carrier = List (DecSetoid.Carrier S)
  ; _≈_ = _≋_
  ; _≤_ = _⊆_
  ; isPartialOrder = ⊆-isPartialOrder
  }

setoid : Setoid _ _
setoid = record
  { Carrier = List (DecSetoid.Carrier S)
  ; _≈_ = _≋_
  ; isEquivalence = ≋-isEquivalence
  }

------------------------------------------------------------------------
-- Reasoning

module PosetReasoning where
  open import Relation.Binary.Reasoning.PartialOrder poset public
module EqReasoning where
  open import Relation.Binary.Reasoning.Setoid setoid public


module Cryptol where

open import Bool
open import Nat
open import Eq

postulate
  Int    : Set
  Float  : Set
  Char   : Set
  String : Set

{-# BUILTIN INTEGER Int    #-}
{-# BUILTIN FLOAT   Float  #-}
{-# BUILTIN CHAR    Char   #-}
{-# BUILTIN STRING  String #-}

data List (A : Set) : Set where
  Nil  : List A
  Cons : A → List A → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL Nil #-}
{-# BUILTIN CONS Cons #-}

append : {A : Set} → List A → List A → List A
append Nil ys         = ys
append (Cons x xs) ys = Cons x (append xs ys)

infixr 5 _::_

data Vec (A : Set) : ℕ → Set where
  Nil  : Vec A Z
  _::_ : {n : ℕ} → A → Vec A n → Vec A (S n)

_++_ : ∀ {A m n} → Vec A m → Vec A n → Vec A (m + n)
Nil       ++ ys = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

data Bit : Set where
  O : Bit
  I : Bit

Word : ℕ → Set
Word n = Vec Bit n

data SnocView {A : Set} : List A → Set where
  Nil : SnocView Nil
  Snoc : (xs : List A) → (x : A) → SnocView (append xs (Cons x Nil))

view : {A : Set} → (xs : List A) → SnocView xs
view Nil = Nil
view (Cons x xs) with view xs
view (Cons x _)      | Nil = Snoc Nil x
view (Cons x _)      | Snoc ys y = Snoc (Cons x ys) y

rotateRight : {A : Set} → List A → List A
rotateRight xs with view xs
rotateRight _ | Nil       = Nil
rotateRight _ | Snoc ys y = Cons y ys

take : ∀ {A m} → (n : ℕ) → Vec A (n + m) → Vec A n
take Z l             = Nil
take (S k) (x :: xs) = x :: take k xs

drop : ∀ {A m} → (n : ℕ) → Vec A (n + m) → Vec A m
drop Z xs            = xs
drop (S k) (x :: xs) = drop k xs

split : ∀ {A} → (n : ℕ) → (m : ℕ) → Vec A (m × n) → Vec (Vec A n) m
split n Z     Nil = Nil
split n (S k) xs  = (take n xs) :: (split n k (drop n xs))

concat : ∀ {A n m} → Vec (Vec A n) m → Vec A (m × n)
concat Nil = Nil
concat (xs :: xss) = xs ++ concat xss

postulate
  splitConcatLemma : ∀ {A : Set} → (m : ℕ) → (n : ℕ) → (xs : Vec A (m × n)) → concat (split n m xs) ≡ xs

takeDropLemma : ∀ {A : Set} → (n : ℕ) → (m : ℕ) → (xs : Vec A (n + m)) → ((take n xs) ++ (drop n xs)) ≡ xs
takeDropLemma Z m _ = Refl
takeDropLemma (S k) m (x :: xs) with ((take k xs) ++ (drop k xs)) | takeDropLemma k _ xs
takeDropLemma (S k) m (x :: xs) | ._ | Refl = Refl

data SplitView {A : Set} : {n : ℕ} → (m : ℕ) → Vec A (m × n) → Set where
 [_] : ∀ {m n} → (xss : Vec (Vec A n) m) → SplitView m (concat xss)

splitView : {A : Set} → (n : ℕ) → (m : ℕ) → (xs : Vec A (m × n)) → SplitView m xs
splitView n m xs with concat (split n m xs) | [ split n m xs ] | splitConcatLemma m n xs
splitView n m xs | _ | v | Refl = v

data TakeView (A : Set) (m : ℕ) (n : ℕ) : Vec A (m + n) → Set where
  Take : (xs : Vec A m) → (ys : Vec A n) → TakeView A m n (xs ++ ys)

--sv : {A : Set} → (n : ℕ) → (m : ℕ) → Vec a

swab : Word 32 → Word 32
swab xs with splitView 8 4 xs
swab _ | [ a :: b :: c :: d :: Nil ] = concat (b :: a :: c :: d :: Nil)


-- Andreas, 2016-07-25, issue #2108
-- test case and report by Jesper

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

-- {-# OPTIONS -v tc.pos.occ:70 #-}

open import Agda.Primitive
open import Agda.Builtin.Equality

lone = lsuc lzero

record Level-zero-or-one : Set where
  field
    level : Level
    is-lower : (level ⊔ lone) ≡ lone

open Level-zero-or-one public

Coerce : ∀ {a} → a ≡ lone → Set₁
Coerce refl = Set

data Test : Set₁ where
  test : Coerce (is-lower _) → Test

-- WAS:
-- Meta variable here triggers internal error.

-- Should succeed with unsolved metas.


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

open import HoTT
open import homotopy.HSpace renaming (HSpaceStructure to HSS)
open import homotopy.WedgeExtension

module homotopy.Pi2HSusp where

module Pi2HSusp {i} (A : Type i) (gA : has-level 1 A)
  (cA : is-connected 0 A) (A-H : HSS A)
  where

  {- TODO this belongs somewhere else, but where? -}
  private
    Type=-ext : ∀ {i} {A B : Type i} (p q : A == B)
      → ((x : A) → coe p x == coe q x) → p == q
    Type=-ext p q α =
      ! (ua-η p)
      ∙ ap ua (pair= (λ= α) (prop-has-all-paths-↓ (is-equiv-is-prop (coe q))))
      ∙ ua-η q

  open HSS A-H
  open ConnectedHSpace A cA A-H

  P : Suspension A → Type i
  P x = Trunc 1 (north == x)

  module Codes = SuspensionRec A A (λ a → ua (μ-e-r-equiv a))

  Codes : Suspension A → Type i
  Codes = Codes.f

  Codes-level : (x : Suspension A) → has-level 1 (Codes x)
  Codes-level = Suspension-elim gA gA
    (λ _ → prop-has-all-paths-↓ has-level-is-prop)

  encode₀ : {x : Suspension A} → (north == x) → Codes x
  encode₀ α = transport Codes α e

  encode : {x : Suspension A} → P x → Codes x
  encode {x} = Trunc-rec (Codes-level x) encode₀

  decode' : A → P north
  decode' a = [ (merid a ∙ ! (merid e)) ]

  abstract
    transport-Codes-mer : (a a' : A)
      → transport Codes (merid a) a' == μ a a'
    transport-Codes-mer a a' =
      coe (ap Codes (merid a)) a'
        =⟨ Codes.merid-β a |in-ctx (λ w → coe w a') ⟩
      coe (ua (μ-e-r-equiv a)) a'
        =⟨ coe-β (μ-e-r-equiv a) a' ⟩
      μ a a' ∎

    transport-Codes-mer-e-! : (a : A)
      → transport Codes (! (merid e)) a == a
    transport-Codes-mer-e-! a =
      coe (ap Codes (! (merid e))) a
        =⟨ ap-! Codes (merid e) |in-ctx (λ w → coe w a) ⟩
      coe (! (ap Codes (merid e))) a
        =⟨ Codes.merid-β e |in-ctx (λ w → coe (! w) a) ⟩
      coe (! (ua (μ-e-r-equiv e))) a
        =⟨ Type=-ext (ua (μ-e-r-equiv e)) idp (λ x → coe-β _ x ∙ μ-e-l x)
          |in-ctx (λ w → coe (! w) a) ⟩
      coe (! idp) a ∎

  abstract
    encode-decode' : (a : A) → encode (decode' a) == a
    encode-decode' a =
      transport Codes (merid a ∙ ! (merid e)) e
        =⟨ trans-∙ {B = Codes} (merid a) (! (merid e)) e ⟩
      transport Codes (! (merid e)) (transport Codes (merid a) e)
        =⟨ transport-Codes-mer a e ∙ μ-e-r a
          |in-ctx (λ w → transport Codes (! (merid e)) w) ⟩
      transport Codes (! (merid e)) a
        =⟨ transport-Codes-mer-e-! a ⟩
      a ∎

  abstract
    homomorphism : (a a' : A)
      → Path {A = Trunc 1 (north == south)}
        [ merid (μ a a' ) ] [ merid a' ∙ ! (merid e) ∙ merid a ]
    homomorphism = WedgeExt.ext args
      where
      args : WedgeExt.args {a₀ = e} {b₀ = e}
      args = record {m = -2; n = -2; cA = cA; cB = cA;
        P = λ a a' → (_ , Trunc-level {n = 1} _ _);
        f = λ a →  ap [_] $
              merid (μ a e)
                =⟨ ap merid (μ-e-r a) ⟩
              merid a
                =⟨ ap (λ w → w ∙ merid a) (! (!-inv-r (merid e)))
                   ∙ ∙-assoc (merid e) (! (merid e)) (merid a)  ⟩
              merid e ∙ ! (merid e) ∙ merid a ∎;
        g = λ a' → ap [_] $
              merid (μ e a')
                =⟨ ap merid (μ-e-l a') ⟩
              merid a'
                =⟨ ! (∙-unit-r (merid a'))
                   ∙ ap (λ w → merid a' ∙ w) (! (!-inv-l (merid e))) ⟩
              merid a' ∙ ! (merid e) ∙ merid e ∎ ;
        p = ap (λ {(p₁ , p₂) → ap [_] $
              merid (μ e e) =⟨ p₁ ⟩
              merid e       =⟨ p₂ ⟩
              merid e ∙ ! (merid e) ∙ merid e ∎})
             (pair×= (ap (λ x → ap merid x) (! μ-coh)) (coh (merid e)))}
        where coh : {B : Type i} {b b' : B} (p : b == b')
                → ap (λ w → w ∙ p) (! (!-inv-r p)) ∙ ∙-assoc p (! p) p
                  == ! (∙-unit-r p) ∙ ap (λ w → p ∙ w) (! (!-inv-l p))
              coh idp = idp

  decode : {x : Suspension A} → Codes x → P x
  decode {x} = Suspension-elim {P = λ x → Codes x → P x}
                 decode'
                 (λ a → [ merid a ])
                 (λ a → ↓-→-from-transp (λ= $ STS a))
                 x
    where
    abstract
      STS : (a a' : A) → transport P (merid a) (decode' a')
                         == [ merid (transport Codes (merid a) a') ]
      STS a a' =
        transport P (merid a) [ merid a' ∙ ! (merid e) ]
          =⟨ transport-Trunc (north ==_) (merid a) _ ⟩
        [ transport (north ==_) (merid a) (merid a' ∙ ! (merid e)) ]
          =⟨ ap [_] (trans-pathfrom {A = Suspension A} (merid a) _) ⟩
        [ (merid a' ∙ ! (merid e)) ∙ merid a ]
          =⟨ ap [_] (∙-assoc (merid a') (! (merid e)) (merid a)) ⟩
        [ merid a' ∙ ! (merid e) ∙ merid a ]
          =⟨ ! (homomorphism a a') ⟩
        [ merid (μ a a') ]
          =⟨ ap ([_] ∘ merid) (! (transport-Codes-mer a a')) ⟩
        [ merid (transport Codes (merid a) a') ] ∎

  abstract
    decode-encode : {x : Suspension A} (tα : P x)
      → decode {x} (encode {x} tα) == tα
    decode-encode {x} = Trunc-elim
      {P = λ tα → decode {x} (encode {x} tα) == tα}
      (λ _ → =-preserves-level 1 Trunc-level)
      (J (λ y p → decode {y} (encode {y} [ p ]) == [ p ])
         (ap [_] (!-inv-r (merid e))))

  main-lemma-eq : Trunc 1 (north' A == north) ≃ A
  main-lemma-eq = equiv encode decode' encode-decode' decode-encode

  ⊙main-lemma : ⊙Trunc 1 (⊙Ω (⊙Susp (A , e))) == (A , e)
  ⊙main-lemma = ⊙ua (⊙≃-in main-lemma-eq idp)

  abstract
    main-lemma-iso : Ω^S-group 0 (⊙Trunc 1 (⊙Ω (⊙Susp (A , e)))) Trunc-level
                  ≃ᴳ Ω^S-group 0 (⊙Trunc 1 (A , e)) Trunc-level
    main-lemma-iso = (record {f = f; pres-comp = pres-comp} , ie)
      where
      h : fst (⊙Trunc 1 (⊙Ω (⊙Susp (A , e)))
            ⊙→ ⊙Trunc 1 (A , e))
      h = (λ x → [ encode x ]) , idp

      f : Ω (⊙Trunc 1 (⊙Ω (⊙Susp (A , e)))) → Ω (⊙Trunc 1 (A , e))
      f = fst (ap^ 1 h)

      pres-comp : (p q : Ω^ 1 (⊙Trunc 1 (⊙Ω (⊙Susp (A , e)))))
        → f (conc^S 0 p q) == conc^S 0 (f p) (f q)
      pres-comp = ap^S-conc^S 0 h

      ie : is-equiv f
      ie = is-equiv-ap^ 1 h (snd $ ((unTrunc-equiv A gA)⁻¹ ∘e main-lemma-eq))

  abstract
    π₂-Suspension : πS 1 (⊙Susp (A , e)) == πS 0 (A , e)
    π₂-Suspension =
      πS 1 (⊙Susp (A , e))
        =⟨ πS-inner-iso 0 (⊙Susp (A , e)) ⟩
      πS 0 (⊙Ω (⊙Susp (A , e)))
        =⟨ ! (πS-Trunc-shift-iso 0 (⊙Ω (⊙Susp (A , e)))) ⟩
      Ω^S-group 0 (⊙Trunc 1 (⊙Ω (⊙Susp (A , e)))) Trunc-level
        =⟨ group-ua main-lemma-iso ⟩
      Ω^S-group 0 (⊙Trunc 1 (A , e)) Trunc-level
        =⟨ πS-Trunc-shift-iso 0 (A , e) ⟩
      πS 0 (A , e) ∎


module Container.Foldable where

open import Prelude

record Foldable {a b w} (F : Set a → Set b) : Set (lsuc w ⊔ lsuc a ⊔ b) where
  field
    foldMap : ∀ {A}{W : Set w} {{MonW : Monoid W}} → (A → W) → F A → W
    overlap {{super}} : Functor F

open Foldable {{...}} public

fold : ∀ {a w} {W : Set w} {F : Set w → Set a} {{FoldF : Foldable F}} {{MonW : Monoid W}} → F W → W
fold = foldMap id

minimum : ∀ {a w} {W : Set w} {F : Set w → Set a} {{FoldF : Foldable F}} {{OrdW : Ord W}} → F W → Maybe W
minimum = foldMap {{MonW = monoid}} just
  where
    monoid : Monoid _
    Monoid.mempty monoid = nothing
    Monoid._<>_ monoid (just x) (just y) = just (min x y)
    Monoid._<>_ monoid (just x) nothing = just x
    Monoid._<>_ monoid nothing (just y) = just y
    Monoid._<>_ monoid nothing nothing = nothing

maximum : ∀ {a w} {W : Set w} {F : Set w → Set a} {{FoldF : Foldable F}} {{OrdW : Ord W}} → F W → Maybe W
maximum = foldMap {{MonW = monoid}} just
  where
    monoid : Monoid _
    Monoid.mempty monoid = nothing
    Monoid._<>_ monoid (just x) (just y) = just (max x y)
    Monoid._<>_ monoid (just x) nothing = just x
    Monoid._<>_ monoid nothing (just y) = just y
    Monoid._<>_ monoid nothing nothing = nothing

--- Instances ---

instance
  FoldableList : ∀ {a w} → Foldable {a = a} {w = w} List
  foldMap {{FoldableList}} f = foldr (λ x w → f x <> w) mempty

  FoldableMaybe : ∀ {a w} → Foldable {a = a} {w = w} Maybe
  foldMap {{FoldableMaybe}} = maybe mempty


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

module FinEquiv where

-- The goal is to establish that finite sets and equivalences form a
-- commutative semiring.

import Level using (zero)

open import Data.Empty using (⊥; ⊥-elim)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_,_; _×_; proj₁; proj₂)

open import Data.Nat
  using (ℕ; zero; suc; _+_; _*_; ≤-pred; _<_; _≤_; _≥_; _≤?_;
         module ≤-Reasoning)
open import Data.Nat.DivMod using (_divMod_; result)
open import Data.Nat.Properties using (≰⇒>; 1+n≰n; m≤m+n; ¬i+1+j≤i)
open import Data.Nat.Properties.Simple
  using (+-right-identity; +-assoc; +-suc; +-comm; *-right-zero)

open import Data.Fin
  using (Fin; zero; suc; inject+; raise; toℕ; fromℕ≤; reduce≥)
open import Data.Fin.Properties
  using (bounded; inject+-lemma; toℕ-raise; toℕ-injective; toℕ-fromℕ≤)

open import Algebra using (CommutativeSemiring)
open import Algebra.Structures
  using (IsSemigroup; IsCommutativeMonoid; IsCommutativeSemiring)

open import Function using (_∘_; id; case_of_)
open import Relation.Nullary using (yes; no)
open import Relation.Binary using (IsEquivalence)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; subst;
         module ≡-Reasoning; inspect; [_])

--

open import Equiv
  using (_∼_; _≃_; id≃; sym≃; trans≃; _●_;
         qinv; module isqinv; _⊎≃_; _×≃_)
open import TypeEquiv
  using (assocl₊equiv; unite₊′equiv;
    unite₊equiv; swap₊equiv;
    unite⋆equiv; unite⋆′equiv; swap⋆equiv; assocl⋆equiv;
    distzequiv; distzrequiv; distequiv; distlequiv)

open import Proofs using (
  -- LeqLemmas
  _<?_; cong+r≤; cong+l≤; cong*r≤;
  -- FinNatLemmas
  inj₁-≡; inj₂-≡; inject+-injective; raise-injective; addMul-lemma
  )

------------------------------------------------------------------------------
-- This is the relation we are interested in showing is a commutative
-- semiring.

_fin≃_ : (m n : ℕ) → Set
m fin≃ n = Fin m ≃ Fin n

-- Additive unit and multiplicative unit are Fin 0 and Fin 1 which are
-- equivalent to ⊥ and ⊤

abstract

  Fin0-⊥ : Fin 0 → ⊥
  Fin0-⊥ ()

  F0≃⊥ : Fin 0 ≃ ⊥
  F0≃⊥ = f , qinv g α β
    where
      f : Fin 0 → ⊥
      f ()
      g : ⊥ → Fin 0
      g ()
      α : f ∘ g ∼ id
      α ()
      β : g ∘ f ∼ id
      β ()

  Fin1≃⊤ : Fin 1 ≃ ⊤
  Fin1≃⊤ = f , qinv g α β
    where
      f : Fin 1 → ⊤
      f zero = tt
      f (suc ())
      g : ⊤ → Fin 1
      g tt = zero
      α : f ∘ g ∼ id
      α tt = refl
      β : g ∘ f ∼ id
      β zero = refl
      β (suc ())

------------------------------------------------------------------------------
-- Additive monoid

module Plus where
  infix 9 _+F_

  -- Main goal is to show (Fin m ⊎ Fin n) ≃ Fin (m + n) It is then
  -- fairly easy to show that ⊎ satisfies the commutative monoid
  -- axioms

  fwd : {m n : ℕ} → (Fin m ⊎ Fin n) → Fin (m + n)
  fwd {m} {n} (inj₁ x) = inject+ n x
  fwd {m} {n} (inj₂ y) = raise m y

  bwd : {m n : ℕ} → Fin (m + n) → (Fin m ⊎ Fin n)
  bwd {m} {n} = λ i → case (toℕ i <? m) of λ
    { (yes p) → inj₁ (fromℕ≤ p)
     ; (no ¬p) → inj₂ (reduce≥ i (≤-pred (≰⇒> ¬p)))
     }

  fwd∘bwd~id : {m n : ℕ} → fwd {m} {n} ∘ bwd ∼ id
  fwd∘bwd~id {m} i with toℕ i <? m
  fwd∘bwd~id i | yes p = sym (inj₁-≡ i p)
  fwd∘bwd~id i | no ¬p = sym (inj₂-≡ i (≤-pred (≰⇒> ¬p)))

  bwd∘fwd~id : {m n : ℕ} → bwd {m} {n} ∘ fwd ∼ id
  bwd∘fwd~id {m} {n} (inj₁ x) with toℕ (inject+ n x) <? m
  bwd∘fwd~id {n = n} (inj₁ x) | yes p =
     cong inj₁
       (inject+-injective (fromℕ≤ p) x (sym (inj₁-≡ (inject+ n x) p)))
  bwd∘fwd~id {m} {n} (inj₁ x) | no ¬p = ⊥-elim (1+n≰n pf)
   where
     open ≤-Reasoning
     pf : suc (toℕ x) ≤ toℕ x
     pf = let q =  (≤-pred (≰⇒> ¬p)) in
            begin (
              suc (toℕ x)
                ≤⟨ bounded x ⟩
              m
                ≤⟨ q ⟩
              toℕ (inject+ n x)
                ≡⟨ sym (inject+-lemma n x) ⟩
              toℕ x ∎ )
  bwd∘fwd~id {m} {n} (inj₂ y) with toℕ (raise m y) <? m
  bwd∘fwd~id {m} {n} (inj₂ y) | yes p = ⊥-elim (1+n≰n pf)
   where
     open ≤-Reasoning
     pf : suc m ≤ m
     pf = begin (
             suc m
                 ≤⟨ m≤m+n (suc m) (toℕ y) ⟩
             suc (m + toℕ y)
                 ≡⟨ cong suc (sym (toℕ-raise m y)) ⟩
             suc (toℕ (raise m y))
                 ≤⟨ p ⟩
             m ∎)
  bwd∘fwd~id {m} {n} (inj₂ y) | no ¬p =
     cong inj₂
       (raise-injective {m}
         (reduce≥ (raise m y) (≤-pred (≰⇒> ¬p)))
         y
         (sym (inj₂-≡ (raise m y) (≤-pred (≰⇒> ¬p)))))

  -- the main equivalence

  fwd-iso : {m n : ℕ} → (Fin m ⊎ Fin n) ≃ Fin (m + n)
  fwd-iso {m} {n} = fwd , qinv bwd (fwd∘bwd~id {m}) (bwd∘fwd~id {m})

  -- aliases for the above which are more convenient
  ⊎≃+ : {m n : ℕ} → (Fin m ⊎ Fin n) ≃ Fin (m + n)
  ⊎≃+ = fwd-iso

  +≃⊎ : {m n : ℕ} → Fin (m + n) ≃ (Fin m ⊎ Fin n)
  +≃⊎ = sym≃ fwd-iso

  -- additive monoid equivalences

  -- unite+

  unite+ : {m : ℕ} → Fin (0 + m) ≃ Fin m
  unite+ = unite₊equiv ● F0≃⊥ ⊎≃ id≃ ● +≃⊎

  -- and on the other side as well

  unite+r : {m : ℕ} → Fin (m + 0) ≃ Fin m
  unite+r = unite₊′equiv ● id≃ ⊎≃ F0≃⊥ ● +≃⊎

-- uniti+

  uniti+ : {m : ℕ} → Fin m ≃ Fin (0 + m)
  uniti+ = sym≃ unite+

  uniti+r : {m : ℕ} → Fin m ≃ Fin (m + 0)
  uniti+r = sym≃ unite+r

  -- swap₊

  swap+ : {m n : ℕ} → Fin (m + n) ≃ Fin (n + m)
  swap+ {m} = ⊎≃+ ● swap₊equiv ● +≃⊎ {m}

  -- associativity

  assocl+ : {m n o : ℕ} → Fin (m + (n + o)) ≃ Fin ((m + n) + o)
  assocl+ {m} = ⊎≃+ ● ⊎≃+ ⊎≃ id≃ ● assocl₊equiv ● id≃ ⊎≃ +≃⊎ ● +≃⊎ {m}

  assocr+ : {m n o : ℕ} → Fin ((m + n) + o) ≃ Fin (m + (n + o))
  assocr+ {m} = sym≃ (assocl+ {m})

  -- congruence

  _+F_ : {m n o p : ℕ} → (Fin m ≃ Fin n) → (Fin o ≃ Fin p) →
              Fin (m + o) ≃ Fin (n + p)
  Fm≃Fn +F Fo≃Fp = ⊎≃+ ● Fm≃Fn ⊎≃ Fo≃Fp ● +≃⊎

-----------------------------------------------------------------------------
-- Multiplicative monoid

module Times where
  infixl 7 _*F_

  -- main goal is to show (Fin m × Fin n) ≃ Fin (m * n) It is then
  -- fairly easy to show that × satisfies the commutative monoid
  -- axioms

  fwd : {m n : ℕ} → (Fin m × Fin n) → Fin (m * n)
  fwd {suc m} {n} (zero , k) = inject+ (m * n) k
  fwd {n = n} (suc i , k) = raise n (fwd (i , k))

  private
    soundness : ∀ {m n} (i : Fin m) (j : Fin n) →
                toℕ (fwd (i , j)) ≡ toℕ i * n + toℕ j
    soundness {suc m} {n} zero     j = sym (inject+-lemma (m * n) j)
    soundness {n = n} (suc i) j
      rewrite toℕ-raise n (fwd (i , j)) | soundness i j
      = sym (+-assoc n (toℕ i * n) (toℕ j))

    absurd-quotient : (m n q : ℕ) (r : Fin (suc n)) (k : Fin (m * suc n))
         (k≡r+q*sn : toℕ k ≡ toℕ r + q * suc n) (p : m ≤ q) → ⊥
    absurd-quotient m n q r k k≡r+q*sn p = ¬i+1+j≤i (toℕ k) {toℕ r} k≥k+sr
      where k≥k+sr : toℕ k ≥ toℕ k + suc (toℕ r)
            k≥k+sr = begin (toℕ k + suc (toℕ r)
                       ≡⟨ +-suc (toℕ k) (toℕ r) ⟩
                     suc (toℕ k) + toℕ r
                       ≤⟨ cong+r≤ (bounded k) (toℕ r) ⟩
                     (m * suc n) + toℕ r
                       ≡⟨ +-comm (m * suc n) (toℕ r) ⟩
                     toℕ r + (m * suc n)
                       ≡⟨ refl ⟩
                     toℕ r + m * suc n
                       ≤⟨ cong+l≤ (cong*r≤ p (suc n)) (toℕ r) ⟩
                     toℕ r + q * suc n
                       ≡⟨ sym k≡r+q*sn ⟩
                     toℕ k ∎)
                      where open ≤-Reasoning

  elim-right-zero : ∀ {ℓ} {Whatever : Set ℓ}
                    (m : ℕ) → Fin (m * 0) → Whatever
  elim-right-zero m i = ⊥-elim (Fin0-⊥ (subst Fin (*-right-zero m) i))

  bwd : {m n : ℕ} → Fin (m * n) → (Fin m × Fin n)
  bwd {m} {0} k = elim-right-zero m k
  bwd {m} {suc n} k with (toℕ k) divMod (suc n)
  ... | result q r k≡r+q*sn = (fromℕ≤ {q} {m} (q<m) , r)
    where
          q<m : q < m
          q<m with suc q ≤? m
          ... | no ¬p = ⊥-elim
                          (absurd-quotient m n q r k k≡r+q*sn
                            (≤-pred (≰⇒> ¬p)))
          ... | yes p = p

  fwd∘bwd~id : {m n : ℕ} → fwd {m} {n} ∘ bwd ∼ id
  fwd∘bwd~id {m} {zero} i = elim-right-zero m i
  fwd∘bwd~id {m} {suc n} i with (toℕ i) divMod (suc n)
  ... | result q r k≡r+q*sn with suc q ≤? m
  ... | yes p = toℕ-injective (
      begin (
        toℕ (fwd (fromℕ≤ p , r))
          ≡⟨ soundness (fromℕ≤ p) r ⟩
        toℕ (fromℕ≤ p) * (suc n) + toℕ r
          ≡⟨ cong (λ x → x * (suc n) + toℕ r) (toℕ-fromℕ≤ p) ⟩
        q * (suc n) + toℕ r
          ≡⟨ +-comm _ (toℕ r) ⟩
        toℕ r  + q * (suc n)
          ≡⟨ sym (k≡r+q*sn) ⟩
        toℕ i ∎))
      where open ≡-Reasoning
  ... | no ¬p = ⊥-elim (absurd-quotient m n q r i k≡r+q*sn (≤-pred (≰⇒> ¬p)))

  bwd∘fwd~id : {m n : ℕ} → bwd {m} {n} ∘ fwd ∼ id
  bwd∘fwd~id {n = zero} (b , ())
  bwd∘fwd~id {m} {suc n} (b , d) with fwd (b , d) | inspect fwd (b , d)
  ... | k | [ eq ] with (toℕ k) divMod (suc n)
  ... | result q r pf with q <? m
  ... | no ¬p = ⊥-elim (absurd-quotient m n q r k pf (≤-pred (≰⇒> ¬p)))
  ... | yes p = cong₂ _,_  pf₁ (proj₁ same-quot)
    where
      open ≡-Reasoning
      eq' : toℕ d + toℕ b * suc n ≡ toℕ r + q * suc n
      eq' = begin (
        toℕ d + toℕ b * suc n
          ≡⟨ +-comm (toℕ d) _ ⟩
        toℕ b * suc n + toℕ d
          ≡⟨ trans (sym (soundness b d)) (cong toℕ eq) ⟩
        toℕ k
          ≡⟨ pf ⟩
        toℕ r + q * suc n ∎ )
      same-quot : (r ≡ d) × (q ≡ toℕ b)
      same-quot = addMul-lemma q (toℕ b) n r d ( sym eq' )
      pf₁ = (toℕ-injective (trans (toℕ-fromℕ≤ p) (proj₂ same-quot)))

  fwd-iso : {m n : ℕ} → (Fin m × Fin n) ≃ Fin (m * n)
  fwd-iso {m} {n} = fwd , qinv bwd (fwd∘bwd~id {m}) (bwd∘fwd~id {m})

  -- convenient aliases
  ×≃* : {m n : ℕ} → (Fin m × Fin n) ≃ Fin (m * n)
  ×≃* = fwd-iso

  *≃× : {m n : ℕ} → Fin (m * n) ≃ (Fin m × Fin n)
  *≃× = sym≃ ×≃*

  -- multiplicative monoid equivalences

  -- unite*

  unite* : {m : ℕ} → Fin (1 * m) ≃ Fin m
  unite* {m} = unite⋆equiv ● Fin1≃⊤ ×≃ id≃ ● *≃×

  -- uniti*

  uniti* : {m : ℕ} → Fin m ≃ Fin (1 * m)
  uniti* = sym≃ unite*

  -- unite*r

  unite*r : {m : ℕ} → Fin (m * 1) ≃ Fin m
  unite*r {m} = unite⋆′equiv ● id≃ ×≃ Fin1≃⊤ ● *≃×

  -- uniti*r
  uniti*r : {m : ℕ} → Fin m ≃ Fin (m * 1)
  uniti*r = sym≃ unite*r

  -- swap*

  swap* : {m n : ℕ} → Fin (m * n) ≃ Fin (n * m)
  swap* {m} {n} = ×≃* ● swap⋆equiv ● *≃× {m}

  -- associativity

  assocl* : {m n o : ℕ} → Fin (m * (n * o)) ≃ Fin ((m * n) * o)
  assocl* {m} {n} {o} = ×≃* ● ×≃* ×≃ id≃ ● assocl⋆equiv ● id≃ ×≃ *≃× ● *≃× {m}

  assocr* : {m n o : ℕ} → Fin ((m * n) * o) ≃ Fin (m * (n * o))
  assocr* {m} {n} {o} = sym≃ (assocl* {m})

  -- congruence

  _*F_ : {m n o p : ℕ} → Fin m ≃ Fin n → Fin o ≃ Fin p →
              Fin (m * o) ≃ Fin (n * p)
  Fm≃Fn *F Fo≃Fp = ×≃* ● Fm≃Fn ×≃ Fo≃Fp ● *≃×

------------------------------------------------------------------------------
-- Distributivity of multiplication over addition

module PlusTimes where

  -- now that we have two monoids, we need to check distributivity

  -- note that the sequence below is "logically right", *but* could be
  -- replaced by id≃ !
  distz : {m : ℕ} → Fin (0 * m) ≃ Fin 0
  distz {m} = sym≃ F0≃⊥ ● distzequiv ● F0≃⊥ ×≃ id≃ ● *≃× {0} {m}
    where open Times

  factorz : {m : ℕ} → Fin 0 ≃ Fin (0 * m)
  factorz {m} = sym≃ (distz {m})

  distzr : {m : ℕ} → Fin (m * 0) ≃ Fin 0
  distzr {m} = sym≃ F0≃⊥ ● distzrequiv ● id≃ ×≃ F0≃⊥ ● *≃× {m} {0}
    where open Times

  factorzr : {n : ℕ} → Fin 0 ≃ Fin (n * 0)
  factorzr {n} = sym≃ (distzr {n})

  dist : {m n o : ℕ} → Fin ((m + n) * o) ≃ Fin ((m * o) + (n * o))
  dist {m} {n} {o} = ⊎≃+ {m * o} {n * o} ● ×≃* {m} ⊎≃ ×≃* ● distequiv ● +≃⊎ ×≃ id≃ ● *≃×
    where open Times
          open Plus

  factor : {m n o : ℕ} → Fin ((m * o) + (n * o)) ≃ Fin ((m + n) * o)
  factor {m} = sym≃ (dist {m})

  distl : {m n o : ℕ} → Fin (m * (n + o)) ≃ Fin ((m * n) + (m * o))
  distl {m} {n} {o} = ⊎≃+ {m * n} {m * o} ● ×≃* {m} ⊎≃ ×≃* ● distlequiv ● id≃ ×≃ +≃⊎ ● *≃×
    where open Plus
          open Times

  factorl : {m n o : ℕ} → Fin ((m * n) + (m * o)) ≃ Fin (m * (n + o))
  factorl {m} = sym≃ (distl {m})

------------------------------------------------------------------------------
-- Summarizing... we have a commutative semiring structure

fin≃IsEquiv : IsEquivalence _fin≃_
fin≃IsEquiv = record {
  refl = id≃ ;
  sym = sym≃ ;
  trans = trans≃
  }

finPlusIsSG : IsSemigroup _fin≃_ _+_
finPlusIsSG = record {
  isEquivalence = fin≃IsEquiv ;
  assoc = λ m n o → Plus.assocr+ {m} {n} {o} ;
  ∙-cong = Plus._+F_
  }

finTimesIsSG : IsSemigroup _fin≃_ _*_
finTimesIsSG = record {
  isEquivalence = fin≃IsEquiv ;
  assoc = λ m n o → Times.assocr* {m} {n} {o} ;
  ∙-cong = Times._*F_
  }

finPlusIsCM : IsCommutativeMonoid _fin≃_ _+_ 0
finPlusIsCM = record {
  isSemigroup = finPlusIsSG ;
  identityˡ = λ m → id≃ ;
  comm = λ m n → Plus.swap+ {m} {n}
  }

finTimesIsCM : IsCommutativeMonoid _fin≃_ _*_ 1
finTimesIsCM = record {
  isSemigroup = finTimesIsSG ;
  identityˡ = λ m → Times.unite* {m} ;
  comm = λ m n → Times.swap* {m} {n}
  }

finIsCSR : IsCommutativeSemiring _fin≃_ _+_ _*_ 0 1
finIsCSR = record {
  +-isCommutativeMonoid = finPlusIsCM ;
  *-isCommutativeMonoid = finTimesIsCM ;
  distribʳ = λ o m n → PlusTimes.dist {m} {n} {o} ;
  zeroˡ = λ m → PlusTimes.distz {m}
  }

finCSR : CommutativeSemiring Level.zero Level.zero
finCSR = record {
  Carrier = ℕ ;
  _≈_ = _fin≃_ ;
  _+_ = _+_ ;
  _*_ = _*_ ;
  0# = 0 ;
  1# = 1 ;
  isCommutativeSemiring = finIsCSR
  }

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


open import Prelude hiding (id; Bool)

module Implicits.Resolution.Undecidable.Expressiveness where

open import Implicits.Syntax
open import Implicits.Substitutions
open import Extensions.ListFirst

open import Implicits.Resolution.Ambiguous.Resolution as A
open import Implicits.Resolution.Deterministic.Resolution as D
open import Implicits.Resolution.Undecidable.Resolution as I

mutual
  ↓-sound : ∀ {ν} {Δ : ICtx ν} {a r} → Δ D.⊢ r ↓ a → Δ I.⊢ r ↓ a
  ↓-sound (i-simp a) = i-simp a
  ↓-sound (i-iabs x x₁) = i-iabs (≥-deterministic x) (↓-sound x₁)
  ↓-sound (i-tabs b x) = i-tabs b (↓-sound x)

  Δ⟨τ⟩-sound : ∀ {ν} {Δ Δ' : ICtx ν} {a r} → Δ D.⟨ a ⟩= r → Δ' D.⊢ r ↓ a →
              first r ∈ Δ ⇔ (λ r' → Δ' I.⊢ r' ↓ a)
  Δ⟨τ⟩-sound (here p v) y = here (↓-sound y) v
  Δ⟨τ⟩-sound (there x ¬x◁τ p) y = there x (¬◁-¬↓ ¬x◁τ) (Δ⟨τ⟩-sound p y)
    where
      ↓-◁ : ∀ {ν} {Δ : ICtx ν} {a r} → Δ I.⊢ r ↓ a → r ◁ a
      ↓-◁ (i-simp _) = m-simp
      ↓-◁ (i-iabs _ r2↓a) = m-iabs (↓-◁ r2↓a)
      ↓-◁ (i-tabs b r↓a) = m-tabs b (↓-◁ r↓a)

      ¬◁-¬↓ : ∀ {ν} {Δ : ICtx ν} {a r} → ¬ r ◁ a → ¬ Δ I.⊢ r ↓ a
      ¬◁-¬↓ ¬a◁a (i-simp a) = ¬a◁a m-simp
      ¬◁-¬↓ ¬r◁a (i-iabs ⊢ᵣr₁ r₂↓a) = ¬r◁a (m-iabs (↓-◁ r₂↓a))
      ¬◁-¬↓ ¬r◁a (i-tabs b r[/]↓a) = ¬r◁a (m-tabs b (↓-◁ r[/]↓a))

  ≥-deterministic : ∀ {ν} {Δ : ICtx ν} {a} → Δ D.⊢ᵣ a → Δ I.⊢ᵣ a
  ≥-deterministic (r-simp {τ = a} Δ⟨a⟩=r r↓a) = r-simp (Δ⟨τ⟩-sound Δ⟨a⟩=r r↓a)
  ≥-deterministic (r-iabs ρ₁ x) = r-iabs ρ₁ (≥-deterministic x)
  ≥-deterministic (r-tabs x) = r-tabs (≥-deterministic x)


{-# OPTIONS --copatterns --sized-types #-}
-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.conv:10 -v tc.conv.size:15 #-}
module Delay where

--open import Library
open import Size
open import Category.Monad
open import Level renaming (zero to lzero; suc to lsuc)
open import Relation.Binary public
import Relation.Binary.PreorderReasoning
module Pre = Relation.Binary.PreorderReasoning
open import Data.Product
-- Coinductive delay monad.

mutual

  data Delay (A : Set) (i : Size) : Set where
    now   : A → Delay A i
    later : ∞Delay A i → Delay A i

  record ∞Delay (A : Set) (i : Size) : Set where
    coinductive
    constructor delay
    field
      force : {j : Size< i} → Delay A j

open ∞Delay public

-- Smart constructor.

later! : ∀ {A i} → Delay A i → Delay A (↑ i)
later! x = later (delay x)

-- Monad instance.

module Bind where
  mutual
    _>>=_ : ∀ {i A B} → Delay A i → (A → Delay B i) → Delay B i
    now   x >>= f = f x
    later x >>= f = later (x ∞>>= f)

    _∞>>=_ :  ∀ {i A B} → ∞Delay A i → (A → Delay B i) → ∞Delay B i
    force (x ∞>>= f) = force x >>= f

delayMonad : ∀ {i} → RawMonad {f = lzero} (λ A → Delay A i)
delayMonad {i} = record
  { return = now
  ; _>>=_  = _>>=_ {i}
  } where open Bind

module _ {i : Size} where
  open module DelayMonad = RawMonad (delayMonad {i = i})
                           public renaming (_⊛_ to _<*>_)
open Bind public using (_∞>>=_)

-- Map for ∞Delay

_∞<$>_ : ∀ {i A B} (f : A → B) (∞a : ∞Delay A i) → ∞Delay B i
f ∞<$> ∞a = ∞a ∞>>= λ a → return (f a)
-- force (f ∞<$> ∞a) = f <$> force ∞a

-- Double bind

_=<<2_,_ : ∀ {i A B C} → (A → B → Delay C i) → Delay A i → Delay B i → Delay C i
f =<<2 x , y = x >>= λ a → y >>= λ b → f a b

-- Strong bisimilarity

mutual
  data _~_ {i : Size} {A : Set} : (a? b? : Delay A ∞) → Set where
    ~now   : ∀ a → now a ~ now a
    ~later : ∀ {a∞ b∞} (eq : _∞~_ {i} a∞ b∞) → later a∞ ~ later b∞

  record _∞~_ {i : Size} {A : Set} (a∞ b∞ : ∞Delay A ∞) : Set where
    coinductive
    constructor ~delay
    field
      ~force : {j : Size< i} → _~_ {j} (force a∞) (force b∞)

open _∞~_ public

-- Reflexivity

mutual
  ~refl  : ∀ {i A} (a? : Delay A ∞) → _~_ {i} a? a?
  ~refl (now a)    = ~now a
  ~refl (later a∞) = ~later (∞~refl a∞)

  ∞~refl : ∀ {i A} (a∞ : ∞Delay A ∞) → _∞~_ {i} a∞ a∞
  ~force (∞~refl a∞) = ~refl (force a∞)

-- Symmetry

mutual
  ~sym : ∀ {i A} {a? b? : Delay A ∞} → _~_ {i} a? b? → _~_ {i} b? a?
  ~sym (~now a)    = ~now a
  ~sym (~later eq) = ~later (∞~sym eq)

  ∞~sym : ∀ {i A} {a? b? : ∞Delay A ∞} → _∞~_ {i} a? b? → _∞~_ {i} b? a?
  ~force (∞~sym eq) = ~sym (~force eq)

-- Transitivity

mutual
  ~trans : ∀ {i A} {a? b? c? : Delay A ∞}
    (eq : _~_ {i} a? b?) (eq' : _~_ {i} b? c?) → _~_ {i} a? c?
  ~trans (~now a)    (~now .a)    = ~now a
  ~trans (~later eq) (~later eq') = ~later (∞~trans eq eq')

  ∞~trans : ∀ {i A} {a∞ b∞ c∞ : ∞Delay A ∞}
    (eq : _∞~_ {i} a∞ b∞) (eq' : _∞~_ {i} b∞ c∞) → _∞~_ {i} a∞ c∞
  ~force (∞~trans eq eq') = ~trans (~force eq) (~force eq')

-- Equality reasoning

~setoid : (i : Size) (A : Set) → Setoid lzero lzero
~setoid i A = record
  { Carrier       = Delay A ∞
  ; _≈_           = _~_ {i}
  ; isEquivalence = record
    { refl  = λ {a?} → ~refl a?
    ; sym   = ~sym
    ; trans = ~trans
    }
  }

module ~-Reasoning {i : Size} {A : Set} where
  open Pre (Setoid.preorder (~setoid i A)) public
--    using (begin_; _∎) (_≈⟨⟩_ to _~⟨⟩_; _≈⟨_⟩_ to _~⟨_⟩_)
    renaming (_≈⟨⟩_ to _≡⟨⟩_; _≈⟨_⟩_ to _≡⟨_⟩_; _∼⟨_⟩_ to _~⟨_⟩_; begin_ to proof_)

∞~setoid : (i : Size) (A : Set) → Setoid lzero lzero
∞~setoid i A = record
  { Carrier       = ∞Delay A ∞
  ; _≈_           = _∞~_ {i}
  ; isEquivalence = record
    { refl  = λ {a?} → ∞~refl a?
    ; sym   = ∞~sym
    ; trans = ∞~trans
    }
  }

module ∞~-Reasoning {i : Size} {A : Set} where
  open Pre (Setoid.preorder (∞~setoid i A)) public
--    using (begin_; _∎) (_≈⟨⟩_ to _~⟨⟩_; _≈⟨_⟩_ to _~⟨_⟩_)
    renaming (_≈⟨⟩_ to _≡⟨⟩_; _≈⟨_⟩_ to _≡⟨_⟩_; _∼⟨_⟩_ to _∞~⟨_⟩_; begin_ to proof_)

-- Congruence laws.

mutual
  bind-cong-l : ∀ {i A B} {a? b? : Delay A ∞} (eq : _~_ {i} a? b?)
    (k : A → Delay B ∞) → _~_ {i} (a? >>= k) (b? >>= k)
  bind-cong-l (~now a)    k = ~refl _
  bind-cong-l (~later eq) k = ~later (∞bind-cong-l eq k)

  ∞bind-cong-l : ∀ {i A B} {a∞ b∞ : ∞Delay A ∞} (eq : _∞~_ {i} a∞ b∞) →
    (k : A → Delay B ∞) →
    _∞~_ {i} (a∞ ∞>>= k)  (b∞ ∞>>= k)
  ~force (∞bind-cong-l eq k) = bind-cong-l (~force eq) k

_>>=l_ = bind-cong-l

mutual
  bind-cong-r : ∀ {i A B} (a? : Delay A ∞) {k l : A → Delay B ∞} →
    (h : ∀ a → _~_ {i} (k a) (l a)) → _~_ {i} (a? >>= k) (a? >>= l)
  bind-cong-r (now a)    h = h a
  bind-cong-r (later a∞) h = ~later (∞bind-cong-r a∞ h)

  ∞bind-cong-r : ∀ {i A B} (a∞ : ∞Delay A ∞) {k l : A → Delay B ∞} →
    (h : ∀ a → _~_ {i} (k a) (l a)) → _∞~_ {i} (a∞ ∞>>= k)  (a∞ ∞>>= l)
  ~force (∞bind-cong-r a∞ h) = bind-cong-r (force a∞) h

_>>=r_ = bind-cong-r

mutual
  bind-cong : ∀ {i A B}  {a? b? : Delay A ∞} (eq : _~_ {i} a? b?)
              {k l : A → Delay B ∞} (h : ∀ a → _~_ {i} (k a) (l a)) →
              _~_ {i} (a? >>= k) (b? >>= l)
  bind-cong (~now a)    h = h a
  bind-cong (~later eq) h = ~later (∞bind-cong eq h)

  ∞bind-cong : ∀ {i A B} {a∞ b∞ : ∞Delay A ∞} (eq : _∞~_ {i} a∞ b∞)
    {k l : A → Delay B ∞} (h : ∀ a → _~_ {i} (k a) (l a)) →
    _∞~_ {i} (a∞ ∞>>= k)  (b∞ ∞>>= l)
  ~force (∞bind-cong eq h) = bind-cong (~force eq) h

_~>>=_ = bind-cong

-- Monad laws.

mutual
  bind-assoc : ∀{i A B C}(m : Delay A ∞)
               {k : A → Delay B ∞}{l : B → Delay C ∞} →
               _~_ {i} ((m >>= k) >>= l)  (m >>= λ a → k a >>= l)
  bind-assoc (now a)    = ~refl _
  bind-assoc (later a∞) = ~later (∞bind-assoc a∞)

  ∞bind-assoc : ∀{i A B C}(a∞ : ∞Delay A ∞)
                {k : A → Delay B ∞}{l : B → Delay C ∞} →
                _∞~_ {i} ((a∞ ∞>>= λ a → k a) ∞>>= l) (a∞ ∞>>= λ a → k a >>= l)
  ~force (∞bind-assoc a∞) = bind-assoc (force a∞)

-- Termination/Convergence.  Makes sense only for Delay A ∞.

data _⇓_ {A : Set} : (a? : Delay A ∞) (a : A) → Set where
  now⇓   : ∀ {a} → now a ⇓ a
  later⇓ : ∀ {a} {a∞ : ∞Delay A ∞} → force a∞ ⇓ a → later a∞ ⇓ a

_⇓ : {A : Set} (x : Delay A ∞) → Set
x ⇓ = ∃ λ a → x ⇓ a

-- Monotonicity.

map⇓ : ∀ {A B} {a : A} {a? : Delay A ∞}
  (f : A → B) (a⇓ : a? ⇓ a) → (f <$> a?) ⇓ f a
map⇓ f now⇓        = now⇓
map⇓ f (later⇓ a⇓) = later⇓ (map⇓ f a⇓)

-- some lemmas about convergence
subst~⇓ : ∀{A}{t t' : Delay A ∞}{n : A} → t ⇓ n → t ~ t' → t' ⇓ n
subst~⇓ now⇓ (~now a) = now⇓
subst~⇓ (later⇓ p) (~later eq) = later⇓ (subst~⇓ p (~force eq))

-- this should also hold for weak bisimularity right?
{-
subst≈⇓ : ∀{A}{t t' : Delay A ∞}{n : A} → t ⇓ n → t ≈ t' → t' ⇓ n
subst≈⇓ = ?
-}

⇓>>= : ∀{A B}(f : A → Delay B ∞)
       {?a : Delay A ∞}{a : A} → ?a ⇓ a →
       {b : B} → (?a >>= f) ⇓ b → f a ⇓ b
⇓>>= f now⇓ q = q
⇓>>= f (later⇓ p) (later⇓ q) = ⇓>>= f p q

>>=⇓ : ∀{A B}(f : A → Delay B ∞)
       {?a : Delay A ∞}{a : A} → ?a ⇓ a →
       {b : B} → f a ⇓ b → (?a >>= f) ⇓ b
>>=⇓ f now⇓ q = q
>>=⇓ f (later⇓ p) q = later⇓ (>>=⇓ f p q)

-- handy when you can't pattern match like in a let definition
unlater : ∀{A}{∞a : ∞Delay A ∞}{a : A} → later ∞a ⇓ a → force ∞a ⇓ a
unlater (later⇓ p) = p

{-
mutual
  _⇓_ : {A : Set} {i : Size} (x : Delay A i) (a : A) → Set
  x ⇓ a = Terminates a x

  data Terminates {A : Set} {i : Size} (a : A) : Delay A i → Set where
    now   : now a ⇓ a
    later : ∀ {x : ∞Delay A i} → (force x {j = ?}) ⇓ a → later x ⇓ a

mutual

  cast : ∀ {A i} → Delay A i → (j : Size< ↑ i) → Delay A j
  cast (now x) j = now x
  cast (later x) j = {!later (∞cast x j)!}

  ∞cast : ∀ {A i} → ∞Delay A i → (j : Size< ↑ i) → ∞Delay A j
  ♭ (∞cast x j) {k} = cast {i = j} (♭ x) k
-}


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

open import Cubical.Algebra.Group.Base public
open import Cubical.Algebra.Group.Properties public
open import Cubical.Algebra.Group.GroupPath public
open import Cubical.Algebra.Group.DirProd public
open import Cubical.Algebra.Group.Morphisms public
open import Cubical.Algebra.Group.MorphismProperties public
open import Cubical.Algebra.Group.Subgroup public
open import Cubical.Algebra.Group.QuotientGroup public
open import Cubical.Algebra.Group.IsomorphismTheorems public
open import Cubical.Algebra.Group.Instances.Unit public
open import Cubical.Algebra.Group.Instances.Bool public
open import Cubical.Algebra.Group.Instances.Int public


open import SystemT
open import Data.List using ([])

module Examples where

  -- λ x . x
  ex1 : [] ⊢ base ⟶ base
  ex1 = lam (var i0)

  -- λ x . λ y . y
  ex2 : [] ⊢ base ⟶ base ⟶ base
  ex2 = lam (lam (var i0))

  -- λ x . λ y . x
  ex3 : [] ⊢ base ⟶ base ⟶ base
  ex3 = lam (lam (var (iS i0)))


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

open import HoTT
open import homotopy.HSpace renaming (HSpaceStructure to HSS)
open import homotopy.WedgeExtension

module homotopy.Pi2HSusp where

module Pi2HSusp {i} (A : Type i) (gA : has-level ⟨ 1 ⟩ A)
  (cA : is-connected ⟨0⟩ A) (A-H : HSS A)
  (μcoh : HSS.μe- A-H (HSS.e A-H) == HSS.μ-e A-H (HSS.e A-H))
  where

  {- TODO this belongs somewhere else, but where? -}
  private
    Type=-ext : ∀ {i} {A B : Type i} (p q : A == B)
      → ((x : A) → coe p x == coe q x) → p == q
    Type=-ext p q α =
      ! (ua-η p)
      ∙ ap ua (pair= (λ= α) (prop-has-all-paths-↓ (is-equiv-is-prop (coe q))))
      ∙ ua-η q

  open HSpaceStructure A-H
  open ConnectedHSpace A cA A-H

  P : Suspension A → Type i
  P x = Trunc ⟨ 1 ⟩ (north A == x)

  module Codes = SuspensionRec A A A (λ a → ua (μ-equiv a))

  Codes : Suspension A → Type i
  Codes = Codes.f

  Codes-level : (x : Suspension A) → has-level ⟨ 1 ⟩ (Codes x)
  Codes-level = Suspension-elim A gA gA
    (λ _ → prop-has-all-paths-↓ has-level-is-prop)

  encode₀ : {x : Suspension A} → (north A == x) → Codes x
  encode₀ α = transport Codes α e

  encode : {x : Suspension A} → P x → Codes x
  encode {x} = Trunc-rec (Codes-level x) encode₀

  decode' : A → P (north A)
  decode' a = [ (merid A a ∙ ! (merid A e)) ]

  abstract
    transport-Codes-mer : (a a' : A)
      → transport Codes (merid A a) a' == μ a a'
    transport-Codes-mer a a' =
      coe (ap Codes (merid A a)) a'
        =⟨ Codes.glue-β a |in-ctx (λ w → coe w a') ⟩
      coe (ua (μ-equiv a)) a'
        =⟨ coe-β (μ-equiv a) a' ⟩
      μ a a' ∎

    transport-Codes-mer-e-! : (a : A)
      → transport Codes (! (merid A e)) a == a
    transport-Codes-mer-e-! a =
      coe (ap Codes (! (merid A e))) a
        =⟨ ap-! Codes (merid A e) |in-ctx (λ w → coe w a) ⟩
      coe (! (ap Codes (merid A e))) a
        =⟨ Codes.glue-β e |in-ctx (λ w → coe (! w) a) ⟩
      coe (! (ua (μ-equiv e))) a
        =⟨ Type=-ext (ua (μ-equiv e)) idp (λ x → coe-β _ x ∙ μe- x)
          |in-ctx (λ w → coe (! w) a) ⟩
      coe (! idp) a ∎

  abstract
    encode-decode' : (a : A) → encode (decode' a) == a
    encode-decode' a =
      transport Codes (merid A a ∙ ! (merid A e)) e
        =⟨ trans-∙ {B = Codes} (merid A a) (! (merid A e)) e ⟩
      transport Codes (! (merid A e)) (transport Codes (merid A a) e)
        =⟨ transport-Codes-mer a e ∙ μ-e a
          |in-ctx (λ w → transport Codes (! (merid A e)) w) ⟩
      transport Codes (! (merid A e)) a
        =⟨ transport-Codes-mer-e-! a ⟩
      a ∎

  abstract
    homomorphism : (a a' : A)
      → Path {A = Trunc ⟨ 1 ⟩ (north A == south A)}
        [ merid A (μ a a' ) ] [ merid A a' ∙ ! (merid A e) ∙ merid A a ]
    homomorphism = WedgeExt.ext args
      where
      args : WedgeExt.args {a₀ = e} {b₀ = e}
      args = record {m = ⟨-2⟩; n = ⟨-2⟩; cA = cA; cB = cA;
        P = λ a a' → (_ , Trunc-level {n = ⟨ 1 ⟩} _ _);
        f = λ a →  ap [_] $
              merid A (μ a e)
                =⟨ ap (merid A) (μ-e a) ⟩
              merid A a
                =⟨ ap (λ w → w ∙ merid A a) (! (!-inv-r (merid A e)))
                   ∙ ∙-assoc (merid A e) (! (merid A e)) (merid A a)  ⟩
              merid A e ∙ ! (merid A e) ∙ merid A a ∎;
        g = λ a' → ap [_] $
              merid A (μ e a')
                =⟨ ap (merid A) (μe- a') ⟩
              merid A a'
                =⟨ ! (∙-unit-r (merid A a'))
                   ∙ ap (λ w → merid A a' ∙ w) (! (!-inv-l (merid A e))) ⟩
              merid A a' ∙ ! (merid A e) ∙ merid A e ∎ ;
        p = ap (λ {(p₁ , p₂) → ap [_] $
              merid A (μ e e) =⟨ p₁ ⟩
              merid A e       =⟨ p₂ ⟩
              merid A e ∙ ! (merid A e) ∙ merid A e ∎})
             (pair×= (ap (λ x → ap (merid A) x) (! μcoh)) (coh (merid A e)))}
        where coh : {B : Type i} {b b' : B} (p : b == b')
                → ap (λ w → w ∙ p) (! (!-inv-r p)) ∙ ∙-assoc p (! p) p
                  == ! (∙-unit-r p) ∙ ap (λ w → p ∙ w) (! (!-inv-l p))
              coh idp = idp

  decode : {x : Suspension A} → Codes x → P x
  decode {x} = Suspension-elim A {P = λ x → Codes x → P x}
                 decode'
                 (λ a → [ merid A a ])
                 (λ a → ↓-→-from-transp (λ= $ STS a))
                 x
    where
    abstract
      STS : (a a' : A) → transport P (merid A a) (decode' a')
                         == [ merid A (transport Codes (merid A a) a') ]
      STS a a' =
        transport P (merid A a) [ merid A a' ∙ ! (merid A e) ]
          =⟨ transport-Trunc (λ x → north A == x) (merid A a) _ ⟩
        [ transport (λ x → north A == x) (merid A a) (merid A a' ∙ ! (merid A e)) ]
          =⟨ ap [_] (trans-pathfrom {A = Suspension A} (merid A a) _) ⟩
        [ (merid A a' ∙ ! (merid A e)) ∙ merid A a  ]
          =⟨ ap [_] (∙-assoc (merid A a') (! (merid A e)) (merid A a)) ⟩
        [ merid A a' ∙ ! (merid A e) ∙ merid A a  ]
          =⟨ ! (homomorphism a a') ⟩
        [ merid A (μ a a') ]
          =⟨ ap ([_] ∘ merid A) (! (transport-Codes-mer a a')) ⟩
        [ merid A (transport Codes (merid A a) a') ] ∎

  abstract
    decode-encode : {x : Suspension A} (tα : P x)
      → decode {x} (encode {x} tα) == tα
    decode-encode {x} = Trunc-elim
      {P = λ tα → decode {x} (encode {x} tα) == tα}
      (λ _ → =-preserves-level ⟨ 1 ⟩ Trunc-level)
      (J (λ y p → decode {y} (encode {y} [ p ]) == [ p ])
         (ap [_] (!-inv-r (merid A e))))

  main-lemma-eqv : Trunc ⟨ 1 ⟩ (north A == north A) ≃ A
  main-lemma-eqv = equiv encode decode' encode-decode' decode-encode

  ⊙main-lemma : ⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e))) == (A , e)
  ⊙main-lemma = ⊙ua main-lemma-eqv idp

  abstract
    main-lemma-iso : (t1 : 1 ≠ 0) →
         Ω^-Group 1 t1 (⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e)))) Trunc-level
      ≃ᴳ Ω^-Group 1 t1 (⊙Trunc ⟨ 1 ⟩ (A , e)) Trunc-level
    main-lemma-iso _ = (record {f = f; pres-comp = pres-comp} , ie)
      where
      h : fst (⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e)))
            ⊙→ ⊙Trunc ⟨ 1 ⟩ (A , e))
      h = (λ x → [ encode x ]) , idp

      f : Ω (⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e)))) → Ω (⊙Trunc ⟨ 1 ⟩ (A , e))
      f = fst (ap^ 1 h)

      pres-comp : (p q : Ω^ 1 (⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e)))))
        → f (conc^ 1 (ℕ-S≠O _) p q) == conc^ 1 (ℕ-S≠O _) (f p) (f q)
      pres-comp = ap^-conc^ 1 (ℕ-S≠O _) h

      ie : is-equiv f
      ie = is-equiv-ap^ 1 h (snd $ ((unTrunc-equiv A gA)⁻¹ ∘e main-lemma-eqv))

  abstract
    π₂-Suspension : (t1 : 1 ≠ 0) (t2 : 2 ≠ 0)
      → π 2 t2 (⊙Susp (A , e)) == π 1 t1 (A , e)
    π₂-Suspension t1 t2 =
      π 2 t2 (⊙Susp (A , e))
        =⟨ π-inner-iso 1 t1 t2 (⊙Susp (A , e)) ⟩
      π 1 t1 (⊙Ω (⊙Susp (A , e)))
        =⟨ ! (π-Trunc-shift-iso 1 t1 (⊙Ω (⊙Susp (A , e)))) ⟩
      Ω^-Group 1 t1 (⊙Trunc ⟨ 1 ⟩ (⊙Ω (⊙Susp (A , e)))) Trunc-level
        =⟨ group-ua (main-lemma-iso t1) ⟩
      Ω^-Group 1 t1 (⊙Trunc ⟨ 1 ⟩ (A , e)) Trunc-level
        =⟨ π-Trunc-shift-iso 1 t1 (A , e) ⟩
      π 1 t1 (A , e) ∎


open import Functional hiding (Domain)
import      Structure.Logic.Classical.NaturalDeduction

module Structure.Logic.Classical.SetTheory.ZFC {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic : _ ⦄ (_∈_ : Domain → Domain → Formula) where
open Structure.Logic.Classical.NaturalDeduction.ClassicalLogic {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (classicLogic)

open import Lang.Instance
import      Lvl
open import Structure.Logic.Classical.NaturalDeduction.Proofs            ⦃ classicLogic ⦄
open import Structure.Logic.Classical.SetTheory.SetBoundedQuantification ⦃ classicLogic ⦄ (_∈_)
open import Structure.Logic.Classical.SetTheory.Relation                 ⦃ classicLogic ⦄ (_∈_)
open import Structure.Logic.Constructive.Functions.Properties            ⦃ constructiveLogicSignature ⦄

private
  module Meta where
    open import Numeral.Finite           public
    open import Numeral.Finite.Bound{ℓₗ} public
    open import Numeral.Natural                public

-- The symbols/signature of ZFC set theory.
record Signature : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
  infixl 3000 _∪_
  infixl 3001 _∩_
  infixl 3002 _⨯_ _∖_

  field
    -- Empty set
    -- The set consisting of no elements.
    ∅ : Domain

    -- Pair set.
    -- The set consisting of only two elements.
    pair : Domain → Domain → Domain

    -- Subset filtering.
    -- The subset of the specified set where all elements satisfy the specified formula.
    filter : Domain → (Domain → Formula) → Domain

    -- Power set.
    -- The set of all subsets of the specified set.
    ℘ : Domain → Domain

    -- Union over arbitrary sets.
    -- Constructs a set which consists of elements which are in any of the specified sets.
    ⋃ : Domain → Domain

    -- An inductive set.
    -- A set which has the `Inductive`-property. Also infinite.
    inductiveSet : Domain

    -- The map of a set.
    -- The set of values when a function is applied to every element of a set.
    -- Or: The image of the function on the set.
    -- Or: The image of the function.
    map : (Domain → Domain) → Domain → Domain

    -- An inverse function of a function from its domain to its image.
    inv : (Domain → Domain) → Domain → Domain

  -- Singleton set.
  -- A set consisting of only a single element.
  singleton : Domain → Domain
  singleton(s) = pair(s)(s)

  -- Union operator.
  -- Constructs a set which consists of both elements from LHS and RHS.
  _∪_ : Domain → Domain → Domain
  a ∪ b = ⋃(pair a b)

  -- Intersection operator.
  -- Constructs a set which consists of elements which are in both LHS and RHS.
  _∩_ : Domain → Domain → Domain
  a ∩ b = filter(a)(_∈ b)

  -- "Without"-operator.
  -- Constructs a set which consists of elements which are in LHS, but not RHS.
  _∖_ : Domain → Domain → Domain
  a ∖ b = filter(a)(_∉ b)

  -- Intersection over arbitrary sets.
  -- Constructs a set which consists of elements which are in all of the specified sets.
  ⋂ : Domain → Domain
  ⋂(a) = filter(⋃(a)) (a₁ ↦ ∀ₗ(a₂ ↦ (a₂ ∈ a) ⟶ (a₁ ∈ a₂)))

  -- Tuple value.
  -- An ordered pair of values.
  _,_ : Domain → Domain → Domain
  a , b = pair(singleton(a)) (pair(a)(b))

  -- Set product (Set of tuples) (Cartesian product).
  _⨯_ : Domain → Domain → Domain
  a ⨯ b = filter(℘(℘(a ∪ b))) (t ↦ ∃ₗ(x ↦ (x ∈ a) ∧ ∃ₗ(y ↦ (y ∈ b) ∧ (t ≡ (x , y)))))

  identityPairing : Domain → Domain
  identityPairing(D) = filter(D ⨯ D) (xy ↦ ∃ₗ(a ↦ xy ≡ (a , a)))

  -- swappedPairing : Domain → Domain
  -- swappedPairing() =

  -- Set product over a finite indexed family (Cartesian product).
  -- TODO: Not really like this. See definition of (_⨯_) and (_,_), and try to express the same here
  -- TODO: Also, make it possible to take the set product of infinite indexed families
  -- TODO: Maybe just use functions like (𝕟(n) →ₛₑₜ _) for finite and (ℕ → _) for infinite
  -- ∏_ : ∀{n} → FiniteIndexedFamily(n) → Domain
  -- ∏_ {Meta.𝟎}            _ = singleton(∅)
  -- ∏_ {Meta.𝐒(Meta.𝟎)}    I = I(Meta.𝟎)
  -- ∏_ {Meta.𝐒(Meta.𝐒(n))} I = I(Meta.maximum) ⨯ (∏_ {Meta.𝐒(n)} (I ∘ Meta.bound-𝐒))

  -- Quotient set.
  -- The set of equivalence classes.
  _/_ : Domain → BinaryRelator → Domain
  a / (_▫_) = filter(℘(a))(aₛ ↦ ∀ₛ(aₛ)(x ↦ ∀ₛ(aₛ)(y ↦ x ▫ y)))

  -- Equivalence class
  -- The set of elements which are equivalent to the specified one.
  [_of_,_] : Domain → Domain → BinaryRelator → Domain
  [ x of a , (_▫_) ] = filter(a)(y ↦ x ▫ y)

  -- TODO: Implement a choice function (the "axiom of choice" one) by inv
  -- choice : Domain → Domain → Domain

  -- The unmap of a set.
  -- The set of elements in the domain X when applied to a function gives an element in Y.
  -- Or: The inverse image of the function on the set.
  -- Or: The pre-image of the function on the set.
  -- Note:
  --   The domain is neccessary because a class function's domain is not neccesarily a set.
  --   For example: `const(x): Domain → Domain` for any (x: Domain) is a class function for which its domain is not a set.
  --   This is because const is defined for all objects in `Domain`, so if a set would have to have all objects in `Domain`, it has to be the universal set, but there is no universal set.
  unmap : Domain → (Domain → Domain) → Domain → Domain
  unmap(X) f(Y) = filter(X) (x ↦ f(x) ∈ Y)

{-
module Function ⦃ signature : Signature ⦄ where
  open Signature ⦃ ... ⦄

  record SetRepresentable (f : Function) : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
    constructor intro

    field
      set : Domain

    field
      proof : Proof(∀ₗ(x ↦ ∀ₗ(y ↦ (f(x) ≡ y) ⟷ ((x , y) ∈ set))))

  -- An instance of Type(f) means that the function f has a default domain and codomain, and a proof that the function actually are closed inside this domain/codomain pair.
  record Type (f : Function) : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
    constructor intro
    field
      domain   : Domain
      codomain : Domain

    field
      closure : Proof(∀ₛ(domain)(x ↦ f(x) ∈ codomain))
  open Type ⦃ ... ⦄ public
-}

module Tuple ⦃ signature : Signature ⦄ where -- TODO: Move
  open Signature ⦃ ... ⦄

  left : Domain → Domain
  left(s) = ⋃(⋂ s)

  right : Domain → Domain
  right(s) = (⋃ s) ∖ left(s)

-- A model of natural numbers expressed in set theory (using only sets).
module NumeralNatural ⦃ signature : Signature ⦄ where -- TODO: Move
  open Signature ⦃ ... ⦄

  -- The zero constant from the standard inductive set definition of ℕ in ZFC set theory.
  𝟎 : Domain
  𝟎 = ∅

  -- The successor function from the standard inductive set definition of ℕ in ZFC set theory.
  -- This means that all lesser numbers are contained in every number.
  -- Examples:
  -- • 0: {}
  -- • 1: 0∪{0} = {0} = {{},{{}}}
  -- • 2: 1∪{1} = {0}∪{1} = {0,1} = {{},{{},{{}}}}
  -- • 3: 2∪{2} = {0,1}∪{2} = {0,1,2} = {{{},{{},{{}}}},{{{},{{},{{}}}}}}
  -- • 4: 3∪{3} = {0,1,2}∪{3} = {0,1,2,3} = {{{{},{{},{{}}}},{{{},{{},{{}}}}}},{{{{},{{},{{}}}},{{{},{{},{{}}}}}}}}
  𝐒 : Domain → Domain
  𝐒(n) = n ∪ singleton(n)

  -- A set is ℕ-inductive when has zero and all its successors.
  -- In loose terms: Inductive(I) means (I ⊆ ℕ)
  Inductive : Domain → Formula
  Inductive(I) = (𝟎 ∈ I) ∧ (∀ₗ(x ↦ (x ∈ I) ⟶ (𝐒(x) ∈ I)))

  -- The "smallest" inductive set is the set of natural numbers.
  -- All elements which can be expressed using only 𝟎 and 𝐒.
  ℕ : Domain
  ℕ = ⋂(filter(℘(inductiveSet)) Inductive) -- TODO: This pattern seems useful

  -- The relation "lesser than" in this model of ℕ.
  -- This works for all elements in ℕ by the definition of 𝟎 and 𝐒.
  _<_ : BinaryRelator
  a < b = a ∈ b

  _≤_ : BinaryRelator
  a ≤ b = (a < b) ∨ (a ≡ b)

  _>_ : BinaryRelator
  a > b = b < a

  _≥_ : BinaryRelator
  a ≥ b = b ≤ a

  infixl 2000 _<_ _≤_ _>_ _≥_

  𝕟 : Domain → Domain
  𝕟(n) = filter(ℕ) (_< n)

module Axioms ⦃ signature : Signature ⦄ where
  open NumeralNatural using () renaming (Inductive to [ℕ]-Inductive)
  open Signature ⦃ ... ⦄

  -- `∅` is a set which is empty.
  -- • Allows a construction of an empty set.
  EmptySetMembership : Formula
  EmptySetMembership = Empty(∅)

  -- `pair` is the construction of a set with two elements.
  -- • Allows a construction of a set with two elements.
  PairingMembership : Formula
  PairingMembership = ∀ₗ(x₁ ↦ ∀ₗ(x₂ ↦ (∀ₗ(x ↦ (x ∈ pair(x₁)(x₂)) ⟷ (x ≡ x₁)∨(x ≡ x₂)))))

  -- `filter` is the set which is the subset of a set where all elements satisfies a predicate.
  RestrictedComprehension : (Domain → Formula) → Formula
  RestrictedComprehension(φ) = ∀ₗ(s ↦ ∀ₗ(x ↦ ((x ∈ filter(s)(φ)) ⟷ ((x ∈ s) ∧ φ(x)))))

  -- `℘` is the construction of a set which contains all the subsets of a set.
  -- • Allows a construction of a set that is the powerset of a set.
  PowerSetMembership : Formula
  PowerSetMembership = ∀ₗ(s ↦ ∀ₗ(x ↦ (x ∈ ℘(s)) ⟷ (x ⊆ s)))

  -- `⋃` is the construction of a set which contains all the elements of a collection of sets.
  -- • Allows a construction of a set that is the union of some sets.
  UnionMembership : Formula
  UnionMembership = ∀ₗ(ss ↦ ∀ₗ(x ↦ (x ∈ ⋃(ss)) ⟷ ∃ₗ(s ↦ (s ∈ ss)∧(x ∈ s))))

  -- `inductiveSet` is ℕ-inductive.
  -- • An inductive set is infinite, so this implies that an infinite set exists.
  -- • Makes it possible to construct the set of natural numbers (ℕ).
  Infinity : Formula
  Infinity = [ℕ]-Inductive(inductiveSet)

  -- Set identity is extensionally determined. More specifically by its contents.
  -- • Guarantees the definition of equality for sets.
  Extensionality : Formula
  Extensionality = ∀ₗ(s₁ ↦ ∀ₗ(s₂ ↦ ∀ₗ(x ↦ (x ∈ s₁)⟷(x ∈ s₂)) ⟷ (s₁ ≡ s₂)))

  -- A non-empty set contain sets that are disjoint to it.
  -- • Prevents sets containing themselves.
  -- • Makes every set have an ordinal rank.
  Regularity : Formula
  Regularity = ∀ₗ(s₁ ↦ (NonEmpty(s₁) ⟶ ∃ₗ(s₂ ↦ (s₂ ∈ s₁) ∧ Disjoint(s₁)(s₂))))

  -- `map` is the construction of the image of a function restricted to a set.
  -- • The `map`-function on a function is a function from sets to sets.
  Replacement : (Domain → Domain) → Formula
  Replacement(f) = ∀ₗ(A ↦ ∀ₗ(y ↦ (y ∈ map f(A)) ⟷ ∃ₛ(A)(x ↦ y ≡ f(x))))
  -- ReplacementTraditional = ∀{φ : Domain → Domain → Formula} → Proof(∀ₗ(A ↦ TotalFunction(φ)(A) ⟶ ∃ₗ(B ↦ ∀ₗ(y ↦ (y ∈ B) ⟷ ∃ₗ(x ↦ (x ∈ A) ∧ φ(x)(y))))))

  -- The set product of non-empty finite indexed family of sets where all the sets are non-empty is non-empty.
  -- TODO: Should the indexed family really be finite? https://en.wikipedia.org/wiki/Cartesian_product#Infinite_Cartesian_products
  -- Choice = ∀{n : Meta.ℕ}{F : FiniteIndexedFamily(Meta.𝐒(n))} → (∀{i : Meta.𝕟(Meta.𝐒(n))} → Proof(NonEmpty(F(i)))) → Proof(NonEmpty(∏ F))

  -- `inv` constructs the right inverse for function composition.
  -- • All surjective class functions have a right inverse.
  -- • An element applied to the inverse function of a function yields/returns one of the arguments that yield/return this element as a value when it exists.
  -- TODO: MAybe this is too strong of a statement? Because the image is not neccessarily a set if the class function is defined for all objects (in the domain) in the theory? Is this really equivalent to `ChoiceTraditional`?
  Choice : (Domain → Domain) → Formula
  Choice(f) = ∀ₗ(y ↦ (Value f(y)) ⟶ ((f ∘ (inv f))(y) ≡ y))

  -- ChoiceTraditional = Proof(∀ₗ(s ↦ (∅ ∉ s) ⟶ ∃ₛ(s →ₛₑₜ (⋃ s))(f ↦ ∀ₛ(s)(x ↦ ∀ₛ(⋃ s)(y ↦ ((x , y) ∈ f) ⟶ (y ∈ x))))))
  -- ChoiceTraditional : (Domain → Domain → Domain) → Formula
  -- ChoiceTraditional(choice) = ∀ₗ(s ↦ ∀ₛ(s)(x ↦ NonEmpty(x) ⟶ (choice(s)(x) ∈ x)))

record Z ⦃ signature : Signature ⦄ : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
  open Axioms
  open Signature ⦃ ... ⦄

  field
    extensional   : Proof(Extensionality)
    empty         : Proof(EmptySetMembership)
    pairing       : Proof(PairingMembership)
    comprehension : ∀{φ} → Proof(RestrictedComprehension(φ))
    union         : Proof(UnionMembership)
    power         : Proof(PowerSetMembership)
    infinity      : Proof(Infinity)

record ZF ⦃ signature : Signature ⦄ : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
  open Axioms
  open Signature ⦃ ... ⦄

  field
    extensional   : Proof(Extensionality)
    empty         : Proof(EmptySetMembership)
    pairing       : Proof(PairingMembership)
    comprehension : ∀{φ} → Proof(RestrictedComprehension(φ))
    union         : Proof(UnionMembership)
    power         : Proof(PowerSetMembership)
    infinity      : Proof(Infinity)
    regular       : Proof(Regularity)
    replacement   : ∀{f} → Proof(Replacement(f))

record ZFC ⦃ signature : Signature ⦄ : Set((ℓₗ Lvl.⊔ ℓₒ) Lvl.⊔ ℓₘₗ) where
  open Axioms
  open Signature ⦃ ... ⦄

  field
    extensional   : Proof(Extensionality)
    empty         : Proof(EmptySetMembership)
    pairing       : Proof(PairingMembership)
    comprehension : ∀{φ} → Proof(RestrictedComprehension(φ))
    union         : Proof(UnionMembership)
    power         : Proof(PowerSetMembership)
    infinity      : Proof(Infinity)
    regular       : Proof(Regularity)
    replacement   : ∀{f} → Proof(Replacement(f))
    choice        : ∀{f} → Proof(Choice(f))


-- Andreas, 2013-10-21 fixed this issue
-- by refactoring Internal to spine syntax.
module Issue901 where

open import Common.Level

record Ls : Set where
  constructor _,_
  field
    fst : Level
    snd : Level
open Ls

record R (ls : Ls) : Set (lsuc (fst ls ⊔ snd ls)) where
  field
    A : Set (fst ls)
    B : Set (snd ls)

bad : R _
bad = record { A = Set; B = Set₁ }

good : R (_ , _)
good = record { A = Set; B = Set₁ }

{- PROBLEM WAS:

"good" is fine while the body and signature of "bad" are marked in yellow.
Both are fine if we change the parameter of R to not contain levels.

The meta _1 in R _ is never eta-expanded somehow.  I think this
problem will vanish if we let whnf eta-expand metas that are
projected.  E.g.

  fst _1

will result in

  _1 := _2,_3

and then reduce to

  _2

(And that would be easier to implement if Internal was a spine syntax
(with post-fix projections)).  -}


{-# OPTIONS --safe #-}
module STLC.Operational.Eager where

open import STLC.Syntax
open import STLC.Operational.Base
open import Data.Empty using (⊥-elim)
open import Data.Product using (∃-syntax; _,_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Fin using (Fin; _≟_) renaming (zero to fzero; suc to fsuc)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong)
open import Relation.Nullary using (yes; no; ¬_)

private
  variable
    m n : ℕ
    L M M' N N' : Term n
    A B C : Type
    Γ Δ : Ctx n
    v : Fin n

data Value {n} : Term n → Set where
  abs-value
      -----------------
    : Value (abs A M)
  ⋆-value
      -----------------
    : Value ⋆
  pair-value
    : Value M → Value N
      -----------------
    → Value (pair M N)

infix 6 _↦_

data _↦_ : Term n → Term n → Set where
  red-head
    : M ↦ M'
      ------------------
    → app M N ↦ app M' N
  red-arg
    : Value M → N ↦ N'
      ------------------
    → app M N ↦ app M N'
  red-β
    : Value N
      ---------------------------------
    → app (abs A M) N ↦ M [ fzero ≔ N ]
  red-left
    : M ↦ M'
      --------------------
    → pair M N ↦ pair M' N
  red-right
    : Value M     → N ↦ N'
      --------------------
    → pair M N ↦ pair M N'
  red-projₗ-inner
    : M ↦ M'
      ------------------
    → projₗ M ↦ projₗ M'
  red-projₗ
    : Value M → Value N
      --------------------
    → projₗ (pair M N) ↦ M
  red-projᵣ-inner
    : M ↦ M'
      ------------------
    → projᵣ M ↦ projᵣ M'
  red-projᵣ
    : Value M → Value N
      --------------------
    → projᵣ (pair M N) ↦ N

data  _↦*_ : Term n → Term n → Set where
  pure : M ↦ N → M ↦* N
  id : M ↦* M
  comp : L ↦* M → M ↦* N → L ↦* N

open import STLC.Typing

progress : ● ⊢ M ⦂ A → Value M ⊎ (∃[ N ] (M ↦ N))
progress (ty-abs _) = inj₁ abs-value
progress (ty-app {f = f} {x = x} t u) with progress u | progress t
... | inj₁ u-value | inj₁ (abs-value {M = M}) = inj₂ (M [ fzero ≔ x ] , red-β u-value)
... | inj₂ (u' , u-step) | inj₁ t-value = inj₂ (app f u' , red-arg t-value u-step)
... | inj₁ _ | inj₂ (t' , t-step) = inj₂ (app t' x , red-head t-step)
... | inj₂ _ | inj₂ (t' , t-step) = inj₂ (app t' x , red-head t-step)
progress ty-⋆ = inj₁ ⋆-value
progress (ty-pair {a = a} {b = b} t u) with progress t | progress u
... | inj₁ t-value | inj₁ u-value = inj₁ (pair-value t-value u-value)
... | inj₁ t-value | inj₂ (u' , u-step) = inj₂ (pair a u' , red-right t-value u-step)
... | inj₂ (t' , t-step) | _ = inj₂ (pair t' b , red-left t-step)
progress (ty-projₗ t) with progress t
... | inj₁ (pair-value {M = M} M-value N-value) = inj₂ (M , red-projₗ M-value N-value)
... | inj₂ (t' , t-step) = inj₂ (projₗ t' , red-projₗ-inner t-step)
progress (ty-projᵣ t) with progress t
... | inj₁ (pair-value {N = N} M-value N-value) = inj₂ (N , red-projᵣ M-value N-value)
... | inj₂ (t' , t-step) = inj₂ (projᵣ t' , red-projᵣ-inner t-step)

weakening-var
  : ∀ {Γ : Ctx n} {v' : Fin (suc n)} → Γ ∋ v ⦂ A → liftΓ Γ v' B ∋ Data.Fin.punchIn v' v ⦂ A
weakening-var {v' = fzero} vzero = vsuc vzero
weakening-var {v' = fsuc n} vzero = vzero
weakening-var {v' = fzero} (vsuc v) = vsuc (vsuc v)
weakening-var {v' = fsuc n} (vsuc v) = vsuc (weakening-var v)

-- | The weakening lemma: A term typeable in a context is typeable in an extended context.
--
-- https://www.seas.upenn.edu/~sweirich/dsss17/html/Stlc.Lec2.html
weakening
  : ∀ {Γ : Ctx n} {v : Fin (suc n)} {t : Type} → Γ ⊢ M ⦂ A → liftΓ Γ v t ⊢ lift M v ⦂ A
weakening (ty-abs body) = ty-abs (weakening body)
weakening (ty-app f x) = ty-app (weakening f) (weakening x)
weakening (ty-var v) = ty-var (weakening-var v)
weakening ty-⋆ = ty-⋆
weakening (ty-pair l r) = ty-pair (weakening l) (weakening r)
weakening (ty-projₗ p) = ty-projₗ (weakening p)
weakening (ty-projᵣ p) = ty-projᵣ (weakening p)

lemma : ∀ {Γ : Ctx n} → (v : Fin (suc n)) → liftΓ Γ v B ∋ v ⦂ A → A ≡ B
lemma fzero vzero = refl
lemma {Γ = _ ,- _} (fsuc fin) (vsuc v) = lemma fin v

subst-eq
  : (v : Fin (suc n))
  → liftΓ Γ v B ∋ v ⦂ A
  → Γ ⊢ M ⦂ B
  → Γ ⊢ var v [ v ≔ M ] ⦂ A
subst-eq fzero vzero typing = typing
subst-eq {Γ = Γ ,- C} (fsuc fin) (vsuc v) typing with fin ≟ fin
... | yes refl rewrite lemma fin v = typing
... | no neq = ⊥-elim (neq refl)

subst-neq
  : (v v' : Fin (suc n))
  → liftΓ Γ v B ∋ v' ⦂ A
  → (prf : ¬ v ≡ v')
  → Γ ∋ (Data.Fin.punchOut prf) ⦂ A
subst-neq v v' v-typing neq with v ≟ v'
... | yes refl = ⊥-elim (neq refl)
subst-neq fzero fzero _ _ | no neq = ⊥-elim (neq refl)
subst-neq {Γ = Γ ,- C} fzero (fsuc fin) (vsuc v-typing) _ | no neq = v-typing
subst-neq {Γ = Γ ,- C} (fsuc fin) fzero vzero _ | no neq = vzero
subst-neq {Γ = Γ ,- C} (fsuc fin) (fsuc fin') (vsuc v-typing) neq | no _ =
  vsuc (subst-neq fin fin' v-typing λ { assump → neq (cong fsuc assump) })

-- | The substitution lemma: Substitution preserves typing.
subst
  : ∀ {Γ : Ctx n}
  → liftΓ Γ v B ⊢ M ⦂ A → Γ ⊢ N ⦂ B
  → Γ ⊢ M [ v ≔ N ] ⦂ A
subst (ty-abs body) typing = ty-abs (subst body (weakening typing))
subst (ty-app f x) typing = ty-app (subst f typing) (subst x typing)
subst {v = v} {Γ = _} (ty-var {v = v'} v-typing) typing with v' ≟ v
... | yes refl = subst-eq v v-typing typing
subst {v = fzero} (ty-var {v = fzero} v-typing) typing | no neq = ⊥-elim (neq refl)
subst {v = fzero} (ty-var {v = fsuc v'} (vsuc v-typing)) typing | no neq = ty-var v-typing
subst {v = fsuc v} {Γ = Γ ,- C} (ty-var {v = fzero} vzero) typing | no neq = ty-var vzero
subst {v = fsuc v} {Γ = Γ ,- C} (ty-var {v = fsuc v'} (vsuc v-typing)) typing | no neq
  with v ≟ v'
... | yes eq = ⊥-elim (neq (cong fsuc (sym eq)))
... | no neq' = ty-var (vsuc (subst-neq v v' v-typing _))
subst ty-⋆ _ = ty-⋆
subst (ty-pair l r) typing = ty-pair (subst l typing) (subst r typing)
subst (ty-projₗ p) typing = ty-projₗ (subst p typing)
subst (ty-projᵣ p) typing = ty-projᵣ (subst p typing)

preservation : ● ⊢ M ⦂ A → M ↦ N → ● ⊢ N ⦂ A
preservation (ty-app M-ty N-ty) (red-head M-step) = ty-app (preservation M-ty M-step) N-ty
preservation (ty-app M-ty N-ty) (red-arg M-val N-step) =
  ty-app M-ty (preservation N-ty N-step)
preservation (ty-app (ty-abs body-ty) N-ty) (red-β N-value) = subst body-ty N-ty
preservation (ty-pair M-ty N-ty) (red-left M-step) = ty-pair (preservation M-ty M-step) N-ty
preservation (ty-pair M-ty N-ty) (red-right _ N-step) =
  ty-pair M-ty (preservation N-ty N-step)
preservation (ty-projₗ M-ty) (red-projₗ-inner M-step) = ty-projₗ (preservation M-ty M-step)
preservation (ty-projₗ (ty-pair M-ty _)) (red-projₗ _ _) = M-ty
preservation (ty-projᵣ M-ty) (red-projᵣ-inner M-step) = ty-projᵣ (preservation M-ty M-step)
preservation (ty-projᵣ (ty-pair _ N-ty)) (red-projᵣ _ _) = N-ty


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

open import Cubical.Foundations.Pointed.Base public
open import Cubical.Foundations.Pointed.Properties public
open import Cubical.Foundations.Pointed.FunExt public
open import Cubical.Foundations.Pointed.Homotopy public

open import Cubical.Foundations.Pointed.Homogeneous


module trie-thms where

open import bool
open import bool-thms
open import bool-thms2
open import char
open import eq
open import list
open import list-thms
open import maybe
open import product
open import product-thms
open import sum
open import string
open import trie

trie-lookup-empty-h : ∀ {A} x → trie-lookup-h{A} empty-trie x ≡ nothing
trie-lookup-empty-h [] = refl
trie-lookup-empty-h (_ :: _) = refl

trie-lookup-empty : ∀ {A} x → trie-lookup{A} empty-trie x ≡ nothing
trie-lookup-empty x = trie-lookup-empty-h (string-to-𝕃char x)

trie-cal-insert-nonempty : ∀{A : Set}(ts : cal (trie A))(c : char)(t : trie A) → trie-nonempty t ≡ tt →
                            trie-cal-nonempty (cal-insert ts c t) ≡ tt
trie-cal-insert-nonempty [] c t p rewrite p = refl
trie-cal-insert-nonempty ((c , t') :: ts) c' t p with c' =char c
trie-cal-insert-nonempty ((c , t') :: ts) c' t p | tt rewrite p = refl
trie-cal-insert-nonempty ((c , t') :: ts) c' t p | ff rewrite (trie-cal-insert-nonempty ts c' t p) =
  ||-tt (trie-nonempty t')

trie-insert-h-nonempty : ∀{A : Set}(t : trie A)(cs : 𝕃 char)(a : A) → trie-nonempty (trie-insert-h t cs a) ≡ tt
trie-insert-h-nonempty (Node x x₁) [] a = refl
trie-insert-h-nonempty (Node x ts) (c :: cs) a with cal-lookup ts c
trie-insert-h-nonempty (Node (just x) ts) (c :: cs) a | just t = refl
trie-insert-h-nonempty (Node nothing ts) (c :: cs) a | just t =
  trie-cal-insert-nonempty ts c (trie-insert-h t cs a) (trie-insert-h-nonempty t cs a)
trie-insert-h-nonempty (Node (just x) ts) (c :: cs) a | nothing = refl
trie-insert-h-nonempty (Node nothing ts) (c :: cs) a | nothing rewrite (trie-insert-h-nonempty empty-trie cs a) = refl

trie-insert-nonempty : ∀{A : Set}(t : trie A)(s : string)(a : A) → trie-nonempty (trie-insert t s a) ≡ tt
trie-insert-nonempty t s a = trie-insert-h-nonempty t (string-to-𝕃char s) a

trie-mappings-h-nonempty : ∀ {A : Set}(t : trie A)(prev-str : 𝕃 char) →
                             trie-nonempty t ≡ tt → is-empty (trie-mappings-h t prev-str) ≡ ff
trie-cal-mappings-h-nonempty : ∀ {A : Set}(ts : cal (trie A))(prev-str : 𝕃 char) →
                                 trie-cal-nonempty ts ≡ tt → is-empty (trie-cal-mappings-h ts prev-str) ≡ ff
trie-mappings-h-nonempty (Node (just x) x₁) prev-str _ = refl
trie-mappings-h-nonempty (Node nothing ts) prev-str p = trie-cal-mappings-h-nonempty ts prev-str p
trie-cal-mappings-h-nonempty [] prev-str ()
trie-cal-mappings-h-nonempty ((a , t) :: ts) prev-str p rewrite is-empty-++ (trie-mappings-h t (a :: prev-str)) (trie-cal-mappings-h ts prev-str) with ||-elim{trie-nonempty t} p
trie-cal-mappings-h-nonempty ((a , t) :: ts) prev-str _ | inj₁ p rewrite trie-mappings-h-nonempty t (a :: prev-str) p = refl
trie-cal-mappings-h-nonempty ((a , t) :: ts) prev-str _ | inj₂ p rewrite trie-cal-mappings-h-nonempty ts prev-str p | &&-ff (is-empty (trie-mappings-h t (a :: prev-str))) = refl

trie-mappings-nonempty : ∀ {A : Set}(t : trie A) →
                           trie-nonempty t ≡ tt → is-empty (trie-mappings t) ≡ ff
trie-mappings-nonempty t p = trie-mappings-h-nonempty t [] p


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

open import lib.Basics
open import lib.Equivalence2
open import lib.Relation2
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.TLevel

module lib.NType2 where

module _ {i} {A : Type i} where
  abstract
    has-dec-onesided-eq-is-prop : {x : A} → is-prop (has-dec-onesided-eq x)
    has-dec-onesided-eq-is-prop {x = x} = inhab-to-prop-is-prop λ dec →
      Π-level λ y → Dec-level (dec-onesided-eq-is-prop x dec y)

    has-dec-eq-is-prop : is-prop (has-dec-eq A)
    has-dec-eq-is-prop = Π-level (λ _ → has-dec-onesided-eq-is-prop)

module _ {i j} {A : Type i} {B : A → Type j} where
  abstract
    ↓-level : {a b : A} {p : a == b} {u : B a} {v : B b} {n : ℕ₋₂}
      → has-level (S n) (B b) → has-level n (u == v [ B ↓ p ])
    ↓-level {p = idp} k = has-level-apply k _ _

    ↓-preserves-level : {a b : A} {p : a == b} {u : B a} {v : B b} {n : ℕ₋₂}
      → has-level n (B b) → has-level n (u == v [ B ↓ p ])
    ↓-preserves-level {p = idp} = =-preserves-level

    prop-has-all-paths-↓ : {x y : A} {p : x == y} {u : B x} {v : B y}
      {{_ : is-prop (B y)}} → u == v [ B ↓ p ]
    prop-has-all-paths-↓ {p = idp} = prop-has-all-paths _ _

    set-↓-has-all-paths-↓ : ∀ {k} {C : Type k}
      {x y : C → A} {p : (t : C) → x t == y t} {u : (t : C) → B (x t)} {v : (t : C) → B (y t)}
      {a b : C} {q : a == b} {α : u a == v a [ B ↓ p a ]} {β : u b == v b [ B ↓ p b ]}
      {{_ : is-set (B (y a))}} → α == β [ (λ t → u t == v t [ B ↓ p t ]) ↓ q ]
    set-↓-has-all-paths-↓ {q = idp} {{p}} = lemma _ p
      where
        lemma : {x y : A} (p : x == y) {u : B x} {v : B y} {α β : u == v [ B ↓ p ]}
          → is-set (B y) → α == β
        lemma idp k = contr-center (has-level-apply (has-level-apply k _ _) _ _)

abstract
  -- Every map between contractible types is an equivalence
  contr-to-contr-is-equiv : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
    → (is-contr A → is-contr B → is-equiv f)
  contr-to-contr-is-equiv f cA cB =
    is-eq f (λ _ → contr-center cA) (λ b → ! (contr-path cB _) ∙ contr-path cB b) (contr-path cA)

  is-contr-is-prop : ∀ {i} {A : Type i} → is-prop (is-contr A)
  is-contr-is-prop {A = A} = all-paths-is-prop is-contr-is-prop-aux
          where

    lemma : (x : is-contr A) (b a : A) (p : b == a)
      → contr-path x a == contr-path x b ∙' p
    lemma x b ._ idp = idp

    is-contr-is-prop-aux : (x y : is-contr A) → x == y
    is-contr-is-prop-aux x y =
      ap has-level-in
        (pair= (contr-path x (contr-center y))
               (↓-Π-cst-app-in (λ a → ↓-idf=cst-in' (lemma x (contr-center y) a (contr-path y a)))))

  has-level-is-prop : ∀ {i} {n : ℕ₋₂} {A : Type i}
    → is-prop (has-level n A)
  has-level-is-prop {n = ⟨-2⟩} = is-contr-is-prop
  has-level-is-prop {n = S n} {A} = equiv-preserves-level e {{has-level-aux-prop}} where

    has-level-aux-prop : is-prop (has-level-aux (S n) A)
    has-level-aux-prop = Π-level (λ x → Π-level (λ y → has-level-is-prop))

    e : has-level-aux (S n) A ≃ has-level (S n) A
    fst e = has-level-in
    is-equiv.g (snd e) = has-level-apply
    is-equiv.f-g (snd e) = λ _ → idp
    is-equiv.g-f (snd e) = λ _ → idp
    is-equiv.adj (snd e) = λ _ → idp

  instance
    has-level-level : ∀ {i} {n m : ℕ₋₂} {A : Type i}
      → has-level (S m) (has-level n A)
    has-level-level {m = ⟨-2⟩} = has-level-is-prop
    has-level-level {m = S m} = raise-level _ has-level-level

{- Subtypes. -}

module _ {i j} {A : Type i} (P : SubtypeProp A j) where
  private
    module P = SubtypeProp P

  instance
    Subtype-level : ∀ {n : ℕ₋₂}
      {{_ : has-level (S n) A}}
      → has-level (S n) (Subtype P)
    Subtype-level = Σ-level ⟨⟩ (λ x → prop-has-level-S (P.level x))

  Subtype= : (x y : Subtype P) → Type i
  Subtype= x y = fst x == fst y

  Subtype=-out : ∀ {x y : Subtype P} → Subtype= x y → x == y
  Subtype=-out p = pair= p (prop-has-all-paths-↓ {{P.level _}})

  Subtype=-β : {x y : Subtype P} (p : Subtype= x y)
    → fst= (Subtype=-out {x = x} {y = y} p) == p
  Subtype=-β idp = fst=-β idp _

  Subtype=-η : {x y : Subtype P} (p : x == y)
    → Subtype=-out (fst= p) == p
  Subtype=-η idp = ap (pair= idp)
    (contr-has-all-paths {{has-level-apply (P.level _) _ _}} _ _)

  Subtype=-econv : (x y : Subtype P) → (Subtype= x y) ≃ (x == y)
  Subtype=-econv x y = equiv Subtype=-out fst= Subtype=-η Subtype=-β

  abstract
    Subtype-∙ : ∀ {x y z : Subtype P}
      (p : Subtype= x y) (q : Subtype= y z)
      → (Subtype=-out {x} {y} p ∙ Subtype=-out {y} {z} q)
      == Subtype=-out {x} {z} (p ∙ q)
    Subtype-∙ {x} {y} {z} p q =
      Subtype=-out p ∙ Subtype=-out q
        =⟨ Σ-∙ {p = p} {p' = q} (prop-has-all-paths-↓ {{P.level (fst y)}}) (prop-has-all-paths-↓ {{P.level (fst z)}}) ⟩
      pair= (p ∙ q) (prop-has-all-paths-↓ {p = p} {{P.level (fst y)}} ∙ᵈ prop-has-all-paths-↓ {{P.level (fst z)}})
        =⟨ contr-has-all-paths {{↓-level (P.level (fst z))}} _ (prop-has-all-paths-↓ {{P.level (fst z)}})
          |in-ctx pair= (p ∙ q) ⟩
      Subtype=-out (p ∙ q)
        =∎

-- Groupoids

is-gpd : {i : ULevel} → Type i → Type i
is-gpd = has-level 1

-- Type of all n-truncated types

-- TODO: redefine it like that, so that instance arguments can work

-- record _-Type_ (n : ℕ₋₂) (i : ULevel) : Type (lsucc i) where
--   constructor _,_
--   field
--     El : Type i
--     {{El-level}} : has-level n El
-- open _-Type_ public

has-level-prop : ∀ {i} → ℕ₋₂ → SubtypeProp (Type i) i
has-level-prop n = has-level n , λ _ → has-level-is-prop

_-Type_ : (n : ℕ₋₂) (i : ULevel) → Type (lsucc i)
n -Type i = Subtype (has-level-prop {i} n)

hProp : (i : ULevel) → Type (lsucc i)
hProp i = -1 -Type i

hSet : (i : ULevel) → Type (lsucc i)
hSet i = 0 -Type i

_-Type₀ : (n : ℕ₋₂) → Type₁
n -Type₀ = n -Type lzero

hProp₀ = hProp lzero
hSet₀ = hSet lzero

-- [n -Type] is an (n+1)-type

abstract
  ≃-contr : ∀ {i j} {A : Type i} {B : Type j}
      → is-contr A → is-contr B → is-contr (A ≃ B)
  ≃-contr pA pB = has-level-in
      ((cst (contr-center pB) , contr-to-contr-is-equiv _ pA pB)
      , (λ e → pair= (λ= (λ _ → contr-path pB _))
                     (from-transp is-equiv _ (prop-path is-equiv-is-prop _ _))))

instance
  ≃-level : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j}
    → (has-level n A → has-level n B → has-level n (A ≃ B))
  ≃-level {n = ⟨-2⟩} = ≃-contr
  ≃-level {n = S n} pA pB = Σ-level ⟨⟩ ⟨⟩ where instance _ = pA; _ = pB

  universe-=-level : ∀ {i} {n : ℕ₋₂} {A B : Type i}
    → (has-level n A → has-level n B → has-level n (A == B))
  universe-=-level pA pB = equiv-preserves-level ua-equiv where instance _ = pA; _ = pB

module _ {i} {n} where
  private
    prop : SubtypeProp {lsucc i} (Type i) i
    prop = has-level-prop n

  nType= : (A B : n -Type i) → Type (lsucc i)
  nType= = Subtype= prop

  nType=-out : {A B : n -Type i} → nType= A B → A == B
  nType=-out = Subtype=-out prop

  abstract
    nType=-β : {A B : n -Type i} (p : nType= A B)
      → fst= (nType=-out {A = A} {B = B} p) == p
    nType=-β = Subtype=-β prop

    nType=-η : {A B : n -Type i} (p : A == B)
      → nType=-out (fst= p) == p
    nType=-η = Subtype=-η prop

    nType=-econv : (A B : n -Type i) → (nType= A B) ≃ (A == B)
    nType=-econv = Subtype=-econv prop

    nType-∙ : {A B C : n -Type i}
      (p : nType= A B) (q : nType= B C)
      → (nType=-out {A = A} p ∙ nType=-out {A = B} q)
      == nType=-out {A = A} {B = C} (p ∙ q)
    nType-∙ = Subtype-∙ prop

abstract
 instance
  _-Type-level_ : (n : ℕ₋₂) (i : ULevel)
    → has-level (S n) (n -Type i)
  (n -Type-level i) = has-level-in (λ { (A , pA) (B , pB) → aux A B pA pB}) where

    aux : (A B : Type i) (pA : has-level n A) (pB : has-level n B) → has-level n ((A , pA) == (B , pB))
    aux A B pA pB = equiv-preserves-level (nType=-econv (A , ⟨⟩) (B , ⟨⟩)) where instance _ = pA; _ = pB

hProp-is-set : (i : ULevel) → is-set (hProp i)
hProp-is-set i = -1 -Type-level i

hSet-level : (i : ULevel) → has-level 1 (hSet i)
hSet-level i = 0 -Type-level i

{- The following two lemmas are in NType2 instead of NType because of cyclic
   dependencies -}

module _ {i} {A : Type i} where
  abstract
    raise-level-<T : {m n : ℕ₋₂} → (m <T n) → has-level m A → has-level n A
    raise-level-<T ltS = raise-level _
    raise-level-<T (ltSR lt) = raise-level _ ∘ raise-level-<T lt

    raise-level-≤T : {m n : ℕ₋₂} → (m ≤T n) → has-level m A → has-level n A
    raise-level-≤T (inl p) = transport (λ t → has-level t A) p
    raise-level-≤T (inr lt) = raise-level-<T lt