crypto-agda.agda type-checks for me

crypto-agda.agda type-checks for me

module crypto-agda where
import Cipher.ElGamal.Generic
import Composition.Forkable
import Composition.Horizontal
import Composition.Vertical
import Crypto.Schemes
--import FiniteField.FinImplem
import FunUniverse.Agda
import FunUniverse.BinTree
import FunUniverse.Bits
import FunUniverse.Category
import FunUniverse.Category.Op
import FunUniverse.Circuit
import FunUniverse.Const
import FunUniverse.Core
import FunUniverse.Cost
import FunUniverse.Data
import FunUniverse.Defaults.FirstPart
--import FunUniverse.ExnArrow
import FunUniverse.Fin
import FunUniverse.Fin.Op
import FunUniverse.Fin.Op.Abstract
--import FunUniverse.FlatFunsProd
--import FunUniverse.Interface.Bits
import FunUniverse.Interface.Two
import FunUniverse.Interface.Vec
import FunUniverse.Inverse
--import FunUniverse.Loop
import FunUniverse.Nand
import FunUniverse.Nand.Function
import FunUniverse.Nand.Properties
import FunUniverse.README
import FunUniverse.Rewiring.Linear
--import FunUniverse.State
import FunUniverse.Syntax
import FunUniverse.Types
import Game.DDH
import Game.EntropySmoothing
import Game.EntropySmoothing.WithKey
import Game.IND-CPA
import Game.Transformation.InternalExternal
import Language.Simple.Abstract
import Language.Simple.Interface
import Language.Simple.Two.Mux
import Language.Simple.Two.Mux.Normalise
import Language.Simple.Two.Nand
import README
import Solver.AddMax
import Solver.Linear
--import Solver.Linear.Examples
import Solver.Linear.Parser
import Solver.Linear.Syntax
import adder
import alea.cpo
import bijection-syntax.Bijection-Fin
import bijection-syntax.Bijection
import bijection-syntax.README
--import circuits.bytecode
import circuits.circuit
--import elgamal
--import sha1

module crypto-agda where
import Cipher.ElGamal.Generic
import Composition.Forkable
import Composition.Horizontal
import Composition.Vertical
import Crypto.Schemes
import FiniteField.FinImplem
import FunUniverse.Agda
import FunUniverse.BinTree
import FunUniverse.Bits
import FunUniverse.Category
import FunUniverse.Category.Op
import FunUniverse.Circuit
import FunUniverse.Const
import FunUniverse.Core
import FunUniverse.Cost
import FunUniverse.Data
import FunUniverse.Defaults.FirstPart
import FunUniverse.ExnArrow
import FunUniverse.Fin
import FunUniverse.Fin.Op
import FunUniverse.Fin.Op.Abstract
import FunUniverse.FlatFunsProd
import FunUniverse.Interface.Bits
import FunUniverse.Interface.Two
import FunUniverse.Interface.Vec
import FunUniverse.Inverse
import FunUniverse.Loop
import FunUniverse.Nand
import FunUniverse.Nand.Function
import FunUniverse.Nand.Properties
import FunUniverse.README
import FunUniverse.Rewiring.Linear
import FunUniverse.State
import FunUniverse.Syntax
import FunUniverse.Types
import Game.DDH
import Game.EntropySmoothing
import Game.EntropySmoothing.WithKey
import Game.IND-CPA
import Game.Transformation.InternalExternal
import Language.Simple.Abstract
import Language.Simple.Interface
import Language.Simple.Two.Mux
import Language.Simple.Two.Mux.Normalise
import Language.Simple.Two.Nand
import README
import Solver.AddMax
import Solver.Linear
import Solver.Linear.Examples
import Solver.Linear.Parser
import Solver.Linear.Syntax
import adder
import alea.cpo
import bijection-syntax.Bijection-Fin
import bijection-syntax.Bijection
import bijection-syntax.README
import circuits.bytecode
import circuits.circuit
import elgamal
import sha1


Added missing comment.

Added missing comment.

Ignore-this: e94b7bc15f3a36f09bea4cb19c108816

darcs-hash:20120514153713-3bd4e-094c6eef9fb0ab388d0e5e524246803c7052297f.gz

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

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

-- Tested with the development version of Agda on 14 May 2012.

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

module FOTC where

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

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

module Setoid where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- The identity type.
  data _≡_ (x : D) : D → Set where
    refl : x ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012. We cannot define the identity elimination using the
  -- setoid equality.
  --
  -- Adapted from Peter's email:

  -- Given
  postulate subst : (A : D → Set) → ∀ x y → x ≐ y → A x → A y

  -- you can get the instance

  subst-aux : ∀ x y → x ≐ y → x ≡ x → x ≡ y
  subst-aux x y h₁ h₂ = subst A x y h₁ refl
    where A : D → Set
          A z = x ≡ z

  -- hence you can prove

  thm : ∀ {x y} → x ≐ y → x ≡ y
  thm {x} {y} h = subst-aux x y h refl

  -- but this doesn't hold because "x ≡ y" (propositional equality)
  -- means identical expressions. We do NOT have K · x · y ≡ x.
  --
  -- The point is that ≐ is a non-trivial equivalence relation, and
  -- not all properties preserve it. However, all properties are
  -- preserved by ≡.

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

module LeibnizEquality where

  infix 7 _≡_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality (adapted from
  -- Agda/examples/lib/Logic/Leibniz.agda)

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

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

-- Tested with the development version of Agda on 14 May 2012.

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

module FOTC where

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

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

module Setoid where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- The identity type.
  data _≡_ (x : D) : D → Set where
    refl : x ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012. We cannot define the identity elimination using the
  -- setoid equality.
  --
  -- Adapted from Peter's email:

  -- Given
  postulate subst : (A : D → Set) → ∀ x y → x ≐ y → A x → A y

  -- you can get the instance

  subst-aux : ∀ x y → x ≐ y → x ≡ x → x ≡ y
  subst-aux x y h₁ h₂ = subst A x y h₁ refl
    where A : D → Set
          A z = x ≡ z

  -- hence you can prove

  thm : ∀ {x y} → x ≐ y → x ≡ y
  thm {x} {y} h = subst-aux x y h refl

  -- but this doesn't hold because "x ≡ y" (propositional equality)
  -- means identical expressions. We do NOT have K · x · y ≡ x.

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

module LeibnizEquality where

  infix 7 _≡_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality (adapted from
  -- Agda/examples/lib/Logic/Leibniz.agda)

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)


agda: document a function

agda: document a function

Old-commit-hash: c0550a6f2e84b20bc63a5c0f91a168988125b117

module ChangeContexts where

open import IlcModel
open import Changes
open import meaning
-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

update : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
update {∅} ∅ = ∅
update {τ • Γ} (dv • v • ρ) = apply dv v • update ρ

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore {∅} ∅ = ∅
ignore {τ • Γ} (dv • v • ρ) = v • ignore ρ

-- Δ-Context′: behaves like Δ-Context, but has an extra argument Γ′, a
-- prefix of its first argument which should not be touched.
Δ-Context′ : (Γ : Context) → Prefix Γ → Context
Δ-Context′ Γ ∅ = Δ-Context Γ
Δ-Context′ (.τ • Γ) (τ • Γ′) = τ • Δ-Context′ Γ Γ′

update′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
update′ ∅ ρ = update ρ
update′ (τ • Γ′) (v • ρ) = v • update′ Γ′ ρ

ignore′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
ignore′ ∅ ρ = ignore ρ
ignore′ (τ • Γ′) (v • ρ) = v • ignore′ Γ′ ρ

module ChangeContexts where

open import IlcModel
open import Changes
open import meaning
-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

update : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
update {∅} ∅ = ∅
update {τ • Γ} (dv • v • ρ) = apply dv v • update ρ

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore {∅} ∅ = ∅
ignore {τ • Γ} (dv • v • ρ) = v • ignore ρ

Δ-Context′ : (Γ : Context) → Prefix Γ → Context
Δ-Context′ Γ ∅ = Δ-Context Γ
Δ-Context′ (.τ • Γ) (τ • Γ′) = τ • Δ-Context′ Γ Γ′

update′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
update′ ∅ ρ = update ρ
update′ (τ • Γ′) (v • ρ) = v • update′ Γ′ ρ

ignore′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
ignore′ ∅ ρ = ignore ρ
ignore′ (τ • Γ′) (v • ρ) = v • ignore′ Γ′ ρ


Restore Parametric.Change.Validity

Restore Parametric.Change.Validity

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  instance
    change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
    change-algebra (base ι) = change-algebra₍_₎ {{change-algebra-base}} ι
    change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

  change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
  change-algebra-family = family change-algebra

  -- function changes

  open FunctionChanges public using (cons)
  module _ {τ₁ τ₂ : Type} where
    open FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍_₎ {{environment-changes}} Γ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  instance
    change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
    change-algebra (base ι) = change-algebra₍_₎ {{change-algebra-base}} ι
    change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

  change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
  change-algebra-family = family change-algebra

  -- function changes

  open FunctionChanges public using (cons)
  module _ {τ₁ τ₂ : Type} where
    open FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  {-
  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍  Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍ Γ ₎
  -}


HoTT: +unique-idp-left

HoTT: +unique-idp-left

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

open import Type
open import Level.NP
open import Function.NP
open import Function.Extensionality
open import Data.Zero using (𝟘; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Product.NP
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])
open import Relation.Nullary.NP
open import Relation.Binary using (Reflexive; Symmetric; Transitive)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; ap; coe; coe!; !_; _∙_; J; ap↓; PathOver; tr; ap₂)
       renaming (refl to idp; _≗_ to _∼_; J-orig to J')
open ≡.≡-Reasoning

import Function.Inverse.NP as Inv
open Inv using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)

