HoTT: Π-is-prop and others

HoTT: Π-is-prop and others

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

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

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

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

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

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

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

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

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

  module _ {x y : A} where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Equivalences where

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

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

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

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

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

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

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

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

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

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

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

      open Biinv has-biinv public

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  open Equiv public

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ℕ₋₂ = T-level

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Add big-lift∧ big-lift∨ lift-✓all-Πᵉ lift-✓any↔Σᵉ

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP renaming (map to ⊎-map)
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.Decidable
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

    findKey : FindKey A
    findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

  _$kit_ : ∀ {p} {P : Explore ℓ A → ★ p} {e : Explore ℓ A}
           → ExploreInd p e → ExploreIndKit p P → P e
  _$kit_ {P = P} ind (mk Pε P∙ Pf) = ind P Pε P∙ Pf

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

  to-extra : ∀ {p} {e : Explore ℓ A} → ExploreInd p e → ExploreInd-Extra p e
  to-extra e-ind Q Q-kit P Pε P∙ Pf =
   snd (e-ind (Q ×° P)
           (Qε , Pε)
           (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
           (λ x → Qf x , Pf x))
   where open ExploreIndKit Q-kit renaming (Pε to Qε; P∙ to Q∙; Pf to Qf)

  ExplorePlug : ∀ {m} (M : Monoid ℓ m) (e : Explore _ A) → ★ _
  ExplorePlug M e = ∀ f x → e∘ ε _∙_ f ∙ x ≈ e∘ x _∙_ f
     where open Mon M
           e∘ = explore-endo e

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore 1 _*_

  big-∧ big-∨ big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  big-lift∧ big-lift∨ : Level → (A → 𝟚) → 𝟚
  big-lift∧ ℓ f = lower (explore {ℓ} (lift 1₂) (lift-op₂ _∧_) (lift ∘ f))
  big-lift∨ ℓ f = lower (explore {ℓ} (lift 0₂) (lift-op₂ _∨_) (lift ∘ f))

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

  list : List A
  list = explore List.[] _++_ List.[_]

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromLookup
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (lookup : ∀ {ℓ} → Lookup {ℓ} explore)
    where

  module CheckDec! {ℓ}{P : A → ★ ℓ}(decP : ∀ x → Dec (P x)) where
    CheckDec! : ★ _
    CheckDec! = explore (Lift 𝟙) _×_ λ x → ✓ ⌊ decP x ⌋

    checkDec! : {p✓ : CheckDec!} → ∀ x → P x
    checkDec! {p✓} x = toWitness (lookup p✓ x)

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

    explore-mono : ExploreMono {ℓ} p explore
    explore-mono _⊆_ z⊆ _∙-mono_ {f} {g} f⊆°g =
      explore-ind (λ e → e _ _ f ⊆ e _ _ g) z⊆ _∙-mono_ f⊆°g

    open ExplorePlug {ℓ} {a} {A}

    explore∘-plug : (M : Monoid ℓ ℓ) → ExplorePlug M explore
    explore∘-plug M = explore-ind $kit plugKit M

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

  module LiftHom
       {m p}
       {S T : ★ m}
       (_≈_ : T → T → ★ p)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (zero : S)
       (_+_  : Op₂ S)
       (one  : T)
       (_*_  : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom-0-1 : f zero ≈ one)
       (hom-+-* : ∀ {x y} → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  -- Since so far S and T should have the same level, we get this mess of resizing
  -- There is a later version based on ⟦explore⟧.
  module _ (f : A → 𝟚) {{_ : UA}} where
    lift-✓all-Πᵉ : ✓ (big-lift∧ ₁ f) ≡ Πᵉ explore (✓ ∘ f)
    lift-✓all-Πᵉ = lift-hom-≡ (lift 1₂) (lift-op₂ _∧_) (Lift 𝟙) _×_ (✓ ∘ lower) (lift ∘ f) (≡.! Lift≡id) (✓-∧-× _ _)

  module _ (f : A → 𝟚) where
    lift-✓any↔Σᵉ : ✓ (big-lift∨ ₁ f) ↔ Σᵉ explore (✓ ∘ f)
    lift-✓any↔Σᵉ = LiftHom.lift-hom _↔_ (id , id) (zip (flip _∘′_) _∘′_)
                     (lift 0₂) (lift-op₂ _∨_) (Lift 𝟘) _⊎_
                     (zip ⊎-map ⊎-map) (✓ ∘ lower) (lift ∘ f)
                     ((λ()) , λ{(lift())}) (✓∨-⊎ , ⊎-✓∨)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext 0 _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ z≤n _+-mono_

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.ap₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

  exploreStableUnder→sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  exploreStableUnder→sumStableUnder SU-p = SU-p 0 _+_

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  sumStableUnder→countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  sumStableUnder→countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = lift-hom-≡ (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

    sum-swap : ∀ f → A.sum (B.sum ∘ f) ≡ B.sum (A.sum ∘ flip f)
    sum-swap = explore-swap' ℕ°.+-commutativeMonoid

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  sum-ext : SumExt sum
  sum-ext = ap sum ∘ λ=

  private
    count : Count A
    count f = sum (𝟚▹ℕ ∘ f)

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

{-
module ExplorableRecord where
    record Explorable A : ★₁ where
      constructor mk
      field
        explore     : Explore₀ A
        explore-ind : ExploreInd₀ explore

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

    ExploreForFun : ★₀ → ★₁
    ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

    record Funable A : ★₂ where
      constructor _,_
      field
        explorable : Explorable A
        negative   : ExploreForFun A

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

      DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

    DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
    DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                       ∀ _*_ → Zero _≈_ ε _*_ → _DistributesOver_ _≈_ _*_ _∙_ → _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                       → DistFun.DistFun μA μA→ μB _≈_ ε _∙_ _*_

    DistFunable : ∀ {A} → Funable A → ★₁
    DistFunable (μA , μA→) = DistFun μA μA→

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.Decidable
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

    findKey : FindKey A
    findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

  _$kit_ : ∀ {p} {P : Explore ℓ A → ★ p} {e : Explore ℓ A}
           → ExploreInd p e → ExploreIndKit p P → P e
  _$kit_ {P = P} ind (mk Pε P∙ Pf) = ind P Pε P∙ Pf

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

  to-extra : ∀ {p} {e : Explore ℓ A} → ExploreInd p e → ExploreInd-Extra p e
  to-extra e-ind Q Q-kit P Pε P∙ Pf =
   snd (e-ind (Q ×° P)
           (Qε , Pε)
           (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
           (λ x → Qf x , Pf x))
   where open ExploreIndKit Q-kit renaming (Pε to Qε; P∙ to Q∙; Pf to Qf)

  ExplorePlug : ∀ {m} (M : Monoid ℓ m) (e : Explore _ A) → ★ _
  ExplorePlug M e = ∀ f x → e∘ ε _∙_ f ∙ x ≈ e∘ x _∙_ f
     where open Mon M
           e∘ = explore-endo e

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore 1 _*_

  big-∧ and big-∨ or big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

  list : List A
  list = explore List.[] _++_ List.[_]

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromLookup
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (lookup : ∀ {ℓ} → Lookup {ℓ} explore)
    where

  module CheckDec! {ℓ}{P : A → ★ ℓ}(decP : ∀ x → Dec (P x)) where
    CheckDec! : ★ _
    CheckDec! = explore (Lift 𝟙) _×_ λ x → ✓ ⌊ decP x ⌋

    checkDec! : {p✓ : CheckDec!} → ∀ x → P x
    checkDec! {p✓} x = toWitness (lookup p✓ x)

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

    explore-mono : ExploreMono {ℓ} p explore
    explore-mono _⊆_ z⊆ _∙-mono_ {f} {g} f⊆°g =
      explore-ind (λ e → e _ _ f ⊆ e _ _ g) z⊆ _∙-mono_ f⊆°g

    open ExplorePlug {ℓ} {a} {A}

    explore∘-plug : (M : Monoid ℓ ℓ) → ExplorePlug M explore
    explore∘-plug M = explore-ind $kit plugKit M

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

  module LiftHom
       {m p}
       {S T : ★ m}
       (_≈_ : T → T → ★ p)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (zero : S)
       (_+_  : Op₂ S)
       (one  : T)
       (_*_  : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom-0-1 : f zero ≈ one)
       (hom-+-* : ∀ {x y} → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext 0 _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ z≤n _+-mono_

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.ap₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

  exploreStableUnder→sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  exploreStableUnder→sumStableUnder SU-p = SU-p 0 _+_

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  sumStableUnder→countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  sumStableUnder→countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = LiftHom.lift-hom _≡_ ≡.refl ≡.trans (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ ⊎= (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

    sum-swap : ∀ f → A.sum (B.sum ∘ f) ≡ B.sum (A.sum ∘ flip f)
    sum-swap = explore-swap' ℕ°.+-commutativeMonoid

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  sum-ext : SumExt sum
  sum-ext = ap sum ∘ λ=

  private
    count : Count A
    count f = sum (𝟚▹ℕ ∘ f)

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

{-
module ExplorableRecord where
    record Explorable A : ★₁ where
      constructor mk
      field
        explore     : Explore₀ A
        explore-ind : ExploreInd₀ explore

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

    ExploreForFun : ★₀ → ★₁
    ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

    record Funable A : ★₂ where
      constructor _,_
      field
        explorable : Explorable A
        negative   : ExploreForFun A

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

      DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

    DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
    DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                       ∀ _*_ → Zero _≈_ ε _*_ → _DistributesOver_ _≈_ _*_ _∙_ → _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                       → DistFun.DistFun μA μA→ μB _≈_ ε _∙_ _*_

    DistFunable : ∀ {A} → Funable A → ★₁
    DistFunable (μA , μA→) = DistFun μA μA→

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}


Proof-irrelevance on paths when the type is claimed to be Is-set

-- NOTE with-K
module Relation.Binary.PropositionalEquality.K where

open import Type hiding (★)
open import Relation.Binary.PropositionalEquality
{-
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
-}
open import Relation.Binary.NP
open import Relation.Nullary

module _ where
  postulate
    Is-set : ∀ {a} → Set a → Set a

proof-irrelevance : ∀ {a} {A : Set a} {A-is-set : Is-set A} {x y : A} (p q : x ≡ y) → p ≡ q
proof-irrelevance refl refl = refl

module _ {a} {A : ★ a} where
  _≡≡_ : ∀ {x y : A} (p q : x ≡ y) → p ≡ q
  _≡≡_ refl refl = refl

  _≟≡_ : ∀ {i j : A} → Decidable {A = i ≡ j} _≡_
  _≟≡_ refl refl = yes refl

-- NOTE with-K
module Relation.Binary.PropositionalEquality.K where

open import Type hiding (★)
open import Relation.Binary.PropositionalEquality
{-
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
-}
open import Relation.Binary.NP
open import Relation.Nullary

module _ {a} {A : ★ a} where
  _≡≡_ : ∀ {x y : A} (p q : x ≡ y) → p ≡ q
  _≡≡_ refl refl = refl

  _≟≡_ : ∀ {i j : A} → Decidable {A = i ≡ j} _≡_
  _≟≡_ refl refl = yes refl