------------------------------------------------------------------------
-- Lenses defined in terms of a getter, equivalences between the
-- getter's "preimages", and a coherence property
------------------------------------------------------------------------

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

import Equality.Path as P

module Lens.Non-dependent.Equivalent-preimages
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude renaming (_∘_ to _⊚_)

open import Bijection equality-with-J as B using (_↔_)
open import Equality.Path.Isomorphisms eq hiding (univ)
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as PT using (∥_∥; ∣_∣)
open import Preimage equality-with-J using (_⁻¹_)
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher      eq as Higher
import Lens.Non-dependent.Traditional eq as Traditional

private
  variable
    ℓ       : Level
    A B C   : Set ℓ
    a b c z : A

------------------------------------------------------------------------
-- The lens type family

-- Lenses defined in terms of a getter, equivalences between the
-- getter's "preimages", and a coherence property.
--
-- This definition is based on a suggestion from Andrea Vezzosi. Note
-- that the fields and some derived properties correspond to things
-- discussed by Paolo Capriotti in the context of his higher lenses
-- (http://homotopytypetheory.org/2014/04/29/higher-lenses/).

record Lens (A : Set a) (B : Set b) : Set (a ⊔ b) where
  no-eta-equality
  pattern
  constructor lens
  field
    -- A getter.
    get : A → B

    -- A function from one "preimage" of get to another.
    get⁻¹-const : (b₁ b₂ : B) → get ⁻¹ b₁ → get ⁻¹ b₂

    -- This function is an equivalence.
    get⁻¹-const-equivalence :
      (b₁ b₂ : B) → Is-equivalence (get⁻¹-const b₁ b₂)

    -- A coherence property.
    get⁻¹-const-∘ :
      (b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
      get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p

  -- All the getter's "preimages" are equivalent.

  get⁻¹-constant : (b₁ b₂ : B) → get ⁻¹ b₁ ≃ get ⁻¹ b₂
  get⁻¹-constant b₁ b₂ = Eq.⟨ _ , get⁻¹-const-equivalence b₁ b₂ ⟩

  -- The inverse of get⁻¹-const.

  get⁻¹-const⁻¹ : (b₁ b₂ : B) → get ⁻¹ b₂ → get ⁻¹ b₁
  get⁻¹-const⁻¹ b₁ b₂ = _≃_.from (get⁻¹-constant b₁ b₂)

  -- Some derived coherence properties.

  get⁻¹-const-id :
    (b : B) (p : get ⁻¹ b) → get⁻¹-const b b p ≡ p
  get⁻¹-const-id b p =
    get⁻¹-const b b p                                        ≡⟨ sym $ _≃_.left-inverse-of (get⁻¹-constant _ _) _ ⟩
    get⁻¹-const⁻¹ b b (get⁻¹-const b b (get⁻¹-const b b p))  ≡⟨ cong (get⁻¹-const⁻¹ b b) $ get⁻¹-const-∘ _ _ _ _ ⟩
    get⁻¹-const⁻¹ b b (get⁻¹-const b b p)                    ≡⟨ _≃_.left-inverse-of (get⁻¹-constant _ _) _ ⟩∎
    p                                                        ∎

  get⁻¹-const-inverse :
    (b₁ b₂ : B) (p : get ⁻¹ b₁) →
    get⁻¹-const b₁ b₂ p ≡ get⁻¹-const⁻¹ b₂ b₁ p
  get⁻¹-const-inverse b₁ b₂ p =
    sym $ _≃_.to-from (get⁻¹-constant _ _) (
      get⁻¹-const b₂ b₁ (get⁻¹-const b₁ b₂ p)  ≡⟨ get⁻¹-const-∘ _ _ _ _ ⟩
      get⁻¹-const b₁ b₁ p                      ≡⟨ get⁻¹-const-id _ _ ⟩∎
      p                                        ∎)

  -- A setter.

  set : A → B → A
  set a b =       $⟨ a , refl _ ⟩
    get ⁻¹ get a  ↝⟨ get⁻¹-const (get a) b ⟩
    get ⁻¹ b      ↝⟨ proj₁ ⟩□
    A             □

  -- The lens laws can be proved.

  get-set : ∀ a b → get (set a b) ≡ b
  get-set a b =
    get (proj₁ (get⁻¹-const (get a) b (a , refl _)))  ≡⟨ proj₂ (get⁻¹-const (get a) b (a , refl _)) ⟩∎
    b                                                 ∎

  set-get : ∀ a → set a (get a) ≡ a
  set-get a =
    proj₁ (get⁻¹-const (get a) (get a) (a , refl _))  ≡⟨ cong proj₁ $ get⁻¹-const-id _ _ ⟩∎
    a                                                 ∎

  set-set : ∀ a b₁ b₂ → set (set a b₁) b₂ ≡ set a b₂
  set-set a b₁ b₂ =
    proj₁ (get⁻¹-const (get (set a b₁)) b₂ (set a b₁ , refl _))  ≡⟨ elim¹
                                                                      (λ {b} eq →
                                                                         proj₁ (get⁻¹-const (get (set a b₁)) b₂ (set a b₁ , refl _)) ≡
                                                                         proj₁ (get⁻¹-const b b₂ (set a b₁ , eq)))
                                                                      (refl _)
                                                                      (get-set a b₁) ⟩

    proj₁ (get⁻¹-const b₁ b₂ (set a b₁ , get-set a b₁))          ≡⟨⟩

    proj₁ (get⁻¹-const b₁ b₂
             (get⁻¹-const (get a) b₁ (a , refl _)))              ≡⟨ cong proj₁ $ get⁻¹-const-∘ _ _ _ _ ⟩∎

    proj₁ (get⁻¹-const (get a) b₂ (a , refl _))                  ∎

  -- A traditional lens.

  traditional-lens : Traditional.Lens A B
  traditional-lens = record
    { get     = get
    ; set     = set
    ; get-set = get-set
    ; set-get = set-get
    ; set-set = set-set
    }

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = Lens.get
    ; set = Lens.set
    }

-- The record type above is equivalent to a nested Σ-type.

Lens-as-Σ :
  Lens A B ≃
  ∃ λ (get : A → B) →
  ∃ λ (get⁻¹-const : (b₁ b₂ : B) → get ⁻¹ b₁ → get ⁻¹ b₂) →
    ((b₁ b₂ : B) → Is-equivalence (get⁻¹-const b₁ b₂)) ×
    ((b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
     get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p)
Lens-as-Σ = Eq.↔→≃
  (λ l → get l
       , get⁻¹-const l
       , get⁻¹-const-equivalence l
       , get⁻¹-const-∘ l)
  (λ (g , c , c-e , c-∘) → record
     { get                     = g
     ; get⁻¹-const             = c
     ; get⁻¹-const-equivalence = c-e
     ; get⁻¹-const-∘           = c-∘
     })
  refl
  (λ { (lens _ _ _ _) → refl _ })
  where
  open Lens

-- A variant of Lens-as-Σ.

Lens-as-Σ′ :
  Lens A B ≃
  ∃ λ (get : A → B) →
  ∃ λ (get⁻¹-constant : (b₁ b₂ : B) → get ⁻¹ b₁ ≃ get ⁻¹ b₂) →
    let get⁻¹-const : ∀ _ _ → _
        get⁻¹-const = λ b₁ b₂ → _≃_.to (get⁻¹-constant b₁ b₂) in
    (b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
    get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p
Lens-as-Σ′ {A = A} {B = B} =
  Lens A B                                                             ↝⟨ Lens-as-Σ ⟩

  (∃ λ (get : A → B) →
   ∃ λ (get⁻¹-const : (b₁ b₂ : B) → get ⁻¹ b₁ → get ⁻¹ b₂) →
     ((b₁ b₂ : B) → Is-equivalence (get⁻¹-const b₁ b₂)) ×
     ((b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
      get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p))  ↔⟨ (∃-cong λ _ → Σ-assoc) ⟩

  (∃ λ (get : A → B) →
   ∃ λ ((get⁻¹-const , _) :
        ∃ λ (get⁻¹-const : (b₁ b₂ : B) → get ⁻¹ b₁ → get ⁻¹ b₂) →
          (b₁ b₂ : B) → Is-equivalence (get⁻¹-const b₁ b₂)) →
     (b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
     get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p)    ↝⟨ (∃-cong λ _ →
                                                                           Σ-cong-contra (ΠΣ-comm F.∘ ∀-cong ext (λ _ → ΠΣ-comm)) λ _ → F.id) ⟩
  (∃ λ (get : A → B) →
   ∃ λ (f :
        (b₁ b₂ : B) →
        ∃ λ (get⁻¹-const : get ⁻¹ b₁ → get ⁻¹ b₂) →
          Is-equivalence get⁻¹-const) →
     let get⁻¹-const : ∀ _ _ → _
         get⁻¹-const = λ b₁ b₂ → proj₁ (f b₁ b₂) in
     (b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
     get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p)    ↝⟨ (∃-cong λ _ →
                                                                           Σ-cong-contra (∀-cong ext λ _ → ∀-cong ext λ _ → Eq.≃-as-Σ) λ _ →
                                                                                F.id) ⟩□
  (∃ λ (get : A → B) →
   ∃ λ (get⁻¹-constant : (b₁ b₂ : B) → get ⁻¹ b₁ ≃ get ⁻¹ b₂) →
     let get⁻¹-const : ∀ _ _ → _
         get⁻¹-const = λ b₁ b₂ → _≃_.to (get⁻¹-constant b₁ b₂) in
     (b₁ b₂ b₃ : B) (p : get ⁻¹ b₁) →
     get⁻¹-const b₂ b₃ (get⁻¹-const b₁ b₂ p) ≡ get⁻¹-const b₁ b₃ p)    □

------------------------------------------------------------------------
-- Some results related to h-levels

-- If the domain of a lens is inhabited and has h-level n,
-- then the codomain also has h-level n.

h-level-respects-lens-from-inhabited :
  ∀ n → Lens A B → A → H-level n A → H-level n B
h-level-respects-lens-from-inhabited {A = A} {B = B} n l a =
  H-level n A  ↝⟨ H-level.respects-surjection surj n ⟩□
  H-level n B  □
  where
  open Lens l

  surj : A ↠ B
  surj = record
    { logical-equivalence = record
      { to   = get
      ; from = set a
      }
    ; right-inverse-of = λ b →
        get (set a b)  ≡⟨ get-set a b ⟩∎
        b              ∎
    }

-- If A and B have h-level n given the assumption that the other type
-- is inhabited, then Lens A B has h-level n.

lens-preserves-h-level :
  ∀ n → (B → H-level n A) → (A → H-level n B) →
  H-level n (Lens A B)
lens-preserves-h-level {B = B} {A = A} n hA hB =
  H-level-cong _ n (inverse Lens-as-Σ′) $
  Σ-closure n (Π-closure ext n λ a →
               hB a) λ _ →
  Σ-closure n (Π-closure ext n λ b →
               Π-closure ext n λ _ →
               Eq.h-level-closure ext n
                 (⁻¹-closure (hA b) hB)
                 (⁻¹-closure (hA b) hB)) λ _ →
              (Π-closure ext n λ b →
               Π-closure ext n λ _ →
               Π-closure ext n λ _ →
               Π-closure ext n λ _ →
               ⇒≡ n (⁻¹-closure (hA b) hB))
  where
  ⁻¹-closure :
    {f : A → B} {x : B} →
    H-level n A → (A → H-level n B) →
    H-level n (f ⁻¹ x)
  ⁻¹-closure hA hB =
    Σ-closure n hA λ a →
    ⇒≡ n (hB a)

-- If A has positive h-level n, then Lens A B also has h-level n.

lens-preserves-h-level-of-domain :
  ∀ n → H-level (1 + n) A → H-level (1 + n) (Lens A B)
lens-preserves-h-level-of-domain n hA =
  [inhabited⇒+]⇒+ n λ l →
    lens-preserves-h-level (1 + n) (λ _ → hA) λ a →
      h-level-respects-lens-from-inhabited _ l a hA

------------------------------------------------------------------------
-- Some equality characterisation lemmas

-- An equality characterisation lemma.

equality-characterisation :
  let open Lens in
  {A : Set a} {B : Set b} {l₁ l₂ : Lens A B} →

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (gc : ∀ b₁ b₂ p →
             subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p ≡
             get⁻¹-const l₂ b₁ b₂ p) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (Σ-≡,≡→≡ (⟨ext⟩ g)
          (⟨ext⟩ λ b₁ → ⟨ext⟩ λ b₂ → ⟨ext⟩ λ p → gc b₁ b₂ p))
       (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)
equality-characterisation {l₁ = l₁} {l₂ = l₂} =
  l₁ ≡ l₂                                                      ↝⟨ inverse $ Eq.≃-≡ (lemma₁ F.∘ Lens-as-Σ) ⟩

  ( ((get l₁ , get⁻¹-const l₁) , get⁻¹-const-∘ l₁)
  , get⁻¹-const-equivalence l₁
  ) ≡
  ( ((get l₂ , get⁻¹-const l₂) , get⁻¹-const-∘ l₂)
  , get⁻¹-const-equivalence l₂
  )                                                            ↔⟨ inverse $
                                                                  ignore-propositional-component
                                                                    (Π-closure ext 1 λ _ →
                                                                     Π-closure ext 1 λ _ →
                                                                     Eq.propositional ext _) ⟩
  ((get l₁ , get⁻¹-const l₁) , get⁻¹-const-∘ l₁) ≡
  ((get l₂ , get⁻¹-const l₂) , get⁻¹-const-∘ l₂)               ↔⟨ inverse B.Σ-≡,≡↔≡ ⟩

  (∃ λ (p : (get l₁ , get⁻¹-const l₁) ≡
            (get l₂ , get⁻¹-const l₂)) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       p (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                         ↝⟨ (Σ-cong-contra B.Σ-≡,≡↔≡ λ _ → F.id) ⟩

  (∃ λ (p : ∃ λ (g : get l₁ ≡ get l₂) →
              subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
                g (get⁻¹-const l₁) ≡
              get⁻¹-const l₂) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (uncurry Σ-≡,≡→≡ p) (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                         ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (gc : subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               g (get⁻¹-const l₁) ≡
             get⁻¹-const l₂) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (Σ-≡,≡→≡ g gc) (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                         ↝⟨ (Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ → F.id) ⟩

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (gc : subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               (⟨ext⟩ g) (get⁻¹-const l₁) ≡
             get⁻¹-const l₂) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (Σ-≡,≡→≡ (⟨ext⟩ g) gc) (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                         ↝⟨ (∃-cong λ _ → Σ-cong-contra (inverse $ lemma₂ _) λ _ → F.id) ⟩□

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (gc : ∀ b₁ b₂ p →
             subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p ≡
             get⁻¹-const l₂ b₁ b₂ p) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (Σ-≡,≡→≡ (⟨ext⟩ g)
          (⟨ext⟩ λ b₁ → ⟨ext⟩ λ b₂ → ⟨ext⟩ λ p → gc b₁ b₂ p))
       (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                         □
  where
  open Lens

  lemma₁ :
    {P : A → Set ℓ} {Q R : (x : A) → P x → Set ℓ} →
    (∃ λ (x : A) → ∃ λ (y : P x) → Q x y × R x y) ≃
    (∃ λ (((x , y) , _) : Σ (Σ A P) (uncurry R)) → Q x y)
  lemma₁ {A = A} {P = P} {Q = Q} {R = R} =
    (∃ λ (x : A) → ∃ λ (y : P x) → Q x y × R x y)                      ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ×-comm) ⟩
    (∃ λ (x : A) → ∃ λ (y : P x) → R x y × Q x y)                      ↔⟨ (∃-cong λ _ → Σ-assoc) ⟩
    (∃ λ (x : A) → ∃ λ ((y , _) : ∃ λ (y : P x) → R x y) → Q x y)      ↔⟨ Σ-assoc ⟩
    (∃ λ ((x , y , _) : ∃ λ (x : A) → ∃ λ (y : P x) → R x y) → Q x y)  ↝⟨ (Σ-cong Σ-assoc λ _ → F.id) ⟩□
    (∃ λ (((x , y) , _) : Σ (Σ A P) (uncurry R)) → Q x y)              □

  lemma₂ : (g : ∀ a → get l₁ a ≡ get l₂ a) → _
  lemma₂ g =
    subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
      (⟨ext⟩ g) (get⁻¹-const l₁) ≡
    get⁻¹-const l₂                                              ↝⟨ inverse $ Eq.extensionality-isomorphism bad-ext ⟩

    (∀ b₁ → subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               (⟨ext⟩ g) (get⁻¹-const l₁) b₁ ≡
            get⁻¹-const l₂ b₁)                                  ↝⟨ (∀-cong ext λ _ → inverse $ Eq.extensionality-isomorphism bad-ext) ⟩

    (∀ b₁ b₂ → subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
                 (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ ≡
               get⁻¹-const l₂ b₁ b₂)                            ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → inverse $ Eq.extensionality-isomorphism bad-ext) ⟩□

    (∀ b₁ b₂ p →
     subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
       (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p ≡
     get⁻¹-const l₂ b₁ b₂ p)                                    □

-- An equality characterisation lemma for lenses from sets.

equality-characterisation-for-sets :
  let open Lens in
  {A : Set a} {B : Set b} {l₁ l₂ : Lens A B} →

  Is-set A →

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
     ∀ b₁ b₂ p →
     proj₁ (get⁻¹-const l₁ b₁ b₂ (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p)) ≡
     proj₁ (get⁻¹-const l₂ b₁ b₂ p))
equality-characterisation-for-sets
  {A = A} {B = B} {l₁ = l₁} {l₂ = l₂} A-set =
  l₁ ≡ l₂                                                                 ↝⟨ equality-characterisation ⟩

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (gc : ∀ b₁ b₂ p →
             subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
               (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p ≡
             get⁻¹-const l₂ b₁ b₂ p) →
     subst
       (λ (get , gc) →
          ∀ b₁ b₂ b₃ (p : get ⁻¹ b₁) →
          gc b₂ b₃ (gc b₁ b₂ p) ≡ gc b₁ b₃ p)
       (Σ-≡,≡→≡
          (⟨ext⟩ g)
          (⟨ext⟩ λ b₁ → ⟨ext⟩ λ b₂ → ⟨ext⟩ λ p → gc b₁ b₂ p))
       (get⁻¹-const-∘ l₁) ≡
     get⁻¹-const-∘ l₂)                                                    ↔⟨ (∃-cong λ _ → drop-⊤-right λ _ → _⇔_.to contractible⇔↔⊤ $ +⇒≡ $
                                                                              Π-closure ext 1 λ _ →
                                                                              Π-closure ext 1 λ _ →
                                                                              Π-closure ext 1 λ _ →
                                                                              Π-closure ext 1 λ _ →
                                                                              ⁻¹-set) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
     ∀ b₁ b₂ p →
     subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
       (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p ≡
     get⁻¹-const l₂ b₁ b₂ p)                                              ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (_≡ _) $ lemma₁ _ _ _ _) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
     ∀ b₁ b₂ p →
     subst (_⁻¹ b₂) (⟨ext⟩ g)
       (get⁻¹-const l₁ b₁ b₂ (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p)) ≡
     get⁻¹-const l₂ b₁ b₂ p)                                              ↔⟨ (∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ p →
                                                                              drop-⊤-right (λ _ → _⇔_.to contractible⇔↔⊤ $
                                                                                +⇒≡ (B-set (proj₁ p))) F.∘
                                                                              inverse B.Σ-≡,≡↔≡) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
     ∀ b₁ b₂ p →
     proj₁ (subst (_⁻¹ b₂) (⟨ext⟩ g)
              (get⁻¹-const l₁ b₁ b₂
                 (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p))) ≡
     proj₁ (get⁻¹-const l₂ b₁ b₂ p))                                      ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (_≡ _) $ lemma₂ _ _ _ _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
     ∀ b₁ b₂ p →
     proj₁ (get⁻¹-const l₁ b₁ b₂ (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p)) ≡
     proj₁ (get⁻¹-const l₂ b₁ b₂ p))                                      □
  where
  open Lens

  B-set : A → Is-set B
  B-set a = h-level-respects-lens-from-inhabited 2 l₁ a A-set

  ⁻¹-set : Is-set (get l₂ ⁻¹ b)
  ⁻¹-set =
    Σ-closure 2 A-set λ a →
    mono₁ 1 (B-set a)

  lemma₁ : ∀ g b₁ b₂ p → _
  lemma₁ g b₁ b₂ p =
    subst (λ get → ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
      (⟨ext⟩ g) (get⁻¹-const l₁) b₁ b₂ p                         ≡⟨ cong (λ f → f b₂ p) $ sym $
                                                                    push-subst-application (⟨ext⟩ g) (λ get b₁ → ∀ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂) ⟩
    subst (λ get → ∀ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂)
      (⟨ext⟩ g) (get⁻¹-const l₁ b₁) b₂ p                         ≡⟨ cong (λ f → f p) $ sym $
                                                                    push-subst-application (⟨ext⟩ g) (λ get b₂ → get ⁻¹ b₁ → get ⁻¹ b₂) ⟩
    subst (λ get → get ⁻¹ b₁ → get ⁻¹ b₂)
      (⟨ext⟩ g) (get⁻¹-const l₁ b₁ b₂) p                         ≡⟨ subst-→ {x₁≡x₂ = ⟨ext⟩ g} ⟩∎

    subst (_⁻¹ b₂) (⟨ext⟩ g)
      (get⁻¹-const l₁ b₁ b₂ (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p))  ∎

  lemma₂ : ∀ g b₁ b₂ p → _
  lemma₂ g b₁ b₂ p =
    proj₁ (subst (_⁻¹ b₂) (⟨ext⟩ g)
             (get⁻¹-const l₁ b₁ b₂
                (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p)))                 ≡⟨ cong proj₁ $
                                                                        push-subst-pair {y≡z = ⟨ext⟩ g} _ _ ⟩
    subst (λ _ → A) (⟨ext⟩ g)
      (proj₁ (get⁻¹-const l₁ b₁ b₂
                (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p)))                 ≡⟨ subst-const (⟨ext⟩ g) ⟩∎

    proj₁ (get⁻¹-const l₁ b₁ b₂ (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ g) p))  ∎

------------------------------------------------------------------------
-- Conversions between different kinds of lenses

-- Higher lenses can be converted to the ones defined above.

higher→ : Higher.Lens A B → Lens A B
higher→ l@(Higher.⟨ _ , _ , _ ⟩) = _≃_.from Lens-as-Σ′
  ( Higher.Lens.get l
  , Higher.get⁻¹-constant l
  , Higher.get⁻¹-constant-∘ l
  )

-- The conversion preserves getters and setters.

higher→-preserves-getters-and-setters :
  Preserves-getters-and-setters-→ A B higher→
higher→-preserves-getters-and-setters Higher.⟨ _ , _ , _ ⟩ =
  refl _ , refl _

-- A lens of the kind defined above can be converted to a higher one
-- if the codomain is inhabited when it is merely inhabited.

→higher : (∥ B ∥ → B) → Lens A B → Higher.Lens A B
→higher {B = B} {A = A} ∥B∥→B l@(lens _ _ _ _) = record
  { R     = ∃ λ (b : ∥ B ∥) → Lens.get l ⁻¹ (∥B∥→B b)
  ; equiv =
      A                                                      ↔⟨ (inverse $ drop-⊤-right λ _ → _⇔_.to contractible⇔↔⊤ $
                                                                 other-singleton-contractible _) ⟩
      (∃ λ a → ∃ λ b → Lens.get l a ≡ b)                     ↔⟨ ∃-comm ⟩
      (∃ λ b → Lens.get l ⁻¹ b)                              ↝⟨ (Σ-cong (inverse PT.∥∥×≃) λ _ → Lens.get⁻¹-constant l _ _) ⟩
      (∃ λ ((b , _) : ∥ B ∥ × B) → Lens.get l ⁻¹ (∥B∥→B b))  ↔⟨ inverse Σ-assoc ⟩
      (∃ λ (b : ∥ B ∥) → B × Lens.get l ⁻¹ (∥B∥→B b))        ↔⟨ (∃-cong λ _ → ×-comm) ⟩
      (∃ λ (b : ∥ B ∥) → Lens.get l ⁻¹ (∥B∥→B b) × B)        ↔⟨ Σ-assoc ⟩□
      (∃ λ (b : ∥ B ∥) → Lens.get l ⁻¹ (∥B∥→B b)) × B        □
  ; inhabited = proj₁
  }

-- The conversion preserves getters and setters.

→higher-preserves-getters-and-setters :
  {B : Set b}
  (∥B∥→B : ∥ B ∥ → B) →
  Preserves-getters-and-setters-→ A B (→higher ∥B∥→B)
→higher-preserves-getters-and-setters {A = A} ∥B∥→B l@(lens _ _ _ _) =
    refl _

  , ⟨ext⟩ λ a → ⟨ext⟩ λ b →

    let a′ = set a b in

    _≃_.to-from (Higher.Lens.equiv (→higher ∥B∥→B l)) $ cong₂ _,_

      (∣ get a′ ∣ ,
       get⁻¹-const (get a′) (∥B∥→B ∣ get a′ ∣) (a′ , refl _)          ≡⟨ Σ-≡,≡→≡ (PT.truncation-is-proposition _ _)
                                                                           (
           subst (λ b → get ⁻¹ ∥B∥→B b)
             (PT.truncation-is-proposition _ _)
             (get⁻¹-const (get a′) (∥B∥→B ∣ get a′ ∣) (a′ , refl _))        ≡⟨ elim¹
                                                                                (λ {f} _ →
                                                                                subst (λ b → get ⁻¹ f b)
                                                                                (PT.truncation-is-proposition _ _)
                                                                                (get⁻¹-const (get a′) (f ∣ get a′ ∣) (a′ , refl _)) ≡
                                                                                get⁻¹-const (get a) (f ∣ get a ∣) (a , refl _))
                                                                                (
               subst (λ _ → get ⁻¹ ∥B∥→B ∣ b ∣)
                 (PT.truncation-is-proposition _ _)
                 (get⁻¹-const (get a′) (∥B∥→B ∣ b ∣) (a′ , refl _))               ≡⟨ subst-const (PT.truncation-is-proposition _ _) ⟩

               get⁻¹-const (get a′) (∥B∥→B ∣ b ∣) (a′ , refl _)                   ≡⟨ sym $ get⁻¹-const-∘ _ _ _ _ ⟩

               get⁻¹-const (get a) (∥B∥→B ∣ b ∣)
                 (get⁻¹-const (get a′) (get a) (a′ , refl _))                     ≡⟨ cong (get⁻¹-const (get a) (∥B∥→B ∣ b ∣)) $
                                                                                elim¹
                                                                                (λ {b} eq → get⁻¹-const (get a′) (get a) (a′ , refl _) ≡
                                                                                get⁻¹-const b        (get a) (a′ , eq))
                                                                                (refl _)
                                                                                (get-set a b) ⟩
               get⁻¹-const (get a) (∥B∥→B ∣ b ∣)
                 (get⁻¹-const b (get a) (set a b , get-set a b))                  ≡⟨⟩

               get⁻¹-const (get a) (∥B∥→B ∣ b ∣)
                 (get⁻¹-const b (get a)
                    (get⁻¹-const (get a) b (a , refl _)))                         ≡⟨ cong (λ p → get⁻¹-const (get a) (∥B∥→B ∣ b ∣)
                                                                                (get⁻¹-const b (get a) p)) $
                                                                                get⁻¹-const-inverse _ _ _ ⟩
               get⁻¹-const (get a) (∥B∥→B ∣ b ∣)
                 (get⁻¹-const b (get a)
                    (get⁻¹-const⁻¹ b (get a) (a , refl _)))                       ≡⟨ cong (get⁻¹-const (get a) (∥B∥→B ∣ b ∣)) $
                                                                                _≃_.right-inverse-of (get⁻¹-constant _ _) _ ⟩∎
               get⁻¹-const (get a) (∥B∥→B ∣ b ∣) (a , refl _)                     ∎)
                                                                                (⟨ext⟩ λ _ → cong ∥B∥→B $ PT.truncation-is-proposition _ _) ⟩∎
           get⁻¹-const (get a) (∥B∥→B ∣ get a ∣) (a , refl _)               ∎) ⟩∎

       ∣ get a ∣ ,
       get⁻¹-const (get a) (∥B∥→B ∣ get a ∣) (a , refl _)             ∎)

      (get (set a b)  ≡⟨ get-set a b ⟩∎
       b              ∎)

  where
  open Lens l

-- There is a split surjection from Lens A B to Higher.Lens A B if B
-- is inhabited when it is merely inhabited (assuming univalence).

↠higher :
  {A : Set a} {B : Set b} →
  Univalence (a ⊔ b) →
  (∥ B ∥ → B) →
  Lens A B ↠ Higher.Lens A B
↠higher {A = A} {B = B} univ ∥B∥→B = record
  { logical-equivalence = record
    { to   = →higher ∥B∥→B
    ; from = higher→
    }
  ; right-inverse-of = λ l →
      Higher.lenses-equal-if-setters-equal
        univ _ _
        (λ _ → ∥B∥→B)
        (set (→higher ∥B∥→B (higher→ l))  ≡⟨ proj₂ $ →higher-preserves-getters-and-setters ∥B∥→B (higher→ l) ⟩
         Lens.set (higher→ l)             ≡⟨ proj₂ $ higher→-preserves-getters-and-setters l ⟩∎
         set l                            ∎)
  }
  where
  open Higher.Lens

-- The split surjection preserves getters and setters.

↠higher-preserves-getters-and-setters :
  {A : Set a} {B : Set b}
  (univ : Univalence (a ⊔ b))
  (∥B∥→B : ∥ B ∥ → B) →
  Preserves-getters-and-setters-⇔ A B
    (_↠_.logical-equivalence (↠higher univ ∥B∥→B))
↠higher-preserves-getters-and-setters _ ∥B∥→B =
    →higher-preserves-getters-and-setters ∥B∥→B
  , higher→-preserves-getters-and-setters

-- If B is inhabited when it is merely inhabited and A has positive
-- h-level n, then Higher.Lens A B also has h-level n (assuming
-- univalence).

higher-lens-preserves-h-level-of-domain :
  {A : Set a} {B : Set b} →
  Univalence (a ⊔ b) →
  (∥ B ∥ → B) →
  ∀ n → H-level (1 + n) A → H-level (1 + n) (Higher.Lens A B)
higher-lens-preserves-h-level-of-domain {A = A} {B = B} univ ∥B∥→B n =
  H-level (1 + n) A                  ↝⟨ lens-preserves-h-level-of-domain n ⟩
  H-level (1 + n) (Lens A B)         ↝⟨ H-level.respects-surjection (↠higher univ ∥B∥→B) (1 + n) ⟩□
  H-level (1 + n) (Higher.Lens A B)  □

-- Traditional lenses that satisfy some coherence properties can be
-- translated to lenses of the kind defined above.

coherent→ :
  Block "conversion" →
  Traditional.Coherent-lens A B → Lens A B
coherent→ ⊠ l = _≃_.from Lens-as-Σ′
  ( get
  , (λ b₁ b₂ →
       Eq.↔→≃ (gg b₁ b₂) (gg b₂ b₁) (gg∘gg b₁ b₂) (gg∘gg b₂ b₁))
  , (λ b₁ b₂ b₃ (a , _) →
       Σ-≡,≡→≡
         (set (set a b₂) b₃  ≡⟨ set-set a b₂ b₃ ⟩∎
          set a b₃           ∎)
         (subst (λ a → get a ≡ b₃) (set-set a b₂ b₃)
            (get-set (set a b₂) b₃)                   ≡⟨ subst-∘ _ _ (set-set a b₂ b₃) ⟩

          subst (_≡ b₃) (cong get (set-set a b₂ b₃))
            (get-set (set a b₂) b₃)                   ≡⟨ subst-trans-sym {y≡x = cong get (set-set a b₂ b₃)} ⟩

          trans (sym (cong get (set-set a b₂ b₃)))
            (get-set (set a b₂) b₃)                   ≡⟨ get-set-set′ _ _ _ ⟩∎

          get-set a b₃                                ∎))
  )
  where
  open Traditional.Coherent-lens l

  get-set-set′ :
    ∀ a b₁ b₂ →
    trans (sym (cong get (set-set a b₁ b₂))) (get-set (set a b₁) b₂) ≡
    get-set a b₂
  get-set-set′ a b₁ b₂ =
    trans (sym (cong get (set-set a b₁ b₂))) (get-set (set a b₁) b₂)  ≡⟨ cong (λ eq → trans (sym eq) (get-set _ _)) $
                                                                         get-set-set _ _ _ ⟩
    trans (sym (trans (get-set (set a b₁) b₂) (sym (get-set a b₂))))
      (get-set (set a b₁) b₂)                                         ≡⟨ cong (flip trans (get-set _ _)) $
                                                                         sym-trans _ (sym (get-set _ _)) ⟩
    trans (trans (sym (sym (get-set a b₂)))
             (sym (get-set (set a b₁) b₂)))
      (get-set (set a b₁) b₂)                                         ≡⟨ trans-[trans-sym]- _ (get-set _ _) ⟩

    sym (sym (get-set a b₂))                                          ≡⟨ sym-sym (get-set _ _) ⟩∎

    get-set a b₂                                                      ∎

  gg : ∀ b₁ b₂ → get ⁻¹ b₁ → get ⁻¹ b₂
  gg b₁ b₂ (a , _) = set a b₂ , get-set a b₂

  gg∘gg : ∀ b₁ b₂ p → gg b₁ b₂ (gg b₂ b₁ p) ≡ p
  gg∘gg b₁ b₂ (a , get-a≡b₂) =
    Σ-≡,≡→≡ eq₁
      (subst (λ a → get a ≡ b₂) eq₁ (get-set (set a b₁) b₂)   ≡⟨ subst-∘ _ _ eq₁ ⟩

       subst (_≡ b₂) (cong get eq₁) (get-set (set a b₁) b₂)   ≡⟨ subst-trans-sym {y≡x = cong get eq₁} ⟩

       trans (sym (cong get eq₁)) (get-set (set a b₁) b₂)     ≡⟨ cong (flip trans (get-set (set a b₁) b₂))
                                                                 lemma₂ ⟩
       trans (trans (trans (sym (cong get (set-get a)))
                       (cong (get ⊚ set a) get-a≡b₂))
                (sym (cong get (set-set a b₁ b₂))))
         (get-set (set a b₁) b₂)                              ≡⟨ trans-assoc _ _ (get-set (set a b₁) b₂) ⟩

       trans (trans (sym (cong get (set-get a)))
                (cong (get ⊚ set a) get-a≡b₂))
         (trans (sym (cong get (set-set a b₁ b₂)))
            (get-set (set a b₁) b₂))                          ≡⟨ trans-assoc _ _ (trans (sym (cong get (set-set a b₁ b₂)))
                                                                                (get-set (set a b₁) b₂)) ⟩
       trans (sym (cong get (set-get a)))
         (trans (cong (get ⊚ set a) get-a≡b₂)
            (trans (sym (cong get (set-set a b₁ b₂)))
               (get-set (set a b₁) b₂)))                      ≡⟨ cong₂ (λ p q → trans (sym p) (trans (cong (get ⊚ set a) get-a≡b₂) q))
                                                                   (get-set-get _)
                                                                   (get-set-set′ _ _ _) ⟩
       trans (sym (get-set a (get a)))
         (trans (cong (get ⊚ set a) get-a≡b₂)
            (get-set a b₂))                                   ≡⟨ cong (λ eq → trans (sym (eq (get a)))
                                                                                (trans (cong (get ⊚ set a) get-a≡b₂) (eq b₂))) $ sym $
                                                                 _≃_.left-inverse-of (Eq.extensionality-isomorphism bad-ext) _ ⟩
       trans (sym (ext⁻¹ (⟨ext⟩ (get-set a)) (get a)))
         (trans (cong (get ⊚ set a) get-a≡b₂)
            (ext⁻¹ (⟨ext⟩ (get-set a)) b₂))                   ≡⟨ elim₁
                                                                   (λ {f} gs →
                                                                      trans (sym (ext⁻¹ gs (get a))) (trans (cong f get-a≡b₂) (ext⁻¹ gs b₂)) ≡
                                                                      get-a≡b₂)
                                                                   (
          trans (sym (ext⁻¹ (refl id) (get a)))
             (trans (cong id get-a≡b₂)
                (ext⁻¹ (refl id) b₂))                               ≡⟨ cong₂ (λ p q → trans (sym p) (trans (cong id get-a≡b₂) q))
                                                                         (ext⁻¹-refl _)
                                                                         (ext⁻¹-refl _) ⟩
          trans (sym (refl _))
             (trans (cong id get-a≡b₂) (refl _))                    ≡⟨ cong₂ trans sym-refl (trans-reflʳ _) ⟩

          trans (refl _) (cong id get-a≡b₂)                         ≡⟨ trans-reflˡ (cong id get-a≡b₂) ⟩

          cong id get-a≡b₂                                          ≡⟨ sym $ cong-id get-a≡b₂ ⟩∎

          get-a≡b₂                                                  ∎)
                                                                 (⟨ext⟩ (get-set a)) ⟩
       get-a≡b₂                                               ∎)
    where
    eq₁ =
      set (set a b₁) b₂  ≡⟨ set-set a b₁ b₂ ⟩
      set a b₂           ≡⟨ cong (set a) (sym get-a≡b₂) ⟩
      set a (get a)      ≡⟨ set-get a ⟩∎
      a                  ∎

    lemma₁ =
      sym (cong get (cong (set a) (sym get-a≡b₂)))  ≡⟨ cong sym $ cong-∘ _ _ (sym get-a≡b₂) ⟩
      sym (cong (get ⊚ set a) (sym get-a≡b₂))       ≡⟨ sym $ cong-sym _ (sym get-a≡b₂) ⟩
      cong (get ⊚ set a) (sym (sym get-a≡b₂))       ≡⟨ cong (cong (get ⊚ set a)) $ sym-sym get-a≡b₂ ⟩∎
      cong (get ⊚ set a) get-a≡b₂                   ∎

    lemma₂ =
      sym (cong get eq₁)                                          ≡⟨⟩

      sym (cong get
             (trans (set-set a b₁ b₂)
                (trans (cong (set a) (sym get-a≡b₂))
                   (set-get a))))                                 ≡⟨ cong sym $
                                                                     cong-trans _ _ (trans (cong (set a) (sym get-a≡b₂)) (set-get a)) ⟩
      sym (trans (cong get (set-set a b₁ b₂))
             (cong get (trans (cong (set a) (sym get-a≡b₂))
                          (set-get a))))                          ≡⟨ cong (λ eq → sym (trans _ eq)) $
                                                                     cong-trans _ _ (set-get a) ⟩
      sym (trans (cong get (set-set a b₁ b₂))
             (trans (cong get (cong (set a) (sym get-a≡b₂)))
                (cong get (set-get a))))                          ≡⟨ sym-trans _ (trans (cong get (cong (set a) (sym get-a≡b₂)))
                                                                                (cong get (set-get a))) ⟩
      trans (sym (trans (cong get (cong (set a) (sym get-a≡b₂)))
                    (cong get (set-get a))))
        (sym (cong get (set-set a b₁ b₂)))                        ≡⟨ cong (flip trans (sym (cong get (set-set a b₁ b₂)))) $
                                                                     sym-trans _ (cong get (set-get a)) ⟩
      trans (trans (sym (cong get (set-get a)))
               (sym (cong get (cong (set a) (sym get-a≡b₂)))))
        (sym (cong get (set-set a b₁ b₂)))                        ≡⟨ cong (λ eq → trans (trans (sym (cong get (set-get a))) eq)
                                                                                (sym (cong get (set-set a b₁ b₂))))
                                                                     lemma₁ ⟩∎
      trans (trans (sym (cong get (set-get a)))
               (cong (get ⊚ set a) get-a≡b₂))
        (sym (cong get (set-set a b₁ b₂)))                        ∎

-- The conversion preserves getters and setters.

coherent→-preserves-getters-and-setters :
  (b : Block "conversion") →
  Preserves-getters-and-setters-→ A B (coherent→ b)
coherent→-preserves-getters-and-setters ⊠ _ =
  refl _ , refl _

-- If A is a set, then Traditional.Lens A B is equivalent to Lens A B.

traditional≃ :
  Block "conversion" →
  Is-set A → Traditional.Lens A B ≃ Lens A B
traditional≃ {A = A} {B = B} b@⊠ A-set = Eq.↔→≃
  (Traditional.Lens A B           ↔⟨ Traditional.≃coherent A-set ⟩
   Traditional.Coherent-lens A B  ↝⟨ coherent→ b ⟩□
   Lens A B                       □)
  Lens.traditional-lens
  (λ l → _≃_.from (equality-characterisation-for-sets A-set)
     ( (λ _ → refl _)
     , (λ b₁ b₂ p@(a , _) →
          let l′ = traditional-lens l
              l″ = coherent→ b (_≃_.to (Traditional.≃coherent A-set) l′)
          in
          proj₁ (get⁻¹-const l″ b₁ b₂
                   (subst (_⁻¹ b₁) (sym $ ⟨ext⟩ λ _ → refl _) p))         ≡⟨ cong (λ eq → proj₁ (get⁻¹-const l″ b₁ b₂ (subst (_⁻¹ b₁) (sym eq) p)))
                                                                             ext-refl ⟩

          proj₁ (get⁻¹-const l″ b₁ b₂ (subst (_⁻¹ b₁) (sym (refl _)) p))  ≡⟨ cong (λ eq → proj₁ (get⁻¹-const l″ b₁ b₂ (subst (_⁻¹ b₁) eq p)))
                                                                             sym-refl ⟩

          proj₁ (get⁻¹-const l″ b₁ b₂ (subst (_⁻¹ b₁) (refl _) p))        ≡⟨ cong (proj₁ ⊚ get⁻¹-const l″ b₁ b₂) $
                                                                             subst-refl _ _ ⟩

          proj₁ (get⁻¹-const l″ b₁ b₂ p)                                  ≡⟨⟩

          set l (proj₁ p) b₂                                              ≡⟨⟩

          proj₁ (get⁻¹-const l (get l a) b₂ (a , refl _))                 ≡⟨ elim¹
                                                                               (λ {b} eq →
                                                                                proj₁ (get⁻¹-const l (get l a) b₂ (a , refl _)) ≡
                                                                                proj₁ (get⁻¹-const l b b₂ (a , eq)))
                                                                               (refl _)
                                                                               (proj₂ p) ⟩∎
          proj₁ (get⁻¹-const l b₁ b₂ p)                                   ∎)
     ))
  (λ _ →
     _↔_.from (Traditional.equality-characterisation-for-sets A-set)
       (refl _))
  where
  open Lens

  B-set : Traditional.Lens A B → A → Is-set B
  B-set l a =
    Traditional.h-level-respects-lens-from-inhabited 2 l a A-set

-- The equivalence preserves getters and setters.

traditional≃-preserves-getters-and-setters :
  {A : Set a}
  (b : Block "conversion")
  (s : Is-set A) →
  Preserves-getters-and-setters-⇔ A B
    (_≃_.logical-equivalence (traditional≃ b s))
traditional≃-preserves-getters-and-setters ⊠ _ =
    (λ _ → refl _ , refl _)
  , (λ _ → refl _ , refl _)

-- If B is inhabited when it is merely inhabited, then
-- Traditional.Coherent-lens A B is logically equivalent to
-- Higher.Lens A B.

coherent⇔higher :
  Block "conversion" →
  (∥ B ∥ → B) →
  Traditional.Coherent-lens A B ⇔ Higher.Lens A B
coherent⇔higher {B = B} {A = A} b ∥B∥→B = record
  { to   = Traditional.Coherent-lens A B  ↝⟨ coherent→ b ⟩
           Lens A B                       ↝⟨ →higher ∥B∥→B ⟩□
           Higher.Lens A B                □
  ; from = Higher.Lens.coherent-lens
  }

-- The logical equivalence preserves getters and setters.

coherent⇔higher-preserves-getters-and-setters :
  {B : Set b}
  (bc : Block "conversion")
  (∥B∥→B : ∥ B ∥ → B) →
  Preserves-getters-and-setters-⇔ A B (coherent⇔higher bc ∥B∥→B)
coherent⇔higher-preserves-getters-and-setters b ∥B∥→B =
    Preserves-getters-and-setters-→-∘
      {f = →higher ∥B∥→B}
      {g = coherent→ b}
      (→higher-preserves-getters-and-setters ∥B∥→B)
      (coherent→-preserves-getters-and-setters b)
  , (λ _ → refl _ , refl _)

-- If B is inhabited when it is merely inhabited, then there is a
-- split surjection from Traditional.Coherent-lens A B to
-- Higher.Lens A B (assuming univalence).

coherent↠higher :
  {A : Set a} {B : Set b} →
  Block "conversion" →
  Univalence (a ⊔ b) →
  (∥ B ∥ → B) →
  Traditional.Coherent-lens A B ↠ Higher.Lens A B
coherent↠higher {A = A} {B = B} b univ ∥B∥→B = record
  { logical-equivalence = coherent⇔higher b ∥B∥→B
  ; right-inverse-of    = λ l →
      Higher.lenses-equal-if-setters-equal univ _ _ (λ _ → ∥B∥→B) $
      proj₂ (proj₁ (coherent⇔higher-preserves-getters-and-setters
                      b ∥B∥→B)
               _)
  }

-- The split surjection preserves getters and setters.

coherent↠higher-preserves-getters-and-setters :
  {A : Set a} {B : Set b}
  (bc : Block "conversion")
  (univ : Univalence (a ⊔ b))
  (∥B∥→B : ∥ B ∥ → B) →
  Preserves-getters-and-setters-⇔ A B
    (_↠_.logical-equivalence (coherent↠higher bc univ ∥B∥→B))
coherent↠higher-preserves-getters-and-setters b _ ∥B∥→B =
  coherent⇔higher-preserves-getters-and-setters b ∥B∥→B

------------------------------------------------------------------------
-- Composition

-- A lemma used to define composition.

∘⁻¹≃ :
  Block "∘⁻¹≃" →
  (f : B → C) (g : A → B) →
  f ⊚ g ⁻¹ z ≃ ∃ λ ((y , _) : f ⁻¹ z) → g ⁻¹ y
∘⁻¹≃ {z = z} ⊠ f g =
  f ⊚ g ⁻¹ z                                  ↔⟨⟩
  (∃ λ a → f (g a) ≡ z)                       ↔⟨ (∃-cong λ _ → ∃-intro _ _) ⟩
  (∃ λ a → ∃ λ y → f y ≡ z × y ≡ g a)         ↔⟨ (∃-cong λ _ → Σ-assoc) ⟩
  (∃ λ a → ∃ λ ((y , _) : f ⁻¹ z) → y ≡ g a)  ↔⟨ ∃-comm ⟩
  (∃ λ ((y , _) : f ⁻¹ z) → ∃ λ a → y ≡ g a)  ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ≡-comm) ⟩
  (∃ λ ((y , _) : f ⁻¹ z) → g ⁻¹ y)           □

-- Composition.

infixr 9 _∘_

_∘_ : Lens B C → Lens A B → Lens A C
l₁@(lens _ _ _ _) ∘ l₂@(lens _ _ _ _) = block λ b → _≃_.from Lens-as-Σ′
  ( get l₁ ⊚ get l₂
  , (λ c₁ c₂ →
       get l₁ ⊚ get l₂ ⁻¹ c₁                         ↝⟨ ∘⁻¹≃ b _ _ ⟩
       (∃ λ ((b , _) : get l₁ ⁻¹ c₁) → get l₂ ⁻¹ b)  ↝⟨ (Σ-cong (get⁻¹-constant l₁ c₁ c₂) λ p@(b , _) →
                                                         get⁻¹-constant l₂ b (proj₁ (get⁻¹-const l₁ c₁ c₂ p))) ⟩
       (∃ λ ((b , _) : get l₁ ⁻¹ c₂) → get l₂ ⁻¹ b)  ↝⟨ inverse $ ∘⁻¹≃ b _ _ ⟩□
       get l₁ ⊚ get l₂ ⁻¹ c₂                         □)
  , (λ c₁ c₂ c₃ p →
       _≃_.from (∘⁻¹≃ b _ _)
         (Σ-map (get⁻¹-const l₁ c₂ c₃)
            (λ {p@(b , _)} →
               get⁻¹-const l₂ b (proj₁ (get⁻¹-const l₁ c₂ c₃ p)))
            (_≃_.to (∘⁻¹≃ b _ _)
               (_≃_.from (∘⁻¹≃ b _ _)
                  (Σ-map (get⁻¹-const l₁ c₁ c₂)
                     (λ {p@(b , _)} →
                        get⁻¹-const l₂ b
                          (proj₁ (get⁻¹-const l₁ c₁ c₂ p)))
                     (_≃_.to (∘⁻¹≃ b _ _) p)))))                      ≡⟨ cong (λ x → _≃_.from (∘⁻¹≃ b _ _)
                                                                                (Σ-map (get⁻¹-const l₁ c₂ c₃)
                                                                                (λ {p@(b , _)} →
                                                                                get⁻¹-const l₂ b
                                                                                (proj₁ (get⁻¹-const l₁ c₂ c₃ p))) x)) $
                                                                         _≃_.right-inverse-of (∘⁻¹≃ b _ _) _ ⟩
       _≃_.from (∘⁻¹≃ b _ _)
         (Σ-map (get⁻¹-const l₁ c₂ c₃)
            (λ {p@(b , _)} →
               get⁻¹-const l₂ b (proj₁ (get⁻¹-const l₁ c₂ c₃ p)))
            (Σ-map (get⁻¹-const l₁ c₁ c₂)
               (λ {p@(b , _)} →
                  get⁻¹-const l₂ b (proj₁ (get⁻¹-const l₁ c₁ c₂ p)))
               (_≃_.to (∘⁻¹≃ b _ _) p)))                              ≡⟨⟩

       _≃_.from (∘⁻¹≃ b _ _)
         (Σ-map (get⁻¹-const l₁ c₂ c₃ ⊚ get⁻¹-const l₁ c₁ c₂)
            (λ {p@(b , _)} →
               get⁻¹-const l₂ (proj₁ (get⁻¹-const l₁ c₁ c₂ p))
                 (proj₁ (get⁻¹-const l₁ c₂ c₃
                           (get⁻¹-const l₁ c₁ c₂ p))) ⊚
               get⁻¹-const l₂ b (proj₁ (get⁻¹-const l₁ c₁ c₂ p)))
            (_≃_.to (∘⁻¹≃ b _ _) p))                                  ≡⟨ cong (λ f → _≃_.from (∘⁻¹≃ b _ _)
                                                                                (Σ-map (get⁻¹-const l₁ c₂ c₃ ⊚ get⁻¹-const l₁ c₁ c₂)
                                                                                (λ {p} → f {p})
                                                                                (_≃_.to (∘⁻¹≃ b _ _) p))) $
                                                                         (implicit-extensionality ext λ p →
                                                                          ⟨ext⟩ (get⁻¹-const-∘ l₂ _ (proj₁ (get⁻¹-const l₁ c₁ c₂ p)) _)) ⟩
       _≃_.from (∘⁻¹≃ b _ _)
         (Σ-map (get⁻¹-const l₁ c₂ c₃ ⊚ get⁻¹-const l₁ c₁ c₂)
            (λ {p@(b , _)} →
               get⁻¹-const l₂ b
                 (proj₁ (get⁻¹-const l₁ c₂ c₃
                           (get⁻¹-const l₁ c₁ c₂ p))))
            (_≃_.to (∘⁻¹≃ b _ _) p))                                  ≡⟨ cong (λ f → _≃_.from (∘⁻¹≃ b _ _)
                                                                                (Σ-map f (λ {p@(b , _)} → get⁻¹-const l₂ b (proj₁ (f p)))
                                                                                (_≃_.to (∘⁻¹≃ b _ _) p))) $
                                                                         ⟨ext⟩ (get⁻¹-const-∘ l₁ _ _ _) ⟩∎
       _≃_.from (∘⁻¹≃ b _ _)
         (Σ-map (get⁻¹-const l₁ c₁ c₃)
            (λ {p@(b , _)} →
               get⁻¹-const l₂ b (proj₁ (get⁻¹-const l₁ c₁ c₃ p)))
            (_≃_.to (∘⁻¹≃ b _ _) p))                                  ∎)
  )
  where
  open Lens

-- The setter of the resulting lens is defined in the "right" way.

set-∘≡ :
  (l₁ : Lens B C) (l₂ : Lens A B) →
  Lens.set (l₁ ∘ l₂) a c ≡
  Lens.set l₂ a (Lens.set l₁ (Lens.get l₂ a) c)
set-∘≡ {a = a} {c = c} l₁@(lens _ _ _ _) l₂@(lens _ _ _ _) =
  proj₁ (get⁻¹-const l₂ (get l₂ a)
           (proj₁ (get⁻¹-const l₁ c′ c
                     ( get l₂ a
                     , _↔_.to (subst (λ b → get l₁ b ≡ c′ ↔ c′ ≡ c′)
                                 (refl _) F.id)
                         (refl _))
                     ))
           (a , sym (refl _)))                                        ≡⟨ cong₂ (λ f eq → proj₁ (get⁻¹-const l₂ _
                                                                                (proj₁ (get⁻¹-const l₁ _ _
                                                                                (_ , _↔_.to f (refl _)))) (_ , eq)))
                                                                           (subst-refl _ _)
                                                                           sym-refl ⟩
  proj₁ (get⁻¹-const l₂ (get l₂ a)
           (proj₁ (get⁻¹-const l₁ c′ c (get l₂ a , refl _)))
           (a , refl _))                                              ≡⟨⟩

  set l₂ a (set l₁ (get l₂ a) c)                                      ∎
  where
  open Lens

  c′ = get l₁ (get l₂ a)

-- Composition for higher lenses, defined under the assumption that
-- the resulting codomain is inhabited if it is merely inhabited.

infix 9 ⟨_⟩_⊚_

⟨_⟩_⊚_ :
  (∥ C ∥ → C) →
  Higher.Lens B C → Higher.Lens A B → Higher.Lens A C
⟨_⟩_⊚_ {C = C} {B = B} {A = A} ∥C∥→C = curry (
  Higher.Lens B C × Higher.Lens A B  ↝⟨ Σ-map higher→ higher→ ⟩
  Lens B C × Lens A B                ↝⟨ uncurry _∘_ ⟩
  Lens A C                           ↝⟨ →higher ∥C∥→C ⟩□
  Higher.Lens A C                    □)

-- The setter of the resulting lens is defined in the "right" way.

set-⊚≡ :
  ∀ ∥C∥→C (l₁ : Higher.Lens B C) (l₂ : Higher.Lens A B) →
  Higher.Lens.set (⟨ ∥C∥→C ⟩ l₁ ⊚ l₂) a c ≡
  Higher.Lens.set l₂ a (Higher.Lens.set l₁ (Higher.Lens.get l₂ a) c)
set-⊚≡ {a = a} {c = c} ∥C∥→C l₁ l₂ =
  set (⟨ ∥C∥→C ⟩ l₁ ⊚ l₂) a c                                   ≡⟨ cong (λ f → f a c) $ proj₂ $
                                                                   →higher-preserves-getters-and-setters ∥C∥→C (higher→ l₁ ∘ higher→ l₂) ⟩

  Lens.set (higher→ l₁ ∘ higher→ l₂) a c                        ≡⟨ set-∘≡ (higher→ l₁) (higher→ l₂) ⟩

  Lens.set (higher→ l₂) a
    (Lens.set (higher→ l₁) (Lens.get (higher→ l₂) a) c)         ≡⟨ cong (λ f → Lens.set (higher→ l₂) a (Lens.set (higher→ l₁) (f a) c)) $ proj₁ $
                                                                   higher→-preserves-getters-and-setters l₂ ⟩

  Lens.set (higher→ l₂) a (Lens.set (higher→ l₁) (get l₂ a) c)  ≡⟨ cong (λ f → Lens.set (higher→ l₂) a (f (get l₂ a) c)) $ proj₂ $
                                                                   higher→-preserves-getters-and-setters l₁ ⟩

  Lens.set (higher→ l₂) a (set l₁ (get l₂ a) c)                 ≡⟨ cong (λ f → f a (set l₁ (get l₂ a) c)) $ proj₂ $
                                                                   higher→-preserves-getters-and-setters l₂ ⟩∎
  set l₂ a (set l₁ (get l₂ a) c)                                ∎
  where
  open Higher.Lens

-- The implementation of composition for higher lenses given above
-- matches the one in Higher when both are defined (assuming
-- univalence).

⊚≡∘ :
  ∀ a b {A : Set (a ⊔ b ⊔ c)} {B : Set (b ⊔ c)} {C : Set c} →
  Univalence (a ⊔ b ⊔ c) →
  (∥C∥→C : ∥ C ∥ → C) →
  ⟨_⟩_⊚_ {B = B} {A = A} ∥C∥→C ≡
  Higher.Lens-combinators.⟨ a , b ⟩_∘_
⊚≡∘ a b {A = A} {B = B} {C = C} univ ∥C∥→C =
  Higher.Lens-combinators.composition≡∘
    a b univ ∥C∥→C ⟨ ∥C∥→C ⟩_⊚_
    (λ l₁ l₂ _ _ → set-⊚≡ ∥C∥→C l₁ l₂)


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

module F2a where

open import Agda.Prim
open import Data.Unit
open import Data.Nat hiding (_⊔_)
open import Data.Sum
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality

open import Paths
open import Evaluator

------------------------------------------------------------------------------
--
-- General structure and idea
--
-- We have pointed types (Paths.agda)
-- We have paths between pointed types (Paths.agda)
-- We have functions between pointed types (that use ≡ to make sure the
--   basepoint is respected) (F2a.agda)
-- Then we use univalence to connect these two independently developed
--   notions (F2a.agda)
-- Because our paths are richer than just refl and our functions are
--   more restricted than arbitrary functions, and in fact because our
--   path constructors are sound and complete for the class of functions
--   we consider, we hope to _prove_ univalence
--
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Equivalences between raw functions and types
-- This is generalized below to pointed types

-- Two functions are ∼ is they map each argument to related results

_∼_ : ∀ {ℓ ℓ'} → {A : Set ℓ} {P : A → Set ℓ'} →
      (f g : (x : A) → P x) → Set (ℓ ⊔ ℓ')
_∼_ {ℓ} {ℓ'} {A} {P} f g = (x : A) → f x ≡ g x

-- quasi-inverses

record qinv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) :
  Set (ℓ ⊔ ℓ') where
  constructor mkqinv
  field
    g : B → A
    α : (f ∘ g) ∼ id
    β : (g ∘ f) ∼ id

idqinv : ∀ {ℓ} → {A : Set ℓ} → qinv {ℓ} {ℓ} {A} {A} id
idqinv = record {
           g = id ;
           α = λ b → refl ;
           β = λ a → refl
         }

-- equivalences

record isequiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) :
  Set (ℓ ⊔ ℓ') where
  constructor mkisequiv
  field
    g : B → A
    α : (f ∘ g) ∼ id
    h : B → A
    β : (h ∘ f) ∼ id

equiv₁ : ∀ {ℓ ℓ'} → {A : Set ℓ} {B : Set ℓ'} {f : A → B} → qinv f → isequiv f
equiv₁ (mkqinv qg qα qβ) = mkisequiv qg qα qg qβ

_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A ≃ B = Σ (A → B) isequiv

idequiv : ∀ {ℓ} {A : Set ℓ} → A ≃ A
idequiv = (id , equiv₁ idqinv)

-- Function extensionality

{--
happly : ∀ {ℓ} {A B : Set ℓ} {f g : A → B} → (Path f g) → (f ∼ g)
happly {ℓ} {A} {B} {f} {g} p =
  (pathInd
    (λ _ → f ∼ g) -- f ∼ g
    (λ {AA} a x → {!!}) {!!}
    {!!} {!!} {!!} {!!} {!!} {!!}
    {!!} {!!} (λ a b x → {!cong (evalB p) (eval-resp-• (p))!})
    {!!} {!!} {!!} {!!} {!!} {!!}
    (λ a x → {!!}) (λ p₁ q x x₁ x₂ → x x₂)
    (λ p₁ q x x₁ x₂ → x x₂) (λ p₁ q x x₁ x₂ → x x₂) (λ p₁ q x x₁ x₂ → x₁ x₂))
  {A → B} {A → B} {f} {g} p

postulate
  funextP : {A B : Set} {f g : A → B} →
            isequiv {A = Path f g} {B = f ∼ g} happly

funext : {A B : Set} {f g : A → B} → (f ∼ g) → (Path f g)
funext = isequiv.g funextP

-- Universes; univalence

idtoeqv : {A B : Set} → (Path A B) → (A ≃ B)
idtoeqv {A} {B} p = {!!}
{--
  (pathInd
    (λ {S₁} {S₂} {A} {B} p → {!!})
    {!!} {!!}
    {!!} {!!} {!!} {!!} {!!} {!!}
    {!!} {!!} {!!}
    {!!} {!!} {!!} {!!} {!!} {!!}
    {!!} {!!} {!!} {!!} {!!})
  {Set} {Set} {A} {B} p
--}

postulate
  univalence : {ℓ : Level} {A B : Set ℓ} → (Path A B) ≃ (A ≃ B)

--}

path2fun : {ℓ : Level} {A B : Set ℓ} → (Path A B) → (A ≃ B)
path2fun p = ( {!!} , {!!})

------------------------------------------------------------------------------
-- Functions and equivalences between pointed types

-- Univalence as a postulate for now but hopefully we can actually prove it
-- since the pi-combinators are sound and complete for isomorphisms between
-- finite types

--postulate
--  univalence• : {ℓ : Level} {A• B• : Set• {ℓ}} → (Path A• B•) ≃• (A• ≃• B•)

{--
record isequiv• {ℓ} {A B : Set} {A• B• : Set• {ℓ}} (f• : A• →• B•) :
  Set (lsuc ℓ) where
  constructor mkisequiv•
  field
    equi : isequiv (fun f•)
    path' : Path (• A•) (• B•)

_≈•_ : ∀ {ℓ} {A B : Set} (A• B• : Set• {ℓ}) → Set (lsuc ℓ)
_≈•_ {_} {A} {B} A• B• = Σ (A• →• B•) (isequiv• {_} {A} {B})
--}

------------------------------------------------------------------------------
-- Univalence for pointed types

eval• :  {ℓ : Level} {A• B• : Set• {ℓ}} → A• ⇛ B• → (A• →• B•)
eval• c = record { fun = eval c ; resp• = eval-resp-• c }

evalB• :  {ℓ : Level} {A• B• : Set• {ℓ}} → A• ⇛ B• → (B• →• A•)
evalB• c = record { fun = evalB c ; resp• = evalB-resp-• c }

-- This is at the wrong level... We need to define equivalences ≃ between
-- pointed sets too...

{--
path2iso : {ℓ : Level} {A• B• : Set• {ℓ}} → A• ⇛ B• → ∣ A• ∣ ≃ ∣ B• ∣
path2iso {ℓ} {a} {b} p = (eval p ,
  mkisequiv (evalB p) (λ x → {!!}) (evalB p) (λ x → {!eval∘evalB p!}))
--}

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


module Type{ℓ} where

open import Agda.Primitive public
  using ()
  renaming (Set to TYPE ; Setω to Typeω)

Type : TYPE(_)
Type = TYPE(ℓ)
{-# INLINE Type #-}

module Type where
  -- Returns the type of a certain value
  of : ∀{T : Type} → T → Type
  of {T} _ = T
  {-# INLINE of #-}


module Type.Size.Proofs where

import      Lvl
open import Data
open import Data.Proofs
open import Functional
open import Function.Equals
open import Function.Inverseᵣ
open import Function.Inverse
open import Function.Proofs
open import Logic
open import Logic.IntroInstances
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Relator.Equivalence
open import Structure.Relator.Ordering
open import Structure.Relator.Properties
open import Type
import      Type.Size

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ : Lvl.Level
private variable T A B C : Type{ℓ}

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  open Type.Size

  [≼]-maximum : (_≼_ T (T → T) ⦃ [⊜]-equiv ⦄)
  [≼]-maximum = [∃]-intro(const) ⦃ intro(proof) ⦄ where
    proof : ∀{x y} → (const(x) ⊜ const(y)) → (x ≡ y)
    proof{x}{y} (intro fneq) = fneq{x}

  [≍]-reflexivity-raw : (T ≍ T)
  [≍]-reflexivity-raw = [∃]-intro(id) ⦃ id-bijective ⦄

  [≼]-reflexivity-raw : (T ≼ T)
  [≼]-reflexivity-raw = [∃]-intro(id) ⦃ id-injective ⦄

  [≽]-reflexivity-raw : (T ≽ T)
  [≽]-reflexivity-raw = [∃]-intro(id) ⦃ id-surjective ⦄

  [≼]-minimum-raw : ⦃ equiv-empty : Equiv{ℓₑ₁}(Empty{ℓ}) ⦄ → (_≼_ Empty ⦃ equiv-empty ⦄ T)
  [≼]-minimum-raw = [∃]-intro(empty) ⦃ empty-injective ⦄

    -- TODO: Impossible because there are no functions of type (T → ⊥)?
    -- instance
    --   [≽]-minimum : Weak.Properties.Maximum(_≽_ {ℓ})(Empty)
    --   Weak.Properties.Maximum.proof([≽]-minimum) {T} {}

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  open Type.Size

  [≍]-to-[≼] : (A ≍ B) → (A ≼ B)
  [≍]-to-[≼] ([∃]-intro(f) ⦃ f-bijective ⦄) =
    ([∃]-intro(f) ⦃ bijective-to-injective(f) ⦃ f-bijective ⦄ ⦄)

  [≍]-to-[≽] : (A ≍ B) → (A ≽ B)
  [≍]-to-[≽] ([∃]-intro(f) ⦃ f-bijective ⦄) =
    ([∃]-intro(f) ⦃ bijective-to-surjective(f) ⦃ f-bijective ⦄ ⦄)

  [≽]-to-[≼] : (ab@([∃]-intro f) : (A ≽ B)) → ⦃ func : Function(f) ⦄ ⦃ inv-func : Function(invᵣ-surjective f) ⦄ → (B ≼ A)
  [≽]-to-[≼] ([∃]-intro(f) ⦃ f-surjective ⦄) ⦃ inv-func ⦄ = [∃]-intro(invᵣ f ⦃ surjective-to-invertibleᵣ ⦄) ⦃ inverseᵣ-injective{f = f} ⦃ [∧]-elimᵣ([∃]-proof surjective-to-invertibleᵣ) ⦄ ⦄

  {-[≼]-to-[≽] : (A ≼ B) → (B ≽ A)
  [≼]-to-[≽] ([∃]-intro(f) ⦃ f-injective ⦄) =
    {![∃]-intro()!}
  -}

  [≍]-symmetry-raw : (ab@([∃]-intro f) : (A ≍ B)) → ⦃ func : Function(f) ⦄ → (B ≍ A)
  [≍]-symmetry-raw ([∃]-intro(f) ⦃ f-bijective ⦄)
    = [∃]-intro(inv f ⦃ bijective-to-invertible ⦄) ⦃ inv-bijective{f = f} ⦃ inver = bijective-to-invertible ⦄ ⦄

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ ⦃ equiv-C : Equiv{ℓₑ₃}(C) ⦄ where
  open Type.Size

  [≍]-transitivity-raw : (ab@([∃]-intro f) : (A ≍ B)) ⦃ func-f : Function(f) ⦄ → (bc@([∃]-intro g) : (B ≍ C)) ⦃ func-g : Function(g) ⦄ → (A ≍ C)
  [≍]-transitivity-raw ([∃]-intro(f) ⦃ f-bijective ⦄) ([∃]-intro(g) ⦃ g-bijective ⦄)
    = [∃]-intro(g ∘ f) ⦃ [∘]-bijective {f = g} {g = f} ⦃ g-bijective ⦄ ⦃ f-bijective ⦄ ⦄

  [≼]-transitivity-raw : (A ≼ B) → (B ≼ C) → (A ≼ C)
  [≼]-transitivity-raw ([∃]-intro(f) ⦃ f-injective ⦄) ([∃]-intro(g) ⦃ g-injective ⦄)
    = [∃]-intro(g ∘ f) ⦃ [∘]-injective {f = g}{g = f} ⦃ g-injective ⦄ ⦃ f-injective ⦄ ⦄

  [≽]-transitivity-raw : (A ≽ B) → (([∃]-intro g) : (B ≽ C)) ⦃ func-g : Function(g) ⦄ → (A ≽ C)
  [≽]-transitivity-raw ([∃]-intro(f) ⦃ f-surjective ⦄) ([∃]-intro(g) ⦃ g-surjective ⦄)
    = [∃]-intro(g ∘ f) ⦃ [∘]-surjective {f = g} {g = f} ⦃ g-surjective ⦄ ⦃ f-surjective ⦄ ⦄

module _ where
  open import Relator.Equals renaming (_≡_ to _≡ₑ_)
  open import Relator.Equals.Proofs

  private
    _≍_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≍_ A B = Type.Size._≍_ A B

    _≼_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≼_ A B = Type.Size._≼_ A B

    _≽_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≽_ A B = Type.Size._≽_ A B

    _≭_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≭_ A B = Type.Size._≭_ A B

    _≺_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≺_ A B = Type.Size._≺_ A B

    _≻_ : ∀{ℓ₁ ℓ₂} → (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Stmt
    _≻_ A B = Type.Size._≻_ A B

  module _ {ℓ} where
    instance
      [≍]-reflexivity : Reflexivity(_≍_ {ℓ})
      [≍]-reflexivity = intro [≍]-reflexivity-raw

    instance
      [≍]-symmetry : Symmetry(_≍_ {ℓ})
      [≍]-symmetry = intro(f ↦ [≍]-symmetry-raw f)

    instance
      [≍]-transitivity : Transitivity(_≍_ {ℓ})
      [≍]-transitivity = intro(f ↦ g ↦ [≍]-transitivity-raw f g)

    instance
      [≍]-equivalence : Equivalence(_≍_ {ℓ})
      [≍]-equivalence = intro

    instance
      [≼]-reflexivity : Reflexivity(_≼_ {ℓ})
      [≼]-reflexivity = intro [≼]-reflexivity-raw

    instance
      [≼]-transitivity : Transitivity(_≼_ {ℓ})
      [≼]-transitivity = intro [≼]-transitivity-raw

    instance
      [≽]-reflexivity : Reflexivity(_≽_ {ℓ})
      [≽]-reflexivity = intro [≽]-reflexivity-raw

    instance
      [≽]-transitivity : Transitivity(_≽_ {ℓ})
      [≽]-transitivity = intro(p ↦ q ↦ [≽]-transitivity-raw p q)

    instance
      [≼]-minimum : Weak.Properties.LE.Minimum(_≼_ {ℓ})(Empty)
      Weak.Properties.Extremumₗ.proof [≼]-minimum = [≼]-minimum-raw

    -- TODO: Impossible because there are no functions of type (T → ⊥)?
    -- instance
    --   [≽]-minimum : Weak.Properties.Maximum(_≽_ {ℓ})(Empty)
    --   Weak.Properties.Maximum.proof([≽]-minimum) {T} {}

  -- TODO: Remove this and the similar one in the other module. A more general variant is defined in Relator.Equals.Proofs
  module _ {A : Type{ℓ}} {B : Type{ℓ}} where
    [≡]-to-[≍] : (A ≡ₑ B) → (A ≍ B)
    [≡]-to-[≍] [≡]-intro = reflexivity(_≍_)


module Builtin.Float where

open import Prelude
open import Prelude.Equality.Unsafe

open import Agda.Builtin.Float
open Agda.Builtin.Float public using (Float)

natToFloat : Nat → Float
natToFloat = primNatToFloat

intToFloat : Int → Float
intToFloat (pos    x) = natToFloat x
intToFloat (negsuc x) = primFloatMinus -1.0 (natToFloat x)

instance
  EqFloat : Eq Float
  _==_ {{EqFloat}} x y with primFloatEquality x y
  ... | true  = yes unsafeEqual
  ... | false = no  unsafeNotEqual

data LessFloat (x y : Float) : Set where
  less-float : primFloatLess x y ≡ true → LessFloat x y

instance
  OrdFloat : Ord Float
  OrdFloat = defaultOrd cmpFloat
    where
      cmpFloat : ∀ x y → Comparison LessFloat x y
      cmpFloat x y with inspect (primFloatLess x y)
      ... | true  with≡ eq = less (less-float eq)
      ... | false with≡ _ with inspect (primFloatLess y x)
      ...   | true  with≡ eq = greater (less-float eq)
      ...   | false with≡ _  = equal unsafeEqual

  OrdLawsFloat : Ord/Laws Float
  Ord/Laws.super OrdLawsFloat    = it
  less-antirefl {{OrdLawsFloat}} (less-float eq) = unsafeNotEqual eq
  less-trans    {{OrdLawsFloat}} (less-float _) (less-float _) = less-float unsafeEqual

instance
  ShowFloat : Show Float
  ShowFloat = simpleShowInstance primShowFloat

instance
  NumFloat : Number Float
  Number.Constraint NumFloat _ = ⊤
  Number.fromNat    NumFloat x = primNatToFloat x

  SemiringFloat : Semiring Float
  Semiring.zro SemiringFloat = 0.0
  Semiring.one SemiringFloat = 1.0
  Semiring._+_ SemiringFloat = primFloatPlus
  Semiring._*_ SemiringFloat = primFloatTimes

  SubFloat : Subtractive Float
  Subtractive._-_    SubFloat = primFloatMinus
  Subtractive.negate SubFloat = primFloatNegate

  NegFloat : Negative Float
  Negative.Constraint NegFloat _ = ⊤
  Negative.fromNeg    NegFloat x = negate (primNatToFloat x)

  FracFloat : Fractional Float
  Fractional.Constraint FracFloat _ _ = ⊤
  Fractional._/_ FracFloat x y = primFloatDiv x y

floor   = primFloor
round   = primRound
ceiling = primCeiling
exp     = primExp
ln      = primLog
sin     = primSin
sqrt    = primFloatSqrt

π : Float
π = 3.141592653589793

cos : Float → Float
cos x = sin (π / 2.0 - x)

tan : Float → Float
tan x = sin x / cos x

log : Float → Float → Float
log base x = ln x / ln base

_**_ : Float → Float → Float
a ** x = exp (x * ln a)

NaN : Float
NaN = 0.0 / 0.0

Inf : Float
Inf = 1.0 / 0.0

-Inf : Float
-Inf = -1.0 / 0.0


-- Andreas, 2018-06-19, issue #3130
-- Produce parenthesized dot pattern .(p) instead of .p
-- when is a projection.

-- {-# OPTIONS -v reify.pat:80 #-}

record R : Set₁ where
  field p : Set
open R

data D : (R → Set) → Set₁ where
  c : D p

test : (f : R → Set) (x : D f) → Set₁
test f x = {!x!}  -- split on x

-- Expected:
-- test .(p) c = ?


-- Andreas, 2017-01-18, issue #819, reported by stevana
-- Underscores should be preserved when case-splitting

data List (A : Set) : Set where
  _∷_ : (x : A)(xs : List A) → List A

data ⊥ : Set where

-- Case-splitting on x:
test : List ⊥ → ⊥
test (x ∷ _) = {!x!} -- split on x

-- I think the underscore should be kept.

expected : List ⊥ → ⊥
expected (() ∷ _)

-- Likewise here:

test′ : List ⊥ → List ⊥ → List ⊥ → ⊥
test′ (x ∷ _) ys _ = {!ys x!} -- split on ys and x

expected′ : List ⊥ → List ⊥ → List ⊥ → ⊥
expected′ (() ∷ _) (x ∷ ys) _


module Data.Bin.DivMod where

 import Data.Fin
 import Data.Product
 import Data.Bin
 import Data.Nat
 import Relation.Binary.PropositionalEquality
 import Data.Digit hiding (0b; 1b)
 import Data.List
 import Algebra
 import Algebra.Structures
 import Data.Bin.NatHelpers

 open Data.Bin using (Bin; toℕ; toBits; fromBits; _1#; 0#; 2+_; 0b; 1b)
 module PropEq = Relation.Binary.PropositionalEquality

 open Data.List using (_∷_; []; List)
 open Data.Nat using (ℕ; zero; suc)
 import Data.Nat.Properties

 open import Data.Bin.Utils

 open import Data.Bin.Bijection using (fromℕ-bijection; fromℕ; toℕ-inj; toFromℕ-inverse)

 import Data.Bin.Addition

 module Properties where

  open import Data.Bin.Multiplication
  open Data.Bin using () renaming (_+_ to _B+_; _*_ to _B*_)
  open Algebra.Structures using (IsCommutativeMonoid; module IsCommutativeSemiring)
  open PropEq
  open Data.Nat using (_+_; _*_)
  open Data.Nat.Properties using (isCommutativeSemiring)
  open IsCommutativeSemiring isCommutativeSemiring

 module Everything where

  open Data.Bin using (_1#; 0#; Bin; _+_; _*2; _*2+1; toℕ; ⌊_/2⌋; _*_; less)
  open import Data.Bin.Properties using (<-strictTotalOrder)
  open import Function
  open Data.Product
  open import Relation.Binary
  open Relation.Binary.PropositionalEquality renaming (setoid to ≡-setoid)
  open import Relation.Nullary
  open import Relation.Nullary.Decidable
  open Data.Fin using (zero; suc)
  open Data.List using (_∷_; [])

  open StrictTotalOrder <-strictTotalOrder hiding (trans)

  open import Data.Bin.Minus using (_-_)

  BinFin : Bin → Set
  BinFin n = ∃ λ x → x < n

  toBin : ∀ {x} → BinFin x → Bin
  toBin = proj₁

{-  data DivMod : Bin → Bin → Set where
    result : ∀ {divisor : Bin} (q : Bin) (r : BinFin divisor) → DivMod (toBin r + q * divisor) divisor-}

  data DivMod' (dividend : Bin) (divisor : Bin) : Set where
    result : (q : Bin) (r : BinFin divisor) → (eq : dividend ≡ toBin r + q * divisor) → DivMod' dividend divisor

  open Data.Digit

  open Data.Bin using (addBitLists; addBits; toBits; fromBits)

  open import Data.List using (List; _++_; [_]; [])
  open import Data.Empty

  import Data.Bin.Bijection

  import Data.Bin.Multiplication

  open Algebra.Structures using (module IsCommutativeMonoid)

  import Data.Bin.Props
  open Data.Bin.Props using (*-distrib; *2-is-2*; *2-distrib)
  open IsCommutativeMonoid Data.Bin.Props.bin-+-is-comm-monoid using ()
    renaming (identity to +-identity; comm to +-comm; assoc to +-assoc)

  open IsCommutativeMonoid Data.Bin.Props.bin-*-is-comm-monoid using () renaming (comm to *-comm)

  *-distribˡ : ∀ {a b c} → c * (a + b) ≡ c * a + c * b
  *-distribˡ {a} {b} {c} = *-comm c (a + b) ⟨ trans ⟩ *-distrib {a} {b} {c} ⟨ trans ⟩ cong₂ _+_ (*-comm a c) (*-comm b c)

  *-*2-assoc : ∀ {a b} → (a * b) *2 ≡ a *2 * b
  *-*2-assoc {a} {b} = Data.Bin.Multiplication.*-*2-comm a b

  *2-cong : ∀ {a b} → a ≡ b → a *2 ≡ b *2
  *2-cong = cong _*2

  +-cong₁ : ∀ {a b c} → a ≡ b → a + c ≡ b + c
  +-cong₁ {c = c} = cong (λ z → z + c)

  +-cong₂ : ∀ {a b c} → a ≡ b → c + a ≡ c + b
  +-cong₂ {c = c} = cong (λ z → c + z)

  +-identityʳ = proj₂ +-identity

  divMod2-lem : ∀ {a} → a ≡ ⌊ a /2⌋ *2 + a %2
  divMod2-lem {0#} = refl
  divMod2-lem {[] 1#} = refl
  divMod2-lem {(zero ∷ xs) 1#} = sym (+-identityʳ (⌊ (zero ∷ xs) 1# /2⌋ *2))
  divMod2-lem {(suc zero ∷ xs) 1#} = Data.Bin.Multiplication.∷1#-interpretation (suc zero) xs
                               ⟨ trans ⟩ +-comm ([] 1#) ((zero ∷ xs) 1#)
  divMod2-lem {(suc (suc ()) ∷ xs) 1#}

  import Relation.Binary.EqReasoning
  open import Data.Bin.Props

  helper' : ∀ l → ⌊ l 1# /2⌋ < l 1#
  helper' [] = Data.Bin.less (Data.Nat.s≤s Data.Nat.z≤n)
  helper' (x ∷ xs) = Data.Bin.less (Data.Bin.NatHelpers.kojojo x (toℕ (xs 1#)) (1+≢0 xs))

  helper : ∀ {a} {d} → (≢0 : False (d ≟ fromℕ 0)) → ¬ (a < d) → ⌊ a /2⌋ < a
  helper {_} {0#} () _
  helper {0#} {l 1#} _ a≮d = ⊥-elim (a≮d (z<nz l))
  helper {l 1#} _ _ = helper' l

  open import Data.Sum

  _≤_ : Bin → Bin → Set
  a ≤ b = a ≡ b ⊎ a < b

  ¬>→< : ∀ {a b} → ¬ (b ≤ a) → a < b
  ¬>→< {a} {b} a≰b with compare a b
  ... | tri< a<b _ _ = a<b
  ... | tri≈ _ a≡b _ = ⊥-elim (a≰b (inj₁ (sym a≡b)))
  ... | tri> _ _ a>b = ⊥-elim (a≰b (inj₂ a>b))

  *2-gives-space : ∀ {x y z} → (x < y) → z < fromℕ 2 → x *2 + z < y *2
  *2-gives-space {x} {y} {z} (less x<y) (less z<2) = less (finalize (Data.Bin.NatHelpers.*2-gives-space x<y z<2)) where
    open Data.Nat using () renaming (_*_ to _ℕ*_; _+_ to _ℕ+_; _<_ to _ℕ<_)

    eq1 : toℕ x ℕ* 2 ℕ+ toℕ z ≡ toℕ (x *2 + z)
    eq1 = sym (Data.Bin.Addition.+-is-addition (x *2) z ⟨ trans ⟩ cong (λ q → q ℕ+ toℕ z) (Data.Bin.Multiplication.*2-is-*2 x))
    eq2 : toℕ y ℕ* 2 ≡ toℕ (y *2)
    eq2 = sym (Data.Bin.Multiplication.*2-is-*2 y)

    finalize : toℕ x ℕ* 2 ℕ+ toℕ z ℕ< toℕ y ℕ* 2 → toℕ (x *2 + z) ℕ< toℕ (y *2)
    finalize = subst₂  _ℕ<_ eq1 eq2

  <-pres₁ : ∀ {a b c} → a ≡ b → a < c → b < c
  <-pres₁ refl eq = eq

  <-pres₂ : ∀ {a b c} → a ≡ b → c < a → c < b
  <-pres₂ refl eq = eq

  *-identityˡ : ∀ {x} → [] 1# * x ≡ x
  *-identityˡ = refl

  x*2≡x+x : ∀ {x} → x *2 ≡ x + x
  x*2≡x+x {x} = *2-is-2* x ⟨ trans ⟩ *-distrib {[] 1#} {[] 1#} {x} ⟨ trans ⟩ cong₂ _+_ (*-identityˡ {x}) (*-identityˡ {x})

  %2<2 : ∀ {x} → x %2 < fromℕ 2
  %2<2 {0#} = Data.Bin.less (Data.Nat.s≤s Data.Nat.z≤n)
  %2<2 {[] 1#} = Data.Bin.less (Data.Nat.s≤s (Data.Nat.s≤s Data.Nat.z≤n))
  %2<2 {(zero ∷ xs) 1#} = Data.Bin.less (Data.Nat.s≤s Data.Nat.z≤n)
  %2<2 {(suc zero ∷ xs) 1#} = Data.Bin.less (Data.Nat.s≤s (Data.Nat.s≤s Data.Nat.z≤n))
  %2<2 {(suc (suc ()) ∷ xs) 1#}

  -+-elim : ∀ {x z} → ¬ x < z → x - z + z ≡ x
  -+-elim = Data.Bin.Minus.-+-elim'

  open import Data.Bin.Addition using (+-is-addition)

  open import Data.Bin.Minus using (_-?_; positive; negative; equal; Greater; greater)

  lemma1 : ∀ (f d q : Bin) → (d + f) + q * d ≡ f + (fromℕ 1 + q) * d
  lemma1 f d q =
    let open ≡-Reasoning in
    begin
      (d + f) + q * d
        ≡⟨ +-cong₁ {c = q * d} (+-comm d f) ⟩
      (f + d) + q * d
        ≡⟨ +-assoc f d (q * d) ⟩
      f + (d + q * d)
        ≡⟨ +-cong₂ {c = f} (+-cong₁ {c = q * d} (*-identityˡ {d})) ⟩
      f + ((fromℕ 1 * d) + q * d)
        ≡⟨ +-cong₂ {c = f} (PropEq.sym (*-distrib {fromℕ 1} {q} {d}))  ⟩
      f + (fromℕ 1 + q) * d
    ∎

  lemma2 : ∀ d q → d + q * d ≡ d + 0# + q * d
  lemma2 d q =  cong₂ _+_ (sym (proj₂ +-identity d)) (refl {x = q * d})

  open import Algebra.FunctionProperties
    using (LeftCancellative; RightCancellative; Cancellative)

  +-cancelˡ-< : LeftCancellative Data.Nat._<_ Data.Nat._+_
  +-cancelˡ-< c {y} {z} le =
    Data.Nat.Properties.+-cancelˡ-≤ c
      (subst₂ Data.Nat._≤_
        (PropEq.sym (Data.Nat.Properties.+-suc c y))
        (PropEq.refl {x = (Data.Nat._+_ c z)}) le)

  +-<-left-cancellative : LeftCancellative _<_ _+_
  +-<-left-cancellative c {a} {b} (less le) = less (+-cancelˡ-< (toℕ c) brr) where
     brr : toℕ c Data.Nat.+ toℕ a Data.Nat.< toℕ c Data.Nat.+ toℕ b
     brr = (subst₂ Data.Nat._<_
         (Data.Bin.Addition.+-is-addition c a)
         (Data.Bin.Addition.+-is-addition c b) le)

  +-elim₂ : RightCancellative _<_ _+_
  +-elim₂ {z} x y (less lt) rewrite +-is-addition x z | +-is-addition y z = less (Data.Bin.NatHelpers.+-elim₂ {toℕ x} {toℕ y} {toℕ z} lt)

  fixup-divmod :
    ∀ a d q r
    → a ≡ r + q * d
    → r < d + d
    → DivMod' a d
  fixup-divmod a d q r eq not-too-big =
    case r -? d of λ {
      (positive (greater diff PropEq.refl)) →
        result
          (fromℕ 1 + q)
          (diff 1# , +-<-left-cancellative d not-too-big)
          (PropEq.trans eq (lemma1 (diff 1#) d q));
      (negative x) → result q (r , Data.Bin.Minus.greater-to-< _ _ x) eq ;
      (equal PropEq.refl) →
        result
          (fromℕ 1 + q)
          (0# ,
            (+-<-left-cancellative
              d
              (subst (λ z → z < d + d) (PropEq.sym (proj₂ +-identity _)) not-too-big )) )
          (PropEq.trans eq (PropEq.trans (lemma2 d q) (lemma1 0# d q)))
       }

  lemma3 : ∀ r q d bit → (r + q * d) *2 + bit ≡ (r *2 + bit) + q *2 * d
  lemma3 r q d bit =
    let open ≡-Reasoning in
    begin
      (r + q * d) *2 + bit
        ≡⟨ +-cong₁ {c = bit}
           (begin
             (r + q * d) *2
               ≡⟨ *2-distrib r (q * d) ⟩
             r *2 + (q * d) *2
               ≡⟨ +-comm (r *2) ((q * d) *2) ⟩
             (q * d) *2 + r *2
           ∎) ⟩
      ((q * d) *2 + r *2) + bit
        ≡⟨ +-assoc ((q * d) *2) (r *2) (bit) ⟩
      (q * d) *2 + (r *2 + bit)
        ≡⟨ +-comm ((q * d) *2) (r *2 + bit) ⟩
      (r *2 + bit) + (q * d) *2
        ≡⟨ +-cong₂ {c = r *2 + bit} (*-*2-assoc {q} {d})  ⟩
      (r *2 + bit) + q *2 * d
    ∎

  dm-step :
    ∀ a d q (r : BinFin d) → a ≡ toBin r + q * d →
    ∀ w (bit : BinFin (fromℕ 2))
    → w ≡ (a *2 + proj₁ bit)
    → DivMod' w d
  dm-step ._ d q (r' , r'<d) refl ._ (bit , bit<2) refl =
    fixup-divmod
      _ d (q *2) (r' *2 + bit)
      (lemma3 r' q d bit)
      (<-pres₂ x*2≡x+x (*2-gives-space {r'} {d} {bit} r'<d (bit<2)))

  dmRec : (d : Bin) → {≢0 : False (d ≟ fromℕ 0)} → (a : Bin) → ((a' : Bin) → (a' < a) → DivMod' a' d) → DivMod' a d
  dmRec d {≢0} a rec =
    case a <? d of λ {
      (yes a<d) → result (0#) (a , a<d) (sym (+-identityʳ _)) ;
      (no ¬a<d) →
        case rec ⌊ a /2⌋ (helper ≢0 ¬a<d) of
          λ { (result q r eq) →
            dm-step ⌊ a /2⌋ d q r eq a (a %2 , %2<2) divMod2-lem } }

  import Data.Bin.Rec

  _divMod_ : (a : Bin) → (d : Bin) → {≢0 : False (d ≟ fromℕ 0)} → DivMod' a d
  _divMod_ a d {≡0} = Data.Bin.Rec.rec (λ x → DivMod' x d) (dmRec d {≡0}) a


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

open import Categories.Category.Monoidal.Structure
  using (SymmetricMonoidalCategory)

module Categories.Functor.Monoidal.Symmetric {o o′ ℓ ℓ′ e e′}
  (C : SymmetricMonoidalCategory o ℓ e) (D : SymmetricMonoidalCategory o′ ℓ′ e′)
  where

open import Level
open import Data.Product using (_,_)

open import Categories.Functor using (Functor)
open import Categories.Functor.Monoidal

private
  module C = SymmetricMonoidalCategory C renaming (braidedMonoidalCategory to B)
  module D = SymmetricMonoidalCategory D renaming (braidedMonoidalCategory to B)

import Categories.Functor.Monoidal.Braided C.B D.B as Braided

module Lax where
  open Braided.Lax

  -- Lax symmetric monoidal functors are just lax braided monoidal
  -- functors between symmetric monoidal categories.

  record SymmetricMonoidalFunctor : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      F                 : Functor C.U D.U
      isBraidedMonoidal : IsBraidedMonoidalFunctor F

    open Functor F public
    open IsBraidedMonoidalFunctor isBraidedMonoidal public

    monoidalFunctor : MonoidalFunctor C.monoidalCategory D.monoidalCategory
    monoidalFunctor = record { isMonoidal = isMonoidal }

module Strong where
  open Braided.Strong

  -- Strong symmetric monoidal functors are just strong braided
  -- monoidal functors between symmetric monoidal categories.

  record SymmetricMonoidalFunctor : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      F                 : Functor C.U D.U
      isBraidedMonoidal : IsBraidedMonoidalFunctor F

    open Functor F public
    open IsBraidedMonoidalFunctor isBraidedMonoidal public

    monoidalFunctor : StrongMonoidalFunctor C.monoidalCategory D.monoidalCategory
    monoidalFunctor = record { isStrongMonoidal = isStrongMonoidal }


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

module Data.Binary.Proofs.Addition where

open import Relation.Binary.PropositionalEquality
open import Data.Binary.Operations.Unary
open import Data.Binary.Operations.Addition
open import Data.Binary.Proofs.Unary
open import Data.Binary.Proofs.Semantics
open import Data.Binary.Definitions
open import Data.Binary.Operations.Semantics
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality.FasterReasoning
import Data.Nat.Properties as ℕ
open import Function
open import Data.Nat.Reasoning

mutual
  add₀-homo : ∀ xs ys → ⟦ add O xs ys ⇓⟧⁺ ≡ ⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺
  add₀-homo 1ᵇ 1ᵇ = refl
  add₀-homo 1ᵇ (O ∷ ys) = refl
  add₀-homo 1ᵇ (I ∷ ys) = cong 2* (inc⁺⁺-homo ys) ⟨ trans ⟩ ℕ.+-suc (suc ⟦ ys ⇓⟧⁺) _
  add₀-homo (O ∷ xs) 1ᵇ = ℕ.+-comm 1 _
  add₀-homo (O ∷ xs) (O ∷ ys) = cong 2* (add₀-homo xs ys) ⟨ trans ⟩ 2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺
  add₀-homo (O ∷ xs) (I ∷ ys) = cong suc (cong 2* (add₀-homo xs ys) ⟨ trans ⟩ 2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺) ⟨ trans ⟩ sym (ℕ.+-suc (2* ⟦ xs ⇓⟧⁺) (2* ⟦ ys ⇓⟧⁺))
  add₀-homo (I ∷ xs) 1ᵇ = inc⁺⁺-homo (I ∷ xs) ⟨ trans ⟩ cong suc (ℕ.+-comm 1 _)
  add₀-homo (I ∷ xs) (O ∷ ys) = cong suc (cong 2* (add₀-homo xs ys) ⟨ trans ⟩ 2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺)
  add₀-homo (I ∷ xs) (I ∷ ys) = cong 2* (add₁-homo xs ys) ⟨ trans ⟩ (ℕ.+-suc (suc (⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺)) _ ⟨ trans ⟩
                                cong suc (cong suc (2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺))) ⟨ trans ⟩
                                sym (cong suc (ℕ.+-suc (2* ⟦ xs ⇓⟧⁺) _))

  add₁-homo : ∀ xs ys → ⟦ add I xs ys ⇓⟧⁺ ≡ suc (⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺)
  add₁-homo 1ᵇ 1ᵇ = refl
  add₁-homo 1ᵇ (O ∷ ys) = cong 2* (inc⁺⁺-homo ys) ⟨ trans ⟩ ℕ.+-suc (suc ⟦ ys ⇓⟧⁺) _
  add₁-homo 1ᵇ (I ∷ ys) = cong suc (cong 2* (inc⁺⁺-homo ys) ⟨ trans ⟩ ℕ.+-suc (suc ⟦ ys ⇓⟧⁺) _)
  add₁-homo (O ∷ xs) 1ᵇ = cong 2* (inc⁺⁺-homo xs) ⟨ trans ⟩ (ℕ.+-suc (suc ⟦ xs ⇓⟧⁺) _ ⟨ trans ⟩ cong suc (ℕ.+-comm 1 _))
  add₁-homo (O ∷ xs) (O ∷ ys) = cong suc (cong 2* (add₀-homo xs ys) ⟨ trans ⟩ 2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺)
  add₁-homo (O ∷ xs) (I ∷ ys) = cong 2* (add₁-homo xs ys) ⟨ trans ⟩ (ℕ.+-suc (suc (⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺)) _ ⟨ trans ⟩ (cong suc (cong suc ((2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺))) ⟨ trans ⟩ cong suc (sym (ℕ.+-suc (2* ⟦ xs ⇓⟧⁺) _)) ))
  add₁-homo (I ∷ xs) 1ᵇ = cong suc (cong 2* (inc⁺⁺-homo xs) ⟨ trans ⟩ cong suc (ℕ.+-suc ⟦ xs ⇓⟧⁺ _ ⟨ trans ⟩ ℕ.+-comm 1 _))
  add₁-homo (I ∷ xs) (O ∷ ys) = cong 2* (add₁-homo xs ys) ⟨ trans ⟩ (ℕ.+-suc (suc (⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺)) _ ⟨ trans ⟩ cong suc (cong suc (2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺)))
  add₁-homo (I ∷ xs) (I ∷ ys) = cong suc (cong 2* (add₁-homo xs ys) ⟨ trans ⟩ (ℕ.+-suc (suc (⟦ xs ⇓⟧⁺ ℕ.+ ⟦ ys ⇓⟧⁺) ) _ ⟨ trans ⟩ cong suc (cong suc (2*-distrib ⟦ xs ⇓⟧⁺ ⟦ ys ⇓⟧⁺)) ⟨ trans ⟩ cong suc (sym (ℕ.+-suc (2* ⟦ xs ⇓⟧⁺) _)) ))

+-homo : ∀ xs ys → ⟦ xs + ys ⇓⟧ ≡ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧
+-homo 0ᵇ ys = refl
+-homo (0< x) 0ᵇ = sym (ℕ.+-identityʳ _)
+-homo (0< xs) (0< ys) = add₀-homo xs ys


module Cats.Category.Cat where

open import Cats.Functor public using (Functor ; _∘_ ; id)

open import Data.Product using (_,_)
open import Data.Unit using (⊤ ; tt)
open import Level
open import Relation.Binary using
  (IsEquivalence ; _Preserves_⟶_ ; _Preserves₂_⟶_⟶_)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

open import Cats.Category
open import Cats.Category.Zero
open import Cats.Category.One
open import Cats.Trans.Iso as NatIso using (NatIso ; iso ; forth-natural)
open import Cats.Util.Simp using (simp!)

open Functor
open Category._≅_

_⇒_ : ∀ {lo la l≈ lo′ la′ l≈′}
  → Category lo la l≈ → Category lo′ la′ l≈′ → Set _
C ⇒ D = Functor C D

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  infixr 4 _≈_

  _≈_ : (F G : C ⇒ D) → Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′)
  F ≈ G = NatIso F G

  equiv : IsEquivalence _≈_
  equiv = record
      { refl = NatIso.id
      ; sym = NatIso.sym
      ; trans = λ eq₁ eq₂ → eq₂ NatIso.∘ eq₁
      }

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  ∘-resp : ∀ {lo″ la″ l≈″} {E : Category lo″ la″ l≈″}
    → {F G : D ⇒ E} {H I : C ⇒ D}
    → F ≈ G
    → H ≈ I
    → F ∘ H ≈ G ∘ I
  ∘-resp {E = E} {F} {G} {H} {I}
    record { iso = F≅G ; forth-natural = fnat-GH }
    record { iso = H≅I ; forth-natural = fnat-HI }
      = record
      { iso = E.≅.trans F≅G (fobj-resp G H≅I)
      ; forth-natural = λ {_} {_} {f} →
          begin
            (fmap G (forth H≅I) E.∘ forth F≅G) E.∘ fmap F (fmap H f)
          ≈⟨ simp! E ⟩
            fmap G (forth H≅I) E.∘ forth F≅G E.∘ fmap F (fmap H f)
          ≈⟨ E.∘-resp-r fnat-GH ⟩
            fmap G (forth H≅I) E.∘ fmap G (fmap H f) E.∘ forth F≅G
          ≈⟨ simp! E ⟩
            (fmap G (forth H≅I) E.∘ fmap G (fmap H f)) E.∘ forth F≅G
          ≈⟨ E.∘-resp-l (fmap-∘ G) ⟩
            fmap G (forth H≅I D.∘ fmap H f) E.∘ forth F≅G
          ≈⟨ E.∘-resp-l (fmap-resp G fnat-HI) ⟩
            fmap G (fmap I f D.∘ forth H≅I) E.∘ forth F≅G
          ≈⟨ E.∘-resp-l (E.≈.sym (fmap-∘ G)) ⟩
            (fmap G (fmap I f) E.∘ fmap G (forth H≅I)) E.∘ forth F≅G
          ≈⟨ simp! E ⟩
            fmap G (fmap I f) E.∘ fmap G (forth H≅I) E.∘ forth F≅G
          ∎
      }
    where
      module D = Category D
      module E = Category E
      open E.≈-Reasoning

  id-r : {F : C ⇒ D} → F ∘ id ≈ F
  id-r {F} = record
      { iso = D.≅.refl
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }
    where
      module D = Category D

  id-l : {F : C ⇒ D} → id ∘ F ≈ F
  id-l {F} = record
      { iso = D.≅.refl
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }
    where
      module D = Category D

  assoc : ∀ {lo″ la″ l≈″ lo‴ la‴ l≈‴}
    → {E : Category lo″ la″ l≈″} {X : Category lo‴ la‴ l≈‴}
    → (F : E ⇒ X) (G : D ⇒ E) (H : C ⇒ D)
    → (F ∘ G) ∘ H ≈ F ∘ (G ∘ H)
  assoc {E = E} {X} _ _ _ = record
      { iso = X.≅.refl
      ; forth-natural = X.≈.trans X.id-l (X.≈.sym X.id-r)
      }
    where
      module X = Category X

instance
  Cat : ∀ lo la l≈
    → Category (suc (lo ⊔ la ⊔ l≈)) (lo ⊔ la ⊔ l≈) (lo ⊔ la ⊔ l≈)
  Cat lo la l≈ = record
      { Obj = Category lo la l≈
      ; _⇒_ = _⇒_
      ; _≈_ = _≈_
      ; id = id
      ; _∘_ = _∘_
      ; equiv = equiv
      ; ∘-resp = ∘-resp
      ; id-r = id-r
      ; id-l = id-l
      ; assoc = λ {_} {_} {_} {_} {F} {G} {H} → assoc F G H
      }


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

open import Data.Product

data ⊥ : Set where

-- f doesn't type check unless we put the equality type in Set
data _≡_ {ℓ} {A : Set ℓ} (a : A) : A → Set where
  refl : a ≡ a

subst : ∀ {ℓ ℓ′} {A : Set ℓ} {a b : A} → (P : A → Set ℓ′) → (p : a ≡ b) → P a → P b
subst _ refl pa = pa

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ A = A → ⊥

℘ : ∀ {ℓ} → Set ℓ → Set _
℘ {ℓ} S = S → Set

{-# NO_POSITIVITY_CHECK #-}
record Bad : Set₁ where
  constructor mkBad
  field bad : ℘ (℘ Bad)

f : ℘ Bad → Bad
f p = mkBad (_≡ p)

fInj : ∀ {p q} → f p ≡ f q → p ≡ q
fInj {p} fp≡fq = subst (λ p≡ → p≡ p) (badInj fp≡fq) refl
  where
  badInj : ∀ {a b} → mkBad a ≡ mkBad b → a ≡ b
  badInj refl = refl

-- type-in-type is for here onwards
P₀ : ℘ Bad
P₀ x = Σ[ P ∈ ℘ Bad ] x ≡ f P × ¬ (P x)

x₀ : Bad
x₀ = f P₀

P₀x₀→¬P₀x₀ : P₀ x₀ → ¬ P₀ x₀
P₀x₀→¬P₀x₀ (P , x₀≡fP , ¬Px₀) P₀x₀ = ¬Px₀ (subst (λ P → P x₀) (fInj x₀≡fP) P₀x₀)

¬P₀x₀→P₀x₀ : ¬ P₀ x₀ → P₀ x₀
¬P₀x₀→P₀x₀ ¬P₀x₀ = P₀ , refl , ¬P₀x₀

¬P₀x₀ : ¬ P₀ x₀
¬P₀x₀ P₀x₀ = P₀x₀→¬P₀x₀ P₀x₀ P₀x₀

false : ⊥
false = ¬P₀x₀ (¬P₀x₀→P₀x₀ ¬P₀x₀)


{-# OPTIONS --cubical-compatible #-}
open import Common.Prelude
open import Common.Equality
open import Common.Product

data _≅_ {A : Set} (a : A) : {B : Set} (b : B) → Set₁ where
  refl : a ≅ a

data D : Bool → Set where
  x  : D true
  y  : D false

P : Set -> Set₁
P S = Σ S (\s → s ≅ x)

pbool : P (D true)
pbool = _ , refl

¬pfin : P (D false) → ⊥
¬pfin (y , ())


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

module Issue3577 where

open import Agda.Primitive.Cubical renaming (primTransp to transp; primHComp to hcomp)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Sigma
open import Agda.Builtin.Cubical.Sub renaming (primSubOut to ouc; Sub to _[_↦_])

refl : ∀ {l} {A : Set l} {x : A} → x ≡ x
refl {x = x} = \ _ → x

ptType : Set₁
ptType = Σ Set (λ A → A)

data Susp' (A : ptType) : Set where
  susp*  : Susp' A

-- Non-computation of transp on non-HIT's hcomp
testTr : {A' : ptType} (ψ : I) (A : I → ptType [ ψ ↦ (\ _ → A') ])
         {φ : I}
         (u : ∀ i → Partial φ (Susp' (ouc (A i0))))
         (u0 : Susp' (ouc (A i0)) [ φ ↦ u i0 ])
         → transp (\ i -> Susp' (ouc (A i))) ψ (hcomp u (ouc u0))
         ≡ hcomp (λ j .o → transp (λ i → Susp' (ouc (A i))) ψ (u j o)) (transp (λ i → Susp' (ouc (A i))) ψ (ouc u0))
testTr ψ A u u0 = refl


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

open import HoTT
open import cohomology.Exactness
open import cohomology.FunctionOver

module cohomology.ProductRepr where

{- Given the following commutative diagram of homomorphisms,

       H₁  i₁  i₂  H₂
          ↘     ↙
    id ↓     G     ↓ id
           ↙   ↘
       H₁ j₁   j₂  H₂

 - there exists an isomorphism G == H₁ × H₂ such that i₁,i₂ correspond
 - to the natural injections and j₁,j₂ correspond to the natural
 - projections. -}

module ProductRepr {i j}
  {G : Group (lmax i j)} {H₁ : Group i} {H₂ : Group j}
  (i₁ : H₁ →ᴳ G) (i₂ : H₂ →ᴳ G) (j₁ : G →ᴳ H₁) (j₂ : G →ᴳ H₂)
  (p₁ : ∀ h₁ → GroupHom.f j₁ (GroupHom.f i₁ h₁) == h₁)
  (p₂ : ∀ h₂ → GroupHom.f j₂ (GroupHom.f i₂ h₂) == h₂)
  (ex₁ : is-exact (GroupHom.⊙f i₁) (GroupHom.⊙f j₂))
  (ex₂ : is-exact (GroupHom.⊙f i₂) (GroupHom.⊙f j₁))
  where

  zero-ker : (g : Group.El G)
    → GroupHom.f (×ᴳ-hom-in j₁ j₂) g == Group.ident (H₁ ×ᴳ H₂)
    → g == Group.ident G
  zero-ker g q = Trunc-rec (Group.El-level G _ _)
      (lemma g (fst×= q))
      (ktoi ex₁ g (snd×= q))
    where
    lemma : (g : Group.El G) (r : GroupHom.f j₁ g == Group.ident H₁)
      → Σ (Group.El H₁) (λ h → GroupHom.f i₁ h == g)
      → g == Group.ident G
    lemma ._ r (h , idp) =
      ap (GroupHom.f i₁) (! (p₁ h) ∙ r) ∙ GroupHom.pres-ident i₁

  β₁ : (h₁ : Group.El H₁) (h₂ : Group.El H₂)
    → GroupHom.f j₁ (Group.comp G (GroupHom.f i₁ h₁) (GroupHom.f i₂ h₂)) == h₁
  β₁ h₁ h₂ =
    GroupHom.pres-comp j₁ (GroupHom.f i₁ h₁) (GroupHom.f i₂ h₂)
    ∙ ap2 (Group.comp H₁) (p₁ h₁) (itok ex₂ _ [ h₂ , idp ])
    ∙ Group.unitr H₁ h₁

  β₂ : (h₁ : Group.El H₁) (h₂ : Group.El H₂)
    → GroupHom.f j₂ (Group.comp G (GroupHom.f i₁ h₁) (GroupHom.f i₂ h₂)) == h₂
  β₂ h₁ h₂ =
    GroupHom.pres-comp j₂ (GroupHom.f i₁ h₁) (GroupHom.f i₂ h₂)
    ∙ ap2 (Group.comp H₂) (itok ex₁ _ [ h₁ , idp ]) (p₂ h₂)
    ∙ Group.unitl H₂ h₂

  iso : G == H₁ ×ᴳ H₂
  iso = surj-inj-= (×ᴳ-hom-in j₁ j₂)
    (zero-kernel-injective (×ᴳ-hom-in j₁ j₂) zero-ker)
    (λ {(h₁ , h₂) → [ Group.comp G (GroupHom.f i₁ h₁) (GroupHom.f i₂ h₂) ,
                      pair×= (β₁ h₁ h₂) (β₂ h₁ h₂) ]})

  fst-over : j₁ == ×ᴳ-fst [ (λ U → U →ᴳ H₁) ↓ iso ]
  fst-over = domain-over-iso _ _ _ _ $ domain-over-equiv fst _

  snd-over : j₂ == ×ᴳ-snd {G = H₁} [ (λ U → U →ᴳ H₂) ↓ iso ]
  snd-over = domain-over-iso _ _ _ _ $ domain-over-equiv snd _

  inl-over : i₁ == ×ᴳ-inl [ (λ V → H₁ →ᴳ V) ↓ iso ]
  inl-over = codomain-over-iso _ _ _ _ $
    codomain-over-equiv (GroupHom.f i₁) _
    ▹ λ= (λ h₁ → pair×= (p₁ h₁) (itok ex₁ _ [ h₁ , idp ]))

  inr-over : i₂ == ×ᴳ-inr {G = H₁} [ (λ V → H₂ →ᴳ V) ↓ iso ]
  inr-over = codomain-over-iso _ _ _ _ $
    codomain-over-equiv (GroupHom.f i₂) _
    ▹ λ= (λ h₂ → pair×= (itok ex₂ _ [ h₂ , idp ]) (p₂ h₂))

  {- Given additionally maps

            i₀    j₀
         K –––→ G ––→ L

   - such that j₀∘i₀ = 0, we have j₀(i₁(j₁(i₀ k)))⁻¹ = j₀(i₂(j₂(i₀ k))).
   - (This is called the hexagon lemma in Eilenberg & Steenrod's book.
   - The hexagon is not visible in this presentation.)
   -}

  module HexagonLemma {k l}
    {K : Group k} {L : Group l}
    (i₀ : K →ᴳ G) (j₀ : G →ᴳ L)
    (ex₀ : ∀ g → GroupHom.f j₀ (GroupHom.f i₀ g) == Group.ident L)
    where

    decomp : ∀ g → Group.comp G (GroupHom.f i₁ (GroupHom.f j₁ g))
                                (GroupHom.f i₂ (GroupHom.f j₂ g))
                   == g
    decomp = transport
      (λ {(G' , i₁' , i₂' , j₁' , j₂') → ∀ g →
         Group.comp G' (GroupHom.f i₁' (GroupHom.f j₁' g))
                       (GroupHom.f i₂' (GroupHom.f j₂' g))
         == g})
      (! (pair= iso (↓-×-in inl-over (↓-×-in inr-over
                                             (↓-×-in fst-over snd-over)))))
      (λ {(h₁ , h₂) → pair×= (Group.unitr H₁ h₁) (Group.unitl H₂ h₂)})

    cancel : ∀ k →
      Group.comp L (GroupHom.f (j₀ ∘ᴳ i₁ ∘ᴳ j₁ ∘ᴳ i₀) k)
                   (GroupHom.f (j₀ ∘ᴳ i₂ ∘ᴳ j₂ ∘ᴳ i₀) k)
      == Group.ident L
    cancel k = ! (GroupHom.pres-comp j₀ _ _)
             ∙ ap (GroupHom.f j₀) (decomp (GroupHom.f i₀ k))
             ∙ ex₀ k

    inv₁ : ∀ k → Group.inv L (GroupHom.f (j₀ ∘ᴳ i₁ ∘ᴳ j₁ ∘ᴳ i₀) k)
              == GroupHom.f (j₀ ∘ᴳ i₂ ∘ᴳ j₂ ∘ᴳ i₀) k
    inv₁ k = group-inv-unique-r L _ _ (cancel k)

    inv₂ : ∀ k → Group.inv L (GroupHom.f (j₀ ∘ᴳ i₂ ∘ᴳ j₂ ∘ᴳ i₀) k)
              == GroupHom.f (j₀ ∘ᴳ i₁ ∘ᴳ j₁ ∘ᴳ i₀) k
    inv₂ k = group-inv-unique-l L _ _ (cancel k)


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Sigma

open import Cubical.Foundations.Structure
open import Cubical.Foundations.Structure using (typ) public
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Isomorphism

private
  variable
    ℓ ℓ' : Level

Pointed : (ℓ : Level) → Type (ℓ-suc ℓ)
Pointed ℓ = TypeWithStr ℓ (λ x → x)

pt : ∀ {ℓ} (A∙ : Pointed ℓ) → typ A∙
pt = str

Pointed₀ = Pointed ℓ-zero

{- Pointed functions -}
_→∙_ : ∀{ℓ ℓ'} → (A : Pointed ℓ) (B : Pointed ℓ') → Type (ℓ-max ℓ ℓ')
_→∙_ A B = Σ[ f ∈ (typ A → typ B) ] f (pt A) ≡ pt B

_→∙_∙ : ∀{ℓ ℓ'} → (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
A →∙ B ∙  = (A →∙ B) , (λ x → pt B) , refl

idfun∙ : ∀ {ℓ} (A : Pointed ℓ) → A →∙ A
idfun∙ A = (λ x → x) , refl

-- Pointed equivalences
_≃∙_ : (A : Pointed ℓ) (B : Pointed ℓ') → Type (ℓ-max ℓ ℓ')
A ≃∙ B = Σ[ (f , p) ∈ A →∙ B ] isEquiv f

≃∙→≃ : {A : Pointed ℓ} {B : Pointed ℓ'}
       (f : A ≃∙ B)
       → typ A ≃ typ B
≃∙→≃ f = fst (fst f) , snd f

idEquiv∙ : (A : Pointed ℓ) → A ≃∙ A
idEquiv∙ (A , ⋆) =
  (idfun∙ (A , ⋆)) ,
  record { equiv-proof = λ a → p a }
    where
      module _ (a : A) where
        p : isContr (Σ[ a' ∈ A ] a' ≡ a)
        p = isContrRespectEquiv (Σ-cong-equiv-snd (λ a₁ → isoToEquiv (iso sym sym (λ _ → refl) λ _ → refl))) (isContrSingl a)

{- HIT allowing for pattern matching on pointed types -}
data Pointer {ℓ} (A : Pointed ℓ) : Type ℓ where
  pt₀ : Pointer A
  ⌊_⌋ : typ A → Pointer A
  id : ⌊ pt A ⌋ ≡ pt₀

IsoPointedPointer : ∀ {ℓ} {A : Pointed ℓ} → Iso (typ A) (Pointer A)
Iso.fun IsoPointedPointer = ⌊_⌋
Iso.inv (IsoPointedPointer {A = A}) pt₀ = pt A
Iso.inv IsoPointedPointer ⌊ x ⌋ = x
Iso.inv (IsoPointedPointer {A = A}) (id i) = pt A
Iso.rightInv IsoPointedPointer pt₀ = id
Iso.rightInv IsoPointedPointer ⌊ x ⌋ = refl
Iso.rightInv IsoPointedPointer (id i) j = id (i ∧ j)
Iso.leftInv IsoPointedPointer x = refl


{-# OPTIONS --without-K --safe #-}
open import Categories.Category using (Category)

-- A "canonical" presentation of cartesian closed categories.
--
-- This presentation is equivalent to the one in
-- Categories.Category.CartesianClosed but it is easier to work with
-- in some circumstances.
--
-- Here, exponentials are not defined in terms of arbitrary products,
-- but in terms of a family of "canonical" products.  Since products
-- are defined only up to isomorphism the choice of product does not
-- matter for the property of being cartesian closed, but working with
-- a fixed choice of representatives simplifies the constructions of
-- some instances of CCCs (e.g. Cats).

module Categories.Category.CartesianClosed.Canonical {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level using (levelOfTerm)
open import Function using (flip)

open import Categories.Category.Cartesian 𝒞 using (Cartesian)
import Categories.Category.CartesianClosed 𝒞 as 𝒞-CC
open import Categories.Object.Exponential 𝒞 using (Exponential)
open import Categories.Object.Product 𝒞
open import Categories.Object.Terminal 𝒞 using (Terminal)
open import Categories.Morphism.Reasoning 𝒞

private
  module 𝒞 = Category 𝒞
  open Category 𝒞
  open HomReasoning

  variable
    A B C : Obj
    f g h f₁ f₂ g₁ g₂ : A ⇒ B

-- A (canonical) cartesian closed category is a category with all
-- (canonical) products and exponentials
--
-- This presentation is equivalent to the one in
-- Categories.Category.CartesianClosed.CartesianClosed.
record CartesianClosed : Set (levelOfTerm 𝒞) where
  infixr 7 _×_
  infixr 9 _^_
  infix 10 ⟨_,_⟩

  field

    -- Canonical products

    ⊤    : Obj
    _×_  : Obj → Obj → Obj

    !     : A ⇒ ⊤
    π₁    : A × B ⇒ A
    π₂    : A × B ⇒ B
    ⟨_,_⟩ : C ⇒ A → C ⇒ B → C ⇒ A × B

    !-unique : (f : A ⇒ ⊤) → ! ≈ f

    π₁-comp  : π₁ ∘ ⟨ f , g ⟩ ≈ f
    π₂-comp  : π₂ ∘ ⟨ f , g ⟩ ≈ g

    ⟨,⟩-unique : π₁ ∘ h ≈ f → π₂ ∘ h ≈ g → ⟨ f , g ⟩ ≈ h

  -- The above defines canonical finite products, making 𝒞 cartesian.

  ⊤-terminal : Terminal
  ⊤-terminal = record { !-unique = !-unique }

  ×-product : ∀ {A B} → Product A B
  ×-product {A} {B} =
    record { project₁ = π₁-comp; project₂ = π₂-comp; unique = ⟨,⟩-unique }

  isCartesian : Cartesian
  isCartesian = record
    { terminal = ⊤-terminal
    ; products = record { product = ×-product }
    }

  module cartesian = Cartesian isCartesian
  open cartesian public
    hiding (_×_; π₁; π₂; ⟨_,_⟩)
    renaming (⟨⟩-cong₂ to ⟨,⟩-resp-≈)

  field

    -- Canonical exponentials (w.r.t. the canonical products)

    _^_   : Obj → Obj → Obj
    eval  : B ^ A × A ⇒ B
    curry : C × A ⇒ B → C ⇒ B ^ A

    eval-comp  : eval ∘ (curry f ⁂ id) ≈ f

    curry-resp-≈ : f ≈ g → curry f ≈ curry g
    curry-unique : eval ∘ (f ⁂ id) ≈ g → f ≈ curry g

  -- The above defines canonical exponentials, making 𝒞 cartesian closed.
  --
  -- NOTE: below we use "⊗" to indicate "non-canonical" products.

  ^-exponential : ∀ {A B} → Exponential A B
  ^-exponential {A} {B} = record
    { B^A      = B ^ A
    ; product  = ×-product
    ; eval     = eval
    ; λg       = λ C⊗A f → curry (f ∘ repack ×-product C⊗A)
    ; β        = λ {C} C⊗A {g} →
      begin
        eval ∘ [ C⊗A ⇒ ×-product ] curry (g ∘ repack ×-product C⊗A) ×id
      ≈˘⟨ pullʳ [ ×-product ⇒ ×-product ]×∘⟨⟩ ⟩
        (eval ∘ (curry (g ∘ repack ×-product C⊗A) ⁂ id)) ∘ repack C⊗A ×-product
      ≈⟨ eval-comp ⟩∘⟨refl ⟩
        (g ∘ repack ×-product C⊗A) ∘ repack C⊗A ×-product
      ≈⟨ cancelʳ (repack∘repack≈id ×-product C⊗A) ⟩
        g
      ∎
    ; λ-unique = λ {C} C⊗A {g} {f} hyp →
      curry-unique (begin
        eval ∘ (f ⁂ id)
      ≈˘⟨ pullʳ [ C⊗A ⇒ ×-product ]×∘⟨⟩ ⟩
        (eval ∘ [ C⊗A ⇒ ×-product ] f ×id) ∘ repack ×-product C⊗A
      ≈⟨ hyp ⟩∘⟨refl ⟩
        g ∘ repack ×-product C⊗A
      ∎)
    }

module Equivalence where
  open 𝒞-CC using () renaming (CartesianClosed to CartesianClosed′)

  -- The two presentations of CCCs are equivalent

  fromCanonical : CartesianClosed → CartesianClosed′
  fromCanonical cc = record
    { cartesian = CartesianClosed.isCartesian cc
    ; exp       = CartesianClosed.^-exponential cc
    }

  toCanonical : CartesianClosed′ → CartesianClosed
  toCanonical cc = record
    { ⊤     = ⊤
    ; _×_   = _×_
    ; !     = !
    ; π₁    = π₁
    ; π₂    = π₂
    ; ⟨_,_⟩ = ⟨_,_⟩
    ; !-unique   = !-unique
    ; π₁-comp    = project₁
    ; π₂-comp    = project₂
    ; ⟨,⟩-unique = unique
    ; _^_   = _^_
    ; eval  = eval′
    ; curry = λg
    ; eval-comp    = β′
    ; curry-resp-≈ = λ-cong
    ; curry-unique = λ-unique′
    }
    where open CartesianClosed′ cc


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

open import Cubical.Core.Everything
open import Cubical.Relation.Binary.Raw

module Cubical.Relation.Binary.Raw.Construct.NonStrictToStrict
  {a ℓ} {A : Type a} (_≤_ : RawRel A ℓ) where

open import Cubical.Relation.Binary.Raw.Properties
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma
open import Cubical.Data.Sum.Base using (inl; inr)
open import Cubical.Data.Empty hiding (rec)
open import Cubical.Foundations.Function using (_∘_; flip)
open import Cubical.Relation.Nullary
open import Cubical.HITs.PropositionalTruncation hiding (elim)

private
  _≢_ : RawRel A a
  x ≢ y = ¬ (x ≡ y)

------------------------------------------------------------------------
-- _≤_ can be turned into _<_ as follows:

_<_ : RawRel A _
x < y = x ≤ y × x ≢ y

------------------------------------------------------------------------
-- Relationship between relations

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ = fst

<⇒≢ : _<_ ⇒ _≢_
<⇒≢ = snd

≤∧≢⇒< : ∀ {x y} → x ≤ y → x ≢ y → x < y
≤∧≢⇒< = _,_

<⇒≱ : Antisymmetric _≤_ → ∀ {x y} → x < y → ¬ (y ≤ x)
<⇒≱ antisym (x≤y , x≢y) y≤x = x≢y (antisym x≤y y≤x)

≤⇒≯ : Antisymmetric _≤_ → ∀ {x y} → x ≤ y → ¬ (y < x)
≤⇒≯ antisym x≤y y<x = <⇒≱ antisym y<x x≤y

≰⇒> : Reflexive _≤_ → Total _≤_ →
      ∀ {x y} → ¬ (x ≤ y) → y < x
≰⇒> rfl total {x} {y} x≰y with total x y
... | inl x≤y = elim (x≰y x≤y)
... | inr y≤x = y≤x , x≰y ∘ reflx→fromeq _≤_ rfl ∘ sym

≮⇒≥ : Discrete A → Reflexive _≤_ → Total _≤_ →
      ∀ {x y} → ¬ (x < y) → y ≤ x
≮⇒≥ _≟_ ≤-refl _≤?_ {x} {y} x≮y with x ≟ y
... | yes x≈y            = reflx→fromeq _≤_ ≤-refl (sym x≈y)
... | no x≢y with y ≤? x
...   | inl y≤x = y≤x
...   | inr x≤y = elim (x≮y (x≤y , x≢y))

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

<-isPropValued : isPropValued _≤_ → isPropValued _<_
<-isPropValued propv x y = isProp× (propv x y) (isPropΠ λ _ → isProp⊥)

<-toNotEq : ToNotEq _<_
<-toNotEq (_ , x≢y) x≡y = x≢y x≡y

<-irrefl : Irreflexive _<_
<-irrefl = tonoteq→irrefl _<_ <-toNotEq

<-transitive : IsPartialOrder _≤_ → Transitive _<_
<-transitive po (x≤y , x≢y) (y≤z , y≉z) =
  (transitive x≤y y≤z , x≢y ∘ antisym x≤y ∘ transitive y≤z ∘ fromEq ∘ sym)
  where open IsPartialOrder po

<-≤-trans : Transitive _≤_ → Antisymmetric _≤_ →
           Trans _<_ _≤_ _<_
<-≤-trans transitive antisym (x≤y , x≢y) y≤z =
  transitive x≤y y≤z , (λ x≡z → x≢y (antisym x≤y (Respectsʳ≡ _≤_ (sym x≡z) y≤z)))

≤-<-trans : Transitive _≤_ → Antisymmetric _≤_ →
           Trans _≤_ _<_ _<_
≤-<-trans trans antisym x≤y (y≤z , y≢z) =
  trans x≤y y≤z , (λ x≡z → y≢z (antisym y≤z (Respectsˡ≡ _≤_ x≡z x≤y)))

<-asym : Antisymmetric _≤_ → Asymmetric _<_
<-asym antisym (x≤y , x≢y) (y≤x , _) = x≢y (antisym x≤y y≤x)

<-decidable : Discrete A → Decidable _≤_ → Decidable _<_
<-decidable _≟_ _≤?_ x y with x ≤? y
... | no ¬p = no (¬p ∘ fst)
... | yes p with x ≟ y
...   | yes q = no (λ x<y → snd x<y q)
...   | no ¬q = yes (p , ¬q)

------------------------------------------------------------------------
-- Structures

isStrictPartialOrder : IsPartialOrder _≤_ → IsStrictPartialOrder _<_
isStrictPartialOrder po = record
  { irrefl     = <-irrefl
  ; transitive = <-transitive po
  } where open IsPartialOrder po