module _ {a} {A : ★_ a} where
  idp_ : (x : A) → x ≡ x
  idp_ _ = idp

  refl-∙ : ∀ {x y : A} (p : x ≡ y) → idp_ x ∙ p ≡ p
  refl-∙ _ = idp

  ∙-refl : ∀ {x y : A} (p : x ≡ y) → p ∙ idp_ y ≡ p
  ∙-refl = J' (λ (x y : A) (p : x ≡ y) → (p ∙ idp_ y) ≡ p) (λ x → idp)

  -- could be derived in any groupoid
  hom-!-∙ : ∀ {x y z : A} (p : x ≡ y)(q : y ≡ z) → !(p ∙ q) ≡ ! q ∙ ! p
  hom-!-∙ p q = J' (λ x y p → ∀ z → (q : y ≡ z) → !(p ∙ q) ≡ ! q ∙ ! p) (λ x z q → ! ∙-refl (! q)) p _ q

  module _ {x y : A} where

    ∙-assoc : (p : x ≡ y) {z : A} (q : y ≡ z) {t : A} (r : z ≡ t) → p ∙ q ∙ r ≡ (p ∙ q) ∙ r
    ∙-assoc = J' (λ x y p → ∀ {z} (q : y ≡ z) {t} (r : z ≡ t) → p ∙ (q ∙ r) ≡ (p ∙ q) ∙ r)
                 (λ x q r → idp)

    module _ (p : x ≡ y) where
      -- ! is a left-inverse for _∙_
      !-∙ : ! p ∙ p ≡ idp_ y
      !-∙ = J' (λ x y p → (! p ∙ p) ≡ idp_ y) (λ x → idp) p

      -- ! is a right-inverse for _∙_
      ∙-! : p ∙ ! p ≡ idp_ x
      ∙-! = J' (λ x y p → (p ∙ ! p) ≡ idp_ x) (λ x → idp) p

      -- ! is involutive
      !-involutive : ! (! p) ≡ p
      !-involutive = J' (λ x y p → ! (! p) ≡ p) (λ x → idp) p

      !p∙p = !-∙
      p∙!p = ∙-!

      ==-refl-∙ : {q : x ≡ x} → q ≡ idp_ x → q ∙ p ≡ p
      ==-refl-∙ = ap (flip _∙_ p)

      ∙-==-refl : {q : y ≡ y} → q ≡ idp_ y → p ∙ q ≡ p
      ∙-==-refl qr = ap (_∙_ p) qr ∙ ∙-refl p

  module _ {x y : A} where
    module _ (p : x ≡ x)(q : x ≡ y)(e : p ∙ q ≡ q) where
      unique-idp-left : p ≡ idp
      unique-idp-left
        = p              ≡⟨ ! ∙-refl p ⟩
          p ∙ idp        ≡⟨ ap (_∙_ p) (! ∙-! q) ⟩
          p ∙ (q ∙ ! q)  ≡⟨ ∙-assoc p q (! q) ⟩
          (p ∙ q) ∙ ! q  ≡⟨ ap (flip _∙_ (! q)) e ⟩
          q ∙ ! q        ≡⟨ ∙-! q ⟩
          idp            ∎

  module _ {x y z : A}{p₀ p₁ : x ≡ y}{q₀ q₁ : y ≡ z}(p : p₀ ≡ p₁)(q : q₀ ≡ q₁) where
      ∙= : p₀ ∙ q₀ ≡ p₁ ∙ q₁
      ∙= = ap (flip _∙_ q₀) p ∙ ap (_∙_ p₁) q

  module _ {x y z : A} where
    module _ (p : x ≡ y)(q : y ≡ z) where
      ∙-∙-==-refl : {r : z ≡ z} → r ≡ idp_ z → p ∙ q ∙ r ≡ p ∙ q
      ∙-∙-==-refl rr = ∙-assoc p q _ ∙ ∙-==-refl (p ∙ q) rr

      !p∙p∙q : ! p ∙ p ∙ q ≡ q
      !p∙p∙q = ∙-assoc (! p) p q ∙ ==-refl-∙ q (!-∙ p)

    p∙!p∙q : (p : y ≡ x) (q : y ≡ z) → p ∙ ! p ∙ q ≡ q
    p∙!p∙q p q = ∙-assoc p _ q ∙ ==-refl-∙ q (∙-! p)

    p∙!q∙q : (p : x ≡ y) (q : z ≡ y) → p ∙ ! q ∙ q ≡ p
    p∙!q∙q p q = ∙-==-refl p (!-∙ q)

    p∙q∙!q : (p : x ≡ y) (q : y ≡ z) → p ∙ q ∙ ! q ≡ p
    p∙q∙!q p q = ∙-==-refl p (∙-! q)

    ∙-cancel : {p q : x ≡ y}(r : y ≡ z) → p ∙ r ≡ q ∙ r → p ≡ q
    ∙-cancel {p = p} {q} r e
      = p               ≡⟨ ! p∙q∙!q p r ⟩
         p ∙ r  ∙ ! r   ≡⟨ ∙-assoc p r (! r) ⟩
        (p ∙ r) ∙ ! r   ≡⟨ ∙= e idp ⟩
        (q ∙ r) ∙ ! r   ≡⟨ ! ∙-assoc q r (! r) ⟩
        q ∙ (r  ∙ ! r)  ≡⟨ p∙q∙!q q r ⟩
        q               ∎

!-ap : ∀ {a b}{A : Set a}{B : Set b}(f : A → B){x y}(p : x ≡ y)
       → ! (ap f p) ≡ ap f (! p)
!-ap f idp = idp

ap-id : ∀ {a}{A : Set a}{x y : A}(p : x ≡ y) → ap id p ≡ p
ap-id idp = idp

module _ {a b}{A : Set a}{B : Set b}{f g : A → B}(H : ∀ x → f x ≡ g x) where
  ap-nat : ∀ {x y}(q : x ≡ y) → ap f q ∙ H _ ≡ H _ ∙ ap g q
  ap-nat idp = ! ∙-refl _

module _ {a}{A : Set a}{f : A → A}(H : ∀ x → f x ≡ x) where
  ap-nat-id : ∀ x → ap f (H x) ≡ H (f x)
  ap-nat-id x = ∙-cancel (H x) (ap-nat H (H x) ∙ ap (_∙_ (H (f x))) (ap-id (H x)))

tr-∘ : ∀ {a b p}{A : Set a}{B : Set b}(P : B → Set p)(f : A → B){x y}(p : x ≡ y)
  → tr (P ∘ f) p ≡ tr P (ap f p)
tr-∘ P f idp = idp

module _ {a}{A : ★_ a} where
    tr-∙′ : ∀ {ℓ}(P : A → ★_ ℓ) {x y z} (p : x ≡ y) (q : y ≡ z) →
             tr P (p ∙ q) ∼ tr P q ∘ tr P p
    tr-∙′ P idp _ _ = idp

    tr-∙ : ∀ {ℓ}(P : A → ★_ ℓ) {x y z} (p : x ≡ y) (q : y ≡ z) (pq : x ≡ z) →
             pq ≡ p ∙ q →
             tr P pq ∼ tr P q ∘ tr P p
    tr-∙ P p q ._ idp = tr-∙′ P p q

module _ {k} {K : ★_ k} {a} {A : ★_ a} {x y : A} (p : x ≡ y) where
    tr-const : tr (const K) p ≡ id
    tr-const = J (λ _ p₁ → tr (const K) p₁ ≡ id) idp p

-- Contractible
module _ {a}(A : ★_ a) where
    Is-contr : ★_ a
    Is-contr = Σ A λ x → ∀ y → x ≡ y

