[ power function] Added missing hypothesis.

------------------------------------------------------------------------------
-- Some proofs related to the power function
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.Pow.PropertiesATP where

open import FOT.FOTC.Data.Nat.Pow

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

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

postulate 0^0≡1 : 0' ^ 0' ≡ 1'
{-# ATP prove 0^0≡1 #-}

0^Sx≡0 : ∀ {n} → N n → 0' ^ succ₁ n ≡ 0'
0^Sx≡0 {.zero} nzero  = prf
  where postulate prf : 0' ^ succ₁ zero ≡ 0'
        {-# ATP prove prf #-}

0^Sx≡0 (nsucc {n} Nn) = prf
  where postulate prf : 0' ^ succ₁ (succ₁ n) ≡ 0'
        {-# ATP prove prf #-}

thm₁ : ∀ {n} → N n → 5' ≤ n → n ^ 5' ≤ 5' ^ n
thm₁ nzero h = prf
  where postulate prf : zero ^ 5' ≤ 5' ^ zero
        {-# ATP prove prf #-}
thm₁ (nsucc {n} Nn) h = prf (thm₁ Nn) h
  where
  postulate prf : (5' ≤ n → n ^ 5' ≤ 5' ^ n) →
                  5' ≤ succ₁ n →
                  succ₁ n ^ 5' ≤ 5' ^ succ₁ n
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf 5-N #-}

thm₂ : ∀ {n} → N n →
       ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡ 2' ^ (n + 1') ∸ 1'
thm₂ nzero = prf
  where
  postulate prf : ((2' ^ zero) ∸ 1') + 1' + ((2' ^ zero) ∸ 1') ≡
                  2' ^ (zero + 1') ∸ 1'
  {-# ATP prove prf #-}
thm₂ (nsucc {n} Nn) = prf (thm₂ Nn)
  where
  postulate prf : ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡
                  2' ^ (n + 1') ∸ 1' →
                  ((2' ^ succ₁ n) ∸ 1') + 1' + ((2' ^ succ₁ n) ∸ 1') ≡
                  2' ^ (succ₁ n + 1') ∸ 1'
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Some proofs related to the power function
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.Pow.PropertiesATP where

open import FOT.FOTC.Data.Nat.Pow

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

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

postulate 0^0≡1 : 0' ^ 0' ≡ 1'
{-# ATP prove 0^0≡1 #-}

0^Sx≡0 : ∀ {n} → N n → 0' ^ succ₁ n ≡ 0'
0^Sx≡0 {.zero} nzero  = prf
  where postulate prf : 0' ^ succ₁ zero ≡ 0'
        {-# ATP prove prf #-}

0^Sx≡0 (nsucc {n} Nn) = prf
  where postulate prf : 0' ^ succ₁ (succ₁ n) ≡ 0'
        {-# ATP prove prf #-}

thm₁ : ∀ {n} → N n → 5' ≤ n → n ^ 5' ≤ 5' ^ n
thm₁ nzero h = prf
  where postulate prf : zero ^ 5' ≤ 5' ^ zero
        {-# ATP prove prf #-}
thm₁ (nsucc {n} Nn) h = prf (thm₁ Nn)
  where
  postulate prf : (5' ≤ n → n ^ 5' ≤ 5' ^ n) → (succ₁ n) ^ 5' ≤ 5' ^ (succ₁ n)
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf 5-N #-}

thm₂ : ∀ {n} → N n →
       ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡ 2' ^ (n + 1') ∸ 1'
thm₂ nzero = prf
  where
  postulate prf : ((2' ^ zero) ∸ 1') + 1' + ((2' ^ zero) ∸ 1') ≡
                  2' ^ (zero + 1') ∸ 1'
  {-# ATP prove prf #-}
thm₂ (nsucc {n} Nn) = prf (thm₂ Nn)
  where
  postulate prf : ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡
                  2' ^ (n + 1') ∸ 1' →
                  ((2' ^ succ₁ n) ∸ 1') + 1' + ((2' ^ succ₁ n) ∸ 1') ≡
                  2' ^ (succ₁ n + 1') ∸ 1'
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf #-}


{-# OPTIONS --universe-polymorphism #-}
module Data.Nat.Logical where

import Level as L
open import Data.Nat using (ℕ; zero; suc; pred; _≤_; z≤n; s≤s; ≤-pred; _≤?_; _+_)
open import Function
open import Relation.Nullary
open import Relation.Binary.NP
open import Relation.Binary.Logical
import      Relation.Binary.PropositionalEquality as PropEq

data ⟦ℕ⟧ : ⟦Set₀⟧ ℕ ℕ where
  zero : ⟦ℕ⟧ zero zero
  suc  : ∀ {n₁ n₂} (nᵣ : ⟦ℕ⟧ n₁ n₂) → ⟦ℕ⟧ (suc n₁) (suc n₂)

_⟦+⟧_ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) _+_ _+_
zero  ⟦+⟧ n = n
suc m ⟦+⟧ n = suc (m ⟦+⟧ n)

⟦pred⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred pred
⟦pred⟧ (suc nᵣ) = nᵣ
⟦pred⟧ zero     = zero

_≟_ : Decidable ⟦ℕ⟧
zero  ≟ zero   = yes zero
suc m ≟ suc n  with m ≟ n
...            | yes p = yes (suc p)
...            | no ¬p = no (¬p ∘ ⟦pred⟧)
zero  ≟ suc n  = no λ()
suc m ≟ zero   = no λ()

private
  refl : Reflexive ⟦ℕ⟧
  refl {zero}  = zero
  refl {suc n} = suc (refl {n})
  sym : Symmetric ⟦ℕ⟧
  sym zero = zero
  sym (suc nᵣ) = suc (sym nᵣ)
  trans : Transitive ⟦ℕ⟧
  trans zero    zero     = zero
  trans (suc mᵣ) (suc nᵣ) = suc (trans mᵣ nᵣ)
  subst : ∀ {ℓ} → Substitutive ⟦ℕ⟧ ℓ
  subst _ zero    = id
  subst P (suc nᵣ) = subst (P ∘ suc) nᵣ

⟦ℕ⟧-isEquivalence : IsEquivalence ⟦ℕ⟧
⟦ℕ⟧-isEquivalence = record { refl = refl; sym = sym; trans = trans }

⟦ℕ⟧-isDecEquivalence : IsDecEquivalence ⟦ℕ⟧
⟦ℕ⟧-isDecEquivalence = record { isEquivalence = ⟦ℕ⟧-isEquivalence; _≟_ = _≟_ }

⟦ℕ⟧-equality : Equality ⟦ℕ⟧
⟦ℕ⟧-equality = record { isEquivalence = ⟦ℕ⟧-isEquivalence; subst = subst }

⟦ℕ⟧⇒≡ : ⟦ℕ⟧ ⇒ PropEq._≡_
⟦ℕ⟧⇒≡ = Equality.to-reflexive ⟦ℕ⟧-equality {PropEq._≡_} PropEq.refl

⟦ℕ⟧-setoid : Setoid _ _
⟦ℕ⟧-setoid = record { Carrier = ℕ; _≈_ = ⟦ℕ⟧; isEquivalence = ⟦ℕ⟧-isEquivalence }

⟦ℕ⟧-decSetoid : DecSetoid _ _
⟦ℕ⟧-decSetoid = record { Carrier = ℕ; _≈_ = ⟦ℕ⟧; isDecEquivalence = ⟦ℕ⟧-isDecEquivalence }

⟦ℕ⟧-cong : ∀ f → ⟦ℕ⟧ =[ f ]⇒ ⟦ℕ⟧
⟦ℕ⟧-cong _ zero     = refl
⟦ℕ⟧-cong f (suc nᵣ) = ⟦ℕ⟧-cong (f ∘ suc) nᵣ

module ⟦ℕ⟧-Reasoning = Setoid-Reasoning ⟦ℕ⟧-setoid

data ⟦≤⟧ : ⟦REL⟧ ⟦ℕ⟧ ⟦ℕ⟧ L.zero _≤_ _≤_ where
  z≤n : ∀ {m₁ m₂} {mᵣ : ⟦ℕ⟧ m₁ m₂} → ⟦≤⟧ zero mᵣ z≤n z≤n
  s≤s : ∀ {m₁ m₂ n₁ n₂ mᵣ nᵣ} {m≤n₁ : m₁ ≤ n₁} {m≤n₂ : m₂ ≤ n₂} (m≤nᵣ : ⟦≤⟧ mᵣ nᵣ m≤n₁ m≤n₂)
        → ⟦≤⟧ (suc mᵣ) (suc nᵣ) (s≤s m≤n₁) (s≤s m≤n₂)

⟦≤-pred⟧ : ∀ {m₁ m₂ n₁ n₂ mᵣ nᵣ} {m≤n₁ : suc m₁ ≤ suc n₁} {m≤n₂ : suc m₂ ≤ suc n₂}
          → ⟦≤⟧ (suc mᵣ) (suc nᵣ) m≤n₁ m≤n₂ → ⟦≤⟧ mᵣ nᵣ (≤-pred m≤n₁) (≤-pred m≤n₂)
⟦≤-pred⟧ (s≤s m≤n) = m≤n

_⟦≤?⟧_ : ⟦Decidable⟧ ⟦ℕ⟧ ⟦ℕ⟧ ⟦≤⟧ _≤?_ _≤?_
zero             ⟦≤?⟧ _      = yes z≤n
suc nᵣ           ⟦≤?⟧ zero   = no (λ())
suc {m₁} {m₂} mᵣ ⟦≤?⟧ suc {n₁} {n₂} nᵣ
 with m₁ ≤? n₁ | m₂ ≤? n₂ | mᵣ ⟦≤?⟧ nᵣ
... | yes _     | yes _      | yes m≤nᵣ = yes (s≤s m≤nᵣ)
... | no _      | no _       | no ¬m≤nᵣ = no (¬m≤nᵣ ∘ ⟦≤-pred⟧)
... | yes _     | no _       | ()
... | no _      | yes _      | ()

{-# OPTIONS --universe-polymorphism #-}
module Data.Nat.Logical where

import Level as L
open import Data.Nat using (ℕ; zero; suc; pred; _≤_; z≤n; s≤s; ≤-pred; _≤?_; _+_)
open import Function
open import Relation.Nullary
open import Relation.Binary.NP
open import Relation.Binary.Logical
import      Relation.Binary.PropositionalEquality as PropEq

data ⟦ℕ⟧ : ⟦Set₀⟧ ℕ ℕ where
  zero : ⟦ℕ⟧ zero zero
  suc  : ∀ {n₁ n₂} (nᵣ : ⟦ℕ⟧ n₁ n₂) → ⟦ℕ⟧ (suc n₁) (suc n₂)

_⟦+⟧_ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) _+_ _+_
zero  ⟦+⟧ n = n
suc m ⟦+⟧ n = suc (m ⟦+⟧ n)

⟦pred⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred pred
⟦pred⟧ (suc nᵣ) = nᵣ
⟦pred⟧ zero     = zero

_≟_ : Decidable ⟦ℕ⟧
zero  ≟ zero   = yes zero
suc m ≟ suc n  with m ≟ n
...            | yes p = yes (suc p)
...            | no ¬p = no (¬p ∘ ⟦pred⟧)
zero  ≟ suc n  = no λ()
suc m ≟ zero   = no λ()

private
  refl : Reflexive ⟦ℕ⟧
  refl {zero}  = zero
  refl {suc n} = suc (refl {n})
  sym : Symmetric ⟦ℕ⟧
  sym zero = zero
  sym (suc nᵣ) = suc (sym nᵣ)
  trans : Transitive ⟦ℕ⟧
  trans zero    zero     = zero
  trans (suc mᵣ) (suc nᵣ) = suc (trans mᵣ nᵣ)
  subst : ∀ {ℓ} → Substitutive ⟦ℕ⟧ ℓ
  subst _ zero    = id
  subst P (suc nᵣ) = subst (P ∘ suc) nᵣ

⟦ℕ⟧-isEquivalence : IsEquivalence ⟦ℕ⟧
⟦ℕ⟧-isEquivalence = record { refl = refl; sym = sym; trans = trans }

⟦ℕ⟧-isDecEquivalence : IsDecEquivalence ⟦ℕ⟧
⟦ℕ⟧-isDecEquivalence = record { isEquivalence = ⟦ℕ⟧-isEquivalence; _≟_ = _≟_ }

⟦ℕ⟧-equality : Equality ⟦ℕ⟧
⟦ℕ⟧-equality = record { isEquivalence = ⟦ℕ⟧-isEquivalence; subst = subst }

⟦ℕ⟧⇒≡ : ⟦ℕ⟧ ⇒ PropEq._≡_
⟦ℕ⟧⇒≡ = Equality.to-reflexive ⟦ℕ⟧-equality {PropEq._≡_} PropEq.refl

⟦ℕ⟧-setoid : Setoid _ _
⟦ℕ⟧-setoid = record { Carrier = ℕ; _≈_ = ⟦ℕ⟧; isEquivalence = ⟦ℕ⟧-isEquivalence }

⟦ℕ⟧-decSetoid : DecSetoid _ _
⟦ℕ⟧-decSetoid = record { Carrier = ℕ; _≈_ = ⟦ℕ⟧; isDecEquivalence = ⟦ℕ⟧-isDecEquivalence }

⟦ℕ⟧-cong : ∀ f → ⟦ℕ⟧ =[ f ]⇒ ⟦ℕ⟧
⟦ℕ⟧-cong _ zero     = refl
⟦ℕ⟧-cong f (suc nᵣ) = ⟦ℕ⟧-cong (f ∘ suc) nᵣ

module ⟦ℕ⟧-Reasoning = Trans-Reasoning ⟦ℕ⟧ trans

data ⟦≤⟧ : ⟦REL⟧ ⟦ℕ⟧ ⟦ℕ⟧ L.zero _≤_ _≤_ where
  z≤n : ∀ {m₁ m₂} {mᵣ : ⟦ℕ⟧ m₁ m₂} → ⟦≤⟧ zero mᵣ z≤n z≤n
  s≤s : ∀ {m₁ m₂ n₁ n₂ mᵣ nᵣ} {m≤n₁ : m₁ ≤ n₁} {m≤n₂ : m₂ ≤ n₂} (m≤nᵣ : ⟦≤⟧ mᵣ nᵣ m≤n₁ m≤n₂)
        → ⟦≤⟧ (suc mᵣ) (suc nᵣ) (s≤s m≤n₁) (s≤s m≤n₂)

⟦≤-pred⟧ : ∀ {m₁ m₂ n₁ n₂ mᵣ nᵣ} {m≤n₁ : suc m₁ ≤ suc n₁} {m≤n₂ : suc m₂ ≤ suc n₂}
          → ⟦≤⟧ (suc mᵣ) (suc nᵣ) m≤n₁ m≤n₂ → ⟦≤⟧ mᵣ nᵣ (≤-pred m≤n₁) (≤-pred m≤n₂)
⟦≤-pred⟧ (s≤s m≤n) = m≤n

_⟦≤?⟧_ : ⟦Decidable⟧ ⟦ℕ⟧ ⟦ℕ⟧ ⟦≤⟧ _≤?_ _≤?_
zero             ⟦≤?⟧ _      = yes z≤n
suc nᵣ           ⟦≤?⟧ zero   = no (λ())
suc {m₁} {m₂} mᵣ ⟦≤?⟧ suc {n₁} {n₂} nᵣ
 with m₁ ≤? n₁ | m₂ ≤? n₂ | mᵣ ⟦≤?⟧ nᵣ
... | yes _     | yes _      | yes m≤nᵣ = yes (s≤s m≤nᵣ)
... | no _      | no _       | no ¬m≤nᵣ = no (¬m≤nᵣ ∘ ⟦≤-pred⟧)
... | yes _     | no _       | ()
... | no _      | yes _      | ()


refactor

refactor

open import Prelude
open import Nat
open import core
open import contexts

module lemmas-disjointness where
  -- disjointness is commutative
  ##-comm : {A : Set} {Δ1 Δ2 : A ctx} → Δ1 ## Δ2 → Δ2 ## Δ1
  ##-comm (π1 , π2) = π2 , π1

  -- the empty context is disjoint from any context
  empty-disj : {A : Set} (Γ : A ctx) → ∅ ## Γ
  empty-disj Γ = ed1 , ed2
   where
    ed1 : {A : Set} (n : Nat) → dom {A} ∅ n → n # Γ
    ed1 n (π1 , ())

    ed2 : {A : Set} (n : Nat) → dom Γ n →  _#_ {A} n ∅
    ed2 _ _ = refl

  -- two singleton contexts with different indices are disjoint
  disjoint-singles : {A : Set} {x y : A} {u1 u2 : Nat} →
                          u1 ≠ u2 →
                          (■ (u1 , x)) ## (■ (u2 , y))
  disjoint-singles {_} {x} {y} {u1} {u2} neq = ds1 , ds2
    where
      ds1 : (n : Nat) → dom (■ (u1 , x)) n → n # (■ (u2 , y))
      ds1 n d with lem-dom-eq _ _ _ d
      ds1 .u1 d | refl with natEQ u2 u1
      ds1 .u1 d | refl | Inl xx = abort (neq (! xx))
      ds1 .u1 d | refl | Inr x₁ = refl

      ds2 : (n : Nat) → dom (■ (u2 , y)) n → n # (■ (u1 , x))
      ds2 n d with lem-dom-eq _ _ _ d
      ds2 .u2 d | refl with natEQ u1 u2
      ds2 .u2 d | refl | Inl x₁ = abort (neq x₁)
      ds2 .u2 d | refl | Inr x₁ = refl

  -- the only index of a singleton context is in its domain
  lem-domsingle : {A : Set} (p : Nat) (q : A) → dom (■ (p , q)) p
  lem-domsingle p q with natEQ p p
  lem-domsingle p q | Inl refl = q , refl
  lem-domsingle p q | Inr x₁ = abort (x₁ refl)

  apart-noteq : {A : Set} (p r : Nat) (q : A) → p # (■ (r , q)) → p ≠ r
  apart-noteq p r q apt with natEQ r p
  apart-noteq p .p q apt | Inl refl = abort (somenotnone apt)
  apart-noteq p r q apt | Inr x₁ = flip x₁

  -- if singleton contexts are disjoint, their indices must be disequal
  singles-notequal : {A : Set} {x y : A} {u1 u2 : Nat} →
                          (■ (u1 , x)) ## (■ (u2 , y)) →
                          u1 ≠ u2
  singles-notequal {A} {x} {y} {u1} {u2} (d1 , d2) = apart-noteq u1 u2 y (d1 u1 (lem-domsingle u1 x))

  -- dual of lem2 above; if two indices are disequal, then either is apart
  -- from the singleton formed with the other
  apart-singleton : {A : Set} → ∀{x y} → {τ : A} →
                          x ≠ y →
                          x # (■ (y , τ))
  apart-singleton {A} {x} {y} {τ} neq with natEQ y x
  apart-singleton neq | Inl x₁ = abort ((flip neq) x₁)
  apart-singleton neq | Inr x₁ = refl

  -- if an index is apart from two contexts, it's apart from their union as
  -- well. used below and in other files, so it's outside the local scope.
  apart-parts : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # Γ1 → n # Γ2 → n # (Γ1 ∪ Γ2)
  apart-parts Γ1 Γ2 n apt1 apt2 with Γ1 n
  apart-parts _ _ n refl apt2 | .None = apt2

  -- this is just for convenience; it shows up a lot.
  apart-extend1 : {A : Set} → ∀{ x y τ} → (Γ : A ctx)  → x ≠ y → x # Γ → x # (Γ ,, (y , τ))
  apart-extend1 {A} {x} {y} {τ} Γ neq apt = apart-parts Γ (■ (y , τ)) x apt (apart-singleton neq)

  -- if both parts of a union are disjoint with a target, so is the union
  disjoint-parts : {A : Set} {Γ1 Γ2 Γ3 : A ctx} → Γ1 ## Γ3 → Γ2 ## Γ3 → (Γ1 ∪ Γ2) ## Γ3
  disjoint-parts {_} {Γ1} {Γ2} {Γ3} D13 D23 = d31 , d32
    where
      dom-split : {A : Set} → (Γ1 Γ2 : A ctx) (n : Nat) → dom (Γ1 ∪ Γ2) n → dom Γ1 n + dom Γ2 n
      dom-split Γ4 Γ5 n (π1 , π2) with Γ4 n
      dom-split Γ4 Γ5 n (π1 , π2) | Some x = Inl (x , refl)
      dom-split Γ4 Γ5 n (π1 , π2) | None = Inr (π1 , π2)

      d31 : (n : Nat) → dom (Γ1 ∪ Γ2) n → n # Γ3
      d31 n D with dom-split Γ1 Γ2 n D
      d31 n D | Inl x = π1 D13 n x
      d31 n D | Inr x = π1 D23 n x

      d32 : (n : Nat) → dom Γ3 n → n # (Γ1 ∪ Γ2)
      d32 n D = apart-parts Γ1 Γ2 n (π2 D13 n D) (π2 D23 n D)

  apart-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ1
  apart-union1 Γ1 Γ2 n aprt with Γ1 n
  apart-union1 Γ1 Γ2 n () | Some x
  apart-union1 Γ1 Γ2 n aprt | None = refl

  apart-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ2
  apart-union2 Γ1 Γ2 n aprt with Γ1 n
  apart-union2 Γ3 Γ4 n () | Some x
  apart-union2 Γ3 Γ4 n aprt | None = aprt

  -- if a union is disjoint with a target, so is the left unand
  disjoint-union1 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ1 ## Δ
  disjoint-union1 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du11 , du12
    where
      dom-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ1 n → dom (Γ1 ∪ Γ2) n
      dom-union1 Γ1 Γ2 n (π1 , π2) with Γ1 n
      dom-union1 Γ1 Γ2 n (π1 , π2) | Some x = x , refl
      dom-union1 Γ1 Γ2 n (π1 , ()) | None

      du11 : (n : Nat) → dom Γ1 n → n # Δ
      du11 n dom = ud1 n (dom-union1 Γ1 Γ2 n dom)

      du12 : (n : Nat) → dom Δ n → n # Γ1
      du12 n dom = apart-union1 Γ1 Γ2 n (ud2 n dom)

  -- if a union is disjoint with a target, so is the right unand
  disjoint-union2 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ2 ## Δ
  disjoint-union2 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du21 , du22
    where
      dom-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ2 n → dom (Γ1 ∪ Γ2) n
      dom-union2 Γ1 Γ2 n (π1 , π2) with Γ1 n
      dom-union2 Γ3 Γ4 n (π1 , π2) | Some x = x , refl
      dom-union2 Γ3 Γ4 n (π1 , π2) | None = π1 , π2

      du21 : (n : Nat) → dom Γ2 n → n # Δ
      du21 n dom = ud1 n (dom-union2 Γ1  Γ2 n dom)

      du22 : (n : Nat) → dom Δ n → n # Γ2
      du22 n dom = apart-union2 Γ1 Γ2 n (ud2 n dom)

open import Prelude
open import Nat
open import core
open import contexts

module lemmas-disjointness where
  -- disjointness is commutative
  ##-comm : {A : Set} {Δ1 Δ2 : A ctx} → Δ1 ## Δ2 → Δ2 ## Δ1
  ##-comm (π1 , π2) = π2 , π1

  -- the empty context is disjoint from any context
  empty-disj : {A : Set} (Γ : A ctx) → ∅ ## Γ
  empty-disj Γ = ed1 , ed2
   where
    ed1 : {A : Set} (n : Nat) → dom {A} ∅ n → n # Γ
    ed1 n (π1 , ())

    ed2 : {A : Set} (n : Nat) → dom Γ n →  _#_ {A} n ∅
    ed2 _ _ = refl

  -- two singleton contexts with different indices are disjoint
  disjoint-singles : {A : Set} {x y : A} {u1 u2 : Nat} → u1 ≠ u2 → (■ (u1 , x)) ## (■ (u2 , y))
  disjoint-singles {_} {x} {y} {u1} {u2} neq = ds1 , ds2
    where
      ds1 : (n : Nat) → dom (■ (u1 , x)) n → n # (■ (u2 , y))
      ds1 n d with lem-dom-eq _ _ _ d
      ds1 .u1 d | refl with natEQ u2 u1
      ds1 .u1 d | refl | Inl xx = abort (neq (! xx))
      ds1 .u1 d | refl | Inr x₁ = refl

      ds2 : (n : Nat) → dom (■ (u2 , y)) n → n # (■ (u1 , x))
      ds2 n d with lem-dom-eq _ _ _ d
      ds2 .u2 d | refl with natEQ u1 u2
      ds2 .u2 d | refl | Inl x₁ = abort (neq x₁)
      ds2 .u2 d | refl | Inr x₁ = refl

  -- the only index of a singleton context is in its domain
  lem-domsingle : {A : Set} (p : Nat) (q : A) → dom (■ (p , q)) p
  lem-domsingle p q with natEQ p p
  lem-domsingle p q | Inl refl = q , refl
  lem-domsingle p q | Inr x₁ = abort (x₁ refl)

  -- if singleton contexts are disjoint, their indices must be disequal
  singles-notequal : {A : Set} {x y : A} {u1 u2 : Nat} →
                          (■ (u1 , x)) ## (■ (u2 , y)) →
                          u1 ≠ u2
  singles-notequal {A} {x} {y} {u1} {u2} (d1 , d2) = lem2 u1 u2 y (d1 u1 (lem-domsingle u1 x))
    where
      lem2 : {A : Set} (p r : Nat) (q : A) → p # (■ (r , q)) → p ≠ r
      lem2 p r q apt with natEQ r p
      lem2 p .p q apt | Inl refl = abort (somenotnone apt)
      lem2 p r q apt | Inr x₁ = flip x₁

  -- dual of lem2 above; if two indices are disequal, then either is apart
  -- from the singleton formed with the other
  apart-singleton : {A : Set} → ∀{x y} → {τ : A} →
                          x ≠ y →
                          x # (■ (y , τ))
  apart-singleton {A} {x} {y} {τ} neq with natEQ y x
  apart-singleton neq | Inl x₁ = abort ((flip neq) x₁)
  apart-singleton neq | Inr x₁ = refl

  -- if an index is apart from two contexts, it's apart from their union as
  -- well. used below and in other files, so it's outside the local scope.
  apart-parts : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # Γ1 → n # Γ2 → n # (Γ1 ∪ Γ2)
  apart-parts Γ1 Γ2 n apt1 apt2 with Γ1 n
  apart-parts _ _ n refl apt2 | .None = apt2

  -- this is just for convenience; it shows up a lot.
  apart-extend1 : {A : Set} → ∀{ x y τ} → (Γ : A ctx)  → x ≠ y → x # Γ → x # (Γ ,, (y , τ))
  apart-extend1 {A} {x} {y} {τ} Γ neq apt = apart-parts Γ (■ (y , τ)) x apt (apart-singleton neq)

  -- if both parts of a union are disjoint with a target, so is the union
  disjoint-parts : {A : Set} {Γ1 Γ2 Γ3 : A ctx} → Γ1 ## Γ3 → Γ2 ## Γ3 → (Γ1 ∪ Γ2) ## Γ3
  disjoint-parts {_} {Γ1} {Γ2} {Γ3} D13 D23 = d31 , d32
    where
      dom-split : {A : Set} → (Γ1 Γ2 : A ctx) (n : Nat) → dom (Γ1 ∪ Γ2) n → dom Γ1 n + dom Γ2 n
      dom-split Γ4 Γ5 n (π1 , π2) with Γ4 n
      dom-split Γ4 Γ5 n (π1 , π2) | Some x = Inl (x , refl)
      dom-split Γ4 Γ5 n (π1 , π2) | None = Inr (π1 , π2)

      d31 : (n : Nat) → dom (Γ1 ∪ Γ2) n → n # Γ3
      d31 n D with dom-split Γ1 Γ2 n D
      d31 n D | Inl x = π1 D13 n x
      d31 n D | Inr x = π1 D23 n x

      d32 : (n : Nat) → dom Γ3 n → n # (Γ1 ∪ Γ2)
      d32 n D = apart-parts Γ1 Γ2 n (π2 D13 n D) (π2 D23 n D)

  -- if a union is disjoint with a target, so is the left unand
  disjoint-union1 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ1 ## Δ
  disjoint-union1 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du11 , du12
    where
      dom-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ1 n → dom (Γ1 ∪ Γ2) n
      dom-union1 Γ1 Γ2 n (π1 , π2) with Γ1 n
      dom-union1 Γ1 Γ2 n (π1 , π2) | Some x = x , refl
      dom-union1 Γ1 Γ2 n (π1 , ()) | None

      apart-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ1
      apart-union1 Γ1 Γ2 n aprt with Γ1 n
      apart-union1 Γ1 Γ2 n () | Some x
      apart-union1 Γ1 Γ2 n aprt | None = refl

      du11 : (n : Nat) → dom Γ1 n → n # Δ
      du11 n dom = ud1 n (dom-union1 Γ1 Γ2 n dom)

      du12 : (n : Nat) → dom Δ n → n # Γ1
      du12 n dom = apart-union1 Γ1 Γ2 n (ud2 n dom)

  -- if a union is disjoint with a target, so is the right unand
  disjoint-union2 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ2 ## Δ
  disjoint-union2 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du21 , du22
    where
      dom-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ2 n → dom (Γ1 ∪ Γ2) n
      dom-union2 Γ1 Γ2 n (π1 , π2) with Γ1 n
      dom-union2 Γ3 Γ4 n (π1 , π2) | Some x = x , refl
      dom-union2 Γ3 Γ4 n (π1 , π2) | None = π1 , π2

      apart-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ2
      apart-union2 Γ1 Γ2 n aprt with Γ1 n
      apart-union2 Γ3 Γ4 n () | Some x
      apart-union2 Γ3 Γ4 n aprt | None = aprt

      du21 : (n : Nat) → dom Γ2 n → n # Δ
      du21 n dom = ud1 n (dom-union2 Γ1  Γ2 n dom)

      du22 : (n : Nat) → dom Δ n → n # Γ2
      du22 n dom = apart-union2 Γ1 Γ2 n (ud2 n dom)


update HoTT , remove postulate for hae

update HoTT , remove postulate for hae

{-# 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               ∎

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

!-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

ap-∘ : ∀ {a b c}{A : Set a}{B : Set b}{C : Set c}(f : B → C)(g : A → B){x y}(p : x ≡ y)
       → ap (f ∘ g) p ≡ ap f (ap g p)
ap-∘ f g 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 ?!} ∙ {!!}

      hae : HAE (qinv g f-g' g-f)
      hae a = ∙-cancel′ (ap (f ∘ g) (f-g (f a)))
        (ap (f ∘ g) (f-g (f a)) ∙ ap f (g-f a) ≡⟨ ∙= (ap-nat-id f-g (f a)) (! ap-id (ap f (g-f a))) ⟩
         f-g (f (g (f a))) ∙ ap id (ap f (g-f a))  ≡⟨ ! ap-nat f-g {f (g (f a))} {f a} (ap f (g-f a)) ⟩
         ap (f ∘ g) (ap f (g-f a)) ∙ f-g (f a)    ≡⟨ ap (flip _∙_ (f-g (f a))) (! ap-∘ (f ∘ g) f (g-f a)
                                                                               ∙ ap-∘ f (g ∘ f) (g-f a))  ⟩
         ap f (ap (λ z → g (f z)) (g-f a)) ∙ f-g (f a) ≡⟨ ap (flip _∙_ (f-g (f a))) (ap (ap f) (ap-nat-id g-f a)) ⟩
         ap f (g-f (g (f a))) ∙ f-g (f a)      ≡⟨ ! p∙!p∙q (ap (f ∘ g) (f-g (f a))) (ap f (g-f (g (f a))) ∙ f-g (f a)) ⟩
         ap (f ∘ g) (f-g (f a)) ∙ ! ap (f ∘ g) (f-g (f a)) ∙ ap f (g-f (g (f a))) ∙ f-g (f a)    ∎
        )

      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))

      Is-contr→is-prop : Is-contr A → is-prop A
      Is-contr→is-prop (x , p) y z
         = ! p y ∙ p z
         , J' (λ y₁ z₁ q → ! p y₁ ∙ p z₁ ≡ q) (!-∙ ∘ p)

      {-
      has-level-up : ∀ {n} → has-level n A → has-level ⟨S n ⟩ A
      has-level-up {⟨-2⟩} = Is-contr→is-prop
      has-level-up {⟨S n ⟩} π x y p q = {!!}

      Is-contr-is-prop : is-prop (Is-contr A)
      Is-contr-is-prop (x , p) (y , q) = ?

      module _ {{_ : FunExt}} where
        is-prop-is-prop : has-all-paths (has-all-paths A)
        is-prop-is-prop h0 h1 = λ= λ x → λ= λ y → {!!}
      -}

𝟘-is-prop : is-prop 𝟘
𝟘-is-prop () _

𝟘-has-all-paths : has-all-paths 𝟘
𝟘-has-all-paths () _

𝟙-is-contr : Is-contr 𝟙
𝟙-is-contr = _ , λ _ → idp

𝟙-is-prop : is-prop 𝟙
𝟙-is-prop = Is-contr→is-prop 𝟙-is-contr

𝟙-has-all-paths : has-all-paths 𝟙
𝟙-has-all-paths _ _ = idp

module _ {{_ : FunExt}}{a b}{A : ★_ a}{B : A → ★_ b} where
  Π-has-all-paths : (∀ x → has-all-paths (B x)) → has-all-paths (Π A B)
  Π-has-all-paths B-has-all-paths f g
    = λ= λ _ → B-has-all-paths _ _ _

  Π-is-prop : (∀ x → is-prop (B x)) → is-prop (Π A B)
  Π-is-prop B-is-prop = all-paths-is-prop (Π-has-all-paths (prop-has-all-paths ∘ B-is-prop))

module _ {{_ : FunExt}}{a}{A : ★_ a} where
    ¬-has-all-paths : has-all-paths (¬ A)
    ¬-has-all-paths = Π-has-all-paths (λ _ → 𝟘-has-all-paths)

    ¬-is-prop : is-prop (¬ A)
    ¬-is-prop = Π-is-prop (λ _ → 𝟘-is-prop)

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')
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))

      Is-contr→is-prop : Is-contr A → is-prop A
      Is-contr→is-prop (x , p) y z
         = ! p y ∙ p z
         , J' (λ y₁ z₁ q → ! p y₁ ∙ p z₁ ≡ q) (!-∙ ∘ p)

      {-
      has-level-up : ∀ {n} → has-level n A → has-level ⟨S n ⟩ A
      has-level-up {⟨-2⟩} = Is-contr→is-prop
      has-level-up {⟨S n ⟩} π x y p q = {!!}

      Is-contr-is-prop : is-prop (Is-contr A)
      Is-contr-is-prop (x , p) (y , q) = ?

      module _ {{_ : FunExt}} where
        is-prop-is-prop : has-all-paths (has-all-paths A)
        is-prop-is-prop h0 h1 = λ= λ x → λ= λ y → {!!}
      -}

𝟘-is-prop : is-prop 𝟘
𝟘-is-prop () _

𝟘-has-all-paths : has-all-paths 𝟘
𝟘-has-all-paths () _

𝟙-is-contr : Is-contr 𝟙
𝟙-is-contr = _ , λ _ → idp

𝟙-is-prop : is-prop 𝟙
𝟙-is-prop = Is-contr→is-prop 𝟙-is-contr

𝟙-has-all-paths : has-all-paths 𝟙
𝟙-has-all-paths _ _ = idp

module _ {{_ : FunExt}}{a b}{A : ★_ a}{B : A → ★_ b} where
  Π-has-all-paths : (∀ x → has-all-paths (B x)) → has-all-paths (Π A B)
  Π-has-all-paths B-has-all-paths f g
    = λ= λ _ → B-has-all-paths _ _ _

  Π-is-prop : (∀ x → is-prop (B x)) → is-prop (Π A B)
  Π-is-prop B-is-prop = all-paths-is-prop (Π-has-all-paths (prop-has-all-paths ∘ B-is-prop))

module _ {{_ : FunExt}}{a}{A : ★_ a} where
    ¬-has-all-paths : has-all-paths (¬ A)
    ¬-has-all-paths = Π-has-all-paths (λ _ → 𝟘-has-all-paths)

    ¬-is-prop : is-prop (¬ A)
    ¬-is-prop = Π-is-prop (λ _ → 𝟘-is-prop)

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

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


True/False and lt/le

True/False and lt/le

data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]      ++ ys = ys
x :: xs ++ ys = x :: (xs ++ ys)

