------------------------------------------------------------------------
-- Coinductive higher lenses
------------------------------------------------------------------------

-- Paolo Capriotti came up with these lenses, and provided an informal
-- proof showing that this lens type is pointwise equivalent to his
-- higher lenses. I turned this proof into the proof presented below,
-- with help from Andrea Vezzosi (see
-- Lens.Non-dependent.Higher.Coherently.Coinductive).

{-# OPTIONS --cubical --guardedness #-}

import Equality.Path as P

module Lens.Non-dependent.Higher.Coinductive
  {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

open import Bijection equality-with-J using (_↔_)
import Coherently-constant eq as CC
open import Colimit.Sequential eq as C using (∣_∣)
open import Equality.Decidable-UIP equality-with-J using (Constant)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
import Equivalence.Half-adjoint equality-with-J as HA
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as T using (∥_∥; ∣_∣)
import H-level.Truncation.Propositional.Non-recursive eq as N
open import H-level.Truncation.Propositional.One-step eq as O
  using (∥_∥¹; ∥_∥¹-out-^; ∥_∥¹-in-^; ∣_∣; ∣_,_∣-in-^)
open import Preimage equality-with-J using (_⁻¹_)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher eq as H
import Lens.Non-dependent.Higher.Capriotti eq as Higher
open import Lens.Non-dependent.Higher.Coherently.Coinductive eq

private
  variable
    a b p : Level
    A B   : Type a
    P     : A → Type p
    f     : (x : A) → P x

------------------------------------------------------------------------
-- Weakly constant functions

-- A variant of Constant.

Constant′ :
  {A : Type a} {B : Type b} →
  (A → B) → Type (a ⊔ b)
Constant′ {A = A} {B = B} f =
  ∃ λ (g : ∥ A ∥¹ → B) → ∀ x → g ∣ x ∣ ≡ f x

-- Constant and Constant′ are pointwise equivalent.

Constant≃Constant′ : (f : A → B) → Constant f ≃ Constant′ f
Constant≃Constant′ f = Eq.↔→≃
  (λ c → O.rec′ f c
       , λ x → O.rec′ f c ∣ x ∣  ≡⟨⟩
               f x               ∎)
  (λ (g , h) x y →
     f x      ≡⟨ sym (h x) ⟩
     g ∣ x ∣  ≡⟨ cong g (O.∣∣-constant x y) ⟩
     g ∣ y ∣  ≡⟨ h y ⟩∎
     f y      ∎)
  (λ (g , h) →
     let lem = O.elim λ where
           .O.Elim.∣∣ʳ x →
             f x      ≡⟨ sym (h x) ⟩∎
             g ∣ x ∣  ∎
           .O.Elim.∣∣-constantʳ x y →
             let g′ = O.rec′ f λ x y →
                        trans (sym (h x))
                          (trans (cong g (O.∣∣-constant x y))
                             (h y))
             in
             subst (λ z → g′ z ≡ g z) (O.∣∣-constant x y) (sym (h x))  ≡⟨ subst-in-terms-of-trans-and-cong ⟩

             trans (sym (cong g′ (O.∣∣-constant x y)))
               (trans (sym (h x)) (cong g (O.∣∣-constant x y)))        ≡⟨ cong (flip trans _) $ cong sym
                                                                          O.rec-∣∣-constant ⟩
             trans (sym (trans (sym (h x))
                           (trans (cong g (O.∣∣-constant x y))
                              (h y))))
               (trans (sym (h x)) (cong g (O.∣∣-constant x y)))        ≡⟨ trans (cong (flip trans _) $
                                                                                trans (cong sym $ sym $ trans-assoc _ _ _) $
                                                                                sym-trans _ _) $
                                                                          trans-[trans-sym]- _ _ ⟩∎
             sym (h y)                                                 ∎
     in
     Σ-≡,≡→≡
       (⟨ext⟩ lem)
       (⟨ext⟩ λ x →

        subst (λ g → ∀ x → g ∣ x ∣ ≡ f x)
          (⟨ext⟩ lem) (λ x → refl (f x)) x                         ≡⟨ sym $ push-subst-application _ _ ⟩

        subst (λ g → g ∣ x ∣ ≡ f x) (⟨ext⟩ lem) (refl (f x))       ≡⟨ subst-∘ _ _ _ ⟩

        subst (_≡ f x) (cong (_$ ∣ x ∣) (⟨ext⟩ lem)) (refl (f x))  ≡⟨ subst-trans-sym ⟩

        trans (sym (cong (_$ ∣ x ∣) (⟨ext⟩ lem))) (refl (f x))     ≡⟨ trans-reflʳ _ ⟩

        sym (cong (_$ ∣ x ∣) (⟨ext⟩ lem))                          ≡⟨ cong sym $ cong-ext _ ⟩

        sym (lem ∣ x ∣)                                            ≡⟨⟩

        sym (sym (h x))                                            ≡⟨ sym-sym _ ⟩∎

        h x                                                        ∎))
  (λ c → ⟨ext⟩ λ x → ⟨ext⟩ λ y →
     trans (sym (refl _))
       (trans (cong (O.rec′ f c) (O.∣∣-constant x y)) (refl _))  ≡⟨ trans (cong₂ trans sym-refl (trans-reflʳ _)) $
                                                                    trans-reflˡ _ ⟩

     cong (O.rec′ f c) (O.∣∣-constant x y)                       ≡⟨ O.rec-∣∣-constant ⟩∎

     c x y                                                       ∎)

------------------------------------------------------------------------
-- Coherently constant functions

-- Coherently constant functions.

Coherently-constant :
  {A : Type a} {B : Type b} (f : A → B) → Type (a ⊔ b)
Coherently-constant = Coherently Constant O.rec′

-- Coherently constant functions are weakly constant.

constant : Coherently-constant f → Constant f
constant c = c .property

-- An alternative to Coherently-constant.

Coherently-constant′ :
  {A : Type a} {B : Type b} (f : A → B) → Type (a ⊔ b)
Coherently-constant′ = Coherently Constant′ (λ _ → proj₁)

-- Coherently-constant and Coherently-constant′ are pointwise
-- equivalent (assuming univalence).

Coherently-constant≃Coherently-constant′ :
  Block "Coherently-constant≃Coherently-constant′" →
  {A : Type a} {B : Type b} {f : A → B} →
  Univalence (a ⊔ b) →
  Coherently-constant f ≃ Coherently-constant′ f
Coherently-constant≃Coherently-constant′ ⊠ univ =
  Coherently-cong univ
    Constant≃Constant′
    (λ f c →
       O.rec′ f (_≃_.from (Constant≃Constant′ f) c)   ≡⟨⟩

       proj₁ (_≃_.to (Constant≃Constant′ f)
                (_≃_.from (Constant≃Constant′ f) c))  ≡⟨ cong proj₁ $
                                                         _≃_.right-inverse-of (Constant≃Constant′ f) _ ⟩∎
       proj₁ c                                        ∎)

private

  -- Some definitions used in the implementation of
  -- ∃Coherently-constant′≃.

  module ∃Coherently-constant′≃ where

    to₁ :
      (f : A → B) → Coherently-constant′ f →
      ∀ n → ∥ A ∥¹-in-^ n → B
    to₁ f c zero    = f
    to₁ f c (suc n) = to₁ (proj₁ (c .property)) (c .coherent) n

    to₂ :
      ∀ (f : A → B) (c : Coherently-constant′ f) n x →
      to₁ f c (suc n) ∣ n , x ∣-in-^ ≡ to₁ f c n x
    to₂ f c zero    = proj₂ (c .property)
    to₂ f c (suc n) = to₂ (proj₁ (c .property)) (c .coherent) n

    from :
      (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
      (∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x) →
      Coherently-constant′ (f 0)
    from f c .property = f 1 , c 0
    from f c .coherent = from (f ∘ suc) (c ∘ suc)

    from-to :
      (f : A → B) (c : Coherently-constant′ f) →
      from (to₁ f c) (to₂ f c) P.≡ c
    from-to f c i .property = (c .property  P.∎) i
    from-to f c i .coherent =
      from-to (proj₁ (c .property)) (c .coherent) i

    to₁-from :
      (f : ∀ n → ∥ A ∥¹-in-^ n → B)
      (c : ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x) →
      ∀ n x → to₁ (f 0) (from f c) n x ≡ f n x
    to₁-from f c zero    = refl ∘ f 0
    to₁-from f c (suc n) = to₁-from (f ∘ suc) (c ∘ suc) n

    to₂-from :
      (f : ∀ n → ∥ A ∥¹-in-^ n → B)
      (c : ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x) →
      ∀ n x →
      trans (sym (to₁-from f c (suc n) ∣ n , x ∣-in-^))
        (trans (to₂ (f 0) (from f c) n x)
           (to₁-from f c n x)) ≡
      c n x
    to₂-from f c (suc n) = to₂-from (f ∘ suc) (c ∘ suc) n
    to₂-from f c zero    = λ x →
      trans (sym (refl _)) (trans (c 0 x) (refl _))  ≡⟨ trans (cong (flip trans _) sym-refl) $
                                                        trans-reflˡ _ ⟩
      trans (c 0 x) (refl _)                         ≡⟨ trans-reflʳ _ ⟩∎
      c 0 x                                          ∎

-- "Functions from A to B that are coherently constant" can be
-- expressed in a different way.

∃Coherently-constant′≃ :
  (∃ λ (f : A → B) → Coherently-constant′ f)
    ≃
  (∃ λ (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
     ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)
∃Coherently-constant′≃ = Eq.↔→≃
  (λ (f , c) → to₁ f c , to₂ f c)
  (λ (f , c) → f 0 , from f c)
  (λ (f , c) → Σ-≡,≡→≡
     (⟨ext⟩ λ n → ⟨ext⟩ λ x → to₁-from f c n x)
     (⟨ext⟩ λ n → ⟨ext⟩ λ x →
        subst (λ f → ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)
          (⟨ext⟩ λ n → ⟨ext⟩ λ x → to₁-from f c n x)
          (to₂ (f 0) (from f c))
          n x                                                       ≡⟨ trans (cong (_$ x) $ sym $
                                                                              push-subst-application _ _) $
                                                                       sym $ push-subst-application _ _ ⟩
        subst (λ f → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)
          (⟨ext⟩ λ n → ⟨ext⟩ λ x → to₁-from f c n x)
          (to₂ (f 0) (from f c) n x)                                ≡⟨ subst-in-terms-of-trans-and-cong ⟩

        trans (sym (cong (λ f → f (suc n) ∣ n , x ∣-in-^)
                      (⟨ext⟩ λ n → ⟨ext⟩ λ x → to₁-from f c n x)))
          (trans (to₂ (f 0) (from f c) n x)
             (cong (λ f → f n x)
                (⟨ext⟩ λ n → ⟨ext⟩ λ x → to₁-from f c n x)))        ≡⟨ cong₂ (λ p q → trans (sym p) (trans (to₂ (f 0) (from f c) n x) q))
                                                                         (trans (sym $ cong-∘ _ _ _) $
                                                                          trans (cong (cong _) $ cong-ext _) $
                                                                          cong-ext _)
                                                                         (trans (sym $ cong-∘ _ _ _) $
                                                                          trans (cong (cong _) $ cong-ext _) $
                                                                          cong-ext _) ⟩
        trans (sym (to₁-from f c (suc n) ∣ n , x ∣-in-^))
          (trans (to₂ (f 0) (from f c) n x)
             (to₁-from f c n x))                                    ≡⟨ to₂-from f c n x ⟩∎

        c n x                                                       ∎))
  (λ (f , c) → cong (f ,_) $ _↔_.from ≡↔≡ $ from-to f c)
  where
  open ∃Coherently-constant′≃

private

  -- A lemma that is used in the implementation of
  -- Coherently-constant′≃.

  Coherently-constant′≃-lemma :
    (∃ λ (f : A → B) → Coherently-constant′ f) ≃
    (∃ λ (f : A → B) →
     ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
       (∀ x → g 0 ∣ x ∣ ≡ f x) ×
       (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x))
  Coherently-constant′≃-lemma {A = A} {B = B} =
    (∃ λ (f : A → B) → Coherently-constant′ f)          ↝⟨ ∃Coherently-constant′≃ ⟩

    (∃ λ (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
       ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)        ↝⟨ Eq.↔→≃
                                                             (λ (f , eq) →
                                                                f 0 , f ∘ suc , ℕ-case (eq 0) (eq ∘ suc))
                                                             (λ (f , g , eq) → ℕ-case f g , eq)
                                                             (λ (f , g , eq) →
                                                                cong (λ eq → f , g , eq) $ ⟨ext⟩ $
                                                                ℕ-case (refl _) (λ _ → refl _))
                                                             lemma ⟩
    (∃ λ (f : A → B) →
     ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
       ∀ n x →
         g n ∣ n , x ∣-in-^ ≡
         ℕ-case {P = λ n → ∥ A ∥¹-in-^ n → B} f g n x)  ↝⟨ (∃-cong λ _ → ∃-cong λ _ →
                                                            Πℕ≃ ext) ⟩□
    (∃ λ (f : A → B) →
     ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
       (∀ x → g 0 ∣ x ∣ ≡ f x) ×
       (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x))      □
    where

    -- An alternative (unused) proof of the second step above. If this
    -- proof is used instead of the other one, then the proof of
    -- from-Coherently-constant′≃ below fails (at least at the time of
    -- writing).

    second-step :
      (∃ λ (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
         ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x) ≃
      (∃ λ (f : A → B) →
       ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
         ∀ n x →
           g n ∣ n , x ∣-in-^ ≡
           ℕ-case {P = λ n → ∥ A ∥¹-in-^ n → B} f g n x)
    second-step = from-bijection $ inverse $
      (Σ-cong (inverse $ Πℕ≃ {k = equivalence} ext) λ _ → F.id) F.∘
      Σ-assoc

    abstract

      lemma :
        (p@(f , eq) : ∃ λ (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
                        ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x) →
        (ℕ-case (f 0) (f ∘ suc) , ℕ-case (eq 0) (eq ∘ suc)) ≡ p
      lemma (f , eq) =
        Σ-≡,≡→≡
          (⟨ext⟩ $ ℕ-case (refl _) (λ _ → refl _))
          (⟨ext⟩ λ n → ⟨ext⟩ λ x →
           let eq′ = ℕ-case (eq 0) (eq ∘ suc)
               r   = ℕ-case (refl _) (λ _ → refl _)
           in
           subst {y = f}
             (λ f → ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)
             (⟨ext⟩ r) eq′ n x                                            ≡⟨ sym $
                                                                             trans (push-subst-application _ _) $
                                                                             cong (_$ x) $ push-subst-application _ _ ⟩
           subst
             (λ f → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)
             (⟨ext⟩ r) (eq′ n x)                                          ≡⟨ subst-in-terms-of-trans-and-cong ⟩

           trans (sym (cong (λ f → f (suc n) ∣ n , x ∣-in-^) (⟨ext⟩ r)))
             (trans (eq′ n x) (cong (λ f → f n x) (⟨ext⟩ r)))             ≡⟨ trans (cong (flip trans _) $
                                                                                trans (cong sym $
                                                                                trans (sym $ cong-∘ _ _ _) $
                                                                                trans (cong (cong (_$ ∣ n , x ∣-in-^)) $
                                                                                cong-ext _)
                                                                                (cong-refl _))
                                                                                sym-refl) $
                                                                             trans-reflˡ _ ⟩

           trans (eq′ n x) (cong (λ f → f n x) (⟨ext⟩ r))                 ≡⟨ cong (trans _) $
                                                                             trans (sym $ cong-∘ _ _ _) $
                                                                             cong (cong (_$ x)) $
                                                                             cong-ext _ ⟩

           trans (eq′ n x) (cong (_$ x) $ r n)                            ≡⟨ ℕ-case
                                                                               {P = λ n → ∀ x → trans (eq′ n x) (cong (_$ x) $ r n) ≡ eq n x}
                                                                               (λ _ → trans (cong (trans _) $ cong-refl _) $
                                                                                trans-reflʳ _)
                                                                               (λ _ _ → trans (cong (trans _) $ cong-refl _) $
                                                                                trans-reflʳ _)
                                                                               n x ⟩∎
           eq n x                                                         ∎)

-- Coherently-constant′ can be expressed in a different way.

Coherently-constant′≃ :
  Block "Coherently-constant′≃" →
  {f : A → B} →
  Coherently-constant′ f
    ≃
  (∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
     (∀ x → g 0 ∣ x ∣ ≡ f x) ×
     (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x))
Coherently-constant′≃ ⊠ {f = f} =
  Eq.⟨ _
     , Eq.drop-Σ-map-id _
         (_≃_.is-equivalence Coherently-constant′≃-lemma)
         f
     ⟩

-- A "computation" rule for Coherently-constant′≃.

from-Coherently-constant′≃-property :
  (bl : Block "Coherently-constant′≃") →
  (f : A → B)
  {c@(g , g₀ , _) :
   ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
     (∀ x → g 0 ∣ x ∣ ≡ f x) ×
     (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x)} →
  _≃_.from (Coherently-constant′≃ bl) c .property ≡ (g 0 , g₀)
from-Coherently-constant′≃-property
  {A = A} {B = B} ⊠ f {c = c@(g , g₀ , g₊)} =

  _≃_.from (Coherently-constant′≃ ⊠) c .property                      ≡⟨⟩

  HA.inverse
    (Eq.drop-Σ-map-id _
       (_≃_.is-equivalence Coherently-constant′≃-lemma)
       f)
    c .property                                                       ≡⟨ cong (λ c → c .property) $
                                                                         Eq.inverse-drop-Σ-map-id
                                                                           {x = f} {eq = _≃_.is-equivalence Coherently-constant′≃-lemma} ⟩
  subst Coherently-constant′
    (cong proj₁ $
     _≃_.right-inverse-of Coherently-constant′≃-lemma (f , c))
    (proj₂ (_≃_.from Coherently-constant′≃-lemma (f , c)))
    .property                                                         ≡⟨ subst-Coherently-property ⟩

  subst Constant′
    (cong proj₁ $
     _≃_.right-inverse-of Coherently-constant′≃-lemma (f , c))
    (proj₂ (_≃_.from Coherently-constant′≃-lemma (f , c)) .property)  ≡⟨⟩

  subst Constant′
    (cong proj₁ $
     trans
       (cong {B = ∃ λ (f : A → B) →
                  ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
                    (∀ x → g 0 ∣ x ∣ ≡ f x) ×
                    (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x)}
             (λ (f , eq) → f 0 , f ∘ suc , eq 0 , eq ∘ suc) $
        _≃_.right-inverse-of ∃Coherently-constant′≃
          (ℕ-case f g , ℕ-case g₀ g₊)) $
     trans
       (cong (λ (f , g , eq) → f , g , eq 0 , eq ∘ suc) $
        cong {B = ∃ λ (f : A → B) →
                  ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
                    ∀ n x →
                      g n ∣ n , x ∣-in-^ ≡
                      ℕ-case {P = λ n → ∥ A ∥¹-in-^ n → B} f g n x}
             {x = ℕ-case g₀ g₊}
             {y = ℕ-case g₀ g₊}
             (λ eq → f , g , eq) $
        ⟨ext⟩ (ℕ-case (refl _) (λ _ → refl _))) $
     cong (f ,_) (cong (g ,_) (refl _)))
    (g 0 , g₀)                                                        ≡⟨ cong (flip (subst Constant′) _) lemma ⟩

  subst Constant′ (refl _) (g 0 , g₀)                                 ≡⟨ subst-refl _ _ ⟩∎

  g 0 , g₀                                                            ∎
  where
  lemma =
    (cong proj₁ $
     trans
       (cong {B = ∃ λ (f : A → B) →
                  ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
                    (∀ x → g 0 ∣ x ∣ ≡ f x) ×
                    (∀ n x → g (suc n) ∣ n , x ∣-in-^ ≡ g n x)}
             (λ (f , eq) → f 0 , f ∘ suc , eq 0 , eq ∘ suc) $
        _≃_.right-inverse-of ∃Coherently-constant′≃
          (ℕ-case f g , ℕ-case g₀ g₊)) $
     trans
       (cong (λ (f , g , eq) → f , g , eq 0 , eq ∘ suc) $
        cong {B = ∃ λ (f : A → B) →
                  ∃ λ (g : ∀ n → ∥ A ∥¹-in-^ (suc n) → B) →
                    ∀ n x →
                      g n ∣ n , x ∣-in-^ ≡
                      ℕ-case {P = λ n → ∥ A ∥¹-in-^ n → B} f g n x}
             {x = ℕ-case g₀ g₊}
             {y = ℕ-case g₀ g₊}
             (λ eq → f , g , eq) $
        ⟨ext⟩ (ℕ-case (refl _) (λ _ → refl _))) $
     cong (f ,_) (cong (g ,_) (refl _)))                               ≡⟨ trans (cong-trans _ _ _) $
                                                                          cong₂ trans
                                                                            (trans (cong-∘ _ _ _) $
                                                                             sym $ cong-∘ _ _ _)
                                                                            (trans (cong-trans _ _ _) $
                                                                             cong₂ trans
                                                                               (trans (cong-∘ _ _ _) $
                                                                                cong-∘ _ _ _)
                                                                               (cong-∘ _ _ _)) ⟩
    (trans
       (cong (_$ 0) $ cong proj₁ $
        _≃_.right-inverse-of ∃Coherently-constant′≃
          (ℕ-case f g , ℕ-case g₀ g₊)) $
     trans
       (cong (const f) $
        ⟨ext⟩ (ℕ-case (refl _) (λ _ → refl _))) $
     cong (const f) (cong (g ,_) (refl _)))                            ≡⟨ trans (cong (trans _) $
                                                                                trans (cong₂ trans
                                                                                (cong-const _)
                                                                                (cong-const _)) $
                                                                                trans-refl-refl) $
                                                                          trans-reflʳ _ ⟩
    (cong (_$ 0) $ cong proj₁ $
     _≃_.right-inverse-of ∃Coherently-constant′≃
       (ℕ-case f g , ℕ-case g₀ g₊))                                    ≡⟨ cong (cong (_$ 0)) $
                                                                          proj₁-Σ-≡,≡→≡ _ _ ⟩
    (cong (_$ 0) $ ⟨ext⟩ λ n → ⟨ext⟩ λ x →
     ∃Coherently-constant′≃.to₁-from (ℕ-case f g) (ℕ-case g₀ g₊) n x)  ≡⟨ cong-ext _ ⟩

    (⟨ext⟩ λ x →
     ∃Coherently-constant′≃.to₁-from (ℕ-case f g) (ℕ-case g₀ g₊) 0 x)  ≡⟨⟩

    (⟨ext⟩ λ _ → refl _)                                               ≡⟨ ext-refl ⟩∎

    refl _                                                             ∎

-- Functions from ∥ A ∥ can be expressed as coherently constant
-- functions from A (assuming univalence).

∥∥→≃ :
  ∀ {A : Type a} {B : Type b} →
  Univalence (a ⊔ b) →
  (∥ A ∥ → B)
    ≃
  (∃ λ (f : A → B) → Coherently-constant f)
∥∥→≃ {A = A} {B = B} univ =
  (∥ A ∥ → B)                                   ↝⟨ N.∥∥→≃ ⟩

  (∃ λ (f : ∀ n → ∥ A ∥¹-out-^ n → B) →
     ∀ n x → f (suc n) ∣ x ∣ ≡ f n x)           ↝⟨ (Σ-cong {k₁ = equivalence} (∀-cong ext λ n → →-cong₁ ext (O.∥∥¹-out-^≃∥∥¹-in-^ n)) λ f →
                                                    ∀-cong ext λ n →
                                                    Π-cong-contra ext (inverse $ O.∥∥¹-out-^≃∥∥¹-in-^ n) λ x →
                                                    ≡⇒↝ _ $ cong (λ y → f (suc n) y ≡ f n (_≃_.from (O.∥∥¹-out-^≃∥∥¹-in-^ n) x)) (
    ∣ _≃_.from (O.∥∥¹-out-^≃∥∥¹-in-^ n) x ∣           ≡⟨ sym $ O.∣,∣-in-^≡∣∣ n ⟩∎

    _≃_.from (O.∥∥¹-out-^≃∥∥¹-in-^ (suc n))
      ∣ n , x ∣-in-^                                  ∎)) ⟩

  (∃ λ (f : ∀ n → ∥ A ∥¹-in-^ n → B) →
     ∀ n x → f (suc n) ∣ n , x ∣-in-^ ≡ f n x)  ↝⟨ inverse ∃Coherently-constant′≃ ⟩

  (∃ λ (f : A → B) → Coherently-constant′ f)    ↝⟨ (∃-cong λ _ → inverse $ Coherently-constant≃Coherently-constant′ ⊠ univ) ⟩□

  (∃ λ (f : A → B) → Coherently-constant f)     □

-- A function used in the statement of proj₂-to-∥∥→≃-property≡.

proj₁-to-∥∥→≃-constant :
  {A : Type a} {B : Type b}
  (univ : Univalence (a ⊔ b)) →
  (f : ∥ A ∥ → B) →
  Constant (proj₁ (_≃_.to (∥∥→≃ univ) f))
proj₁-to-∥∥→≃-constant _ f x y =
  f ∣ x ∣  ≡⟨ cong f (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ⟩∎
  f ∣ y ∣  ∎

-- A "computation rule" for ∥∥→≃.

proj₂-to-∥∥→≃-property≡ :
  {A : Type a} {B : Type b}
  (univ : Univalence (a ⊔ b)) →
  {f : ∥ A ∥ → B} →
  proj₂ (_≃_.to (∥∥→≃ univ) f) .property ≡
  proj₁-to-∥∥→≃-constant univ f
proj₂-to-∥∥→≃-property≡ univ {f = f} = ⟨ext⟩ λ x → ⟨ext⟩ λ y →

  let g , c = _≃_.to C.universal-property (f ∘ _≃_.to N.∥∥≃∥∥) in

  proj₂ (_≃_.to (∥∥→≃ univ) f) .property x y                             ≡⟨⟩

  _≃_.from (Coherently-constant≃Coherently-constant′ ⊠ univ)
    (proj₂
       (_≃_.from ∃Coherently-constant′≃
          (Σ-map (λ g n → g n ∘ _≃_.from (oi n))
                 (λ {g} c n x →
                    ≡⇒→ (cong (λ y → g (suc n) y ≡
                                     g n (_≃_.from (oi n) x))
                           (sym $ O.∣,∣-in-^≡∣∣ n))
                      (c n (_≃_.from (oi n) x)))
             (_≃_.to C.universal-property (f ∘ _≃_.to N.∥∥≃∥∥)))))
    .property x y                                                        ≡⟨⟩

  _≃_.from (Constant≃Constant′ _)
    (proj₂
       (_≃_.from ∃Coherently-constant′≃
          (Σ-map (λ g n → g n ∘ _≃_.from (oi n))
                 (λ {g} c n x →
                    ≡⇒→ (cong (λ y → g (suc n) y ≡
                                     g n (_≃_.from (oi n) x))
                           (sym $ O.∣,∣-in-^≡∣∣ n))
                      (c n (_≃_.from (oi n) x)))
             (_≃_.to C.universal-property (f ∘ _≃_.to N.∥∥≃∥∥))))
       .property)
     x y                                                                 ≡⟨⟩

  _≃_.from (Constant≃Constant′ _)
    ( g 1
    , λ x → ≡⇒→ (cong (λ z → g 1 z ≡ g 0 x) (sym $ refl ∣ _ ∣)) (c 0 x)
    ) x y                                                                ≡⟨⟩

  trans (sym (≡⇒→ (cong (λ z → g 1 z ≡ g 0 x) (sym $ refl ∣ _ ∣))
                (c 0 x)))
    (trans (cong (g 1) (O.∣∣-constant x y))
       (≡⇒→ (cong (λ z → g 1 z ≡ g 0 y) (sym $ refl ∣ _ ∣)) (c 0 y)))    ≡⟨ cong₂ (λ p q → trans (sym p) (trans (cong (g 1) (O.∣∣-constant x y)) q))
                                                                              (trans (cong (λ eq → ≡⇒→ (cong (λ z → g 1 z ≡ g 0 x) eq) (c 0 x))
                                                                                sym-refl) $
                                                                               trans (cong (λ eq → ≡⇒→ eq (c 0 x)) $
                                                                                cong-refl _) $
                                                                               cong (_$ c 0 x) ≡⇒→-refl)
                                                                              (trans (cong (λ eq → ≡⇒→ (cong (λ z → g 1 z ≡ g 0 y) eq) (c 0 y))
                                                                                sym-refl) $
                                                                               trans (cong (λ eq → ≡⇒→ eq (c 0 y)) $
                                                                                cong-refl _) $
                                                                               cong (_$ c 0 y) ≡⇒→-refl) ⟩
  trans (sym (c 0 x)) (trans (cong (g 1) (O.∣∣-constant x y)) (c 0 y))   ≡⟨⟩

  trans (sym (cong (f ∘ _≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ x)))
    (trans (cong (f ∘ _≃_.to N.∥∥≃∥∥ ∘ ∣_∣) (O.∣∣-constant x y))
       (cong (f ∘ _≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ y)))                          ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                              (sym $ cong-∘ _ _ _)
                                                                              (cong₂ trans
                                                                                (sym $ cong-∘ _ _ _)
                                                                                (sym $ cong-∘ _ _ _)) ⟩
  trans (sym (cong f (cong (_≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ x))))
    (trans (cong f (cong (_≃_.to N.∥∥≃∥∥ ∘ ∣_∣) (O.∣∣-constant x y)))
       (cong f (cong (_≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ y))))                     ≡⟨ trans (cong₂ trans
                                                                                (sym $ cong-sym _ _)
                                                                                (sym $ cong-trans _ _ _)) $
                                                                            sym $ cong-trans _ _ _ ⟩
  cong f
    (trans (sym (cong (_≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ x)))
      (trans (cong (_≃_.to N.∥∥≃∥∥ ∘ ∣_∣) (O.∣∣-constant x y))
         (cong (_≃_.to N.∥∥≃∥∥) (C.∣∣≡∣∣ y))))                           ≡⟨ cong (cong f) $
                                                                            mono₁ 1 T.truncation-is-proposition _ _ ⟩∎
  cong f (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)                       ∎
  where
  oi = O.∥∥¹-out-^≃∥∥¹-in-^

-- Two variants of Coherently-constant are pointwise equivalent
-- (assuming univalence).

Coherently-constant≃Coherently-constant :
  {A : Type a} {B : Type b} {f : A → B} →
  Univalence (a ⊔ b) →
  CC.Coherently-constant f ≃ Coherently-constant f
Coherently-constant≃Coherently-constant {A = A} {B = B} {f = f} univ =
  CC.Coherently-constant f                                           ↔⟨⟩

  (∃ λ (g : ∥ A ∥ → B) → f ≡ g ∘ ∣_∣)                                ↝⟨ (Σ-cong (∥∥→≃ univ) λ _ → F.id) ⟩

  (∃ λ ((g , _) : ∃ λ (g : A → B) → Coherently-constant g) → f ≡ g)  ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (g : A → B) → Coherently-constant g × f ≡ g)                  ↝⟨ (∃-cong λ _ → ×-cong₁ λ eq → ≡⇒↝ _ $
                                                                         cong Coherently-constant $ sym eq) ⟩

  (∃ λ (g : A → B) → Coherently-constant f × f ≡ g)                  ↔⟨ ∃-comm ⟩

  Coherently-constant f × (∃ λ (g : A → B) → f ≡ g)                  ↔⟨ (drop-⊤-right λ _ →
                                                                         _⇔_.to contractible⇔↔⊤ (other-singleton-contractible _)) ⟩□
  Coherently-constant f                                              □

-- A "computation rule" for Coherently-constant≃Coherently-constant.

to-Coherently-constant≃Coherently-constant-property :
  ∀ {A : Type a} {B : Type b} {f : A → B}
    {c : CC.Coherently-constant f} {x y}
  (univ : Univalence (a ⊔ b)) →
  _≃_.to (Coherently-constant≃Coherently-constant univ)
    c .property x y ≡
  trans (cong (_$ x) (proj₂ c))
     (trans (proj₁-to-∥∥→≃-constant univ (proj₁ c) _ _)
        (cong (_$ y) (sym (proj₂ c))))
to-Coherently-constant≃Coherently-constant-property
  {f = f} {c = c} {x = x} {y = y} univ =
  _≃_.to (Coherently-constant≃Coherently-constant univ)
    c .property x y                                       ≡⟨⟩

  ≡⇒→ (cong Coherently-constant $ sym (proj₂ c))
    (proj₂ (_≃_.to (∥∥→≃ univ) (proj₁ c))) .property x y  ≡⟨ cong (λ (c : Coherently-constant _) → c .property x y) $ sym $
                                                             subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
  subst Coherently-constant (sym (proj₂ c))
    (proj₂ (_≃_.to (∥∥→≃ univ) (proj₁ c))) .property x y  ≡⟨ cong (λ (f : Constant _) → f x y)
                                                             subst-Coherently-property ⟩
  subst Constant (sym (proj₂ c))
    (proj₂ (_≃_.to (∥∥→≃ univ) (proj₁ c)) .property) x y  ≡⟨ trans (cong (_$ y) $ sym $ push-subst-application _ _) $
                                                             sym $ push-subst-application _ _ ⟩
  subst (λ f → f x ≡ f y) (sym (proj₂ c))
    (proj₂ (_≃_.to (∥∥→≃ univ) (proj₁ c)) .property x y)  ≡⟨ cong (λ (f : Constant _) → subst (λ f → f x ≡ f y) (sym (proj₂ c)) (f x y)) $
                                                             proj₂-to-∥∥→≃-property≡ univ ⟩
  subst (λ f → f x ≡ f y) (sym (proj₂ c))
    (proj₁-to-∥∥→≃-constant univ (proj₁ c) x y)           ≡⟨ subst-in-terms-of-trans-and-cong ⟩

  trans (sym (cong (_$ x) (sym (proj₂ c))))
     (trans (proj₁-to-∥∥→≃-constant univ (proj₁ c) _ _)
        (cong (_$ y) (sym (proj₂ c))))                    ≡⟨ cong (flip trans _) $
                                                             trans (sym $ cong-sym _ _) $
                                                             cong (cong (_$ x)) $ sym-sym _ ⟩∎
  trans (cong (_$ x) (proj₂ c))
     (trans (proj₁-to-∥∥→≃-constant univ (proj₁ c) _ _)
        (cong (_$ y) (sym (proj₂ c))))                    ∎

------------------------------------------------------------------------
-- Lenses, defined as getters with coherently constant fibres

-- The lens type family.

Lens : Type a → Type b → Type (lsuc (a ⊔ b))
Lens A B = ∃ λ (get : A → B) → Coherently-constant (get ⁻¹_)

-- Some derived definitions.

module Lens {A : Type a} {B : Type b} (l : Lens A B) where

  -- A getter.

  get : A → B
  get = proj₁ l

  -- The family of fibres of the getter is coherently constant.

  get⁻¹-coherently-constant : Coherently-constant (get ⁻¹_)
  get⁻¹-coherently-constant = proj₂ l

  -- All the getter's fibres are equivalent.

  get⁻¹-constant : (b₁ b₂ : B) → get ⁻¹ b₁ ≃ get ⁻¹ b₂
  get⁻¹-constant b₁ b₂ =
    ≡⇒≃ (get⁻¹-coherently-constant .property b₁ b₂)

  -- A setter.

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

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
    }

-- Lens is pointwise equivalent to Higher.Lens (assuming univalence).

Higher-lens≃Lens :
  {A : Type a} {B : Type b} →
  Block "Higher-lens≃Lens" →
  Univalence (lsuc (a ⊔ b)) →
  Higher.Lens A B ≃ Lens A B
Higher-lens≃Lens {A = A} {B = B} ⊠ univ =
  Higher.Lens A B                                         ↔⟨⟩
  (∃ λ (get : A → B) → CC.Coherently-constant (get ⁻¹_))  ↝⟨ (∃-cong λ _ → Coherently-constant≃Coherently-constant univ) ⟩□
  (∃ λ (get : A → B) → Coherently-constant (get ⁻¹_))     □

-- The equivalence preserves getters and setters.

Higher-lens≃Lens-preserves-getters-and-setters :
  {A : Type a} {B : Type b}
  (bl : Block "Higher-lens≃Lens")
  (univ : Univalence (lsuc (a ⊔ b))) →
  Preserves-getters-and-setters-⇔ A B
    (_≃_.logical-equivalence (Higher-lens≃Lens bl univ))
Higher-lens≃Lens-preserves-getters-and-setters {A = A} {B = B} bl univ =
  Preserves-getters-and-setters-→-↠-⇔
    (_≃_.surjection (Higher-lens≃Lens bl univ))
    (λ l → get-lemma bl l , set-lemma bl l)
  where
  get-lemma :
    ∀ bl (l : Higher.Lens A B) →
    Lens.get (_≃_.to (Higher-lens≃Lens bl univ) l) ≡ Higher.Lens.get l
  get-lemma ⊠ _ = refl _

  set-lemma :
    ∀ bl (l : Higher.Lens A B) →
    Lens.set (_≃_.to (Higher-lens≃Lens bl univ) l) ≡ Higher.Lens.set l
  set-lemma bl@⊠ l = ⟨ext⟩ λ a → ⟨ext⟩ λ b →
    Lens.set (_≃_.to (Higher-lens≃Lens bl univ) l) a b               ≡⟨⟩

    proj₁ (≡⇒→ (≡⇒→ (cong Coherently-constant (sym get⁻¹-≡))
                    (proj₂ (_≃_.to (∥∥→≃ univ) H))
                    .property (get a) b)
               (a , refl (get a)))                                   ≡⟨ cong (λ (c : Coherently-constant (get ⁻¹_)) →
                                                                                proj₁ (≡⇒→ (c .property (get a) b) (a , refl _))) $ sym $
                                                                        subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
    proj₁ (≡⇒→ (subst Coherently-constant (sym get⁻¹-≡)
                  (proj₂ (_≃_.to (∥∥→≃ univ) H))
                  .property (get a) b)
               (a , refl (get a)))                                   ≡⟨ cong (λ (c : Constant (get ⁻¹_)) →
                                                                                proj₁ (≡⇒→ (c (get a) b) (a , refl _)))
                                                                        subst-Coherently-property ⟩
    proj₁ (≡⇒→ (subst Constant (sym get⁻¹-≡)
                  (proj₂ (_≃_.to (∥∥→≃ univ) H) .property)
                  (get a) b)
               (a , refl (get a)))                                   ≡⟨ cong (λ c → proj₁ (≡⇒→ (subst Constant (sym get⁻¹-≡) c (get a) b)
                                                                                (a , refl _))) $
                                                                        proj₂-to-∥∥→≃-property≡ univ ⟩
    proj₁ (≡⇒→ (subst Constant (sym get⁻¹-≡)
                  (proj₁-to-∥∥→≃-constant univ H)
                  (get a) b)
               (a , refl (get a)))                                   ≡⟨ cong (λ eq → proj₁ (≡⇒→ eq (a , refl _))) $
                                                                        trans (cong (_$ b) $ sym $
                                                                               push-subst-application _ _) $
                                                                        sym $ push-subst-application _ _ ⟩
    proj₁ (≡⇒→ (subst (λ f → f (get a) ≡ f b) (sym get⁻¹-≡)
                  (proj₁-to-∥∥→≃-constant univ H (get a) b))
               (a , refl (get a)))                                   ≡⟨ cong (λ eq → proj₁ (≡⇒→ eq (a , refl _))) $
                                                                        subst-in-terms-of-trans-and-cong ⟩
    proj₁ (≡⇒→ (trans (sym (cong (_$ get a) (sym get⁻¹-≡)))
                  (trans (proj₁-to-∥∥→≃-constant univ H (get a) b)
                     (cong (_$ b) (sym get⁻¹-≡))))
               (a , refl (get a)))                                   ≡⟨⟩

    proj₁ (≡⇒→ (trans (sym (cong (_$ get a) (sym get⁻¹-≡)))
                  (trans (cong H (T.truncation-is-proposition _ _))
                     (cong (_$ b) (sym get⁻¹-≡))))
               (a , refl (get a)))                                   ≡⟨ cong (λ f → proj₁ (f (a , refl _))) $
                                                                        ≡⇒↝-trans equivalence ⟩
    proj₁ (≡⇒→ (trans (cong H (T.truncation-is-proposition _ _))
                  (cong (_$ b) (sym get⁻¹-≡)))
             (≡⇒→ (sym (cong (_$ get a) (sym get⁻¹-≡)))
                (a , refl (get a))))                                 ≡⟨ cong (λ f → proj₁ (f (≡⇒→ (sym (cong (_$ get a) (sym get⁻¹-≡)))
                                                                                (a , refl _)))) $
                                                                        ≡⇒↝-trans equivalence ⟩
    proj₁ (≡⇒→ (cong (_$ b) (sym get⁻¹-≡))
             (≡⇒→ (cong H (T.truncation-is-proposition _ _))
                (≡⇒→ (sym (cong (_$ get a) (sym get⁻¹-≡)))
                   (a , refl (get a)))))                             ≡⟨ cong₂ (λ p q → proj₁ (≡⇒→ p
                                                                                (≡⇒→ (cong H (T.truncation-is-proposition _ _))
                                                                                (≡⇒→ q (a , refl _)))))
                                                                          (cong-sym _ _)
                                                                          (trans (cong sym $ cong-sym _ _) $
                                                                           sym-sym _) ⟩
    proj₁ (≡⇒→ (sym $ cong (_$ b) get⁻¹-≡)
             (≡⇒→ (cong H (T.truncation-is-proposition _ _))
                (≡⇒→ (cong (_$ get a) get⁻¹-≡)
                   (a , refl (get a)))))                             ≡⟨ cong (λ f → proj₁ (f (≡⇒→ (cong H (T.truncation-is-proposition _ _))
                                                                                (≡⇒→ (cong (_$ get a) get⁻¹-≡)
                                                                                (a , refl _))))) $
                                                                        ≡⇒↝-sym equivalence ⟩
    proj₁ (_≃_.from (≡⇒≃ (cong (_$ b) get⁻¹-≡))
             (≡⇒→ (cong H (T.truncation-is-proposition _ _))
                (≡⇒→ (cong (_$ get a) get⁻¹-≡)
                   (a , refl (get a)))))                             ≡⟨⟩

    set a b                                                          ∎
    where
    open Higher.Lens l


module _ where

module A where

  syntax c x = ⟦ x

  data D₁ : Set where
    b : D₁
    c : D₁ → D₁

module B where

  syntax c x = ⟦ x ⟧

  data D₂ : Set where
    c : A.D₁ → D₂

open A
open B

test₁ : D₂
test₁ = ⟦ (⟦ c b) ⟧

test₂ : D₂ → D₁
test₂ ⟦ x ⟧ = ⟦ x

test₃ : D₁ → D₂
test₃ b     = c b
test₃ (⟦ x) = ⟦ x ⟧

test₄ : D₁ → D₂
test₄ A.b     = B.c A.b
test₄ (A.⟦ x) = B.⟦ x ⟧

test₅ : D₂ → D₁
test₅ B.⟦ x ⟧ = A.⟦ x

-- Should work.


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

open import Polynomial.Simple.AlmostCommutativeRing
open import Relation.Binary
open import Data.Bool using (Bool; false; true ; _∧_; _∨_; not; if_then_else_)
open import Data.String using (String)
open import EqBool

module Relation.Traced
  {c ℓ}
  (base : AlmostCommutativeRing c ℓ)
  ⦃ eqBase : HasEqBool (AlmostCommutativeRing.Carrier base) ⦄
  (showBase : AlmostCommutativeRing.Carrier base → String)
  where

open import Data.Sum
open import Relation.Binary.Construct.Closure.Equivalence
open import Relation.Binary.Construct.Closure.Symmetric
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Data.String
open import Relation.Nullary
open import Function
open import Level using (_⊔_)
open import Algebra.FunctionProperties
open import Data.String renaming (_==_ to eqBoolString)
open import Data.Maybe
open import Data.Nat using (ℕ)

open AlmostCommutativeRing base
open import Polynomial.Expr.Normalising rawRing showBase

open import Agda.Builtin.FromNat using (Number; fromNat) public

instance
  numberVar : {{nc : Number Carrier}} → Number Expr
  numberVar {{nc}} = record
    { Constraint = Number.Constraint nc
    ; fromNat = λ n → C ( (Number.fromNat nc n)) }

data BinOp : Set where
  [+] : BinOp
  [*] : BinOp

instance
  eqBinOp : HasEqBool BinOp
  EqBool._==_ ⦃ eqBinOp ⦄ [+] [+] = true
  EqBool._==_ ⦃ eqBinOp ⦄ [+] [*] = false
  EqBool._==_ ⦃ eqBinOp ⦄ [*] [+] = false
  EqBool._==_ ⦃ eqBinOp ⦄ [*] [*] = true

liftBinOp : BinOp → Expr → Expr → Expr
liftBinOp [+] (C x) (C y) = normalise (C (x + y))
liftBinOp [+] (C x) (O y) = normalise (O (K x ⊕ y))
liftBinOp [+] (O x) (C y) = normalise (O (x ⊕ K y))
liftBinOp [+] (O x) (O y) = normalise (O (x ⊕ y))
liftBinOp [*] (C x) (C y) = normalise (C (x * y))
liftBinOp [*] (C x) (O y) = normalise (O (K x ⊗ y))
liftBinOp [*] (O x) (C y) = normalise (O (x ⊗ K y))
liftBinOp [*] (O x) (O y) = normalise (O (x ⊗ y))

⊟_ : Expr → Expr
⊟ C x = C (- x)
⊟ O x = normalise (O (⊝ x))

data Step : Set c where
  [sym]      : Step → Step
  [cong]     : Step → BinOp → Step → Step
  [-cong]    : Step → Step
  [refl]     : Expr  → Step
  [assoc]    : BinOp → Expr → Expr → Expr → Step
  [ident]    : BinOp → Expr → Step
  [comm]     : BinOp → Expr → Expr → Step
  [zero]     : Expr → Step
  [distrib]  : Expr → Expr → Expr → Step
  [-distrib] : Expr → Expr → Step
  [-+comm]   : Expr → Expr → Step

_==S_ : Step → Step → Bool
_==S_ ([sym] x) ([sym] y) = x ==S y
_==S_ ([cong] x x₁ x₂) ([cong] y y₁ y₂) = x ==S y ∧ x₁ EqBool.== y₁ ∧ x₂ ==S y₂
_==S_ ([-cong] x) ([-cong] y) = x ==S y
_==S_ ([assoc] x x₁ x₂ x₃) ([assoc] y y₁ y₂ y₃) = x EqBool.== y ∧ x₁ EqBool.== y₁ ∧ x₂ EqBool.== y₂ ∧ x₃ EqBool.== y₃
_==S_ ([ident] x x₁) ([ident] y y₁) = x EqBool.== y ∧ x₁ EqBool.== y₁
_==S_ ([comm] x x₁ x₂) ([comm] y y₁ y₂) = x EqBool.== y ∧ x₁ EqBool.== y₁ ∧ x₂ EqBool.== y₂
_==S_ ([zero] x) ([zero] y) = x EqBool.== y
_==S_ ([distrib] x x₁ x₂) ([distrib] y y₁ y₂) = x EqBool.== y ∧ x₁ EqBool.== y₁ ∧ x₂ EqBool.== y₂
_==S_ ([-distrib] x x₁) ([-distrib] y y₁) = x EqBool.== y ∧ x₁ EqBool.== y₁
_==S_ ([-+comm] x x₁) ([-+comm] y y₁) = x EqBool.== y ∧ x₁ EqBool.== y₁
_==S_ ([refl] x) ([refl] y) = x EqBool.== y
_==S_ _ _ = false

instance
  eqStep : HasEqBool Step
  EqBool._==_ {{eqStep}} = _==S_

record _≈ⁱ_ (x y : Expr) : Set c where
   constructor ~?_
   field
     why : Step
open _≈ⁱ_

interesting : Step → Maybe Step
interesting ([sym] x) = interesting x
interesting ([-cong] x) = interesting x
interesting ([refl] x) = nothing
interesting ([assoc] x x₁ x₂ x₃) = nothing
interesting ([ident] x x₁) = nothing
interesting ([zero] x) = nothing
interesting ([cong] x x₁ x₂) with interesting x | interesting x₂
interesting ([cong] x x₁ x₂) | just res₁ | just res₂ = just ([cong] res₁ x₁ res₂)
interesting ([cong] x x₁ x₂) | just res₁ | nothing  = just res₁
interesting ([cong] x x₁ x₂) | nothing | just res₂ = just res₂
interesting ([cong] x x₁ x₂) | nothing | nothing  = nothing
interesting s@([comm] _ x y) with x EqBool.== y
interesting s@([comm] _ x y) | true = nothing
interesting s@([comm] o (C x) (C y))    | false = nothing
interesting s@([comm] [+] (C x) x₂)     | false = if x EqBool.== 0# then nothing else just s
interesting s@([comm] [+] (O x) (C x₁)) | false = if x₁ EqBool.== 0# then nothing else just s
interesting s@([comm] [+] (O x) (O x₁)) | false = just s
interesting s@([comm] [*] (C x) x₂)     | false = if (x EqBool.== 0# ∨ x EqBool.== 1#) then nothing else just s
interesting s@([comm] [*] (O x) (C x₁)) | false = if (x₁ EqBool.== 0# ∨ x₁ EqBool.== 1#) then nothing else just s
interesting s@([comm] [*] (O x) (O x₁)) | false = just s
interesting s@([distrib] (C _) (C _) (C _)) = nothing
interesting s@([distrib] (C x) x₁ x₂) = if (x EqBool.== 0# ∨ x EqBool.== 1#) then nothing else just s
interesting s@([distrib] x x₁ x₂) = just s
interesting s@([-distrib] x x₁) = nothing
interesting s@([-+comm] x x₁) = nothing

neg-cong : ∀ {x y} → x ≈ⁱ y → ⊟_  x ≈ⁱ ⊟_  y
neg-cong (~? reason) = ~? ( [-cong] reason)

zip-cong : BinOp
         → (f : Expr → Expr → Expr)
         → Congruent₂ (EqClosure _≈ⁱ_) f
zip-cong op f {x₁} {x₂} {y₁} {y₂} ε ε = ε
zip-cong op f {x₁} {x₂} {y₁} {y₂} ε (inj₁ (~? yr) ◅ ys) = inj₁ (~? ([cong] ([refl] x₁) op yr)) ◅ zip-cong op f ε ys
zip-cong op f {x₁} {x₂} {y₁} {y₂} ε (inj₂ (~? yr) ◅ ys) = inj₂ (~? ([cong] ([refl] x₁) op yr)) ◅ zip-cong op f ε ys
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₁ (~? xr) ◅ xs) ε = inj₁ (~? ([cong] xr op ([refl] y₁))) ◅ zip-cong op f xs ε
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₂ (~? xr) ◅ xs) ε = inj₂ (~? ([cong] xr op ([refl] y₁))) ◅ zip-cong op f xs ε
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₁ (~? xr) ◅ xs) (inj₁ (~? yr) ◅ ys) = inj₁ (~? ([cong] xr op yr)) ◅ zip-cong op f xs ys
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₁ (~? xr) ◅ xs) (inj₂ (~? yr) ◅ ys) = inj₁ (~? ([cong] xr op ([sym] yr))) ◅ zip-cong op f xs ys
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₂ (~? xr) ◅ xs) (inj₁ (~? yr) ◅ ys) = inj₂ (~? ([cong] xr op ([sym] yr))) ◅ zip-cong op f xs ys
zip-cong op f {x₁} {x₂} {y₁} {y₂} (inj₂ (~? xr) ◅ xs) (inj₂ (~? yr) ◅ ys) = inj₂ (~? ([cong] xr op yr)) ◅ zip-cong op f xs ys

isZero : (x : Expr) → Maybe (EqClosure _≈ⁱ_ (C 0#) x)
isZero (C x) = if 0# EqBool.== x then just (inj₁ (~? [refl] (C x)) ◅ ε) else nothing
isZero _ = nothing

tracedRing : AlmostCommutativeRing c c
tracedRing = record
  { Carrier                 = Expr
  ; _≈_                     = EqClosure _≈ⁱ_
  ; _+_                     = liftBinOp [+]
  ; _*_                     = liftBinOp [*]
  ; -_                      = ⊟_
  ; 0#                      = C 0#
  ; 1#                      = C 1#
  ; 0≟_                     = isZero
  ; isAlmostCommutativeRing = record
    {  -‿cong      = Relation.Binary.Construct.Closure.ReflexiveTransitive.gmap ⊟_ (Data.Sum.map neg-cong neg-cong)
    ; -‿*-distribˡ = λ x y → return (inj₁ (~? [-distrib] x y))
    ; -‿+-comm     = λ x y → return (inj₁ (~? [-+comm] x y))
    ; isCommutativeSemiring = record
      { distribʳ = λ x y z → return (inj₁ (~? [distrib] x y z))
      ; zeroˡ = λ x → return (inj₁ (~? ([zero] x)))
      ; *-isCommutativeMonoid = record
        { identityˡ = λ x → return (inj₁ (~? [ident] [*] x))
        ; comm = λ x y → return (inj₁ (~? [comm] [*] x y))
        ; isSemigroup = record
          { assoc = λ x y z → return (inj₁ (~? [assoc] [*] x y z))
          ; isMagma = record
            { isEquivalence = Relation.Binary.Construct.Closure.Equivalence.isEquivalence _≈ⁱ_
            ; ∙-cong = zip-cong [*] (liftBinOp [*])
            }
          }
        }
      ; +-isCommutativeMonoid = record
        { identityˡ = λ x → return (inj₁ (~? ([ident] [+] x)))
        ; comm = λ x y → return (inj₁ (~? ([comm] [+] x y)))
        ; isSemigroup = record
          { assoc = λ x y z → return (inj₁ (~? ([assoc] [+] x y z)))
          ; isMagma = record
            { isEquivalence = Relation.Binary.Construct.Closure.Equivalence.isEquivalence _≈ⁱ_
            ; ∙-cong = zip-cong [+] (liftBinOp [+])
            }
          }
        }
      }
    }
  }

open import Data.List as List using (List; _∷_; [])

record Explanation {a} (A : Set a) : Set (a ⊔ c) where
  constructor _≈⟨_⟩≈_
  field
    lhs : A
    step : Step
    rhs : A
open Explanation

toExplanation : ∀ {x y} → x ≈ⁱ y → Explanation Expr
toExplanation {x} {y} x≈y = x ≈⟨ why x≈y ⟩≈ y

showProof′ : ∀ {x y} → EqClosure _≈ⁱ_ x y → List (Explanation Expr)
showProof′ ε = []
showProof′ (inj₁ x ◅ xs) = toExplanation x ∷ showProof′ xs
showProof′ (inj₂ y ◅ xs) = toExplanation y ∷ showProof′ xs

open import Data.String.Printf
open Printf standard

⟨_⟩ₛ : Step → String
⟨ [sym] x  ⟩ₛ             = printf "sym (%s)" ⟨ x ⟩ₛ
⟨ [cong] x [+] x₂ ⟩ₛ      = printf "(%s) + (%s)" ⟨ x ⟩ₛ ⟨ x₂ ⟩ₛ
⟨ [cong] x [*] x₂ ⟩ₛ      = printf "(%s) * (%s)" ⟨ x ⟩ₛ ⟨ x₂ ⟩ₛ
⟨ [-cong] x ⟩ₛ            = printf "- (%s)" ⟨ x ⟩ₛ
⟨ [refl] x ⟩ₛ             = "eval"
⟨ [assoc] [+] x₁ x₂ x₃ ⟩ₛ = printf "+-assoc(%s, %s, %s)" ⟨ x₁ ⟩ₑ  ⟨ x₂ ⟩ₑ ⟨ x₃ ⟩ₑ
⟨ [assoc] [*] x₁ x₂ x₃ ⟩ₛ = printf "*-assoc(%s, %s, %s)" ⟨ x₁ ⟩ₑ  ⟨ x₂ ⟩ₑ ⟨ x₃ ⟩ₑ
⟨ [ident] [+] x₁ ⟩ₛ       = printf "+-ident(%s)" ⟨ x₁ ⟩ₑ
⟨ [ident] [*] x₁ ⟩ₛ       = printf "*-ident(%s)" ⟨ x₁ ⟩ₑ
⟨ [comm] [+] x₁ x₂ ⟩ₛ     = printf "+-comm(%s, %s)" ⟨ x₁ ⟩ₑ ⟨ x₂ ⟩ₑ
⟨ [comm] [*] x₁ x₂ ⟩ₛ     = printf "*-comm(%s, %s)" ⟨ x₁ ⟩ₑ ⟨ x₂ ⟩ₑ
⟨ [zero] x ⟩ₛ             = printf "*-zero(%s)" ⟨ x ⟩ₑ
⟨ [distrib] x x₁ x₂ ⟩ₛ    = printf "*-distrib(%s, %s, %s)" ⟨ x ⟩ₑ ⟨ x₁ ⟩ₑ  ⟨ x₂ ⟩ₑ
⟨ [-distrib] x x₁ ⟩ₛ      = printf "-‿distrib(%s, %s)" ⟨ x ⟩ₑ ⟨ x₁ ⟩ₑ
⟨ [-+comm] x x₁ ⟩ₛ        = printf "-+-comm(%s, %s)" ⟨ x ⟩ₑ ⟨ x₁ ⟩ₑ

showProof : ∀ {x y} → EqClosure _≈ⁱ_ x y → List String
showProof = List.foldr unparse [] ∘ List.foldr spotReverse [] ∘ List.mapMaybe interesting′ ∘ showProof′
  where
  unparse : Explanation Expr → List String → List String
  unparse (lhs₁ ≈⟨ step₁ ⟩≈ rhs₁) [] = ⟨ lhs₁ ⟩ₑ ∷ printf "    ={ %s }" ⟨ step₁ ⟩ₛ ∷ ⟨ rhs₁ ⟩ₑ ∷ []
  unparse (lhs₁ ≈⟨ step₁ ⟩≈ rhs₁) (y ∷ ys) = if r EqBool.== y then l ∷ m ∷ y ∷ ys else l ∷ m ∷ r ∷ "    ={ eval }" ∷ y ∷ ys
    where
    l = ⟨ lhs₁ ⟩ₑ
    m = printf "    ={ %s }" ⟨ step₁ ⟩ₛ
    r = ⟨ rhs₁ ⟩ₑ

  spotReverse : Explanation Expr → List (Explanation Expr) → List (Explanation Expr)
  spotReverse x [] = x ∷ []
  spotReverse x (y ∷ xs) = if lhs x EqBool.== rhs y then xs else x ∷ y ∷ xs

  interesting′ : Explanation Expr → Maybe (Explanation Expr)
  interesting′ (lhs ≈⟨ stp ⟩≈ rhs) with interesting stp
  interesting′ (lhs ≈⟨ stp ⟩≈ rhs) | just x = just (lhs ≈⟨ x ⟩≈ rhs)
  interesting′ (lhs ≈⟨ stp ⟩≈ rhs) | nothing = nothing

open import Agda.Builtin.FromString using (IsString; fromString) public
import Data.String.Literals
open import Data.Unit using (⊤)
open import Level using (Lift)

instance
  stringString : IsString String
  stringString = Data.String.Literals.isString

instance
  lift-inst : ∀ {ℓ a} { A : Set a } → ⦃ x : A ⦄ → Lift ℓ A
  lift-inst ⦃ x = x ⦄ = Level.lift x

instance
  exprString : IsString Expr
  exprString = record
    { Constraint = λ _ → Lift _ ⊤ ; fromString = λ s → O (V s) }


module Compilation.Term where

open import Context
open import Type.Core
open import Type.NbE
import Term.Core as Core
open import Compilation.Data
open import Compilation.Encode.Core

open import Function
open import Data.Empty
open import Data.Sum.Base
open import Data.List.Base as List

infix 3 _⊢_

data Recursivity : Set where
  NonRec Rec : Recursivity

caseRec : ∀ {ρ} {R : Set ρ} -> Recursivity -> R -> R -> R
caseRec NonRec x y = x
caseRec Rec    x y = y

data _⊢_ {Θ} Γ : Star Θ -> Set where
  letType : ∀ {σ β} -> (α : Θ ⊢ᵗ σ) -> shiftᶜ Γ ⊢ β -> Γ ⊢ β [ α ]ᵗ
  letTerm : ∀ {α} Δ rec -> Seq (caseRec rec Γ (Γ ▻▻ Δ) ⊢_) Δ -> Γ ▻▻ Δ ⊢ α -> Γ ⊢ α
  var  : ∀ {α}   -> α ∈ Γ -> Γ ⊢ α
  Λ_   : ∀ {σ α} -> shiftᶜ Γ ⊢ α -> Γ ⊢ π σ α
  _[_] : ∀ {σ β} -> Γ ⊢ π σ β -> (α : Θ ⊢ᵗ σ) -> Γ ⊢ β [ α ]ᵗ
  ƛ_   : ∀ {α β} -> Γ ▻ α ⊢ β -> Γ ⊢ α ⇒ β
  _·_  : ∀ {α β} -> Γ ⊢ α ⇒ β -> Γ ⊢ α -> Γ ⊢ β
  iwrap  : ∀ {κ ψ} {α : Θ ⊢ᵗ κ} -> Γ ⊢ Core.unfold ψ α -> Γ ⊢ μ ψ α
  unwrap : ∀ {κ ψ} {α : Θ ⊢ᵗ κ} -> Γ ⊢ μ ψ α -> Γ ⊢ Core.unfold ψ α

mutual
  compile : ∀ {Θ} {Γ : Con (Star Θ)} {α} -> Γ ⊢ α -> Γ Core.⊢ α
  compile (letType α term)         = (Core.Λ (compile term)) Core.[ α ]
  compile (letTerm Δ rec env term) with rec
  ... | NonRec = Core.instNonRec (map-compile env) (compile term)
  ... | Rec    = Core.instRec    (map-compile env) (compile term)
  compile (var v)                  = Core.var v
  compile (Λ body)                 = Core.Λ (compile body)
  compile (fun [ α ])              = compile fun Core.[ α ]
  compile (ƛ body)                 = Core.ƛ (compile body)
  compile (fun · arg)              = compile fun Core.· compile arg
  compile (iwrap  term)            = Core.iwrap (compile term)
  compile (unwrap term)            = Core.unwrap (compile term)

  -- This is just `mapˢ compile` inlined to convince Agda there are no termination problems.
  map-compile : ∀ {Θ} {Γ Δ : Con (Star Θ)} -> Seq (Γ ⊢_) Δ -> Seq (Γ Core.⊢_) Δ
  map-compile  ø           = ø
  map-compile (seq ▶ term) = map-compile seq ▶ compile term


-- Andreas, 2015-05-02, issue reported by Gabe Dijkstra
open import Common.Prelude
open import Common.Equality

data T : Set where
  c0 : ⊥ → T
  c1 : ⊥ → T

-- The following should not pass, as c0 and c1 are not fully applied.
c0≠c1 : c0 ≡ c1 → ⊥
c0≠c1 ()

-- The latter conflicts with function extensionality.
postulate
  fun-ext : {A B : Set} → (f g : A → B) → ((x : A) → f x ≡ g x) → f ≡ g

c0=c1 : c0 ≡ c1
c0=c1 = fun-ext c0 c1 (λ ())

wrong : ⊥
wrong = c0≠c1 c0=c1


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

open import Everything

module Test.ProblemWithLevelZero where

module _ (𝔓 : Ø₀) where

  open Substitunction 𝔓
  open Term 𝔓

  fails : ∀ {m n} (f : Substitunction m n) → Substitunction m n
  fails f = transitivity f ε -- FIXME

  refl-works : ∀ {m} → Substitunction m m
  refl-works = ε

  solution-1o solution-1a solution-2o solution-2a :
    ∀ {m n} (f : Substitunction m n) → Substitunction m n

  solution-1o f = transitivity {𝔒 = ¶} f ε
  solution-1a f = transitivity[ Substitunction ] f ε
  solution-2o f = transitivity {𝔒 = Ø₀} f ε
  solution-2a f = transitivity[ Function ] f ε

  transitivity-hole : ∀ {m n} (f : Substitunction m n) → Substitunction m n
  transitivity-hole f =
    transitivity
      ⦃ {!!!} -- FIXME does not resolve instance
        ⦄
      f
      {!!}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.MayerVietorisUnreduced where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Data.Sigma
open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; rec2 to sRec2 ; elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; elim2 to pElim2 ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁)
open import Cubical.Data.Nat
open import Cubical.Algebra.Group
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec ; elim3 to trElim3)

open GroupHom

module MV {ℓ ℓ' ℓ''} (A : Type ℓ) (B : Type ℓ') (C : Type ℓ'') (f : C → A) (g : C → B) where
  -- Proof from Brunerie 2016.
  -- We first define the three morphisms involved: i, Δ and d.

  private
    i* : (n : ℕ) → coHom n (Pushout f g) → coHom n A × coHom n B
    i* n = sRec (isSet× setTruncIsSet setTruncIsSet) λ δ → ∣ (λ x → δ (inl x)) ∣₂ , ∣ (λ x → δ (inr x)) ∣₂

  iIsHom : (n : ℕ) → isGroupHom (coHomGr n (Pushout f g)) (×coHomGr n A B) (i* n)
  iIsHom n = sElim2 (λ _ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _) λ _ _ → refl

  i : (n : ℕ) → GroupHom (coHomGr n (Pushout f g)) (×coHomGr n A B)
  GroupHom.fun (i n) = i* n
  GroupHom.isHom (i n) = iIsHom n

  private
    distrLem : (n : ℕ) (x y z w : coHomK n) → (x +[ n ]ₖ y) -[ n ]ₖ (z +[ n ]ₖ w) ≡ (x -[ n ]ₖ z) +[ n ]ₖ (y -[ n ]ₖ w)
    distrLem n x y z w = cong (λ z → (x +[ n ]ₖ y) +[ n ]ₖ z) (-distrₖ n z w)
                     ∙∙ sym (assocₖ n x y ((-[ n ]ₖ z) +[ n ]ₖ (-[ n ]ₖ w)))
                     ∙∙ cong (λ y → x +[ n ]ₖ y) (commₖ n y ((-[ n ]ₖ z) +[ n ]ₖ (-[ n ]ₖ w)) ∙ sym (assocₖ n _ _ _))
                     ∙∙ assocₖ n _ _ _
                     ∙∙ cong (λ y → (x -[ n ]ₖ z) +[ n ]ₖ y) (commₖ n (-[ n ]ₖ w) y)

    Δ' : (n : ℕ) → coHom n A × coHom n B → coHom n C
    Δ' n (α , β) = coHomFun n f α -[ n ]ₕ coHomFun n g β

    Δ'-isMorph : (n : ℕ) → isGroupHom (×coHomGr n A B) (coHomGr n C) (Δ' n)
    Δ'-isMorph n =
      prodElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _ )
        λ f' x1 g' x2 i → ∣ (λ x → distrLem n (f' (f x)) (g' (f x)) (x1 (g x)) (x2 (g x)) i) ∣₂

  Δ : (n : ℕ) → GroupHom (×coHomGr n A B) (coHomGr n C)
  GroupHom.fun (Δ n) = Δ' n
  GroupHom.isHom (Δ n) = Δ'-isMorph n

  d-pre : (n : ℕ) → (C → coHomK n) → Pushout f g → coHomK (suc n)
  d-pre n γ (inl x) = 0ₖ (suc n)
  d-pre n γ (inr x) = 0ₖ (suc n)
  d-pre n γ (push a i) = Kn→ΩKn+1 n (γ a) i

  dHomHelper : (n : ℕ) (h l : C → coHomK n) (x : Pushout f g)
             → d-pre n (λ x → h x +[ n ]ₖ l x) x ≡ d-pre n h x +[ suc n ]ₖ d-pre n l x
  dHomHelper n h l (inl x) = sym (rUnitₖ (suc n) (0ₖ (suc n)))
  dHomHelper n h l (inr x) = sym (lUnitₖ (suc n) (0ₖ (suc n)))
  dHomHelper n h l (push a i) j =
    hcomp (λ k → λ { (i = i0) → rUnitₖ (suc n) (0ₖ (suc n)) (~ j)
                    ; (i = i1) → lUnitₖ (suc n) (0ₖ (suc n)) (~ j)
                    ; (j = i0) → Kn→ΩKn+1-hom n (h a) (l a) (~ k) i
                    ; (j = i1) → cong₂Funct (λ x y → x +[ (suc n) ]ₖ y) (Kn→ΩKn+1 n (h a)) (Kn→ΩKn+1 n (l a)) (~ k) i })
          (hcomp (λ k → λ { (i = i0) → rUnitₖ (suc n) (0ₖ (suc n)) (~ j)
                           ; (i = i1) → lUnitₖ (suc n) (Kn→ΩKn+1 n (l a) k) (~ j)})
                 (hcomp (λ k → λ { (i = i0) → rUnitₖ (suc n) (0ₖ (suc n)) (~ j)
                                  ; (i = i1) → lUnitₖ≡rUnitₖ (suc n) (~ k) (~ j)
                                  ; (j = i0) → Kn→ΩKn+1 n (h a) i
                                  ; (j = i1) → (Kn→ΩKn+1 n (h a) i) +[ (suc n) ]ₖ coHom-pt (suc n)})
                        (rUnitₖ (suc n) (Kn→ΩKn+1 n (h a) i) (~ j))))

  dIsHom : (n : ℕ) → isGroupHom (coHomGr n C) (coHomGr (suc n) (Pushout f g)) (sRec setTruncIsSet λ a → ∣ d-pre n a ∣₂)
  dIsHom n = sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                     λ f g i → ∣ funExt (λ x → dHomHelper n f g x) i ∣₂

  d : (n : ℕ) → GroupHom (coHomGr n C) (coHomGr (suc n) (Pushout f g))
  GroupHom.fun (d n) = sRec setTruncIsSet λ a → ∣ d-pre n a ∣₂
  GroupHom.isHom (d n) = dIsHom n

  -- The long exact sequence
  Im-d⊂Ker-i : (n : ℕ) (x : ⟨ (coHomGr (suc n) (Pushout f g)) ⟩)
            → isInIm (coHomGr n C) (coHomGr (suc n) (Pushout f g)) (d n) x
            → isInKer (coHomGr (suc n) (Pushout f g)) (×coHomGr (suc n) A B) (i (suc n)) x
  Im-d⊂Ker-i n = sElim (λ _ → isSetΠ λ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _)
                       λ a → pRec (isOfHLevelPath' 1 (isSet× setTruncIsSet setTruncIsSet) _ _)
                               (sigmaElim (λ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _)
                                λ δ b i → sRec (isSet× setTruncIsSet setTruncIsSet)
                                               (λ δ → ∣ (λ x → δ (inl x)) ∣₂ , ∣ (λ x → δ (inr x)) ∣₂ ) (b (~ i)))

  Ker-i⊂Im-d : (n : ℕ) (x : ⟨ coHomGr (suc n) (Pushout f g) ⟩)
             → isInKer (coHomGr (suc n) (Pushout f g)) (×coHomGr (suc n) A B) (i (suc n)) x
             → isInIm (coHomGr n C) (coHomGr (suc n) (Pushout f g)) (d n) x
  Ker-i⊂Im-d n =
     sElim (λ _ → isSetΠ λ _ → isProp→isSet propTruncIsProp)
           λ a p → pRec {A = (λ x → a (inl x)) ≡ λ _ → 0ₖ (suc n)}
                        (isProp→ propTruncIsProp)
                        (λ p1 → pRec propTruncIsProp λ p2 → ∣ ∣ (λ c → ΩKn+1→Kn n (sym (cong (λ F → F (f c)) p1)
                                                                                ∙∙ cong a (push c)
                                                                                ∙∙ cong (λ F → F (g c)) p2)) ∣₂
                                                                             , cong ∣_∣₂ (funExt (λ δ → helper a p1 p2 δ)) ∣₁)
                                       (Iso.fun PathIdTrunc₀Iso (cong fst p))
                                       (Iso.fun PathIdTrunc₀Iso (cong snd p))

      where
      helper : (F : (Pushout f g) → coHomK (suc n))
               (p1 : Path (_ → coHomK (suc n)) (λ a₁ → F (inl a₁)) (λ _ → coHom-pt (suc n)))
               (p2 : Path (_ → coHomK (suc n)) (λ a₁ → F (inr a₁)) (λ _ → coHom-pt (suc n)))
             → (δ : Pushout f g)
             → d-pre n (λ c → ΩKn+1→Kn n ((λ i₁ → p1 (~ i₁) (f c))
                                                     ∙∙ cong F (push c)
                                                     ∙∙ cong (λ F → F (g c)) p2)) δ
              ≡ F δ
      helper F p1 p2 (inl x) = sym (cong (λ f → f x) p1)
      helper F p1 p2 (inr x) = sym (cong (λ f → f x) p2)
      helper F p1 p2 (push a i) j =
        hcomp (λ k → λ { (i = i0) → p1 (~ j) (f a)
                       ; (i = i1) → p2 (~ j) (g a)
                       ; (j = i0) → Iso.rightInv (Iso-Kn-ΩKn+1 n) ((λ i₁ → p1 (~ i₁) (f a))
                                                                       ∙∙ cong F (push a)
                                                                       ∙∙ cong (λ F₁ → F₁ (g a)) p2) (~ k) i
                        ; (j = i1) → F (push a i)})
              (doubleCompPath-filler (sym (cong (λ F → F (f a)) p1)) (cong F (push a)) (cong (λ F → F (g a)) p2) (~ j) i)

  open GroupHom

  Im-i⊂Ker-Δ : (n : ℕ) (x : ⟨ ×coHomGr n A B ⟩)
            → isInIm (coHomGr n (Pushout f g)) (×coHomGr n A B) (i n) x
            → isInKer (×coHomGr n A B) (coHomGr n C) (Δ n) x
  Im-i⊂Ker-Δ n (Fa , Fb) =
    sElim {B = λ Fa → (Fb : _) → isInIm (coHomGr n (Pushout f g)) (×coHomGr n A B) (i n) (Fa , Fb)
                               → isInKer (×coHomGr n A B) (coHomGr n C) (Δ n) (Fa , Fb)}
          (λ _ → isSetΠ2 λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          (λ Fa → sElim (λ _ → isSetΠ λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                        λ Fb → pRec (setTruncIsSet _ _)
                                     (sigmaElim (λ x → isProp→isSet (setTruncIsSet _ _))
                                                λ Fd p → helper n Fa Fb Fd p))
          Fa
          Fb
    where
    helper : (n : ℕ) (Fa : A → coHomK n) (Fb : B → coHomK n) (Fd : (Pushout f g) → coHomK n)
          → (fun (i n) ∣ Fd ∣₂ ≡ (∣ Fa ∣₂ , ∣ Fb ∣₂))
          → (fun (Δ n)) (∣ Fa ∣₂ , ∣ Fb ∣₂) ≡ 0ₕ n
    helper n Fa Fb Fd p = cong (fun (Δ n)) (sym p)
                           ∙∙ (λ i → ∣ (λ x → Fd (inl (f x))) ∣₂ -[ n ]ₕ ∣ (λ x → Fd (push x (~ i))) ∣₂ )
                           ∙∙ rCancelₕ n ∣ (λ x → Fd (inl (f x))) ∣₂

  Ker-Δ⊂Im-i : (n : ℕ) (a : ⟨ ×coHomGr n A B ⟩)
            → isInKer (×coHomGr n A B) (coHomGr n C) (Δ n) a
            → isInIm (coHomGr n (Pushout f g)) (×coHomGr n A B) (i n) a
  Ker-Δ⊂Im-i n = prodElim (λ _ → isSetΠ (λ _ → isProp→isSet propTruncIsProp))
                          (λ Fa Fb p → pRec propTruncIsProp
                                            (λ q → ∣ ∣ helpFun Fa Fb q ∣₂ , refl ∣₁)
                                            (helper Fa Fb p))
    where
    helper : (Fa : A → coHomK n) (Fb : B → coHomK n)
           → fun (Δ n) (∣ Fa ∣₂ , ∣ Fb ∣₂) ≡ 0ₕ n
           → ∥ Path (_ → _) (λ c → Fa (f c)) (λ c → Fb (g c)) ∥₁
    helper Fa Fb p = Iso.fun PathIdTrunc₀Iso
                               (sym (cong ∣_∣₂ (funExt (λ x → sym (assocₖ n _ _ _)
                               ∙∙ cong (λ y → Fa (f x) +[ n ]ₖ y) (lCancelₖ n (Fb (g x)))
                               ∙∙ rUnitₖ n (Fa (f x)))))
                               ∙∙ cong (λ x → x +[ n ]ₕ ∣ (λ c → Fb (g c)) ∣₂) p
                               ∙∙ lUnitₕ n _)

    helpFun : (Fa : A → coHomK n) (Fb : B → coHomK n)
            → ((λ c → Fa (f c)) ≡ (λ c → Fb (g c)))
            → Pushout f g → coHomK n
    helpFun Fa Fb p (inl x) = Fa x
    helpFun Fa Fb p (inr x) = Fb x
    helpFun Fa Fb p (push a i) = p i a

  private
    distrHelper : (n : ℕ) (p q : _)
                → ΩKn+1→Kn n p +[ n ]ₖ (-[ n ]ₖ ΩKn+1→Kn n q) ≡ ΩKn+1→Kn n (p ∙ sym q)
    distrHelper n p q = cong (λ x → ΩKn+1→Kn n p +[ n ]ₖ x) helper ∙ sym (ΩKn+1→Kn-hom n _ _)
      where
      helper : -[ n ]ₖ ΩKn+1→Kn n q ≡ ΩKn+1→Kn n (sym q)
      helper =
           sym (rUnitₖ n _)
        ∙∙ cong (λ x → (-[ n ]ₖ (ΩKn+1→Kn n q)) +[ n ]ₖ x) (sym helper2)
        ∙∙ (assocₖ n _ _ _ ∙∙ cong (λ x → x +[ n ]ₖ (ΩKn+1→Kn n (sym q))) (lCancelₖ n _) ∙∙ lUnitₖ n _)
        where
        helper2 : ΩKn+1→Kn n q +[ n ]ₖ (ΩKn+1→Kn n (sym q)) ≡ coHom-pt n
        helper2 = sym (ΩKn+1→Kn-hom n q (sym q)) ∙∙ cong (ΩKn+1→Kn n) (rCancel q) ∙∙ ΩKn+1→Kn-refl n

  Ker-d⊂Im-Δ : (n : ℕ) (a : coHom n C)
             → isInKer (coHomGr n C) (coHomGr (suc n) (Pushout f g)) (d n) a
             → isInIm (×coHomGr n A B) (coHomGr n C) (Δ n) a
  Ker-d⊂Im-Δ n =
    sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
          λ Fc p → pRec propTruncIsProp (λ p → ∣ (∣ (λ a → ΩKn+1→Kn n (cong (λ f → f (inl a)) p)) ∣₂ ,
                                                     ∣ (λ b → ΩKn+1→Kn n (cong (λ f → f (inr b)) p)) ∣₂) ,
                                                  Iso.inv (PathIdTrunc₀Iso) ∣ funExt (λ c → helper2 Fc p c) ∣₁ ∣₁)
                                         (Iso.fun (PathIdTrunc₀Iso) p)

    where

    helper2 : (Fc : C → coHomK n)
              (p : d-pre n Fc ≡ (λ _ → coHom-pt (suc n))) (c : C)
            → ΩKn+1→Kn n (λ i₁ → p i₁ (inl (f c))) -[ n ]ₖ (ΩKn+1→Kn n (λ i₁ → p i₁ (inr (g c)))) ≡ Fc c
    helper2 Fc p c = distrHelper n _ _ ∙∙ cong (ΩKn+1→Kn n) helper3 ∙∙ Iso.leftInv (Iso-Kn-ΩKn+1 n) (Fc c)
      where
      helper3 : (λ i₁ → p i₁ (inl (f c))) ∙ sym (λ i₁ → p i₁ (inr (g c))) ≡ Kn→ΩKn+1 n (Fc c)
      helper3 = cong ((λ i₁ → p i₁ (inl (f c))) ∙_) (lUnit _) ∙ sym (PathP→compPathR (cong (λ f → cong f (push c)) p))

  Im-Δ⊂Ker-d : (n : ℕ) (a : coHom n C)
             → isInIm (×coHomGr n A B) (coHomGr n C) (Δ n) a
             → isInKer (coHomGr n C) (coHomGr (suc n) (Pushout f g)) (d n) a
  Im-Δ⊂Ker-d n =
    sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          λ Fc → pRec (isOfHLevelPath' 1 setTruncIsSet _ _)
                       (sigmaProdElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                      λ Fa Fb p → pRec (isOfHLevelPath' 1 setTruncIsSet _ _)
                                                        (λ q → ((λ i → fun (d n) ∣ (q (~ i)) ∣₂) ∙ dΔ-Id n Fa Fb))
                                                        (Iso.fun (PathIdTrunc₀Iso) p))

    where
    d-preLeftId : (n : ℕ) (Fa : A → coHomK n)(d : (Pushout f g))
                → d-pre n (Fa ∘ f) d ≡ 0ₖ (suc n)
    d-preLeftId n Fa (inl x) = Kn→ΩKn+1 n (Fa x)
    d-preLeftId n Fa (inr x) = refl
    d-preLeftId n Fa (push a i) j = Kn→ΩKn+1 n (Fa (f a)) (j ∨ i)

    d-preRightId : (n : ℕ) (Fb : B → coHomK n) (d : (Pushout f g))
                → d-pre n (Fb ∘ g) d ≡ 0ₖ (suc n)
    d-preRightId n Fb (inl x) = refl
    d-preRightId n Fb (inr x) = sym (Kn→ΩKn+1 n (Fb x))
    d-preRightId n Fb (push a i) j = Kn→ΩKn+1 n (Fb (g a)) (~ j ∧ i)

    dΔ-Id : (n : ℕ) (Fa : A → coHomK n) (Fb : B → coHomK n)
            → fun (d n) (fun (Δ n) (∣ Fa ∣₂ , ∣ Fb ∣₂)) ≡ 0ₕ (suc n)
    dΔ-Id n Fa Fb = -distrLemma n (suc n) (d n) ∣ Fa ∘ f ∣₂ ∣ Fb ∘ g ∣₂
                    ∙∙ (λ i → ∣ (λ x → d-preLeftId n Fa x i) ∣₂ -[ (suc n) ]ₕ ∣ (λ x → d-preRightId n Fb x i) ∣₂)
                    ∙∙ rCancelₕ (suc n) (0ₕ (suc n))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Binary where

open import Cubical.Relation.Binary.Base public
open import Cubical.Relation.Binary.Properties public
open import Cubical.Relation.Binary.Fiberwise public


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

open import HoTT

module homotopy.S1SuspensionS0 where

{- To -}

module To = S¹Rec (north Bool) (merid _ true ∙ ! (merid _ false))

to : S¹ → Suspension Bool
to = To.f

{- From -}

from-merid : Bool → base == base
from-merid true = loop
from-merid false = idp

module From = SuspensionRec Bool base base from-merid

from : Suspension Bool → S¹
from = From.f

{- ToFrom and FromTo -}

module _ {i}  {A : Type i} where
  ∙idp∙ : {x y z : A} (p : x == y) (q : y == z) → p ∙ idp ∙ q == p ∙ q
  ∙idp∙ idp idp = idp
  p∙!q∙q : {x y z : A} (p : x == y) (q : z == y) → p ∙ ( ! q ∙ q)  == p
  p∙!q∙q idp idp = idp
  !-∙∙ :  {x y z w : A} (p : x == y) (q : y == z) (r : x == w) →  ! (p ∙ q) ∙ r == (! q ∙ ! p ) ∙ r
  !-∙∙ idp idp idp = idp
  !-coh : {x y : A} {p p' : x == y} → p == p' → ! p == ! p'
  !-coh idp = idp
  add-idp-r : {x y : A} → (p : x == y) → p == p ∙ idp
  add-idp-r idp = idp

ap-coh : ∀ {i j} {A : Type i} {B : Type j} {x y : A} → (f : A → B) → {p p' : x == y} → p == p' → ap f p == ap f p'
ap-coh f idp = idp
_∋_ : ∀ {i} (A : Type i) → A → A
A ∋ x = x

mt : north Bool == south Bool
mt = merid Bool true

mf : north Bool == south Bool
mf = merid Bool false

to-from-merid-t' :  ( ! (ap to (ap from mt))) ∙ idp ∙ mt ==  mf
to-from-merid-t' =  ! (ap to (ap from mt)) ∙ idp ∙ mt         =⟨ ∙idp∙ ( ! (ap to (ap from mt)))  mt  ⟩
                    ! (ap to (ap from mt)) ∙ mt               =⟨ (!-coh (ap-coh to (From.glue-β true))) ∙ᵣ mt ⟩
                    ! (ap to loop) ∙ mt                       =⟨ (!-coh (To.loop-β)) ∙ᵣ mt ⟩
                    (! (mt ∙ ! mf)) ∙ mt                      =⟨ !-∙∙ mt (! mf) mt ⟩
                    ((! (! mf)) ∙ ! mt) ∙ mt                  =⟨ ((!-! mf) ∙ᵣ (! mt)) ∙ᵣ mt ⟩
                    (mf ∙ ! mt) ∙ mt                          =⟨ ∙-assoc mf (! mt) mt  ⟩
                    mf ∙ (! mt ∙ mt)                          =⟨ p∙!q∙q mf mt ⟩
                    mf ∎

to-from-merid-f' :  ( ! (ap to (ap from mf))) ∙ idp ∙ mf ==  mf
to-from-merid-f' =  ! (ap to (ap from mf)) ∙ idp ∙ mf        =⟨ ∙idp∙ ( ! (ap to (ap from mf))) mf ⟩
                    ! (ap to (ap from mf)) ∙ mf              =⟨ (!-coh (ap-coh to (From.glue-β false))) ∙ᵣ mf ⟩
                    mf ∎

-- to-from-merid' : (b : Bool) → ( ! (ap to (ap from (merid Bool b)))) ∙ idp ∙ mf ==  (merid Bool b)
-- to-from-merid' false = to-from-merid-f'
-- to-from-merid' true = to-from-merid-t'

to-from : (x : Suspension Bool) → to (from x) == x
to-from = ToFrom.f
  where
    Q : Suspension Bool → Set lzero
    Q x = to (from x) == x

    n : to (from (north Bool)) == north Bool
    n = idp

    s : to (from (south Bool)) == south Bool
    s = mf

    lemma : {x y : Suspension Bool} → (q : x == y) → (α : to (from x) == x) → transport Q q α == (! (ap to (ap from q))) ∙ α ∙ q
    lemma idp α = add-idp-r α

    p : (b : Bool) → n == s [ Q ↓ merid Bool b ]
    p true = from-transp Q mt ((lemma mt n) ∙ to-from-merid-t')
    p false = from-transp Q mf ((lemma mf n) ∙ to-from-merid-f')

    module ToFrom = SuspensionElim Bool {P = Q} n s p

from-to-loop' : (! (ap from (ap to loop))) ∙ idp ∙ loop == idp
from-to-loop' = ! (ap from (ap to loop)) ∙ idp ∙ loop         =⟨ ∙idp∙ (! (ap from (ap to loop)))  loop  ⟩
                ! (ap from (ap to loop)) ∙ loop               =⟨ (!-coh (ap-coh from To.loop-β)) ∙ᵣ loop ⟩
                ! (ap from (mt ∙ ! mf)) ∙ loop                =⟨ (!-coh (ap-∙ from mt (! mf))) ∙ᵣ loop  ⟩
                (! ((ap from mt) ∙ (ap from (! mf)))) ∙ loop  =⟨ (!-coh ( (From.glue-β true) ∙ᵣ (ap from (! mf)))) ∙ᵣ loop  ⟩
                ! (loop ∙ (ap from (! mf))) ∙ loop            =⟨ !-coh (loop ∙ₗ ap-! from mf) ∙ᵣ loop ⟩
                ! (loop ∙ ! (ap from mf)) ∙ loop              =⟨ !-coh (loop ∙ₗ (!-coh (From.glue-β false))) ∙ᵣ loop ⟩
                ! (loop ∙ ! idp) ∙ loop                       =⟨ !-∙∙ loop (! idp) loop ⟩
                (! loop) ∙ loop                               =⟨ !-inv-l loop ⟩
                idp ∎

from-to : (x : S¹) → from (to x) == x
from-to = FromTo.f
  where
    Q : S¹ → Type lzero
    Q x = from (to x) == x

    b : Q base
    b = idp

    lemma : {x y : S¹} → (q : x == y) → (α : from (to x) == x) → transport Q q α == (! (ap from (ap to q))) ∙ α ∙ q
    lemma idp α = add-idp-r α

    l : b == b [ Q ↓ loop ]
    l = from-transp Q loop ((lemma loop b) ∙ from-to-loop')

    module FromTo = S¹Elim {P = Q} b l

e : S¹ ≃ Suspension Bool
e = equiv to from to-from from-to


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

open import HoTT

{- Proof that if [A] and [B] are two propositions, then so is [A * B]. -}

module homotopy.PropJoinProp
  {i} (A : Type i) {pA : (a a' : A) → a == a'}
  {j} (B : Type j) {pB : (b b' : B) → b == b'} where

{-
We first prove that [left a == y] for all [a : A] and [y : A * B].
For that we will need the coherence condition [coh1] below.
-}

eq-left : (a : A) (y : A * B) → left a == y
eq-left = EqLeft.f  module M where

  coh1 : {b' : B} {a a' : A} (p : a == a')
    → ap left p ∙ glue (a' , b') == glue (a , b') :> (left a == right b' :> A * B)
  coh1 idp = idp

  module EqLeft (a : A) =
    PushoutElim (λ a' → ap left (pA a a'))
                (λ b' → glue (a , b'))
                (λ {(a' , b') → ↓-cst=idf-in (coh1 (pA a a'))})

open M

{-
Now we prove that [right b == y] for all [b : B] and [y : A * B].
We will again need some coherence condition [coh2].
-}

eq-right : (b : B) (y : A * B) → right b == y
eq-right = EqRight.f  module M' where

  coh2 : {a' : A} {b b' : B} (p : b == b')
    → ! (glue (a' , b)) ∙ glue (a' , b') == ap right p :> (right b == right b' :> A * B)
  coh2 idp = !-inv-l (glue _)

  module EqRight (b : B) =
    PushoutElim (λ a' → ! (glue (a' , b)))
                (λ b' → ap right (pB b b'))
                (λ {(a' , b') → ↓-cst=idf-in (coh2 (pB b b'))})

open M'

{-
Then we prove the missing cases.
For the cases [x == left a'] and [x == right b'] we will need the coherence
conditions [coh3] and [coh4].
For the last case, we need a "2-dimensional" coherence condition [coh²],
relating [coh1], [coh2], [coh3] and [coh4].
-}

eq : (x y : A * B) → x == y
eq = Pushout-elim eq-left eq-right
       (λ {(a , b) → ↓-cst→app-in (Pushout-elim (λ a' → ↓-idf=cst-in (coh3 (pA a a')))
                                                (λ b' → ↓-idf=cst-in (coh4 (pB b b')))
                                                (λ {(a' , b') → ↓-idf=cst-in=↓ (↓-=-in
   (coh3 (pA a a') ◃ apd (λ x → glue (a , b) ∙' eq-right b x) (glue (a' , b'))
          =⟨ apd∙' (λ x → glue (a , b)) (eq-right b) (glue (a' , b')) |in-ctx (λ u → coh3 (pA a a') ◃ u) ⟩
    coh3 (pA a a') ◃ (apd (λ x → glue (a , b)) (glue (a' , b')) ∙'2ᵈ apd (eq-right b) (glue (a' , b')))
          =⟨ EqRight.glue-β b (a' , b') |in-ctx (λ u → coh3 (pA a a') ◃ (apd (λ x → glue (a , b)) (glue (a' , b')) ∙'2ᵈ u)) ⟩
    coh3 (pA a a') ◃ (apd (λ x → glue (a , b)) (glue (a' , b')) ∙'2ᵈ ↓-cst=idf-in {p = glue _} {u = ! (glue _)} (coh2 (pB b b')))
          =⟨ coh² (pA a a') (pB b b') ⟩
    ↓-cst=idf-in (coh1 (pA a a')) ▹ coh4 (pB b b')
          =⟨ ! (EqLeft.glue-β a (a' , b')) |in-ctx (λ u → u ▹ coh4 (pB b b')) ⟩
    apd (eq-left a) (glue (a' , b')) ▹ coh4 (pB b b') ∎))}))})

  where

  coh3 : {b : B} {a a' : A} (p : a == a')
    → ap left p == (glue (a , b) ∙' ! (glue (a' , b))) :> (left a == left a' :> A * B)
  coh3 idp = ! (!-inv-r (glue _)) ∙ ∙=∙' (glue _) (! (glue _))

  coh4 : {a : A} {b b' : B} (p : b == b')
    → glue (a , b') == (glue (a , b) ∙' ap right p) :> (left a == right b' :> A * B)
  coh4 idp = idp

  {- Should go to lib.types.Paths -}
  ↓-idf=cst-in=↓ : ∀ {i} {A : Type i} {a a' : A} {p : a == a'} {a0 a0' : A} {p0 : a0 == a0'} {f : (a : A) → a0 == a} {g : (a : A) → a0' == a}
    {q : f a == p0 ∙' g a } {r : f a' == p0 ∙' g a'}
    → q == r [ (λ a → f a == p0 ∙' g a) ↓ p ]
    → ↓-idf=cst-in q == ↓-idf=cst-in r [ (λ a → f a == g a [ (λ x → x == a) ↓ p0 ]) ↓ p ]
  ↓-idf=cst-in=↓ {p = idp} {p0 = idp} idp = idp

  abstract
    coh² : {a a' : A} {b b' : B} (p : a == a') (q : b == b')
      → coh3 {b = b} p ◃ (apd (λ x → glue (a , b)) (glue (a' , b')) ∙'2ᵈ ↓-cst=idf-in {p = glue (a' , b')} {u = ! (glue (a' , b))} (coh2 q))
        == ↓-cst=idf-in (coh1 p) ▹ coh4 q
    coh² idp idp = aux (glue _)  where

      abstract
        aux : {x y : A * B} (p : x == y) →
              (! (!-inv-r p) ∙ ∙=∙' p (! p))
              ◃
              (apd (λ x → p) p ∙'2ᵈ ↓-cst=idf-in {p = p} {u = ! p} (!-inv-l p))
              == ↓-cst=idf-in idp ▹ idp
        aux idp = idp


F : (A A : Set) → Set
F A _ = A


------------------------------------------------------------------------
-- A monad-like structure
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Delay-monad.Sized.Monad where

open import Prelude
open import Prelude.Size

open import Delay-monad.Sized
open import Delay-monad.Sized.Bisimilarity

------------------------------------------------------------------------
-- Monadic combinators

-- Return.

return : ∀ {i a} {A : Size → Type a} → A i → Delay A i
return = now

-- Map. Note the function argument's type.

map : ∀ {i a b} {A : Size → Type a} {B : Size → Type b} →
      ({j : Size< (ssuc i)} → A j → B j) → Delay A i → Delay B i
map f (now   x) = now (f x)
map f (later x) = later λ { .force → map f (force x) }

-- Join.

join : ∀ {i a} {A : Size → Type a} →
       Delay (Delay A) i → Delay A i
join (now   x) = x
join (later x) = later λ { .force → join (force x) }

-- Bind. Note the function argument's type.

infixl 5 _>>=_

_>>=_ : ∀ {i a b} {A : Size → Type a} {B : Size → Type b} →
        Delay A i → ({j : Size< (ssuc i)} → A j → Delay B j) →
        Delay B i
x >>= f = join (map f x)

------------------------------------------------------------------------
-- Monad laws

left-identity :
  ∀ {a b} {A : Size → Type a} {B : Size → Type b}
  x (f : ∀ {i} → A i → Delay B i) →
  return x >>= f ∼ f x
left-identity x f = reflexive (f x)

right-identity : ∀ {a i} {A : Size → Type a} (x : Delay A ∞) →
                 [ i ] x >>= return ∼ x
right-identity (now   x) = now
right-identity (later x) = later λ { .force →
                             right-identity (force x) }

associativity :
  ∀ {a b c i}
    {A : Size → Type a} {B : Size → Type b} {C : Size → Type c} →
  (x : Delay A ∞) (f : ∀ {i} → A i → Delay B i)
  (g : ∀ {i} → B i → Delay C i) →
  [ i ] x >>= (λ x → f x >>= g) ∼ x >>= f >>= g
associativity (now   x) f g = reflexive (f x >>= g)
associativity (later x) f g = later λ { .force →
                                associativity (force x) f g }

------------------------------------------------------------------------
-- The functions map, join and _>>=_ preserve strong and weak
-- bisimilarity and expansion

map-cong : ∀ {k i a b} {A : Size → Type a} {B : Size → Type b}
           (f : ∀ {i} → A i → B i) {x y : Delay A ∞} →
           [ i ] x ⟨ k ⟩ y → [ i ] map f x ⟨ k ⟩ map f y
map-cong f now        = now
map-cong f (later  p) = later λ { .force → map-cong f (force p) }
map-cong f (laterˡ p) = laterˡ (map-cong f p)
map-cong f (laterʳ p) = laterʳ (map-cong f p)

join-cong : ∀ {k i a} {A : Size → Type a} {x y : Delay (Delay A) ∞} →
              [ i ] x ⟨ k ⟩ y → [ i ] join x ⟨ k ⟩ join y
join-cong now        = reflexive _
join-cong (later  p) = later λ { .force → join-cong (force p) }
join-cong (laterˡ p) = laterˡ (join-cong p)
join-cong (laterʳ p) = laterʳ (join-cong p)

infixl 5 _>>=-cong_

_>>=-cong_ :
  ∀ {k i a b} {A : Size → Type a} {B : Size → Type b}
    {x y : Delay A ∞} {f g : ∀ {i} → A i → Delay B i} →
  [ i ] x ⟨ k ⟩ y → (∀ z → [ i ] f z ⟨ k ⟩ g z) →
  [ i ] x >>= f ⟨ k ⟩ y >>= g
now      >>=-cong q = q _
later  p >>=-cong q = later λ { .force → force p >>=-cong q }
laterˡ p >>=-cong q = laterˡ (p >>=-cong q)
laterʳ p >>=-cong q = laterʳ (p >>=-cong q)

------------------------------------------------------------------------
-- A lemma

-- The function map can be expressed using _>>=′_ and now.

map∼>>=-now :
  ∀ {i a b} {A : Size → Type a} {B : Size → Type b}
    {f : ∀ {i} → A i → B i} (x : Delay A ∞) →
  [ i ] map f x ∼ x >>= now ∘ f
map∼>>=-now (now x)   = now
map∼>>=-now (later x) = later λ { .force → map∼>>=-now (x .force) }


-- Record expressions are translated to copattern matches.

module _ where

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

open _×_

dup : ∀ {A} → A → A × A
dup x = record {fst = x; snd = x}

-- dup is translated internally to
--   dup x .fst = x
--   dup x .snd = x
-- so dup should not normalise to λ x → x , x

dup' : ∀ {A} → A → A × A
dup' x = x , x

-- But dup' is not translated, so dup' does reduce.


------------------------------------------------------------------------------
-- Testing a non-admissible property from the HALO paper
------------------------------------------------------------------------------

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

module FOT.FOTC.UnguardedCorecursion.HALO where

-- open import Common.FOL.Relation.Binary.EqReasoning

-- open import FOTC.Base
-- open import FOTC.Base.List
-- open import FOTC.Base.List.PropertiesI
-- open import FOTC.Data.Conat
-- open import FOTC.Data.Conat.PropertiesI
-- open import FOTC.Data.Nat
-- open import FOTC.Data.Stream.Type
-- open import FOTC.Data.Stream.Equality.PropertiesI
-- open import FOTC.Relation.Binary.Bisimilarity.PropertiesI
-- open import FOTC.Relation.Binary.Bisimilarity.Type

-- ------------------------------------------------------------------------------
-- -- The HALO paper states the property
-- --
-- -- ∀ x . f x ≠ ones (1)
-- --
-- -- cannot be proved because it is a non-admissible one.

-- postulate
--   ones    : D
--   ones-eq : ones ≡ succ₁ zero ∷ ones

-- postulate
--   f     : D → D
--   f-eq₁ : ∀ n → f (succ₁ n) ≡ succ₁ zero ∷ f n
--   f-eq₂ : f zero ≡ zero ∷ []

-- ------------------------------------------------------------------------------
-- -- Auxiliary properties

-- fCong : ∀ {m n} → m ≡ n → f m ≡ f n
-- fCong refl = refl

-- succ-∞-Conat : Conat (succ₁ ∞)
-- succ-∞-Conat = subst Conat ∞-eq ∞-Conat

-- ones-Stream : Stream ones
-- ones-Stream = Stream-coind A h refl
--   where
--   A : D → Set
--   A xs = xs ≡ xs

--   h : A ones → ∃[ x' ] ∃[ xs' ] ones ≡ x' ∷ xs' ∧ A xs'
--   h _ = succ₁ zero , ones , ones-eq , refl

-- f-∞-Stream : Stream (f ∞)
-- f-∞-Stream = Stream-coind A h refl
--   where
--   A : D → Set
--   A xs = f xs ≡ f xs

--   h : A (f ∞) → ∃[ x' ] ∃[ xs' ] f ∞ ≡ x' ∷ xs' ∧ A xs'
--   h Af∞ = succ₁ zero , f ∞ , trans (fCong ∞-eq) (f-eq₁ ∞) , Af∞

-- ------------------------------------------------------------------------------
-- -- A proof of (1) adding the N totality hypothesis.

-- thm₁ : ∀ {n} → N n → f n ≢ ones
-- thm₁ nzero h = 0≢S (∧-proj₁ (∷-injective helper))
--   where
--   helper : zero ∷ [] ≡ succ₁ zero ∷ ones
--   helper = trans₂ (sym f-eq₂) h ones-eq

-- thm₁ (nsucc {n} Nn) h = thm₁ Nn (∧-proj₂ (∷-injective helper))
--   where
--   helper : succ₁ zero ∷ f n ≡ succ₁ zero ∷ ones
--   helper = trans₂ (sym (f-eq₁ n)) h ones-eq

-- ------------------------------------------------------------------------------
-- -- A proof of (1) adding the N totality hypothesis and replacing the
-- -- propositional equality by the bisimilarity relation.

-- thm₂ : ∀ {n} → N n → f n ≉ ones
-- thm₂ nzero h with ≈-out h
-- ... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = 0≢S (trans (sym x'≡0) x'≡1)
--   where
--   x'≡0 : x' ≡ zero
--   x'≡0 = ∧-proj₁ (∷-injective (trans (sym prf₁) f-eq₂))

--   x'≡1 : x' ≡ succ₁ zero
--   x'≡1 = ∧-proj₁ (∷-injective (trans (sym prf₂) ones-eq))

-- thm₂ (nsucc {n} Nn) h with ≈-out h
-- ... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = thm₂ Nn (∷-injective≈ helper)
--   where
--   xs'≡fn : xs' ≡ f n
--   xs'≡fn = ∧-proj₂ (∷-injective (trans (sym prf₁) (f-eq₁ n)))

--   ys'≡ones : ys' ≡ ones
--   ys'≡ones = ∧-proj₂ (∷-injective (trans (sym prf₂) ones-eq))

--   helper : x' ∷ f n ≈ x' ∷ ones
--   helper = ≈-in ( x'
--                 , xs'
--                 , ys'
--                 , ∷-rightCong (sym xs'≡fn)
--                 , ∷-rightCong (sym ys'≡ones)
--                 , prf₃
--                 )

-- ------------------------------------------------------------------------------
-- -- A proof of the negation of (1) adding the Conat totality hypothesis
-- -- and replacing the propositional equality by the bisimilarity
-- -- relation.

-- thm₃ : ∃[ n ] (Conat n ∧ f n ≈ ones)
-- thm₃ =  ∞ , ∞-Conat , ≈-coind B h (refl , refl)
--   where
--   B : D → D → Set
--   B xs ys = xs ≡ xs ∧ ys ≡ ys

--   h : B (f ∞) ones →
--       ∃[ x' ] ∃[ xs' ] ∃[ ys' ] f ∞ ≡ x' ∷ xs' ∧ ones ≡ x' ∷ ys' ∧ B xs' ys'
--   h Bh' = succ₁ zero , f ∞ , ones , trans (fCong ∞-eq) (f-eq₁ ∞) , ones-eq , Bh'

------------------------------------------------------------------------------
-- References
--
-- Vytiniotis, D., Peyton Jones, S., Rosén, D. and Claessen,
-- K. (2013). HALO: Haskell to Logic thorugh Denotational
-- Semantics. In: Proceedings of the 40th annual ACM SIGPLAN-SIGACT
-- symposium on Principles of programming languages (POPL’13),
-- pp. 431–442.


------------------------------------------------------------------------
-- The Agda standard library
--
-- The unit type and the total relation on unit
------------------------------------------------------------------------

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

module Data.Unit.Base where

------------------------------------------------------------------------
-- A unit type defined as a record type

-- Note that the name of this type is "\top", not T.

open import Agda.Builtin.Unit public using (⊤; tt)

record _≤_ (x y : ⊤) : Set where


{-
This second-order term syntax was created from the following second-order syntax description:

$sig_string
-}

module ${syn_name}.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import ${syn_name}.Signature

private
  variable
    Γ Δ Π : Ctx
    $ty_vars : $type
    𝔛 : Familyₛ

-- Inductive term declaration
module ${sig}:Terms (𝔛 : Familyₛ) where

  data ${sig} : Familyₛ where
    var  : ℐ ⇾̣ ${sig}
    mvar : 𝔛 $fst_ty_var Π → Sub ${sig} Π Γ → ${sig} $fst_ty_var Γ

    $syn_constructors

  $op_fixity

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  ${sig}ᵃ : MetaAlg ${sig}
  ${sig}ᵃ = record
    { 𝑎𝑙𝑔 = λ where
      $alg_patterns
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module ${sig}ᵃ = MetaAlg ${sig}ᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : ${sig} ⇾̣ 𝒜
    𝕊 : Sub ${sig} Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    $sem_patterns

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ ${sig}ᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ ${sig} $fst_ty_var Γ) → 𝕤𝕖𝕞 (${sig}ᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      $alg_hom_patterns

      𝕊-tab : (mε : Π ~[ ${sig} ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : ${sig} ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ ${sig}ᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : ${sig} $fst_ty_var Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub ${sig} Π Γ)(v : ℐ $fst_ty_var Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      $alg_unique_patterns

-- Syntax instance for the signature
${sig}:Syn : Syntax
${sig}:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = ${sig}:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open ${sig}:Terms 𝔛 in record
    { ⊥ = ${sig} ⋉ ${sig}ᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax ${sig}:Syn public
open ${sig}:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands ${sig}ᵃ public
open import SOAS.Metatheory ${sig}:Syn public

$derived_tm_ops


{-# OPTIONS --cubical #-}
module _ where

open import Agda.Builtin.Equality

-- Option --cubical implies --without-K
uip : {A : Set} {x : A} (p : x ≡ x) → p ≡ refl
uip refl = refl


module _ where

open import Agda.Primitive

postulate
  Equiv : ∀ {a b} → (A : Set a) (B : Set b) → Set (a ⊔ b)

{-# BUILTIN EQUIV Equiv #-}


module InstanceMetaType where

⟨⟩ : {A : Set} {{a : A}} → A
⟨⟩ {{a}} = a

postulate
  A : Set
  instance a : A
  f : (a : A) → Set

test₁ : Set
test₁ = f ⟨⟩

postulate
  B : Set
  b : B
  g : (b : B) → Set

instance
  b' : _
  b' = b

test₂ : Set
test₂ = g ⟨⟩


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

module HITs.PropositionalTruncation.Sugar where

open import Cubical.HITs.PropositionalTruncation
open import Level

_=<<_ : ∀ {a} {A : Type a} {b} {B : ∥ A ∥ → Type b}
      → ((x : A) → ∥ B ∣ x ∣ ∥) → (xs : ∥ A ∥) → ∥ B xs ∥
_=<<_ = elimPropTrunc (λ _ → squash)

_>>=_ : ∀ {a} {A : Type a} {b} {B : Type b}
      → (xs : ∥ A ∥) → (A → ∥ B ∥) → ∥ B ∥
_>>=_ {a} {A} {b} {B} xs f = elimPropTrunc (λ _ → squash) f xs

_>>_ : ∥ A ∥ → ∥ B ∥ → ∥ B ∥
_ >> ys = ys

pure : A → ∥ A ∥
pure = ∣_∣

_<*>_ : ∥ (A → B) ∥ → ∥ A ∥ → ∥ B ∥
fs <*> xs = do
  f ← fs
  x ← xs
  ∣ f x ∣

infixr 1 _∥$∥_
_∥$∥_ : (A → B)→ ∥ A ∥ → ∥ B ∥
f ∥$∥ xs = recPropTrunc squash (λ x → ∣ f x ∣) xs