module _ {a}{b}{A : ★_ a}{B : A → ★_ b} where
    pair= : ∀ {x y : Σ A B} → (p : fst x ≡ fst y) → tr B p (snd x) ≡ snd y → x ≡ y
    pair= idp = ap (_,_ _)

    snd= : ∀ {x : A} {y y' : B x} → y ≡ y' → _≡_ {A = Σ A B} (x , y) (x , y')
    snd= = pair= idp

    tr-snd= : ∀ {p}(P : Σ A B → ★_ p){x}{y₀ y₁ : B x}(y= : y₀ ≡ y₁)
            → tr P (snd= {x = x} y=) ∼ tr (P ∘ _,_ x) y=
    tr-snd= P idp p = idp

module _ {a}{A : ★_ a} where
  tr-r≡ : {x y z : A}(p : y ≡ z)(q : x ≡ y) → tr (λ v → x ≡ v) p q ≡ q ∙ p
  tr-r≡ idp q = ! ∙-refl q

  tr-l≡ : {x y z : A}(p : x ≡ y)(q : x ≡ z) → tr (λ v → v ≡ z) p q ≡ ! p ∙ q
  tr-l≡ idp q = idp

module _ {A : ★}(f g : A → ★){x y : A}(p : x ≡ y)(h : f x → g x) where
    tr-→ : tr (λ x → f x → g x) p h ≡ (λ x → tr g p (h (tr f (! p) x)))
    tr-→ = J' (λ x y p → (h : f x → g x) → tr (λ x → f x → g x) p h ≡ (λ x → tr g p (h (tr f (! p) x))))
             (λ _ _ → idp) p h

module _ {a}{b}{A : ★_ a}{B : ★_ b} where
    pair×= : ∀ {x x' : A}(p : x ≡ x')
               {y y' : B}(q : y ≡ y')
             → (x , y) ≡ (x' , y')
    pair×= idp q = snd= q

module _ {a b c}{A : ★_ a}{B : A → ★_ b}{x₀ : A}{y₀ : B x₀}{C : ★_ c}
         (f : (x : A) (y : B x) → C) where
    ap₂↓ : {x₁ : A}(x= : x₀ ≡ x₁)
           {y₁ : B x₁}(y= : y₀ ≡ y₁ [ B ↓ x= ])
         → f x₀ y₀ ≡ f x₁ y₁
    ap₂↓ idp = ap (f x₀)
    {- Or with J
    ap₂↓ x= = J (λ x₁' x=' → {y₁ : B x₁'}(y= : y₀ ≡ y₁ [ _ ↓ x=' ])
                          → f x₀ y₀ ≡ f x₁' y₁)
                (λ y= → ap (f x₀) y=) x=
    -- -}

    apd₂ : {x₁ : A}(x= : x₀ ≡ x₁)
           {y₁ : B x₁}(y= : tr B x= y₀ ≡ y₁)
         → f x₀ y₀ ≡ f x₁ y₁
    -- apd₂ idp = ap (f x₀)
    -- {- Or with J
    apd₂ x= = J (λ x₁' x=' → {y₁ : B x₁'}(y= : tr B x=' y₀ ≡ y₁) → f x₀ y₀ ≡ f x₁' y₁)
                (λ y= → ap (f x₀) y=) x=
    -- -}

module _ {a b c d}{A : ★_ a}{B : A → ★_ b}{C : ★_ c}{x₀ : A}{y₀ : B x₀ → C}{D : ★_ d}
         {{_ : FunExt}}
         (f : (x : A) (y : B x → C) → D) where
    apd₂⁻ : {x₁ : A}(x= : x₀ ≡ x₁)
            {y₁ : B x₁ → C}(y= : ∀ x → y₀ x ≡ y₁ (tr B x= x))
          → f x₀ y₀ ≡ f x₁ y₁
    apd₂⁻ idp y= = ap (f x₀) (λ= y=)

module Equivalences where

  module _ {a b}{A : ★_ a}{B : ★_ b} where
    _LeftInverseOf_ : (B → A) → (A → B) → ★_ a
    linv LeftInverseOf f = ∀ x → linv (f x) ≡ x

    _RightInverseOf_ : (B → A) → (A → B) → ★_ b
    rinv RightInverseOf f = ∀ x → f (rinv x) ≡ x

    record Linv (f : A → B) : ★_(a ⊔ b) where
      field
        linv    : B → A
        is-linv : ∀ x → linv (f x) ≡ x

      injective : ∀ {x y} → f x ≡ f y → x ≡ y
      injective p = ! is-linv _ ∙ ap linv p ∙ is-linv _

    record Rinv (f : A → B) : ★_(a ⊔ b) where
      field
        rinv    : B → A
        is-rinv : ∀ x → f (rinv x) ≡ x

      surjective : ∀ y → ∃ λ x → f x ≡ y
      surjective y = rinv y , is-rinv y

    record Biinv (f : A → B) : ★_(a ⊔ b) where
      field
        has-linv : Linv f
        has-rinv : Rinv f

      open Linv has-linv public
      open Rinv has-rinv public

    module _ {f : A → B}
             (g : B → A)(g-f : (x : A) → g (f x) ≡ x)
             (h : B → A)(f-h : (y : B) → f (h y) ≡ y) where
      biinv : Biinv f
      biinv = record { has-linv = record { linv = g ; is-linv = g-f }
                     ; has-rinv = record { rinv = h ; is-rinv = f-h } }

    record Qinv (f : A → B) : ★_(a ⊔ b) where
      field
        inv : B → A
        inv-is-linv : ∀ x → inv (f x) ≡ x
        inv-is-rinv : ∀ x → f (inv x) ≡ x

      has-biinv : Biinv f
      has-biinv = record { has-linv = record { linv = inv
                                             ; is-linv = inv-is-linv }
                         ; has-rinv = record { rinv = inv
                                             ; is-rinv = inv-is-rinv } }

      open Biinv has-biinv public

    HAE : {f : A → B} → Qinv f → ★_(a ⊔ b)
    HAE {f} f-qinv = ∀ x → ap f (F.inv-is-linv x) ≡ F.inv-is-rinv (f x)
      where module F = Qinv f-qinv

    record Is-equiv (f : A → B) : ★_(a ⊔ b) where
      field
        has-qinv : Qinv f
        is-hae   : HAE has-qinv
      open Qinv has-qinv public

    module _ {f : A → B}(g : B → A)
             (f-g : (y : B) → f (g y) ≡ y)
             (g-f : (x : A) → g (f x) ≡ x) where
      qinv : Qinv f
      qinv = record
            { inv = g
            ; inv-is-linv = g-f
            ; inv-is-rinv = f-g }

    module _ {f : A → B}(g : B → A)
             (f-g : (y : B) → f (g y) ≡ y)
             (g-f : (x : A) → g (f x) ≡ x) where
      f-g' : (x : B) → f (g x) ≡ x
      f-g' x = ! ap (f ∘ g) (f-g x) ∙ ap f (g-f (g x)) ∙ f-g x
      -- g-f' x = ap g {!f-g ?!} ∙ {!!}

      postulate hae : HAE (qinv g f-g' g-f)

      is-equiv : Is-equiv f
      is-equiv = record
        { has-qinv = qinv g f-g' g-f
        ; is-hae   = hae }

  module Biinv-inv {a b}{A : ★_ a}{B : ★_ b}{f : A → B}
                   (fᴮ : Biinv f) where
      open Biinv fᴮ
      inv : B → A
      inv = linv ∘ f ∘ rinv

      inv-biinv : Biinv inv
      inv-biinv =
        biinv f (λ x → ap f (is-linv (rinv x)) ∙ is-rinv x)
              f (λ x → ap linv (is-rinv (f x)) ∙ is-linv x)

  module _ {a b}{A : ★_ a}{B : ★_ b}{f : A → B}
           (fᴱ : Is-equiv f) where
      open Is-equiv fᴱ

      inv-is-equiv : Is-equiv inv
      inv-is-equiv = is-equiv f is-linv is-rinv

  module _ {a b} where
    infix 4 _≃_
    _≃_ : ★_ a → ★_ b → ★_(a ⊔ b)
    A ≃ B = Σ (A → B) Is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b}
           (f : A → B)(g : B → A)
           (f-g : (y : B) → f (g y) ≡ y)
           (g-f : (x : A) → g (f x) ≡ x) where
    equiv : A ≃ B
    equiv = f , is-equiv g f-g g-f

  module _ {a}{A : ★_ a}
           (f : A → A)(f-inv : f LeftInverseOf f) where
      self-inv-is-equiv : Is-equiv f
      self-inv-is-equiv = is-equiv f f-inv f-inv

      self-inv-equiv : A ≃ A
      self-inv-equiv = f , self-inv-is-equiv

      self-inv-biinv : Biinv f
      self-inv-biinv = biinv f f-inv f f-inv

  module _ {a}{A : ★_ a} where
    idᴱ : Is-equiv {A = A} id
    idᴱ = self-inv-is-equiv _ λ _ → idp

    idᴮ : Biinv {A = A} id
    idᴮ = self-inv-biinv _ λ _ → idp

  module _ {a b c}{A : ★_ a}{B : ★_ b}{C : ★_ c}{g : B → C}{f : A → B} where
    _∘ᴱ_ : Is-equiv g → Is-equiv f → Is-equiv (g ∘ f)
    gᴱ ∘ᴱ fᴱ = is-equiv (F.inv ∘ G.inv)
                        (λ x → ap g (F.inv-is-rinv _) ∙ G.inv-is-rinv _)
                        (λ x → ap F.inv (G.inv-is-linv _) ∙ F.inv-is-linv _)
      where
        module G = Is-equiv gᴱ
        module F = Is-equiv fᴱ

    _∘ᴮ_ : Biinv g → Biinv f → Biinv (g ∘ f)
    gᴮ ∘ᴮ fᴮ =
      biinv (F.linv ∘ G.linv)
            (λ x → ap F.linv (G.is-linv (f x)) ∙ F.is-linv x)
            (F.rinv ∘ G.rinv)
            (λ x → ap g (F.is-rinv _) ∙ G.is-rinv x)
      where
        module G = Biinv gᴮ
        module F = Biinv fᴮ

  module Equiv {a b}{A : ★_ a}{B : ★_ b}(e : A ≃ B) where
    ·→ : A → B
    ·→ = fst e

    open Is-equiv (snd e) public
      renaming (linv to ·←; rinv to ·←′; is-linv to ·←-inv-l; is-rinv to ·←-inv-r)

    -- Equivalences are "injective"
    equiv-inj : {x y : A} → (·→ x ≡ ·→ y → x ≡ y)
    equiv-inj p = ! ·←-inv-l _ ∙ ap ·← p ∙ ·←-inv-l _

    –> = ·→
    <– = ·←
    <–' = ·←′

    <–-inv-l = ·←-inv-l
    <–-inv-r = ·←-inv-r

  open Equiv public

  module _ {ℓ} where
    ≃-refl : Reflexive (_≃_ {ℓ})
    ≃-refl = _ , idᴱ

    ≃-sym : Symmetric (_≃_ {ℓ})
    ≃-sym (_ , fᴱ) = _ , inv-is-equiv fᴱ

    ≃-trans : Transitive (_≃_ {ℓ})
    ≃-trans (_ , p) (_ , q) = _ , q ∘ᴱ p

    ≃-! = ≃-sym
    _≃-∙_ = ≃-trans

  module _ {a}(A : ★_ a) where
    Paths : ★_ a
    Paths = Σ A λ x → Σ A λ y → x ≡ y

  module _ {a}{A : ★_ a} where
    id-path : A → Paths A
    id-path x = x , x , idp

    fst-rinv-id-path : ∀ p → id-path (fst p) ≡ p
    fst-rinv-id-path (x , y , p) = snd= (pair= p (J (λ y p → tr (_≡_ x) p idp ≡ p) idp p))

    id-path-is-equiv : Is-equiv id-path
    id-path-is-equiv = is-equiv fst fst-rinv-id-path (λ x → idp)

    ≃-Paths : A ≃ Paths A
    ≃-Paths = id-path , id-path-is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b}(f : A → B) where
    hfiber : (y : B) → ★_(a ⊔ b)
    hfiber y = Σ A λ x → f x ≡ y

    Is-equiv-alt : ★_(a ⊔ b)
    Is-equiv-alt = (y : B) → Is-contr (hfiber y)

  module Is-contr-to-Is-equiv {a}{A : ★_ a}(A-contr : Is-contr A) where
    const-is-equiv : Is-equiv (λ (_ : 𝟙) → fst A-contr)
    const-is-equiv = is-equiv _ (snd A-contr) (λ _ → idp)
    𝟙≃ : 𝟙 ≃ A
    𝟙≃ = _ , const-is-equiv
  module Is-equiv-to-Is-contr {a}{A : ★_ a}(f : 𝟙 → A)(f-is-equiv : Is-equiv f) where
    open Is-equiv f-is-equiv
    A-contr : Is-contr A
    A-contr = f _ , is-rinv

  module _ {a}{A : ★_ a}{b}{B : ★_ b} where
    iso-to-equiv : (A ↔ B) → (A ≃ B)
    iso-to-equiv iso = to iso , is-equiv (from iso) (Inverse.right-inverse-of iso) (Inverse.left-inverse-of iso)

    equiv-to-iso : (A ≃ B) → (A ↔ B)
    equiv-to-iso (f , f-is-equiv) = inverses f (fᴱ.linv ∘ f ∘ fᴱ.rinv)
                                             (λ x → ap fᴱ.linv (fᴱ.is-rinv (f x)) ∙ fᴱ.is-linv x)
                                             (λ x → ap f (fᴱ.is-linv (fᴱ.rinv x)) ∙ fᴱ.is-rinv x)
      where module fᴱ = Is-equiv f-is-equiv

    {-
    iso-to-equiv-to-iso : (iso : A ↔ B) → equiv-to-iso (iso-to-equiv iso) ≡ iso
    iso-to-equiv-to-iso iso = {!!}
      where module Iso = Inverse iso

    iso-to-equiv-is-equiv : Is-equiv iso-to-equiv
    iso-to-equiv-is-equiv = record { linv = equiv-to-iso ; is-linv = {!!} ; rinv = {!!} ; is-rinv = {!!} }
    -}
open Equivalences

data T-level : ★₀ where
  ⟨-2⟩ : T-level
  ⟨S_⟩ : (n : T-level) → T-level

⟨-1⟩ ⟨0⟩ : T-level
⟨-1⟩ = ⟨S ⟨-2⟩ ⟩
⟨0⟩  = ⟨S ⟨-1⟩ ⟩
⟨1⟩  = ⟨S ⟨0⟩  ⟩
⟨2⟩  = ⟨S ⟨1⟩  ⟩

ℕ₋₂ = T-level

module _ {a} where
    private
      U = ★_ a

    has-level : T-level → U → U
    has-level ⟨-2⟩   A = Is-contr A
    has-level ⟨S n ⟩ A = (x y : A) → has-level n (x ≡ y)

    is-prop : U → U
    is-prop A = has-level ⟨-1⟩ A

    is-set : U → U
    is-set A = has-level ⟨0⟩ A

    has-all-paths : U → U
    has-all-paths A = (x y : A) → x ≡ y

    UIP : U → U
    UIP A = {x y : A} (p q : x ≡ y) → p ≡ q

    private
      UIP-check : {A : U} → UIP A ≡ ({x y : A} → has-all-paths (x ≡ y))
      UIP-check = idp

    module _ {A : U} where
        prop-has-all-paths : is-prop A → has-all-paths A
        prop-has-all-paths A-prop x y = fst (A-prop x y)

        all-paths-is-prop : has-all-paths A → is-prop A
        all-paths-is-prop c x y = c x y , canon-path
          where
          lemma : {x y : A} (p : x ≡ y) → c x y ≡ p ∙ c y y
          lemma = J' (λ x y p → c x y ≡ p ∙ c y y) (λ x → idp)

          canon-path : {x y : A} (p : x ≡ y) → c x y ≡ p
          canon-path = J' (λ x y p → c x y ≡ p)
                          (λ x → lemma (! c x x) ∙ !-∙ (c x x))

module _ {a} (A : ★_ a) where
    has-dec-eq : ★_ a
    has-dec-eq = (x y : A) → Dec (x ≡ y)

module _ {a} {A : ★_ a} (d : has-dec-eq A) where
    private
        Code' : {x y : A} (dxy : Dec (x ≡ y)) (dxx : Dec (x ≡ x)) → x ≡ y → ★_ a
        Code' {x} {y} dxy dxx p = case dxy of λ
          { (no  _) → Lift 𝟘
          ; (yes b) → case dxx of λ
                      { (no   _) → Lift 𝟘
                      ; (yes b') → p ≡ ! b' ∙ b
                      }
          }

        Code : {x y : A} → x ≡ y → ★_ a
        Code {x} {y} p = Code' (d x y) (d x x) p

        encode : {x y : A} → (p : x ≡ y) -> Code p
        encode {x} = J (λ y (p : x ≡ y) → Code p) (elim-Dec (λ d → Code' d d idp) (!_ ∘ !p∙p) (λ x₁ → lift (x₁ idp)) (d x x))

    UIP-dec : UIP A
    UIP-dec {x} idp q with d x x | encode q
    UIP-dec     idp q    | yes a | p' = ! !p∙p a ∙ ! p'
    UIP-dec     idp q    | no  r | _  = 𝟘-elim (r idp)

    dec-eq-is-set : is-set A
    dec-eq-is-set _ _ = all-paths-is-prop UIP-dec

module _ {ℓ}{A : ★_ ℓ} where
    UIP-set : is-set A → UIP A
    UIP-set A-is-set p q = fst (A-is-set _ _ p q)

    UIP→is-set : UIP A → is-set A
    UIP→is-set A-is-set' x y = all-paths-is-prop A-is-set'

    Ω₁-set-to-contr : is-set A → (x : A) → Is-contr (x ≡ x)
    Ω₁-set-to-contr A-is-set x = idp , UIP-set A-is-set idp

    coe!-inv-r : ∀ {B}(p : A ≡ B) y → coe p (coe! p y) ≡ y
    coe!-inv-r idp y = idp

    coe!-inv-l : ∀ {B}(p : A ≡ B) x → coe! p (coe p x) ≡ x
    coe!-inv-l idp x = idp

    coe-equiv : ∀ {B} → A ≡ B → A ≃ B
    coe-equiv p = equiv (coe p) (coe! p) (coe!-inv-r p) (coe!-inv-l p)

    coe∘coe : ∀ {B C}(p : B ≡ C)(q : A ≡ B)(m : A) → coe p (coe q m) ≡ coe (q ∙ p) m
    coe∘coe p idp m = idp

    coe-same : ∀ {B}{p q : A ≡ B}(e : p ≡ q)(x : A) → coe p x ≡ coe q x
    coe-same p x = ap (λ X → coe X x) p

    coe-inj : ∀ {B}{x y : A}(p : A ≡ B) → coe p x ≡ coe p y → x ≡ y
    coe-inj idp = id

    module _ {B : ★_ ℓ}(p : A ≡ B){x y : A} where
        coe-paths-equiv : (x ≡ y) ≡ (coe p x ≡ coe p y)
        coe-paths-equiv = J (λ B (p : A ≡ B) → (x ≡ y) ≡ (coe p x ≡ coe p y)) idp p

postulate
  UA : ★
module _ {ℓ}{A B : ★_ ℓ}{{_ : UA}} where
  postulate
    ua : (A ≃ B) → (A ≡ B)
    coe-equiv-β : (e : A ≃ B) → coe-equiv (ua e) ≡ e
    ua-η : (p : A ≡ B) → ua (coe-equiv p) ≡ p

  ua-equiv : (A ≃ B) ≃ (A ≡ B)
  ua-equiv = equiv ua coe-equiv ua-η coe-equiv-β

  coe-β : (e : A ≃ B) (a : A) → coe (ua e) a ≡ ·→ e a
  coe-β e a = ap (λ e → ·→ e a) (coe-equiv-β e)

  postulate
    coe!-β : (e : A ≃ B) (b : B) → coe! (ua e) b ≡ ·← e b

  module _ (e : A ≃ B){x y : A} where
    ·→-paths-equiv : (x ≡ y) ≡ (·→ e x ≡ ·→ e y)
    ·→-paths-equiv = coe-paths-equiv (ua e) ∙ ap₂ _≡_ (coe-β e x) (coe-β e y)

    –>-paths-equiv = ·→-paths-equiv

-- -}
-- -}
-- -}
-- -}

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

open import Type
open import Level.NP
open import Function.NP
open import Function.Extensionality
open import Data.Zero using (𝟘; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Product.NP
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])
open import Relation.Nullary.NP
open import Relation.Binary using (Reflexive; Symmetric; Transitive)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; ap; coe; coe!; !_; _∙_; J; ap↓; PathOver; tr; ap₂)
       renaming (refl to idp; _≗_ to _∼_; J-orig to J')

import Function.Inverse.NP as Inv
open Inv using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)