data Vec (A : Set) : ℕ -> Set where
  nil  : Vec A O
  cons : (n : ℕ) -> A -> Vec A n -> Vec A (S n)

head : {A : Set} {n : ℕ} -> Vec A (S n) -> A
head (cons n v vs) = v

vmap : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap .O f nil = nil
vmap .(S n) f (cons n x xs) = cons n (f x) (vmap n f xs)

vmap′ : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap′ O f nil = nil
vmap′ (S n) f (cons .n x xs) = cons n (f x) (vmap n f xs)

data Fin : ℕ -> Set where
  fzero : {n : ℕ} -> Fin (S n)
  fsuc  : {n : ℕ} -> Fin n -> Fin (S n)

_!_ : {n : ℕ}{A : Set} -> Vec A n -> Fin n -> A
nil ! ()
cons n x a ! fzero = x
cons n x a ! fsuc b = a ! b

tabulate : {n : ℕ}{A : Set} -> (Fin n -> A) -> Vec A n
tabulate {O} f = nil
tabulate {S n} f = cons n (f fzero) (tabulate (f ∘ fsuc))

data   False : Set where
record True  : Set where

trivial : True
trivial = _

isTrue : Bool -> Set
isTrue true  = True
isTrue false = False

_<_ : ℕ -> ℕ -> Bool
_   < O   = false
O   < S n = true
S m < S n = m < n