module _ {a} {A : ★_ a} where
  idp_ : (x : A) → x ≡ x
  idp_ _ = idp

  refl-∙ : ∀ {x y : A} (p : x ≡ y) → idp_ x ∙ p ≡ p
  refl-∙ _ = idp

  ∙-refl : ∀ {x y : A} (p : x ≡ y) → p ∙ idp_ y ≡ p
  ∙-refl = J' (λ (x y : A) (p : x ≡ y) → (p ∙ idp_ y) ≡ p) (λ x → idp)

  hom-!-∙ : ∀ {x y z : A} (p : x ≡ y)(q : y ≡ z) → !(p ∙ q) ≡ ! q ∙ ! p
  hom-!-∙ p q = J' (λ x y p → ∀ z → (q : y ≡ z) → !(p ∙ q) ≡ ! q ∙ ! p) (λ x z q → ! ∙-refl (! q)) p _ q

  !-inv : ∀ {x y : A} (p : x ≡ y) → ! (! p) ≡ p
  !-inv = J' (λ x y p → ! (! p) ≡ p) (λ x → idp)

  !-∙ : ∀ {x y : A} (p : x ≡ y) → ! p ∙ p ≡ idp_ y
  !-∙ = J' (λ x y p → (! p ∙ p) ≡ idp_ y) (λ x → idp)

  ∙-! : ∀ {x y : A} (p : x ≡ y) → p ∙ ! p ≡ idp_ x
  ∙-! = J' (λ x y p → (p ∙ ! p) ≡ idp_ x) (λ x → idp)

  !p∙p = !-∙
  p∙!p = ∙-!

  ∙-assoc : ∀ {x y : A} (p : x ≡ y) {z : A} (q : y ≡ z) {t : A} (r : z ≡ t) → p ∙ q ∙ r ≡ (p ∙ q) ∙ r
  ∙-assoc = J' (λ x y p → ∀ {z} (q : y ≡ z) {t} (r : z ≡ t) → p ∙ (q ∙ r) ≡ (p ∙ q) ∙ r)
               (λ x q r → idp)

  ==-refl-∙ :  {x y : A} (p : x ≡ y) {q : x ≡ x} → q ≡ idp_ x → q ∙ p ≡ p
  ==-refl-∙ p = ap (flip _∙_ p)

  ∙-==-refl :  {x y : A} (p : x ≡ y) {q : y ≡ y} → q ≡ idp_ y → p ∙ q ≡ p
  ∙-==-refl p qr = ap (_∙_ p) qr ∙ ∙-refl p

  ∙-∙-==-refl :  {x y z : A} (p : x ≡ y) (q : y ≡ z) {r : z ≡ z} → r ≡ idp_ z → p ∙ q ∙ r ≡ p ∙ q
  ∙-∙-==-refl p q rr = ∙-assoc p q _ ∙ ∙-==-refl (p ∙ q) rr

  !p∙p∙q : {x y z : A} (p : x ≡ y) (q : y ≡ z) → ! p ∙ p ∙ q ≡ q
  !p∙p∙q p q = ∙-assoc (! p) p q ∙ ==-refl-∙ q (!-∙ p)

  p∙!p∙q : {x y z : A} (p : y ≡ x) (q : y ≡ z) → p ∙ ! p ∙ q ≡ q
  p∙!p∙q p q = ∙-assoc p _ q ∙ ==-refl-∙ q (∙-! p)

  p∙!q∙q : {x y z : A} (p : x ≡ y) (q : z ≡ y) → p ∙ ! q ∙ q ≡ p
  p∙!q∙q p q = ∙-==-refl p (!-∙ q)

  p∙q∙!q : {x y z : A} (p : x ≡ y) (q : y ≡ z) → p ∙ q ∙ ! q ≡ p
  p∙q∙!q p q = ∙-==-refl p (∙-! q)

  ∙-cancel : {x y z : A}{p q : x ≡ y}(r : y ≡ z) → p ∙ r ≡ q ∙ r → p ≡ q
  ∙-cancel {p = p} {q} idp p∙id=q∙id = ! ∙-refl p ∙ p∙id=q∙id ∙ ∙-refl q

!-ap : ∀ {a b}{A : Set a}{B : Set b}(f : A → B){x y}(p : x ≡ y)
  → ! (ap f p) ≡ ap f (! p)
!-ap f idp = idp

ap-id : ∀ {a}{A : Set a}{x y : A}(p : x ≡ y)
  → ap id p ≡ p
ap-id idp = idp

module _ {a b}{A : Set a}{B : Set b}{f g : A → B}(H : ∀ x → f x ≡ g x) where
  ap-nat : ∀ {x y}(q : x ≡ y) → ap f q ∙ H _ ≡ H _ ∙ ap g q
  ap-nat idp = ! ∙-refl _

module _ {a}{A : Set a}{f : A → A}(H : ∀ x → f x ≡ x) where
  ap-nat-id : ∀ x → ap f (H x) ≡ H (f x)
  ap-nat-id x = ∙-cancel (H x) (ap-nat H (H x) ∙ ap (_∙_ (H (f x))) (ap-id (H x)))

tr-∘ : ∀ {a b p}{A : Set a}{B : Set b}(P : B → Set p)(f : A → B){x y}(p : x ≡ y)
  → tr (P ∘ f) p ≡ tr P (ap f p)
tr-∘ P f idp = idp

module _ {a}{A : ★_ a} where
    tr-∙′ : ∀ {ℓ}(P : A → ★_ ℓ) {x y z} (p : x ≡ y) (q : y ≡ z) →
             tr P (p ∙ q) ∼ tr P q ∘ tr P p
    tr-∙′ P idp _ _ = idp

    tr-∙ : ∀ {ℓ}(P : A → ★_ ℓ) {x y z} (p : x ≡ y) (q : y ≡ z) (pq : x ≡ z) →
             pq ≡ p ∙ q →
             tr P pq ∼ tr P q ∘ tr P p
    tr-∙ P p q ._ idp = tr-∙′ P p q

module _ {k} {K : ★_ k} {a} {A : ★_ a} {x y : A} (p : x ≡ y) where
    tr-const : tr (const K) p ≡ id
    tr-const = J (λ _ p₁ → tr (const K) p₁ ≡ id) idp p

-- Contractible
module _ {a}(A : ★_ a) where
    Is-contr : ★_ a
    Is-contr = Σ A λ x → ∀ y → x ≡ y