length : {A : Set} -> List A -> ℕ
length [] = O
length (x :: xs) = S (length xs)

lookup : {A : Set}(xs : List A)(n : ℕ) -> isTrue (n < length xs) -> A
lookup (x :: xs) O b = x
lookup (x :: xs) (S n) b = lookup xs n b
lookup [] a ()

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

data _≤_ : ℕ -> ℕ -> Set where
  ≤O : {m n : ℕ} -> m == n -> m ≤ n
  ≤I : {m n : ℕ} -> m ≤  n -> m ≤ S n

leq-trans : {l m n : ℕ} -> l ≤ m -> m ≤ n -> l ≤ n
leq-trans (≤O refl) b = b
leq-trans a (≤O refl) = a
leq-trans (≤I a) (≤I b) = ≤I (leq-trans (≤I a) b)


Rename Δbase to ΔBase.

Rename Δbase to ΔBase.

Old-commit-hash: e9efdc6e4dd5d76003e901e1ef557ec049d5e59c

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

module Structure where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply diff apply {base ι} = diff , apply
  lift-diff-apply diff apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
      _⊝σ_ = λ s t  → app (app diffσ s) t
      _⊝τ_ = λ s t  → app (app diffτ s) t
      _⊕σ_ = λ t Δt → app (app applyσ Δt) t
      _⊕τ_ = λ t Δt → app (app applyτ Δt) t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff diff apply = λ {τ Γ} →
    proj₁ (lift-diff-apply diff apply {τ} {Γ})

  lift-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply diff apply = λ {τ Γ} →
    proj₂ (lift-diff-apply diff apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (Δbase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base Δbase

open import Data.Product

module Structure where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply diff apply {base ι} = diff , apply
  lift-diff-apply diff apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
      _⊝σ_ = λ s t  → app (app diffσ s) t
      _⊝τ_ = λ s t  → app (app diffτ s) t
      _⊕σ_ = λ t Δt → app (app applyσ Δt) t
      _⊕τ_ = λ t Δt → app (app applyτ Δt) t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff diff apply = λ {τ Γ} →
    proj₁ (lift-diff-apply diff apply {τ} {Γ})

  lift-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply diff apply = λ {τ Γ} →
    proj₂ (lift-diff-apply diff apply {τ} {Γ})


Fixed doc.

Fixed doc.

Ignore-this: d55be4ca0f940a641e282a1d090c1131

darcs-hash:20110401164324-3bd4e-1a750e87a1161fdbc62774ee881f3bad9df90b27.gz

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : (x : D) →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(n,x) → app₁(n,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : (x : D) →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ P. app₁(P,zero) →
--      (∀ x. app1(N,x) → app₁(P,x) → app₁(P,succ x)) →   -- indN
--      (∀ x. app₁(N,x) → app₁(P,x))
------------------------------------------------------------------
-- ∀ x y. app₁(N,x) → app₁(N,y) → app₁(N, x + y)          -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}


Updated doc.

Updated doc.

Ignore-this: f1c847e6477e6855e3eee9457be98c6e

darcs-hash:20110814055030-3bd4e-c4503592e0b36a3ab621331a0f9330790448d922.gz

------------------------------------------------------------------------------
-- The relation of divisibility on partial natural numbers
------------------------------------------------------------------------------

module FOTC.Data.Nat.Divisibility.By0 where

open import FOTC.Base

open import FOTC.Data.Nat

-- We add 3 to the fixities of the standard library.
infix 7 _∣_

------------------------------------------------------------------------------
-- The relation of divisibility.
-- The symbol is '\mid' not '|'.
-- It seems there is not agreement about if 0∣0, e.g.
-- * Agda standard library, version 0.5: 0|0
-- * Coq 8.3pl2: 0∣0
-- * Hardy and Wright. An introduction to the theory of numbers. 1975. 4ed: 0∤0
-- * Isabelle, version Isabelle2011: 0∣0
--
-- In our definition 0∣0, which is used to prove properties of the gcd
-- as it is in GHC 7.2.1, where gcd 0 0 = 0 (see
-- http://hackage.haskell.org/trac/ghc/ticket/3304).
_∣_ : D → D → Set
d ∣ e = ∃ λ k → N k ∧ e ≡ k * d
{-# ATP definition _∣_ #-}

------------------------------------------------------------------------------
-- The relation of divisibility on partial natural numbers
------------------------------------------------------------------------------

module FOTC.Data.Nat.Divisibility.By0 where

open import FOTC.Base

open import FOTC.Data.Nat

-- We add 3 to the fixities of the standard library.
infix 7 _∣_

------------------------------------------------------------------------------
-- The relation of divisibility.
-- The symbol is '\mid' not '|'.
-- It seems there is not agreement about if 0∣0, e.g.
-- * Agda standard library, version 0.5: 0|0
-- * Coq 8.3pl2: 0∣0
-- * Hardy and Wright. An introduction to the theory of numbers. 1975. 4ed: 0∤0
-- * Isabelle, version Isabelle2011: 0∣0
--
-- In our definition 0∣0, which is used to prove properties of the gcd as
-- it is in GHC HEAD (7.1.20110615), where gcd 0 0 = 0 (see
-- http://hackage.haskell.org/trac/ghc/ticket/3304).
_∣_ : D → D → Set
d ∣ e = ∃ λ k → N k ∧ e ≡ k * d
{-# ATP definition _∣_ #-}


More Data.Bits operations and proofs

More Data.Bits operations and proofs

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
open import Relation.Binary.PropositionalEquality.NP
open import Algebra.FunctionProperties
import Data.List as L

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true

Bits : ℕ → Set
Bits = Vec Bit

0… : ∀ {n} → Bits n
0… = replicate 0b

-- Warning: 0… {0} ≡ 1… {0}
1… : ∀ {n} → Bits n
1… = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1…

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1… ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1… x) ⟩
         x ⊕ (x ⊕ 1…) ≡⟨ sym (⊕-assoc x x 1…) ⟩
         (x ⊕ x) ⊕ 1… ≡⟨ cong (flip _⊕_ 1…) (⊕-≡ x) ⟩
         0… ⊕ 1…       ≡⟨ ⊕-left-identity 1… ⟩
         1… ∎ where open ≡-Reasoning

msb : ∀ {n} k → Bits (k + n) → Bits k
msb zero    bs       = []
msb (suc k) (b ∷ bs) = b ∷ msb k bs

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Maybe (Bits n)
sucBCarry [] = nothing
sucBCarry (0b ∷ xs) = just (maybe′ 0∷_ (1b ∷ 0…) (sucBCarry xs))
sucBCarry (1b ∷ xs) = maybe′ (just ∘′ 1∷_) nothing (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB xs = maybe′ id 0… (sucBCarry xs)

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0… sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Bool
open import Data.Fin using (Fin; zero; suc; toℕ; #_; inject₁)
open import Data.Vec hiding (_⊛_) renaming (map to vmap)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry)
open import Function.NP hiding (_→⟨_⟩_)
open import Relation.Binary.PropositionalEquality
open import Algebra.FunctionProperties
import Data.List as L

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true
{-
data Bit : Set where
  0b 1b : Bit
-}

Bits : ℕ → Set
Bits = Vec Bit

0… : ∀ {n} → Bits n
0… = replicate 0b

-- Warning: 0… {0} ≡ 1… {0}
1… : ∀ {n} → Bits n
1… = replicate 1b

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1…

postulate
  ⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
  ⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
  ⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
  ⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
  ⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b

  ⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
  -- x ⊕ vnot x ≡ x ⊕ (1… ⊕ x) ≡ (x ⊕ x) ⊕ 1… ≡ 0… ⊕ 1… ≡ 1…

msb : ∀ {n} k → Bits (k + n) → Bits k
msb zero    bs       = []
msb (suc k) (b ∷ bs) = b ∷ msb k bs

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =

11ᵇ : Bits 2
11ᵇ = 1b ∷ 1b ∷ []

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

bits⁴ : Vec (Bits 4) 16
bits⁴ = fromList $ replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))
  where open RawMonad L.monad

0000b = bits⁴ ! # 0
0001b = bits⁴ ! # 1
0010b = bits⁴ ! # 2
0011b = bits⁴ ! # 3
0100b = bits⁴ ! # 4
0101b = bits⁴ ! # 5
0110b = bits⁴ ! # 6
0111b = bits⁴ ! # 7
1000b = bits⁴ ! # 8
1001b = bits⁴ ! # 9
1010b = bits⁴ ! # 10
1011b = bits⁴ ! # 11
1100b = bits⁴ ! # 12
1101b = bits⁴ ! # 13
1110b = bits⁴ ! # 14
1111b = bits⁴ ! # 15

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup
{- alternative
η {zero} = λ _ → []
η {suc n} = λ xs → head xs ∷ η (tail xs)
-}


Desc model: proof-psi-phi implicit and slightly refactored


Disable reflection for now

Disable reflection for now

module parametricity where
import Data.Bool.Param.NatBool
import Data.Dec.Param.Binary
import Data.Dec.Param.Unary
import Data.Fin.Param.Binary
import Data.Maybe.Param.Binary
import Data.Maybe.Param.Unary
import Data.Nat.Param.Binary
import Data.One.Param.Binary
import Data.One.Param.Unary
import Data.Product.Param.Binary
import Data.Product.Param.Unary
import Data.Sum.Param.Binary
import Data.Sum.Param.Unary
import Data.Two.Param.Binary
import Data.Two.Param.Unary
import Data.Zero.Param.Binary
import Data.Zero.Param.Unary
import Function.Param.Binary
import Function.Param.Unary
{-
import Reflection.NP
import Reflection.Param
import Reflection.Param.Env
import Reflection.Param.Tests
-}
import Type.Param.Binary
import Type.Param.Unary

module parametricity where
import Data.Bool.Param.NatBool
import Data.Dec.Param.Binary
import Data.Dec.Param.Unary
import Data.Fin.Param.Binary
import Data.Maybe.Param.Binary
import Data.Maybe.Param.Unary
import Data.Nat.Param.Binary
import Data.One.Param.Binary
import Data.One.Param.Unary
import Data.Product.Param.Binary
import Data.Product.Param.Unary
import Data.Sum.Param.Binary
import Data.Sum.Param.Unary
import Data.Two.Param.Binary
import Data.Two.Param.Unary
import Data.Zero.Param.Binary
import Data.Zero.Param.Unary
import Function.Param.Binary
import Function.Param.Unary
import Reflection.NP
import Reflection.Param
import Reflection.Param.Env
import Reflection.Param.Tests
import Type.Param.Binary
import Type.Param.Unary


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

module LeastFixedPoints where

open import FOTC.Base

infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least fixed-point of a functor

-- Instead defining the least fixed-point via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
NatF : (D → Set) → D → Set
NatF P n = n ≡ zero ∨ (∃[ m ] P m ∧ n ≡ succ₁ m)

-- The natural numbers are the least fixed-point of NatF.
postulate
  N : D → Set

  -- N is a pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁ : ∀ {n} → n ≡ zero ∨ (∃[ n' ] N n' ∧ n ≡ succ₁ n') → N n
  -- N-lfp₁ : ∀ n → NatF N n → N n  -- Higher-order version

  -- N is a the least pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂ : (A : D → Set) →
           (∀ {n} → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n') → A n) →
           ∀ {n} → N n → A n
  -- N-lfp₂ : (A : D → Set) →  -- Higher-order version
  --          (∀ {n} → NatF A n → A n) →
  --          ∀ {n} → N n → A n

------------------------------------------------------------------------------
-- The data constructors of N.
nzero : N zero
nzero = N-lfp₁ (inj₁ refl)

nsucc : ∀ {n} → N n → N (succ₁ n)
nsucc Nn = N-lfp₁ (inj₂ (_ , (Nn , refl)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also a post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → N m ∧ n ≡ succ₁ m)
N-lfp₃ Nn = N-lfp₂ A prf Nn
  where
  A : D → Set
  A x = x ≡ zero ∨ (∃ λ n' → N n' ∧ x ≡ succ₁ n')

  prf : ∀ {n''} → n'' ≡ zero ∨ (∃[ n' ] A n' ∧ n'' ≡ succ₁ n') → A n''
  prf {n''} h = case inj₁ ((λ h₁ → inj₂ (prf₁ h₁))) h -- case inj₁ prf₁ h
    where
    prf₁ : ∃ (λ n' → A n' ∧ n'' ≡ succ₁ n') → ∃ (λ n' → N n' ∧ n'' ≡ succ₁ n')
    prf₁ (n' , An' , n''=Sn') = n' , prf₂ An' , n''=Sn'
      where
      prf₂ : A n' → N n'
      prf₂ An' = case (λ ah → subst N (sym ah) nzero) prf₃ An'
        where
        prf₃ : ∃ (λ m' → N m' ∧ n' ≡ succ₁ m') → N n'
        prf₃ (_ , Nm' , m≡Sm' ) = subst N (sym m≡Sm') (nsucc Nm')

------------------------------------------------------------------------------
-- The induction principle for N *without* the hypothesis N n in the
-- induction step.
N-ind : (A : D → Set) →
        A zero →
        (∀ {n} → A n → A (succ₁ n)) →
        ∀ {n} → N n → A n
N-ind A A0 h Nn = N-lfp₂ A (case prf₁ prf₂) Nn
  where
  prf₁ : ∀ {n'} → n' ≡ zero → A n'
  prf₁ n'≡0 = subst A (sym n'≡0) A0

  prf₂ : ∀ {n'} → ∃ (λ m → A m ∧ n' ≡ succ₁ m) → A n'
  prf₂ (_ , Am , n'≡Sm) = subst A (sym n'≡Sm) (h Am)

-- The induction principle for N *with* the hypothesis N n in the
-- induction step.
--
-- 2012-03-06. We cannot proof this principle because N-lfp₂ does not
-- have the hypothesis N n.
--
-- indN₂ : (A : D → Set) →
--        A zero →
--        (∀ {n} → N n → A n → A (succ₁ n)) →
--        ∀ {n} → N n → A n
-- indN₂ A A0 is Nn = N-lfp₂ A [ prf₁ , prf₂ ] Nn
--   where
--   prf₁ : ∀ {n'} → n' ≡ zero → A n'
--   prf₁ n'≡0 = subst A (sym n'≡0) A0

--   prf₂ : ∀ {n'} → ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
--   prf₂ {n'} (m , n'≡Sm , Am) = subst A (sym n'≡Sm) (is helper Am)
--     where
--     helper : N m
--     helper = [ prf₃ , prf₄ ] (N-lfp₃ {!!})
--       where
--       prf₃ : n' ≡ zero → N m
--       prf₃ n'≡0 = ⊥-elim (0≢S (trans (sym n'≡0) n'≡Sm))

--       prf₄ : ∃ (λ m' → n' ≡ succ₁ m' ∧ N m') → N m
--       prf₄ (_ , n'≡Sm' , Nm') =
--         subst N (succInjective (trans (sym n'≡Sm') n'≡Sm)) Nm'

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero    + d ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = N-lfp₂ A prf Nm
  where
  A : D → Set
  A i = N (i + n)

  prf : ∀ {m'} → m' ≡ zero ∨ ∃ (λ m'' → A m'' ∧ m' ≡ succ₁ m'') → A m'
  prf h = case prf₁ prf₂ h
    where
    A0 : A zero
    A0 = subst N (sym (+-leftIdentity n)) Nn

    prf₁ : ∀ {m} → m ≡ zero → A m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) A0

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)

    prf₂ : ∀ {m} → ∃ (λ m'' → A m'' ∧ m ≡ succ₁ m'') → A m
    prf₂ (_ ,  Am'' , m≡Sm'') =
      subst N (cong (flip _+_ n) (sym m≡Sm'')) (is Am'')

------------------------------------------------------------------------------
-- From/to N as a least fixed-point to/from N as data type.

open import FOTC.Data.Nat.Type renaming
  ( N to N'
  ; N-ind to N-ind'
  ; nsucc to nsucc'
  ; nzero to nzero'
  )

thm₁ : ∀ {n} → N' n → N n
thm₁ nzero' = nzero
thm₁ (nsucc' Nn) = nsucc (thm₁ Nn)

thm₂ : ∀ {n} → N n → N' n
thm₂ Nn = N-ind N' nzero' nsucc' Nn

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

module LeastFixedPoints where

open import FOTC.Base
open import FOTC.Base.PropertiesI

-- infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least fixed-point of a functor

-- Instead defining the least fixed-point via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
NatF : (D → Set) → D → Set
NatF P n = n ≡ zero ∨ (∃[ m ] P m ∧ n ≡ succ₁ m)

-- The natural numbers are the least fixed-point of NatF.
postulate
  N : D → Set

  -- N is a pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁    : ∀ {n} → n ≡ zero ∨ (∃[ m ] N m ∧ n ≡ succ₁ m) → N n
  -- N-lfp₁ : ∀ n → NatF N n → N n  -- Higher-order version

  -- N is a the least pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂    : (A : D → Set) →
              (∀ {n} → n ≡ zero ∨ (∃[ m ] A m ∧ n ≡ succ₁ m) → A n) →
              ∀ {n} → N n → A n
  -- N-lfp₂ : (A : D → Set) →  -- Higher-order version
  --          (∀ {n} → NatF A n → A n) →
  --          ∀ {n} → N n → A n

------------------------------------------------------------------------------
-- The data constructors of N.
zN : N zero
zN = N-lfp₁ (inj₁ refl)

sN : ∀ {n} → N n → N (succ₁ n)
sN Nn = N-lfp₁ (inj₂ (_ , (Nn , refl)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also a post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → N m ∧ n ≡ succ₁ m)
N-lfp₃ Nn = N-lfp₂ A prf Nn
  where
  A : D → Set
  A x = x ≡ zero ∨ (∃ λ m → N m ∧ x ≡ succ₁ m)

  prf : ∀ {n'} → n' ≡ zero ∨ (∃[ m ] A m ∧ n' ≡ succ₁ m) → A n'
  prf {n'} h = case inj₁ ((λ h₁ → inj₂ (prf₁ h₁))) h -- case inj₁ prf₁ h
    where
    prf₁ : ∃ (λ m → A m ∧ n' ≡ succ₁ m) → ∃ (λ m → N m ∧ n' ≡ succ₁ m)
    prf₁ (m , Am , n'=Sm) = m , prf₂ Am , n'=Sm
      where
      prf₂ : A m → N m
      prf₂ Am = case (λ ah → subst N (sym ah) zN) prf₃ Am
        where
        prf₃ : ∃ (λ m' → N m' ∧ m ≡ succ₁ m') → N m
        prf₃ (_ , Nm' , m≡Sm' ) = subst N (sym m≡Sm') (sN Nm')

------------------------------------------------------------------------------
-- The induction principle for N *without* the hypothesis N n in the
-- induction step.
indN₁ : (A : D → Set) →
       A zero →
       (∀ {n} → A n → A (succ₁ n)) →
       ∀ {n} → N n → A n
indN₁ A A0 is Nn = N-lfp₂ A (case prf₁ prf₂) Nn
  where
  prf₁ : ∀ {n'} → n' ≡ zero → A n'
  prf₁ n'≡0 = subst A (sym n'≡0) A0

  prf₂ : ∀ {n'} → ∃ (λ m → A m ∧ n' ≡ succ₁ m) → A n'
  prf₂ (_ , Am , n'≡Sm) = subst A (sym n'≡Sm) (is Am)

-- The induction principle for N *with* the hypothesis N n in the
-- induction step.
--
-- 2012-03-06. We cannot proof this principle because N-lfp₂ does not
-- have the hypothesis N n.
--
-- indN₂ : (A : D → Set) →
--        A zero →
--        (∀ {n} → N n → A n → A (succ₁ n)) →
--        ∀ {n} → N n → A n
-- indN₂ A A0 is Nn = N-lfp₂ A [ prf₁ , prf₂ ] Nn
--   where
--   prf₁ : ∀ {n'} → n' ≡ zero → A n'
--   prf₁ n'≡0 = subst A (sym n'≡0) A0

--   prf₂ : ∀ {n'} → ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
--   prf₂ {n'} (m , n'≡Sm , Am) = subst A (sym n'≡Sm) (is helper Am)
--     where
--     helper : N m
--     helper = [ prf₃ , prf₄ ] (N-lfp₃ {!!})
--       where
--       prf₃ : n' ≡ zero → N m
--       prf₃ n'≡0 = ⊥-elim (0≢S (trans (sym n'≡0) n'≡Sm))

--       prf₄ : ∃ (λ m' → n' ≡ succ₁ m' ∧ N m') → N m
--       prf₄ (_ , n'≡Sm' , Nm') =
--         subst N (succInjective (trans (sym n'≡Sm') n'≡Sm)) Nm'

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero    + d ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = N-lfp₂ A prf Nm
  where
  A : D → Set
  A i = N (i + n)

  prf : ∀ {m'} → m' ≡ zero ∨ ∃ (λ m'' → A m'' ∧ m' ≡ succ₁ m'') → A m'
  prf h = case prf₁ prf₂ h
    where
    A0 : A zero
    A0 = subst N (sym (+-leftIdentity n)) Nn

    prf₁ : ∀ {m} → m ≡ zero → A m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) A0

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (sN ih)

    prf₂ : ∀ {m} → ∃ (λ m'' → A m'' ∧ m ≡ succ₁ m'') → A m
    prf₂ (_ ,  Am'' , m≡Sm'') =
      subst N (cong (flip _+_ n) (sym m≡Sm'')) (is Am'')