module _ {a}{b}{A : ★_ a}{B : A → ★_ b} where
    pair= : ∀ {x y : Σ A B} → (p : fst x ≡ fst y) → tr B p (snd x) ≡ snd y → x ≡ y
    pair= idp = ap (_,_ _)
    snd= : ∀ {x : A} {y y' : B x} → y ≡ y' → _≡_ {A = Σ A B} (x , y) (x , y')
    snd= = pair= idp

    tr-snd= : ∀ {p}(P : Σ A B → ★_ p){x}{y₀ y₁ : B x}(y= : y₀ ≡ y₁)
            → tr P (snd= {x = x} y=) ∼ tr (P ∘ _,_ x) y=
    tr-snd= P idp p = idp

module _ {a}{A : ★_ a} where
  tr-r≡ : {x y z : A}(p : y ≡ z)(q : x ≡ y) → tr (λ v → x ≡ v) p q ≡ q ∙ p
  tr-r≡ idp q = ! ∙-refl q

  tr-l≡ : {x y z : A}(p : x ≡ y)(q : x ≡ z) → tr (λ v → v ≡ z) p q ≡ ! p ∙ q
  tr-l≡ idp q = idp

module _ {A : ★}(f g : A → ★){x y : A}(p : x ≡ y)(h : f x → g x) where
    tr-→ : tr (λ x → f x → g x) p h ≡ (λ x → tr g p (h (tr f (! p) x)))
    tr-→ = J' (λ x y p → (h : f x → g x) → tr (λ x → f x → g x) p h ≡ (λ x → tr g p (h (tr f (! p) x))))
             (λ _ _ → idp) p h

module _ {a}{b}{A : ★_ a}{B : ★_ b} where
    pair×= : ∀ {x x' : A}(p : x ≡ x')
               {y y' : B}(q : y ≡ y')
             → (x , y) ≡ (x' , y')
    pair×= idp q = snd= q

module _ {a b c}{A : ★_ a}{B : A → ★_ b}{x₀ : A}{y₀ : B x₀}{C : ★_ c}
         (f : (x : A) (y : B x) → C) where
    ap₂↓ : {x₁ : A}(x= : x₀ ≡ x₁)
           {y₁ : B x₁}(y= : y₀ ≡ y₁ [ B ↓ x= ])
         → f x₀ y₀ ≡ f x₁ y₁
    ap₂↓ idp = ap (f x₀)
    {- Or with J
    ap₂↓ x= = J (λ x₁' x=' → {y₁ : B x₁'}(y= : y₀ ≡ y₁ [ _ ↓ x=' ])
                          → f x₀ y₀ ≡ f x₁' y₁)
                (λ y= → ap (f x₀) y=) x=
    -- -}

    apd₂ : {x₁ : A}(x= : x₀ ≡ x₁)
           {y₁ : B x₁}(y= : tr B x= y₀ ≡ y₁)
         → f x₀ y₀ ≡ f x₁ y₁
    -- apd₂ idp = ap (f x₀)
    -- {- Or with J
    apd₂ x= = J (λ x₁' x=' → {y₁ : B x₁'}(y= : tr B x=' y₀ ≡ y₁) → f x₀ y₀ ≡ f x₁' y₁)
                (λ y= → ap (f x₀) y=) x=
    -- -}

module _ {a b c d}{A : ★_ a}{B : A → ★_ b}{C : ★_ c}{x₀ : A}{y₀ : B x₀ → C}{D : ★_ d}
         {{_ : FunExt}}
         (f : (x : A) (y : B x → C) → D) where
    apd₂⁻ : {x₁ : A}(x= : x₀ ≡ x₁)
            {y₁ : B x₁ → C}(y= : ∀ x → y₀ x ≡ y₁ (tr B x= x))
          → f x₀ y₀ ≡ f x₁ y₁
    apd₂⁻ idp y= = ap (f x₀) (λ= y=)

module Equivalences where

  module _ {a b}{A : ★_ a}{B : ★_ b} where
    _LeftInverseOf_ : (B → A) → (A → B) → ★_ a
    linv LeftInverseOf f = ∀ x → linv (f x) ≡ x

    _RightInverseOf_ : (B → A) → (A → B) → ★_ b
    rinv RightInverseOf f = ∀ x → f (rinv x) ≡ x

    record Linv (f : A → B) : ★_(a ⊔ b) where
      field
        linv    : B → A
        is-linv : ∀ x → linv (f x) ≡ x

      injective : ∀ {x y} → f x ≡ f y → x ≡ y
      injective p = ! is-linv _ ∙ ap linv p ∙ is-linv _

    record Rinv (f : A → B) : ★_(a ⊔ b) where
      field
        rinv    : B → A
        is-rinv : ∀ x → f (rinv x) ≡ x

      surjective : ∀ y → ∃ λ x → f x ≡ y
      surjective y = rinv y , is-rinv y

    record Biinv (f : A → B) : ★_(a ⊔ b) where
      field
        has-linv : Linv f
        has-rinv : Rinv f

      open Linv has-linv public
      open Rinv has-rinv public

    module _ {f : A → B}
             (g : B → A)(g-f : (x : A) → g (f x) ≡ x)
             (h : B → A)(f-h : (y : B) → f (h y) ≡ y) where
      biinv : Biinv f
      biinv = record { has-linv = record { linv = g ; is-linv = g-f }
                     ; has-rinv = record { rinv = h ; is-rinv = f-h } }

    record Qinv (f : A → B) : ★_(a ⊔ b) where
      field
        inv : B → A
        inv-is-linv : ∀ x → inv (f x) ≡ x
        inv-is-rinv : ∀ x → f (inv x) ≡ x

      has-biinv : Biinv f
      has-biinv = record { has-linv = record { linv = inv
                                             ; is-linv = inv-is-linv }
                         ; has-rinv = record { rinv = inv
                                             ; is-rinv = inv-is-rinv } }

      open Biinv has-biinv public

    HAE : {f : A → B} → Qinv f → ★_(a ⊔ b)
    HAE {f} f-qinv = ∀ x → ap f (F.inv-is-linv x) ≡ F.inv-is-rinv (f x)
      where module F = Qinv f-qinv

    record Is-equiv (f : A → B) : ★_(a ⊔ b) where
      field
        has-qinv : Qinv f
        is-hae   : HAE has-qinv
      open Qinv has-qinv public

    module _ {f : A → B}(g : B → A)
             (f-g : (y : B) → f (g y) ≡ y)
             (g-f : (x : A) → g (f x) ≡ x) where
      qinv : Qinv f
      qinv = record
            { inv = g
            ; inv-is-linv = g-f
            ; inv-is-rinv = f-g }

    module _ {f : A → B}(g : B → A)
             (f-g : (y : B) → f (g y) ≡ y)
             (g-f : (x : A) → g (f x) ≡ x) where
      f-g' : (x : B) → f (g x) ≡ x
      f-g' x = ! ap (f ∘ g) (f-g x) ∙ ap f (g-f (g x)) ∙ f-g x
      -- g-f' x = ap g {!f-g ?!} ∙ {!!}

      postulate hae : HAE (qinv g f-g' g-f)

      is-equiv : Is-equiv f
      is-equiv = record
        { has-qinv = qinv g f-g' g-f
        ; is-hae   = hae }

  module Biinv-inv {a b}{A : ★_ a}{B : ★_ b}{f : A → B}
                   (fᴮ : Biinv f) where
      open Biinv fᴮ
      inv : B → A
      inv = linv ∘ f ∘ rinv

      inv-biinv : Biinv inv
      inv-biinv =
        biinv f (λ x → ap f (is-linv (rinv x)) ∙ is-rinv x)
              f (λ x → ap linv (is-rinv (f x)) ∙ is-linv x)

  module _ {a b}{A : ★_ a}{B : ★_ b}{f : A → B}
           (fᴱ : Is-equiv f) where
      open Is-equiv fᴱ

      inv-is-equiv : Is-equiv inv
      inv-is-equiv = is-equiv f is-linv is-rinv

  module _ {a b} where
    infix 4 _≃_
    _≃_ : ★_ a → ★_ b → ★_(a ⊔ b)
    A ≃ B = Σ (A → B) Is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b}
           (f : A → B)(g : B → A)
           (f-g : (y : B) → f (g y) ≡ y)
           (g-f : (x : A) → g (f x) ≡ x) where
    equiv : A ≃ B
    equiv = f , is-equiv g f-g g-f

  module _ {a}{A : ★_ a}
           (f : A → A)(f-inv : f LeftInverseOf f) where
      self-inv-is-equiv : Is-equiv f
      self-inv-is-equiv = is-equiv f f-inv f-inv

      self-inv-equiv : A ≃ A
      self-inv-equiv = f , self-inv-is-equiv

      self-inv-biinv : Biinv f
      self-inv-biinv = biinv f f-inv f f-inv

  module _ {a}{A : ★_ a} where
    idᴱ : Is-equiv {A = A} id
    idᴱ = self-inv-is-equiv _ λ _ → idp

    idᴮ : Biinv {A = A} id
    idᴮ = self-inv-biinv _ λ _ → idp

  module _ {a b c}{A : ★_ a}{B : ★_ b}{C : ★_ c}{g : B → C}{f : A → B} where
    _∘ᴱ_ : Is-equiv g → Is-equiv f → Is-equiv (g ∘ f)
    gᴱ ∘ᴱ fᴱ = is-equiv (F.inv ∘ G.inv)
                        (λ x → ap g (F.inv-is-rinv _) ∙ G.inv-is-rinv _)
                        (λ x → ap F.inv (G.inv-is-linv _) ∙ F.inv-is-linv _)
      where
        module G = Is-equiv gᴱ
        module F = Is-equiv fᴱ

    _∘ᴮ_ : Biinv g → Biinv f → Biinv (g ∘ f)
    gᴮ ∘ᴮ fᴮ =
      biinv (F.linv ∘ G.linv)
            (λ x → ap F.linv (G.is-linv (f x)) ∙ F.is-linv x)
            (F.rinv ∘ G.rinv)
            (λ x → ap g (F.is-rinv _) ∙ G.is-rinv x)
      where
        module G = Biinv gᴮ
        module F = Biinv fᴮ

  module Equiv {a b}{A : ★_ a}{B : ★_ b}(e : A ≃ B) where
    ·→ : A → B
    ·→ = fst e

    open Is-equiv (snd e) public
      renaming (linv to ·←; rinv to ·←′; is-linv to ·←-inv-l; is-rinv to ·←-inv-r)

    -- Equivalences are "injective"
    equiv-inj : {x y : A} → (·→ x ≡ ·→ y → x ≡ y)
    equiv-inj p = ! ·←-inv-l _ ∙ ap ·← p ∙ ·←-inv-l _

    –> = ·→
    <– = ·←
    <–' = ·←′

    <–-inv-l = ·←-inv-l
    <–-inv-r = ·←-inv-r

  open Equiv public

  module _ {ℓ} where
    ≃-refl : Reflexive (_≃_ {ℓ})
    ≃-refl = _ , idᴱ

    ≃-sym : Symmetric (_≃_ {ℓ})
    ≃-sym (_ , fᴱ) = _ , inv-is-equiv fᴱ

    ≃-trans : Transitive (_≃_ {ℓ})
    ≃-trans (_ , p) (_ , q) = _ , q ∘ᴱ p

    ≃-! = ≃-sym
    _≃-∙_ = ≃-trans

  module _ {a}(A : ★_ a) where
    Paths : ★_ a
    Paths = Σ A λ x → Σ A λ y → x ≡ y

  module _ {a}{A : ★_ a} where
    id-path : A → Paths A
    id-path x = x , x , idp

    fst-rinv-id-path : ∀ p → id-path (fst p) ≡ p
    fst-rinv-id-path (x , y , p) = snd= (pair= p (J (λ y p → tr (_≡_ x) p idp ≡ p) idp p))

    id-path-is-equiv : Is-equiv id-path
    id-path-is-equiv = is-equiv fst fst-rinv-id-path (λ x → idp)

    ≃-Paths : A ≃ Paths A
    ≃-Paths = id-path , id-path-is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b}(f : A → B) where
    hfiber : (y : B) → ★_(a ⊔ b)
    hfiber y = Σ A λ x → f x ≡ y

    Is-equiv-alt : ★_(a ⊔ b)
    Is-equiv-alt = (y : B) → Is-contr (hfiber y)

  module Is-contr-to-Is-equiv {a}{A : ★_ a}(A-contr : Is-contr A) where
    const-is-equiv : Is-equiv (λ (_ : 𝟙) → fst A-contr)
    const-is-equiv = is-equiv _ (snd A-contr) (λ _ → idp)
    𝟙≃ : 𝟙 ≃ A
    𝟙≃ = _ , const-is-equiv
  module Is-equiv-to-Is-contr {a}{A : ★_ a}(f : 𝟙 → A)(f-is-equiv : Is-equiv f) where
    open Is-equiv f-is-equiv
    A-contr : Is-contr A
    A-contr = f _ , is-rinv

  module _ {a}{A : ★_ a}{b}{B : ★_ b} where
    iso-to-equiv : (A ↔ B) → (A ≃ B)
    iso-to-equiv iso = to iso , is-equiv (from iso) (Inverse.right-inverse-of iso) (Inverse.left-inverse-of iso)

    equiv-to-iso : (A ≃ B) → (A ↔ B)
    equiv-to-iso (f , f-is-equiv) = inverses f (fᴱ.linv ∘ f ∘ fᴱ.rinv)
                                             (λ x → ap fᴱ.linv (fᴱ.is-rinv (f x)) ∙ fᴱ.is-linv x)
                                             (λ x → ap f (fᴱ.is-linv (fᴱ.rinv x)) ∙ fᴱ.is-rinv x)
      where module fᴱ = Is-equiv f-is-equiv

    {-
    iso-to-equiv-to-iso : (iso : A ↔ B) → equiv-to-iso (iso-to-equiv iso) ≡ iso
    iso-to-equiv-to-iso iso = {!!}
      where module Iso = Inverse iso

    iso-to-equiv-is-equiv : Is-equiv iso-to-equiv
    iso-to-equiv-is-equiv = record { linv = equiv-to-iso ; is-linv = {!!} ; rinv = {!!} ; is-rinv = {!!} }
    -}
open Equivalences

data T-level : ★₀ where
  ⟨-2⟩ : T-level
  ⟨S_⟩ : (n : T-level) → T-level

⟨-1⟩ ⟨0⟩ : T-level
⟨-1⟩ = ⟨S ⟨-2⟩ ⟩
⟨0⟩  = ⟨S ⟨-1⟩ ⟩
⟨1⟩  = ⟨S ⟨0⟩  ⟩
⟨2⟩  = ⟨S ⟨1⟩  ⟩

ℕ₋₂ = T-level

module _ {a} where
    private
      U = ★_ a

    has-level : T-level → U → U
    has-level ⟨-2⟩   A = Is-contr A
    has-level ⟨S n ⟩ A = (x y : A) → has-level n (x ≡ y)

    is-prop : U → U
    is-prop A = has-level ⟨-1⟩ A

    is-set : U → U
    is-set A = has-level ⟨0⟩ A

    has-all-paths : U → U
    has-all-paths A = (x y : A) → x ≡ y

    UIP : U → U
    UIP A = {x y : A} (p q : x ≡ y) → p ≡ q

    private
      UIP-check : {A : U} → UIP A ≡ ({x y : A} → has-all-paths (x ≡ y))
      UIP-check = idp

    module _ {A : U} where
        prop-has-all-paths : is-prop A → has-all-paths A
        prop-has-all-paths A-prop x y = fst (A-prop x y)

        all-paths-is-prop : has-all-paths A → is-prop A
        all-paths-is-prop c x y = c x y , canon-path
          where
          lemma : {x y : A} (p : x ≡ y) → c x y ≡ p ∙ c y y
          lemma = J' (λ x y p → c x y ≡ p ∙ c y y) (λ x → idp)

          canon-path : {x y : A} (p : x ≡ y) → c x y ≡ p
          canon-path = J' (λ x y p → c x y ≡ p)
                          (λ x → lemma (! c x x) ∙ !-∙ (c x x))

module _ {a} (A : ★_ a) where
    has-dec-eq : ★_ a
    has-dec-eq = (x y : A) → Dec (x ≡ y)

module _ {a} {A : ★_ a} (d : has-dec-eq A) where
    private
        Code' : {x y : A} (dxy : Dec (x ≡ y)) (dxx : Dec (x ≡ x)) → x ≡ y → ★_ a
        Code' {x} {y} dxy dxx p = case dxy of λ
          { (no  _) → Lift 𝟘
          ; (yes b) → case dxx of λ
                      { (no   _) → Lift 𝟘
                      ; (yes b') → p ≡ ! b' ∙ b
                      }
          }

        Code : {x y : A} → x ≡ y → ★_ a
        Code {x} {y} p = Code' (d x y) (d x x) p

        encode : {x y : A} → (p : x ≡ y) -> Code p
        encode {x} = J (λ y (p : x ≡ y) → Code p) (elim-Dec (λ d → Code' d d idp) (!_ ∘ !p∙p) (λ x₁ → lift (x₁ idp)) (d x x))

    UIP-dec : UIP A
    UIP-dec {x} idp q with d x x | encode q
    UIP-dec     idp q    | yes a | p' = ! !p∙p a ∙ ! p'
    UIP-dec     idp q    | no  r | _  = 𝟘-elim (r idp)

    dec-eq-is-set : is-set A
    dec-eq-is-set _ _ = all-paths-is-prop UIP-dec

module _ {ℓ}{A : ★_ ℓ} where
    UIP-set : is-set A → UIP A
    UIP-set A-is-set p q = fst (A-is-set _ _ p q)

    UIP→is-set : UIP A → is-set A
    UIP→is-set A-is-set' x y = all-paths-is-prop A-is-set'

    Ω₁-set-to-contr : is-set A → (x : A) → Is-contr (x ≡ x)
    Ω₁-set-to-contr A-is-set x = idp , UIP-set A-is-set idp

    coe!-inv-r : ∀ {B}(p : A ≡ B) y → coe p (coe! p y) ≡ y
    coe!-inv-r idp y = idp

    coe!-inv-l : ∀ {B}(p : A ≡ B) x → coe! p (coe p x) ≡ x
    coe!-inv-l idp x = idp

    coe-equiv : ∀ {B} → A ≡ B → A ≃ B
    coe-equiv p = equiv (coe p) (coe! p) (coe!-inv-r p) (coe!-inv-l p)

    coe∘coe : ∀ {B C}(p : B ≡ C)(q : A ≡ B)(m : A) → coe p (coe q m) ≡ coe (q ∙ p) m
    coe∘coe p idp m = idp

    coe-same : ∀ {B}{p q : A ≡ B}(e : p ≡ q)(x : A) → coe p x ≡ coe q x
    coe-same p x = ap (λ X → coe X x) p

    coe-inj : ∀ {B}{x y : A}(p : A ≡ B) → coe p x ≡ coe p y → x ≡ y
    coe-inj idp = id

    module _ {B : ★_ ℓ}(p : A ≡ B){x y : A} where
        coe-paths-equiv : (x ≡ y) ≡ (coe p x ≡ coe p y)
        coe-paths-equiv = J (λ B (p : A ≡ B) → (x ≡ y) ≡ (coe p x ≡ coe p y)) idp p

postulate
  UA : ★
module _ {ℓ}{A B : ★_ ℓ}{{_ : UA}} where
  postulate
    ua : (A ≃ B) → (A ≡ B)
    coe-equiv-β : (e : A ≃ B) → coe-equiv (ua e) ≡ e
    ua-η : (p : A ≡ B) → ua (coe-equiv p) ≡ p

  ua-equiv : (A ≃ B) ≃ (A ≡ B)
  ua-equiv = equiv ua coe-equiv ua-η coe-equiv-β

  coe-β : (e : A ≃ B) (a : A) → coe (ua e) a ≡ ·→ e a
  coe-β e a = ap (λ e → ·→ e a) (coe-equiv-β e)

  postulate
    coe!-β : (e : A ≃ B) (b : B) → coe! (ua e) b ≡ ·← e b

  module _ (e : A ≃ B){x y : A} where
    ·→-paths-equiv : (x ≡ y) ≡ (·→ e x ≡ ·→ e y)
    ·→-paths-equiv = coe-paths-equiv (ua e) ∙ ap₂ _≡_ (coe-β e x) (coe-β e y)

    –>-paths-equiv = ·→-paths-equiv

-- -}
-- -}
-- -}
-- -}


Distance

Distance

open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Data.Nat.Distance where

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-0≡id : ∀ x → dist 0 x ≡ x
dist-0≡id _ = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-sym : ∀ x y → dist x y ≡ dist y x
dist-sym zero zero = idp
dist-sym zero (suc y) = idp
dist-sym (suc x) zero = idp
dist-sym (suc x) (suc y) = dist-sym x y

dist-x+ : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
dist-x+ zero    y z = idp
dist-x+ (suc x) y z = dist-x+ x y z

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm {x} {1} {x} | +-assoc-comm {y} {1} {y} = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm {x} {1} {k} | q | ! +-assoc-comm {x} {1} {k} | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm {1} {y} {k} | dist-sym (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-sym (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite proj₁ ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-sym x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-sym x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

{-
post--ulate
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))

open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Data.Nat.Distance where

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-0≡id : ∀ x → dist 0 x ≡ x
dist-0≡id _ = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-sym : ∀ x y → dist x y ≡ dist y x
dist-sym zero zero = idp
dist-sym zero (suc y) = idp
dist-sym (suc x) zero = idp
dist-sym (suc x) (suc y) = dist-sym x y

dist-x+ : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
dist-x+ zero    y z = idp
dist-x+ (suc x) y z = dist-x+ x y z

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm x 1 x | +-assoc-comm y 1 y = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm x 1 k | q | ! +-assoc-comm x 1 k | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm 1 y k | dist-sym (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-sym (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite proj₁ ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-sym x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-sym x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

{-
post--ulate
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))


Formalize families of change algebras.

Formalize families of change algebras.

Old-commit-hash: 302fcf9d2fd70c553d0d8a7c60d274db43416a3d

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

  nil : ∀ v → Change v
  nil v = diff v v

  update-nil : ∀ v → update v (nil v) ≡ v
  update-nil v = update-diff v v

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of change algebras

record ChangeAlgebraFamily {a p} ℓ {A : Set a} (P : A → Set p): Set (suc ℓ ⊔ p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra ℓ (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    )

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v


Typo.

Typo.

Ignore-this: c3f2332a1570afe8b5821dc1e3510c66

darcs-hash:20110930182110-3bd4e-6ef85c673365d3fbc83ea36f7dfc0ad2c80b2d33.gz

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulate predicate: Using the
-- induction principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulate predicate: Using pattern matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulate predicate to the data predicate
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {n} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {n} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulate predicate: Using the
-- induction principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulate predicate: Using pattern matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulate predicate to the data predicate
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulate inductive principle from the data inductive principle.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {n} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulate predicate.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {n} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)


Try further to make agda work

Try further to make agda work

module hierarchy where

data Bool : Set where
  true  : Bool
  false : Bool

_and_ : Bool → Bool → Bool
true and true = true
true and false = false
false and true = false
false and false = false

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = n == m
_ == _         = false

data List (A : Set) : Set where
  []   : List A
  _::_ : A → List A → List A

_∈_ : ℕ → List ℕ → Bool
x ∈ []      = false
x ∈ (y :: ys) with x == y
...              | true  = true
...              | false = x ∈ ys

_⊂_ : List ℕ → List ℕ → Bool
[] ⊂ ys      = true
(x :: xs) ⊂ ys with x ∈ ys
...               | true  = xs ⊂ ys
...               | false = false

_++_ : List ℕ → List ℕ → List ℕ
[] ++ ys        = ys
(x :: xs) ++ ys with (x ∈ ys)
...               | true  = xs ++ ys
...               | false = x :: (xs ++ ys)

map : {A : Set} → (A → A) → List A → List A
map f []        = []
map f (x :: xs) = (f x) :: (map f xs)

data Arrow : Set where
  _⇒_ : List ℕ → ℕ → Arrow

_⇔_ : Arrow → Arrow → Bool
(at ⇒ ah) ⇔ (bt ⇒ bh) = ((at ⊂ bt) and (bt ⊂ at)) and (ah == bh)

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []      = false
x ∈∈ (y :: ys) with x ⇔ y
...               | true  = true
...               | false = x ∈∈ ys

_⊂⊂_ : List Arrow → List Arrow → Bool
[] ⊂⊂ ys      = true
(x :: xs) ⊂⊂ ys with x ∈∈ ys
...                | true  = xs ⊂⊂ ys
...                | false = false

-- SingleClosure : Arrow → List ℕ → List ℕ
-- SingleClosure (ts ⇒ h) ps with ts ⊂ ps
-- ...                     | true  = h :: ps
-- ...                     | false = ps
--
-- Closure' : List Arrow → List ℕ → List ℕ
-- Closure' [] roots = roots
-- Closure' (c :: cs) roots = (SingleClosure c roots) ++ (Closure' cs roots)
--
-- Closure : List Arrow → List ℕ → List ℕ
-- Closure arrows roots with (Closure' arrows roots) ⊂ roots
-- ...                     | true = roots
-- ...                     | false = Closure arrows (Closure' arrows roots)
--
--
-- _,_⊢_ : List Arrow → List ℕ → ℕ → Bool
-- _ , [] ⊢ _ = false
-- thms , p :: premises ⊢ conc = true
--

ArrowIntro : ℕ → Arrow → Arrow
ArrowIntro n (ts ⇒ h) = (n :: ts) ⇒ h

ArrowElim : ℕ → Arrow → Arrow
ArrowElim _ ([] ⇒ h) = [] ⇒ h
ArrowElim n ((t :: ts) ⇒ h) with (t == n)
...                            | true  = ArrowElim  n (ts ⇒ h)
...                            | false = ArrowIntro t (ArrowElim n (ts ⇒ h))

Reduce : List Arrow → List ℕ → List Arrow
Reduce cs [] = cs
Reduce cs (n :: ns) with (map (ArrowElim n) cs) ⊂⊂ cs
...                    | true  = cs
...                    | false = Reduce (map (ArrowElim n) cs) (n :: ns)

module hierarchy where

data Bool : Set where
  true  : Bool
  false : Bool

_and_ : Bool → Bool → Bool
true and true = true
true and false = false
false and true = false
false and false = false

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = true
_ == _         = false

data List (A : Set) : Set where
  []   : List A
  _::_ : A → List A → List A

_∈_ : ℕ → List ℕ → Bool
x ∈ []      = false
x ∈ (y :: ys) with x == y
...              | true  = true
...              | false = x ∈ ys

_⊂_ : List ℕ → List ℕ → Bool
[] ⊂ ys      = true
(x :: xs) ⊂ ys with x ∈ ys
...               | true  = xs ⊂ ys
...               | false = false

_++_ : List ℕ → List ℕ → List ℕ
[] ++ ys        = ys
(x :: xs) ++ ys with (x ∈ ys)
...               | true  = xs ++ ys
...               | false = x :: (xs ++ ys)

data Arrow : Set where
  _⇒_ : List ℕ → ℕ → Arrow

SingleClosure : Arrow → List ℕ → List ℕ
SingleClosure (ts ⇒ h) ps with ts ⊂ ps
...                     | true  = h :: ps
...                     | false = ps

Closure' : List Arrow → List ℕ → List ℕ
Closure' [] roots = roots
Closure' (c :: cs) roots = (SingleClosure c roots) ++ (Closure' cs roots)

Closure : List Arrow → List ℕ → List ℕ
Closure arrows roots with (Closure' arrows roots) ⊂ roots
...                     | true = roots
...                     | false = Closure arrows (Closure' arrows roots)

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
_ , [] ⊢ _ = false
thms , p :: premises ⊢ conc = true


Move before and after out of the mutually dependent block.

Old-commit-hash: 1d7a74aa7d62457de4936eae9faaeb605d739bf3

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : (ι : Base) → ⟦ ι ⟧Base → Set
    apply-change-base : ∀ ι → (v : ⟦ ι ⟧Base) → Change-base ι v → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → (u v : ⟦ ι ⟧Base) → Change-base ι v
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : (τ : Type) → ⟦ τ ⟧ → Set

  nil-change : ∀ τ v → Change τ v
  apply-change : ∀ τ → (v : ⟦ τ ⟧) (dv : Change τ v) → ⟦ τ ⟧
  diff-change : ∀ τ → (u v : ⟦ τ ⟧) → Change τ v

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex

  -- Change : Type → Set
  Change (base ι) v = Change-base ι v
  Change (σ ⇒ τ) f = Pair
    (∀ v → Change σ v → Change τ (f v))
    (λ Δf → ∀ v dv →
      f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ Δf (v ⊞₍ σ ₎ dv) (nil-change σ (v ⊞₍ σ ₎ dv)) ≡ f v ⊞₍ τ ₎ Δf v dv)

  open Pair public using () renaming
    ( cdr to is-valid
    ; car to call-change
    )

  nil-change τ v = diff-change τ v v

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  apply-change (base ι) n Δn = apply-change-base ι n Δn
  apply-change (σ ⇒ τ) f Δf = λ v → f v ⊞₍ τ ₎ call-change Δf v (nil-change σ v)

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  diff-change (base ι) m n = diff-change-base ι m n
  diff-change (σ ⇒ τ) g f = cons (λ v dv → g (v ⊞₍ σ ₎ dv) ⊟₍ τ ₎ f v)
    (λ v dv →
      begin
        f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g ((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv))) ⊟₍ τ ₎ f (v ⊞₍ σ ₎ dv))
      ≡⟨ cong (λ □ → f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g □ ⊟₍ τ ₎ (f (v ⊞₍ σ ₎ dv))))
              (v+[u-v]=u {σ} {v ⊞₍ σ ₎ dv} {v ⊞₍ σ ₎ dv}) ⟩
        f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g (v ⊞₍ σ ₎ dv) ⊟₍ τ ₎ f (v ⊞₍ σ ₎ dv))
      ≡⟨ v+[u-v]=u {τ} {g (v ⊞₍ σ ₎ dv)} {f (v ⊞₍ σ ₎ dv)} ⟩
        g (v ⊞₍ σ ₎ dv)
      ≡⟨  sym (v+[u-v]=u {τ} {g (v ⊞₍ σ ₎ dv)} {f v} )  ⟩
        f v ⊞₍ τ ₎ (g (v ⊞₍ σ ₎ dv) ⊟₍ τ ₎ f v)
      ∎) where open ≡-Reasoning

  -- call this lemma "replace"?
  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (apply-change (σ ⇒ τ) v (diff-change (σ ⇒ τ) u v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → (v : ⟦ τ ⟧) → Change τ v → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → (u v : ⟦ τ ⟧) → Change τ v
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  -- abbrevitations
  before : ∀ {τ v} → Change τ v → ⟦ τ ⟧
  before {τ} {v} _ = v

  after : ∀ {τ v} → Change τ v → ⟦ τ ⟧
  after {τ} {v} dv = v ⊞₍ τ ₎ dv

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  data ΔEnv : ∀ (Γ : Context) → ⟦ Γ ⟧ → Set where
    ∅ : ΔEnv ∅ ∅
    _•_ : ∀ {τ Γ v ρ} →
      (dv : Change τ v) →
      (dρ : ΔEnv Γ ρ) →
      ΔEnv (τ • Γ) (v • ρ)

  ignore : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  ignore {Γ} {ρ} _ = ρ

  update : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  update ∅ = ∅
  update {τ • Γ} (dv • dρ) = after {τ} dv • update dρ

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : (ι : Base) → ⟦ ι ⟧Base → Set
    apply-change-base : ∀ ι → (v : ⟦ ι ⟧Base) → Change-base ι v → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → (u v : ⟦ ι ⟧Base) → Change-base ι v
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : (τ : Type) → ⟦ τ ⟧ → Set

  nil-change : ∀ τ v → Change τ v
  apply-change : ∀ τ → (v : ⟦ τ ⟧) (dv : Change τ v) → ⟦ τ ⟧
  diff-change : ∀ τ → (u v : ⟦ τ ⟧) → Change τ v

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex

  -- Change : Type → Set
  Change (base ι) v = Change-base ι v
  Change (σ ⇒ τ) f = Pair
    (∀ v → Change σ v → Change τ (f v))
    (λ Δf → ∀ v dv →
      f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ Δf (v ⊞₍ σ ₎ dv) (nil-change σ (v ⊞₍ σ ₎ dv)) ≡ f v ⊞₍ τ ₎ Δf v dv)

  before : ∀ {τ v} → Change τ v → ⟦ τ ⟧
  before {τ} {v} _ = v

  after : ∀ {τ v} → Change τ v → ⟦ τ ⟧
  after {τ} {v} dv = v ⊞₍ τ ₎ dv

  open Pair public using () renaming
    ( cdr to is-valid
    ; car to call-change
    )

  nil-change τ v = diff-change τ v v

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  apply-change (base ι) n Δn = apply-change-base ι n Δn
  apply-change (σ ⇒ τ) f Δf = λ v → f v ⊞₍ τ ₎ call-change Δf v (nil-change σ v)

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  diff-change (base ι) m n = diff-change-base ι m n
  diff-change (σ ⇒ τ) g f = cons (λ v dv → g (after {σ} dv) ⊟₍ τ ₎ f v)
    (λ v dv →
      begin
        f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g ((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv))) ⊟₍ τ ₎ f (v ⊞₍ σ ₎ dv))
      ≡⟨ cong (λ □ → f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g □ ⊟₍ τ ₎ (f (v ⊞₍ σ ₎ dv))))
              (v+[u-v]=u {σ} {v ⊞₍ σ ₎ dv} {v ⊞₍ σ ₎ dv}) ⟩
        f (v ⊞₍ σ ₎ dv) ⊞₍ τ ₎ (g (v ⊞₍ σ ₎ dv) ⊟₍ τ ₎ f (v ⊞₍ σ ₎ dv))
      ≡⟨ v+[u-v]=u {τ} {g (v ⊞₍ σ ₎ dv)} {f (v ⊞₍ σ ₎ dv)} ⟩
        g (v ⊞₍ σ ₎ dv)
      ≡⟨  sym (v+[u-v]=u {τ} {g (v ⊞₍ σ ₎ dv)} {f v} )  ⟩
        f v ⊞₍ τ ₎ (g (v ⊞₍ σ ₎ dv) ⊟₍ τ ₎ f v)
      ∎) where open ≡-Reasoning

  -- call this lemma "replace"?
  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (apply-change (σ ⇒ τ) v (diff-change (σ ⇒ τ) u v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → (v : ⟦ τ ⟧) → Change τ v → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → (u v : ⟦ τ ⟧) → Change τ v
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  data ΔEnv : ∀ (Γ : Context) → ⟦ Γ ⟧ → Set where
    ∅ : ΔEnv ∅ ∅
    _•_ : ∀ {τ Γ v ρ} →
      (dv : Change τ v) →
      (dρ : ΔEnv Γ ρ) →
      ΔEnv (τ • Γ) (v • ρ)

  ignore : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  ignore {Γ} {ρ} _ = ρ

  update : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  update ∅ = ∅
  update {τ • Γ} (dv • dρ) = after {τ} dv • update dρ